FFI-Platypus-1.10/000755 000765 000024 00000000000 13616651126 014321 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/author.yml000644 000765 000024 00000005673 13616651126 016361 0ustar00ollisgstaff000000 000000 --- pod_spelling_system: skip: 0 # list of words that are spelled correctly # (regardless of what spell check thinks) stopwords: - valgrind - merrilymeredith - 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 - 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 - Damyan - Ivanov - Shlomi - shlomif - seg - pthreads - UNIXen - dlclose - dlerror - dlopen - dlsym - libdl - or'd - customizations - unmark - unstick - dlrun - exe - rv - decl - stmt - dirname - osname - diag - cflags - fPIC - ld - ldflags - buildname - libs - cxx - shellwords - fbx - strndup - Petr - Pisar - ppisar - Anwar - MANWAR - api - deallocating - deinitialization - HAKONH - hakonhagland - kon - merrilymeredith - Grinnz - DJERIUS - Diab - Jerius pod_coverage: skip: 0 # format is "Class#method" or "Class", regex allowed # for either Class or method. private: - FFI::Platypus::Type::.* - FFI::Platypus::Record::Meta - FFI::Platypus::ShareConfig - FFI::Platypus::Internal - FFI::Platypus::Type - FFI::Platypus::TypeParser - FFI::Platypus::TypeParser::Version0 - FFI::Platypus::TypeParser::Version1 - FFI::Platypus::Closure#get_data - FFI::Platypus::Closure#add_data - FFI::Probe - FFI::Platypus::Bundle - FFI::Platypus::Constant - App::fbx#main - FFI::Build::File::Object#default_suffix - FFI::Build::File::Library#default_suffix - FFI::Build::File::C#cc - FFI::Build::File::C#ld - FFI::Build::File::C#accept_suffix - FFI::Build::File::C#build_item_cpp - FFI::Build::File::CXX#cc - FFI::Build::File::CXX#ld - FFI::Build::File::CXX#accept_suffix - FFI::Build::File::Fortran#cc - FFI::Build::File::Fortran#ld - FFI::Build::File::Fortran#accept_suffix - FFI::Build::File::C#build_item - FFI::Build::File::Object#build_item - FFI::Build::MM - FFI::Platypus::Function#new - FFI::Temp FFI-Platypus-1.10/Changes000644 000765 000024 00000064705 13616651126 015630 0ustar00ollisgstaff000000 000000 Revision history for FFI-Platypus 1.10 2020-02-05 16:39:51 -0700 - On OS X, check if homebrew + libffi is installed and use that instead of falling back on Alien::FFI (libffi isn't installed by homebrew in a way that it can be found by without specifically looking for it). - Die with an appropriate diagnostic if there is a syntax or runtime error in an .fbx file (FFI::Build). (djerius++ gh#223) 1.09 2020-01-18 13:41:56 -0700 - Production release identical to 1.08_01 1.08_01 2020-01-17 19:39:21 -0700 - Fix warning on some versions of windows (gh#217, gh#218) 1.07 2019-12-28 08:44:36 -0700 - Fix bug in variadic argument count (gh#210, gh#211) 1.06 2019-12-14 07:49:54 -0700 - Visual C++ Perl build probe for ssize_t (gh#208, gh#209) 1.05 2019-12-13 09:27:50 -0700 - ffi_platypus_bundle.h provides an EXPORT macro which allows you to decorate functions/data for export under Visual C++ Perl (gh#207) - ffi_pl_bundle_init, ffi_pl_bundle_constant and ffi_pl_bundle_fini are now properly marked as EXPORT. No code changes needed as long as you are using the header file (gh#207) 1.04_01 2019-12-12 19:05:54 -0700 - Some additional testing fixes for Visual C++ Perl build (gh#206) 1.03_01 2019-12-11 20:53:40 -0700 - Restore support for Visual C++ Perl build (gh#202) - C++ support on Visual C++ Perl is not supported at this time (gh#203) 1.02 2019-12-09 03:07:41 -0700 - FFI::Build is no longer described as "alpha" - Documentation fixes. 1.01 2019-11-16 07:16:20 -0700 - Documentation fixes only (gh#198, gh#199, gh#200) 1.00 2019-11-15 13:46:15 -0500 - Production release identical to 0.99_06 0.99_06 2019-11-12 21:08:23 -0500 - Detect Rust or Go modules according to Cargo.toml or go.mod files (gh#197) 0.99_05 2019-10-30 19:25:02 -0600 - Add FFI::Build support for build_all method (gh#195) 0.99_03 2019-10-24 10:46:02 -0700 - Documentation 0.99_02 2019-10-14 16:16:16 -0600 - api = 1 is no longer experimental (gh#193) 0.99_01 2019-10-14 14:39:18 -0600 - Convert documentation from api => 0 (implicit) to api => 1 (explicit) - Improved documentation (gh#181, gh#184) 0.98 2019-10-14 13:18:02 -0600 - Production release identical to 0.97_05 0.97_05 2019-10-12 13:09:12 -0600 - Fixed several memory leaks on some return types and complex type arguments (gh#190, gh#191) 0.97_04 2019-10-05 12:31:32 -0600 - pointer is no longer an alias for opaque with api => 1 (gh#189) - Added several reserved words for the type parser when api => 1 (gh#189) 0.97_03 2019-09-25 18:03:13 -0600 - FFI::Platypus::Record has a record_layout_1 function which uses api => 1 by default. (gh#187) 0.97_02 2019-09-20 04:03:59 -0600 - FFI::Platypus::Record record_layout may now take FFI::Platypus constructor arguments as a array reference as the first argument (gh#185) 0.97_01 2019-09-18 20:56:59 -0600 - Pre-compute cast functions when they are created to save time each time they are called (gh#178, #179) - sizeof and alignof can now be used as class methods (gh#183) 0.96 2019-08-19 18:33:58 -0400 - Production release identical to 0.95_11 0.95_11 2019-08-19 09:41:56 -0400 - Documentation fixes (hakonhagland++ gh#173) - Increased Perl::Critic criticism and associated fixes (gh#172) 0.95_10 2019-08-16 16:14:54 -0400 - Detect bad forks.pm (gh#170) 0.95_09 2019-08-15 10:37:41 -0400 - Daignostic release 0.95_08 2019-08-14 09:18:10 -0400 - Document constant interface (see FFI::Platypus::Constant) (gh#169) 0.95_07 2019-08-13 13:38:30 -0400 - Minor tweak to bundle interface: do not create fbx.json file when running on-demand (gh#167) - Document bundle interface (see FFI::Platypus::Bundle) (gh#160, gh#168) 0.95_06 2019-08-03 08:51:46 -0400 - Platypus now passes the api version (if > 0) into language plugins class native_type_map method (gh#165, gh#166) 0.95_05 2019-08-01 16:18:41 -0400 - Under api = 1, a warning will be issued when Platypus tries to load a file that is not a dnyamic library. Previously, and under api = 0 this warning was only issued if the environment variable FFI_PLATYPUS_DLERROR is set to a true value (gh#161, gh#163) 0.95_04 2019-07-31 21:18:30 -0400 - New interface for bundling code with dist (see bundle method) experimental, requires api = 1 (gh#160, gh#162) - Bundle API provides a way to define Perl constants from C (gh#138) 0.95_03 2019-07-29 19:21:24 -0400 - Remove build dependent strings from deployment (gh#104, gh#110, gh#157, gh#159) 0.95_02 2019-07-25 17:15:09 -0400 - Fix memory leak related to array in the case of bad type error (gh#154) - Fix compiler warnings in record meta module (gh#153, gh155) - More consistent use of temp directories to work around noexec on /tmp (gh#156, gh#158) 0.95_01 2019-07-23 22:19:14 -0400 - Add support for "object" types. (gh#49, gh#89, gh#151) - Fixed bug where 64 bit integer types could be truncated in a cast on 32 bit platform (gh#151) - You can now decorate record value types with * to get a record type using type parse 1 (gh#150) - Add support for complex arrays on platforms where complex types are supported (gh#89, gh#152) 0.94 2019-07-23 09:53:46 -0400 - Production release identical to 0.93_03 0.93_03 2019-07-22 15:02:05 -0400 - Reclaim some memory waste introduced in 0.93_01 (gh#149) 0.93_02 2019-07-18 10:03:01 -0400 - Fix complex test on 32bit 0.93_01 2019-07-17 20:21:47 -0400 - Add support for returning records pass-by-value (gh#89, gh#147) - Add enum and senum (signed enum) types (gh#146) 0.92 2019-07-17 18:16:40 -0400 - Production release identical to 0.91_02 0.91_02 2019-07-16 19:31:40 -0400 - Documentation improvements. (gh#139, gh#145, et. al) - Fixed minor testing error introduced in 0.91_01 (gh#143, gh#144) 0.91_01 2019-07-14 09:32:13 -0400 - Add support for variadic functions (gh#136, gh#141) - Include Type Parser version 1. This can be activated using the api => 1 when creating a FFI::Platypus instance (gh#135) - Usage of Type Parser version 1 is experimental and will issue a warning until FFI::Platypus 1.00 is released (gh#135) - Added support for pass-by-value records (gh#57,gh#92,gh#135) this requires Type Parser version 1 - Allow decoration of aliases of basic types (gh#135, gh#135) this requires Type Parser version 1 - Fix bug where Math::LongDouble and Math::Complex detection wasn't being made for array and pointers of longdouble, complex_float and complex_double types. (gh#135) - For functions: allow a single 'void' argument type to indicate an empty list of arguments (a la old C style). The 'void' type is otherwise now illegal as an argument type (ie when there is more than one argument) and will throw an exception when the function is created. Previously a warning would be issued when the funtion was called. (gh#140, gh#142) 0.90 2019-07-01 09:47:31 -0400 - Documentation improvements (gh#137, et. al.) 0.89_01 2019-06-24 08:33:05 -0400 - Fixed bug where prototypes to attach were sometimes being ignored. - Add sub_ref method to FFI::Platypus::Function (gh#133) - Better file/line number diagnostics for croak inside a wrapper (gh#129, gh#132) 0.88 2019-06-19 06:56:57 -0400 - Add mangler attribute for FFI::Platypus (gh#128) 0.87 2019-04-23 08:25:35 -0400 - Add probe for intptr_t and uintptr_t types (gh#123) - You may now use the ALIEN_INSTALL_TYPE environment to force using Alien::FFI (gh#121) - Documentation improvements (gh#122 manwar++ gh#120 ppisar++) 0.86 2019-03-02 16:42:12 -0500 - Production release identical to 0.85_01 0.85_01 2019-03-01 20:38:22 -0500 - Fix configure bug that misconfigured Perls with 32bit IVs resulting in truncated 64bit values. (gh#117, gh#118). This was a regression, probably introduced around 0.72 or so. The test t/gh117.t has been added to avoid a recurrence of this regression. 0.84 2019-02-15 15:26:23 -0500 - FFI::Build sets @rpath on libraries that it builds on OS X. 0.83 2019-02-12 14:05:04 -0500 - Fix warning in FFI::Build when verbose off - Allow arry file spec for FFI::Buuild source method - Added scalar_to_pointer to FFI::Platypus::Buffer 0.82 2019-02-10 10:34:57 -0500 - Production release identical to 0.81_04 0.81_04 2019-02-08 14:49:20 -0500 - Diagnostic release 0.81_02 2019-02-05 12:19:50 -0500 - Diagnostic release 0.81_01 2019-02-04 11:51:52 -0500 - Diagnostic release 0.80 2019-02-01 15:36:50 -0500 - Fix incompatibility with parallel bsd make 0.79 2019-01-31 20:58:07 -0500 - Fix probe runner builder bug (gh#112, gh#113) 0.78 2019-01-30 10:28:22 -0500 - Production release identical to 0.77_03 0.77_03 2019-01-29 21:44:29 -0500 - Remove Java gcj examples. The gcj compiler has been deprecated, unmaintained, and removed from the gcc collection for quite a while now. - Fix problem diagnostic window on Windows during probe 0.77_02 2019-01-29 11:30:56 -0500 - Fix regressions in 0.77_01 0.77_01 2019-01-28 15:47:07 -0500 - Honor compiler and linker flag overrides provided on the command-line for FFI::Probe::Runner::Builder, make ffi and make ffi-test (gh#104) 0.76_01 2019-01-20 20:14:45 -0500 - function method can now take a wrapper code reference as its last argument in the same way as attach. 0.75_01 2019-01-19 04:45:19 -0500 - Add strndup to FFI::Platypus::Memory 0.74 2019-01-19 04:42:22 -0500 - Production release identical to 0.73_01 0.73_01 2019-01-13 18:31:33 -0500 - Remove dependency on Win32::ErrorMode on Windows 0.72_01 2019-01-11 22:17:11 -0500 - Remove dependency on Config::AutoConf 0.71_01 2019-01-10 23:29:06 -0500 - Merge FFI-Build into this distribution - Add FFI::Probe 0.70_01 2019-01-10 15:34:57 -0500 - prereq fix: IPC::Cmd as a configure requires since it doesn't come with Perl 5.8.x 0.69_01 2019-01-09 15:59:43 -0500 - require Alien::FFI in fallback mode 0.68_01 2019-01-05 21:12:47 -0500 - Improve platform probing of complex type - Allow override of platform probing using FFI_PLATYPUS_PROBE_OVERRIDE 0.67_01 2019-01-05 09:16:22 -0500 - Better support for complex types: pointers to complex types and complex type and pointers to complex as return value 0.66_01 2019-01-04 20:16:59 -0500 - EXPERIMENTAL ExtUtils::MakeMaker fixes for dynamic prereqs on windows - restore FFI_PLATYPUS_DEBUG_FAKE32 - restore FFI_PLATYPUS_NO_ALLOCA 0.65_01 2019-01-04 13:38:58 -0500 - EXPERIMENTAL ExtUtils::MakeMaker fixes for parallel and freebsd build 0.64_01 2019-01-03 03:16:57 -0500 - EXPERIMENTAL ExtUtils::MakeMaker fixes for MSWin32 / cygwin 0.63_01 2019-01-02 11:23:48 -0500 - EXPERIMENTAL ExtUtils::MakeMaker release 0.62_01 2019-01-01 04:23:23 -0500 - New type: array of string "string [x]" and "string []" are supported - NULL terminated arrays are supported as return types for string and opaque arrays "opaque []" and "string []" 0.61_01 2018-12-31 19:56:20 -0500 - New type: pointers to string "string *" are supported. - FFI::Platypus::Type::StringPointer is now deprecated. 0.60_01 2018-12-30 14:55:15 -0500 - sticky/unstick functions can safely be called multiple times - Removed some extra lookups from closure calls, should be faster now. 0.59 2018-12-16 16:33:37 -0700 - Workaround for possibly buggy pack/unpack on Perl 5.8.8 gh#91 Fixes FFI::Platypus::Type::StringArray 0.58 2018-11-20 14:31:10 -0500 - Add unstick method to FFI::Platypus::Closure 0.57_01 2018-11-04 15:36:33 -0500 - Major refactor of the internals of the type system. The API is the same but some type meta-data (which was never guaranteed to stay the same) may have changed. * The internal representation of types is much smaller (4 bytes for simple types), which can save a lot of memory if you have lots of types. * Fixed width strings example: `string(32)` are now internally treated the same as a record with no class `record(32)`. Previously these were separate types but worked identically, this removes duplicate code. * Fixed width string arguments to a closure are now read-only, Usually you should be copying these arguments anyway. * Removed the internal type "exotic float" which includes `long double`, `complex float` and `complex double`. These are now grouped internally with other scalar types. - Merge FFI::Platypus::Type::StringArray into this distribution 0.56 2018-09-03 09:17:42 -0400 - lib method accepts code reference which will be called immediately and results added to lib list 0.55 2018-08-29 10:37:36 -0400 - Production release identical to 0.54_03 0.54_03 2018-08-28 10:46:04 -0400 - Additional test diagnostics. 0.54_02 2018-08-28 05:30:04 -0400 - record as closure argument is now read-only. This makes sense since such records are actually copies. For when you need a non-copy use an opaque type instead. This allows records with rw strings (although they will be ro in the closure). 0.54_01 2018-08-16 03:27:31 -0400 - Experimental: allow record as closure argument Records with string_rw are not supported, and will likely crash your script if you try to use them. Support for such records is probably not in the cards, but a future version may disallow them to avoid crashes. - Closure objects now have a sticky method, similar to what is already available in the discouraged FFI::Platypus::Declare interface 0.53 2018-08-15 20:38:29 -0400 - Production release identical to 0.52_04 0.52_04 2018-08-15 05:52:15 -0400 - Work-around for Strawberry Perl 5.14.4 unicode bug (see gh#85) 0.52_03 2018-08-14 15:28:19 -0400 - Major refactoring of test suite 0.52_02 2018-08-14 08:05:07 -0400 - Added standard RTLD_ constants to FFI::Platypus::DL - Fixed long standing but till now unused bug on Windows where dlopen was returning a handle for libraries that weren't actually being loaded. 0.52_01 2018-08-13 20:39:32 -0400 - Testing: moved libtest to t/ffi, using the same convention as FFI::Build - Added FFI::Platypus::DL. Previously this had been (under a different name) a private interface to libdl used by FFI::Platypus under the covers. On Windows it is an emulation layer over the native equivalents. 0.51 2018-08-09 03:14:15 -0400 - update the package method to work with FFI-Build 0.50 2018-06-01 07:58:33 -0400 - Additional diagnostics 0.49_05 2018-05-29 12:44:45 -0400 - Require Alien::FFI 0.20 for bugfixes 0.49_04 2018-05-27 07:36:58 -0400 - Additional diagnostics - Added a FAQ section. Some other minor documentation enhancements. 0.49_03 2018-05-19 10:09:15 -0400 - The previous version contained build files that would break the install unless you were building on my machine. This is what the previous version should have been. 0.49_02 2018-05-18 22:08:43 -0400 - Fix version mismatch error with XS 0.49_01 2018-05-18 16:16:13 -0400 - Move the source repository for this project into the GitHub org Perl5-FFI The new URL is https://github.org/Perl5-FFI/FFI-Platypus - Remove dependency on JSON::PP, use Data::Dumper for build configuration. This may improve startup performance. 0.48 2018-02-20 09:37:32 -0500 - setting lib => undef is now the same as setting it to [undef] in the constructor (previously lib => undef was ignored) 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 declarations 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 compatibility 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 FFI-Platypus-1.10/Changes.FFI-Build000644 000765 000024 00000002244 13616651126 017256 0ustar00ollisgstaff000000 000000 Revision history for {{$dist->name}} After 0.12 FFI-Build was merged with FFI-Platypus 0.12 2019-01-06 10:23:17 -0500 - Make FFI::Platypus an optional testing dependency (previously it was a required dependency for testing only). 0.11 2018-12-20 21:55:50 -0700 - Require EUMM 7.24 for fixes in testing 0.10 2018-12-20 17:51:17 -0700 - Fix bug where build aliens were used for test only build 0.09 2018-08-28 10:50:27 -0400 - Additional test diagnostics 0.08 2018-08-28 09:58:19 -0400 - Same workaroudn for linkers with space 0.07 2018-08-20 10:52:27 -0400 - Workaround for compilers with space 0.06 2018-08-20 08:57:30 -0400 - Fix test 0.05 2018-08-20 05:17:36 -0400 - Removed FFI::Build::File::Fortran, which is now part of the FFI-Platypus-Lang-Fortran dist 0.04 2018-08-19 12:56:54 -0400 - When `cc -MM` or `c++ -MM` fails for computing dependencies, fall back on just the .c file being the dependency. 0.03 2018-08-16 04:03:09 -0400 - Fix for test failure on cygwin + MSWin32 - Additional diagnostics for Fortran build test 0.02 2018-08-09 04:54:30 -0400 - initial version FFI-Platypus-1.10/Changes.FFI-Platypus-Type-StringArray000644 000765 000024 00000000372 13616651126 023222 0ustar00ollisgstaff000000 000000 Revision history for FFI-Platypus-Type-StringArray After 0.02 FFI-Platypus-Type-StringArray was merged with FFI-Platypus 0.02 2018-07-28 21:34:16 -0400 - Add support as a return type. 0.01 2015-01-23 16:50:47 -0500 - initial version FFI-Platypus-1.10/CONTRIBUTING000644 000765 000024 00000012330 13616651126 016152 0ustar00ollisgstaff000000 000000 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/Perl5-FFI/FFI-Platypus/pulls This project is developed using Dist::Zilla. The project's git repository also comes with the Makefile.PL file 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 Makefile.PL % make % make ffi-test % 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_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 Makefile.PL DEBUG_FAKE32: + making Math::Int64 a prereq + Using Math::Int64's C API to manipulate 64 bit values Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json % 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 Makefile.PL: helix% env FFI_PLATYPUS_NO_ALLOCA=1 perl Makefile.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json V When building platypus may hide some of the excessive output when probing and building, unless you set V to a true value. % env V=1 perl Makefile.PL % make V=1 ... 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/Perl5-FFI/FFI-Performance System integrators This distribution uses Alien::FFI in fallback mode, meaning if the system doesn't provide pkg-config and libffi it will attempt to download libffi and build it from source. If you are including Platypus in a larger system (for example a Linux distribution) you only need to make sure to declare pkg-config or pkgconf and the development package for libffi as prereqs for this module. FFI-Platypus-1.10/corpus/000755 000765 000024 00000000000 13616651126 015634 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/dist.ini000644 000765 000024 00000017553 13616651126 016000 0ustar00ollisgstaff000000 000000 name = FFI-Platypus author = Graham Ollis license = Perl_5 copyright_holder = Graham Ollis copyright_year = 2015,2016,2017,2018,2019 version = 1.10 ; authordep ExtUtils::MakeMaker [@Author::Plicease] :version = 2.44 release_tests = 1 installer = Author::Plicease::MakeMaker copy_mm = 1 allow_dirty = Makefile.PL diag = +Alien::Base diag = +PkgConfig diag = +Math::LongDouble diag = +Devel::Hide diag = +forks irc = irc://irc.perl.org/#native travis_status = 1 appveyor = dn0iuv0k7ld4ek2i github_user = Perl5-FFI github_repo = FFI-Platypus ;workflow = windows workflow = macos underscore_eval_version = 0 diag_preamble = | $post_diag = sub { diag_preamble = | eval { diag_preamble = | require lib; diag_preamble = | lib->import('inc'); diag_preamble = | require FFI::Platypus::ShareConfig; diag_preamble = | require My::BuildConfig; diag_preamble = | my $build_config = My::BuildConfig->new; diag_preamble = | my $share_config = 'FFI::Platypus::ShareConfig'; diag_preamble = | my $class = $build_config->get('alien')->{class}; diag_preamble = | my $pm = "$class.pm"; diag_preamble = | $pm =~ s/::/\//g; diag_preamble = | require $pm; diag_preamble = | $Alien::FFI::pkgconfig::VERBOSE = diag_preamble = | $Alien::FFI::pkgconfig::VERBOSE = 0; diag_preamble = | require FFI::Platypus; diag_preamble = | require FFI::Platypus::Memory; diag_preamble = | diag "mode : ", $build_config->get('alien')->{mode}; diag_preamble = | diag "$class->VERSION = ", $class->VERSION; diag_preamble = | diag "$class->install_type = ", $class->install_type; diag_preamble = | diag "$class->cflags = ", $class->cflags; diag_preamble = | diag "$class->libs = ", $class->libs; diag_preamble = | diag "$class->version = ", $class->config('version'); diag_preamble = | diag "my_configure = ", $class->runtime_prop->{my_configure} if defined $class->runtime_prop->{my_configure}; diag_preamble = | spacer(); diag_preamble = | my %type_map = %{ $share_config->get('type_map') }; diag_preamble = | my $diag = $build_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 = | diag "ffi.platypus.memory.strndup_impl=@{[ FFI::Platypus::Memory->_strndup_impl ]}"; diag_preamble = | spacer(); diag_preamble = | my %r; diag_preamble = | foreach my $k (keys %type_map) diag_preamble = | { diag_preamble = | my $v = $type_map{$k}; 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 = | if(-f "/proc/cpuinfo") diag_preamble = | { diag_preamble = | open my $fh, '<', '/proc/cpuinfo'; diag_preamble = | my @lines = <$fh>; diag_preamble = | close $fh; diag_preamble = | my($model_name) = grep /^model name/, @lines; diag_preamble = | my($flags) = grep /^flags/, @lines; diag_preamble = | my($address_sizes) = grep /^address sizes/, @lines; diag_preamble = | spacer(); diag_preamble = | diag "CPU Info:"; diag_preamble = | diag " $model_name"; diag_preamble = | diag " $flags" if $flags;; diag_preamble = | diag " $address_sizes" if $address_sizes; diag_preamble = | } diag_preamble = | require IPC::Cmd; diag_preamble = | require Capture::Tiny; diag_preamble = | if(IPC::Cmd::can_run('lsb_release')) diag_preamble = | { diag_preamble = | spacer(); diag_preamble = | diag Capture::Tiny::capture_merged(sub { diag_preamble = | system 'lsb_release', '-a'; diag_preamble = | (); diag_preamble = | }); diag_preamble = | } diag_preamble = | require FFI::Build::Platform; diag_preamble = | spacer(); diag_preamble = | diag "[PLATFORM]\n"; diag_preamble = | diag(FFI::Build::Platform->diag); 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 = if remove = lib remove = Cwd remove = Env remove = XSLoader remove = File::Spec remove = File::Copy remove = Scalar::Util remove = Exporter remove = Carp remove = Encode remove = File::Glob remove = File::Path remove = File::Temp remove = Text::ParseWords remove = Data::Dumper remove = File::Basename ; comes with Strawberry (only place we use it) remove = Win32 remove = Win32::Process remove = Win32API::File ; optional for testing remove = Acme::Alien::DontPanic remove = Sub::Identify remove = Devel::Hide remove = forks ; optional !! remove = Alien::FFI remove = Alien::FFI::pkgconfig ; internal remove = My::BuildConfig [Prereqs / ConfigurePrereqs] -phase = configure ExtUtils::MakeMaker = 7.12 IPC::Cmd = 0 Capture::Tiny = 0 ; 3.30 is actually pretty recent. If Parse is upgraded ; after running `perl Makefile.PL` but before running `make` ; depending on the versions, you may see an error like ; ; Undefined subroutine &ExtUtils::ParseXS::errors called at ; ; because the .pm file and the xsubpp do not match. Bump ; the ParseXS to a relatively recent version as a configure ; requires works around this most of the time. ExtUtils::ParseXS = 3.30 [Prereqs / BuildPrereqs] -phase = build ExtUtils::CBuilder = 0 [Prereqs / TestPrereqs] -phase = test Capture::Tiny = 0 [Prereqs] constant = 1.32 FFI::CheckLib = 0.05 [Prereqs / DevPrereqs] -phase = develop Devel::PPPort = 3.28 Devel::Hide = 0 [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 ; if you have a preference for how to display your name ; feel free send a PR. I don't use the git hisory. 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) contributor = Shlomi Fish (shlomif) contributor = Damyan Ivanov contributor = Ilya Pavlov (Ilya33) contributor = Petr Pisar (ppisar) contributor = Mohammad S Anwar (MANWAR) contributor = Håkon Hægland (hakonhagland, HAKONH) contributor = Meredith (merrilymeredith, MHOWARD) contributor = Diab Jerius (DJERIUS) [PruneFiles] match = /tmpbuild\. match = \.o$ match = \.obj$ match = \.so$ match = \.dll$ match = \.dylib$ match = ^.tmp/ match = ^corpus/ffi_build_mm/project1/blib filename = xt/author/pod_spelling_common.t [AlienBase::Wrapper::Bundle] :version = 0.26 [CopyFilesFromBuild / CopyAlienBaseWrapper] copy = inc/Alien/Base/Wrapper.pm FFI-Platypus-1.10/examples/000755 000765 000024 00000000000 13616651126 016137 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/ffi/000755 000765 000024 00000000000 13616651126 015065 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/000755 000765 000024 00000000000 13616651126 015072 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/include/000755 000765 000024 00000000000 13616651126 015744 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/INSTALL000644 000765 000024 00000004332 13616651126 015354 0ustar00ollisgstaff000000 000000 This 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, install configure prerequisites (see below), then build it: % perl Makefile.PL % make && make test Then install it: % make install On Windows platforms, you should use `dmake` or `nmake`, instead of `make`. 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 The prerequisites of this distribution will also have to be installed manually. The prerequisites are listed in one of the files: `MYMETA.yml` or `MYMETA.json` generated by running the manual build process described above. ## Configure Prerequisites This distribution requires other modules to be installed before this distribution's installer can be run. They can be found under the "configure_requires" key of META.yml or the "{prereqs}{configure}{requires}" key of META.json. ## Other Prerequisites This distribution may require additional modules to be installed after running Makefile.PL. Look for prerequisites in the following phases: * to run make, PHASE = build * to use the module code itself, PHASE = runtime * to run tests, PHASE = test They can all be found in the "PHASE_requires" key of MYMETA.yml or the "{prereqs}{PHASE}{requires}" key of MYMETA.json. ## Documentation FFI-Platypus documentation is available as POD. You can run `perldoc` from a shell to read the documentation: % perldoc FFI::Platypus For more information on installing Perl modules via CPAN, please see: https://www.cpan.org/modules/INSTALL.html FFI-Platypus-1.10/lib/000755 000765 000024 00000000000 13616651126 015067 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/LICENSE000644 000765 000024 00000043751 13616651126 015340 0ustar00ollisgstaff000000 000000 This software is copyright (c) 2015,2016,2017,2018,2019 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,2016,2017,2018,2019 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,2016,2017,2018,2019 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 FFI-Platypus-1.10/maint/000755 000765 000024 00000000000 13616651126 015431 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/Makefile.PL000644 000765 000024 00000011721 13616651126 016275 0ustar00ollisgstaff000000 000000 BEGIN { use strict; use warnings; 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::Author::Plicease::MakeMaker v2.44. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker 6.64; require "./inc/mymm.pl"; my %WriteMakefileArgs = ( "ABSTRACT" => "Write Perl bindings to non-Perl libraries with FFI. No XS required.", "AUTHOR" => "Graham Ollis ", "BUILD_REQUIRES" => { "ExtUtils::CBuilder" => 0 }, "CONFIGURE_REQUIRES" => { "Capture::Tiny" => 0, "ExtUtils::MakeMaker" => "7.12", "ExtUtils::ParseXS" => "3.30", "IPC::Cmd" => 0 }, "DISTNAME" => "FFI-Platypus", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "FFI::Platypus", "PM" => { "lib/FFI/Build.pm" => "\$(INST_LIB)/FFI/Build.pm", "lib/FFI/Build/File/Base.pm" => "\$(INST_LIB)/FFI/Build/File/Base.pm", "lib/FFI/Build/File/C.pm" => "\$(INST_LIB)/FFI/Build/File/C.pm", "lib/FFI/Build/File/CXX.pm" => "\$(INST_LIB)/FFI/Build/File/CXX.pm", "lib/FFI/Build/File/Library.pm" => "\$(INST_LIB)/FFI/Build/File/Library.pm", "lib/FFI/Build/File/Object.pm" => "\$(INST_LIB)/FFI/Build/File/Object.pm", "lib/FFI/Build/MM.pm" => "\$(INST_LIB)/FFI/Build/MM.pm", "lib/FFI/Build/Platform.pm" => "\$(INST_LIB)/FFI/Build/Platform.pm", "lib/FFI/Platypus.pm" => "\$(INST_LIB)/FFI/Platypus.pm", "lib/FFI/Platypus/API.pm" => "\$(INST_LIB)/FFI/Platypus/API.pm", "lib/FFI/Platypus/Buffer.pm" => "\$(INST_LIB)/FFI/Platypus/Buffer.pm", "lib/FFI/Platypus/Bundle.pm" => "\$(INST_LIB)/FFI/Platypus/Bundle.pm", "lib/FFI/Platypus/Closure.pm" => "\$(INST_LIB)/FFI/Platypus/Closure.pm", "lib/FFI/Platypus/Constant.pm" => "\$(INST_LIB)/FFI/Platypus/Constant.pm", "lib/FFI/Platypus/DL.pm" => "\$(INST_LIB)/FFI/Platypus/DL.pm", "lib/FFI/Platypus/Declare.pm" => "\$(INST_LIB)/FFI/Platypus/Declare.pm", "lib/FFI/Platypus/Function.pm" => "\$(INST_LIB)/FFI/Platypus/Function.pm", "lib/FFI/Platypus/Internal.pm" => "\$(INST_LIB)/FFI/Platypus/Internal.pm", "lib/FFI/Platypus/Lang.pm" => "\$(INST_LIB)/FFI/Platypus/Lang.pm", "lib/FFI/Platypus/Lang/ASM.pm" => "\$(INST_LIB)/FFI/Platypus/Lang/ASM.pm", "lib/FFI/Platypus/Lang/C.pm" => "\$(INST_LIB)/FFI/Platypus/Lang/C.pm", "lib/FFI/Platypus/Lang/Win32.pm" => "\$(INST_LIB)/FFI/Platypus/Lang/Win32.pm", "lib/FFI/Platypus/Legacy.pm" => "\$(INST_LIB)/FFI/Platypus/Legacy.pm", "lib/FFI/Platypus/Memory.pm" => "\$(INST_LIB)/FFI/Platypus/Memory.pm", "lib/FFI/Platypus/Record.pm" => "\$(INST_LIB)/FFI/Platypus/Record.pm", "lib/FFI/Platypus/Record/Meta.pm" => "\$(INST_LIB)/FFI/Platypus/Record/Meta.pm", "lib/FFI/Platypus/Record/TieArray.pm" => "\$(INST_LIB)/FFI/Platypus/Record/TieArray.pm", "lib/FFI/Platypus/ShareConfig.pm" => "\$(INST_LIB)/FFI/Platypus/ShareConfig.pm", "lib/FFI/Platypus/Type.pm" => "\$(INST_LIB)/FFI/Platypus/Type.pm", "lib/FFI/Platypus/Type/PointerSizeBuffer.pm" => "\$(INST_LIB)/FFI/Platypus/Type/PointerSizeBuffer.pm", "lib/FFI/Platypus/Type/StringArray.pm" => "\$(INST_LIB)/FFI/Platypus/Type/StringArray.pm", "lib/FFI/Platypus/Type/StringPointer.pm" => "\$(INST_LIB)/FFI/Platypus/Type/StringPointer.pm", "lib/FFI/Platypus/TypeParser.pm" => "\$(INST_LIB)/FFI/Platypus/TypeParser.pm", "lib/FFI/Platypus/TypeParser/Version0.pm" => "\$(INST_LIB)/FFI/Platypus/TypeParser/Version0.pm", "lib/FFI/Platypus/TypeParser/Version1.pm" => "\$(INST_LIB)/FFI/Platypus/TypeParser/Version1.pm", "lib/FFI/Probe.pm" => "\$(INST_LIB)/FFI/Probe.pm", "lib/FFI/Probe/Runner.pm" => "\$(INST_LIB)/FFI/Probe/Runner.pm", "lib/FFI/Probe/Runner/Builder.pm" => "\$(INST_LIB)/FFI/Probe/Runner/Builder.pm", "lib/FFI/Probe/Runner/Result.pm" => "\$(INST_LIB)/FFI/Probe/Runner/Result.pm", "lib/FFI/Temp.pm" => "\$(INST_LIB)/FFI/Temp.pm" }, "PREREQ_PM" => { "Capture::Tiny" => 0, "ExtUtils::MakeMaker" => "7.12", "FFI::CheckLib" => "0.05", "IPC::Cmd" => 0, "JSON::PP" => 0, "List::Util" => "1.45", "constant" => "1.32" }, "TEST_REQUIRES" => { "Capture::Tiny" => 0, "Test::More" => "0.98" }, "VERSION" => "1.10", "test" => { "TESTS" => "t/*.t" } ); mymm::myWriteMakefile(%WriteMakefileArgs);FFI-Platypus-1.10/MANIFEST000644 000765 000024 00000016316 13616651126 015461 0ustar00ollisgstaff000000 000000 # This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. CONTRIBUTING Changes Changes.FFI-Build Changes.FFI-Platypus-Type-StringArray INSTALL LICENSE MANIFEST META.json META.yml Makefile.PL README SUPPORT author.yml corpus/ffi_build/project-cxx/foo1.cxx corpus/ffi_build/project-cxx/foo2.cpp corpus/ffi_build/project1/foo1.c corpus/ffi_build/project1/foo2.c corpus/ffi_build/project2/bar.c corpus/ffi_build/source/foo.c corpus/ffi_build_file_base/basic.foo corpus/ffi_build_file_c/basic.c corpus/ffi_build_file_c/foo1.c corpus/ffi_build_file_c/foo2.c corpus/ffi_build_file_c/include/myfoo.h corpus/ffi_build_file_cxx/basic.cxx corpus/ffi_build_file_cxx/foo1.cxx corpus/ffi_build_file_cxx/foo2.cpp corpus/ffi_build_file_cxx/include/myfoo.h corpus/ffi_build_mm/lb1/hello.fbx corpus/ffi_build_mm/lb1/hello1.c corpus/ffi_build_mm/lb1/hello2.c corpus/ffi_build_mm/lb1bad/hello.fbx corpus/ffi_build_mm/lb1bad/hello1.c corpus/ffi_build_mm/lb1bad/hello2.c corpus/ffi_build_mm/lb2/hello1.c corpus/ffi_build_mm/lb2/hello2.c corpus/ffi_build_mm/project1/ffi/x.c corpus/ffi_build_mm/project1/ffi/y.c corpus/ffi_build_mm/project1/ffi/z.c corpus/ffi_build_mm/project1/t/ffi/a.c corpus/ffi_build_mm/project1/t/ffi/b.c corpus/ffi_build_mm/project1/t/ffi/c.c corpus/ffi_probe_runner/bar.c corpus/ffi_probe_runner/foo.c corpus/memory/arg_array.pl corpus/memory/arg_custom.pl corpus/memory/arg_object.pl corpus/memory/arg_pointer.pl corpus/memory/arg_scalar.pl corpus/memory/attach.pl corpus/memory/empty.pl corpus/memory/function.pl corpus/memory/return_array.pl corpus/memory/return_custom.pl corpus/memory/return_object.pl corpus/memory/return_pointer.pl corpus/memory/return_scalar.pl corpus/memory/supp/basic_type_cache.supp dist.ini examples/archive.pl examples/archive_object.pl examples/attach_from_pointer.pl examples/bundle-const/ffi/const.c examples/bundle-const/ffi/myheader.h examples/bundle-const/lib/Const.pm examples/bundle-const/t/const.t examples/bundle-foo/Makefile.PL examples/bundle-foo/ffi/foo.c examples/bundle-foo/lib/Foo.pm examples/bundle-foo/t/foo.t examples/bundle-init/ffi/init.c examples/bundle-init/lib/Init.pm examples/bundle-init/t/init.t examples/bzip2.pl examples/char.pl examples/closure-opaque.pl examples/closure.c examples/closure.pl examples/file_handle.pl examples/get_uptime.pl examples/getpid.pl examples/integer.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 ffi/constant.c ffi/memory.c ffi/record_meta.c inc/Alien/Base/Wrapper.pm inc/Alien/FFI/PkgConfigPP.pm inc/Alien/FFI/pkgconfig.pm inc/Alien/psapi.pm inc/My/BuildConfig.pm inc/My/Config.pm inc/My/ConfigH.pm inc/My/ConfigPl.pm inc/My/ShareConfig.pm inc/bad-forks.pl inc/mm-build.pl inc/mm-clean.pl inc/mm-config-pb.pl inc/mm-config-set.pl inc/mm-config.pl inc/mm-test.pl inc/mymm.pl inc/pdb inc/probe/abi.c inc/probe/alloca.c inc/probe/bigendian.c inc/probe/bigendian64.c inc/probe/complex.c inc/probe/longdouble.c inc/probe/recordvalue.c inc/probe/variadic.c include/ffi_platypus.h include/ffi_platypus_bundle.h include/ffi_platypus_call.h include/ffi_platypus_guts.h include/libtest.h include/perl_math_int64.h include/ppport.h lib/FFI/Build.pm lib/FFI/Build/File/Base.pm lib/FFI/Build/File/C.pm lib/FFI/Build/File/CXX.pm lib/FFI/Build/File/Library.pm lib/FFI/Build/File/Object.pm lib/FFI/Build/MM.pm lib/FFI/Build/Platform.pm lib/FFI/Platypus.pm lib/FFI/Platypus.xs lib/FFI/Platypus/API.pm lib/FFI/Platypus/Buffer.pm lib/FFI/Platypus/Bundle.pm lib/FFI/Platypus/Closure.pm lib/FFI/Platypus/Constant.pm lib/FFI/Platypus/DL.pm lib/FFI/Platypus/Declare.pm lib/FFI/Platypus/Function.pm lib/FFI/Platypus/Internal.pm lib/FFI/Platypus/Lang.pm lib/FFI/Platypus/Lang/ASM.pm lib/FFI/Platypus/Lang/C.pm lib/FFI/Platypus/Lang/Win32.pm lib/FFI/Platypus/Legacy.pm lib/FFI/Platypus/Memory.pm lib/FFI/Platypus/Record.pm lib/FFI/Platypus/Record/Meta.pm lib/FFI/Platypus/Record/TieArray.pm lib/FFI/Platypus/ShareConfig.pm lib/FFI/Platypus/Type.pm lib/FFI/Platypus/Type/PointerSizeBuffer.pm lib/FFI/Platypus/Type/StringArray.pm lib/FFI/Platypus/Type/StringPointer.pm lib/FFI/Platypus/TypeParser.pm lib/FFI/Platypus/TypeParser/Version0.pm lib/FFI/Platypus/TypeParser/Version1.pm lib/FFI/Probe.pm lib/FFI/Probe/Runner.pm lib/FFI/Probe/Runner/Builder.pm lib/FFI/Probe/Runner/Result.pm lib/FFI/Temp.pm lib/FFI/typemap maint/cip-before-install maint/cip-test-cpan maint/cip-test-examples maint/generate-abw maint/generate-readme maint/generate-record-accessor maint/run-after_build.pl maint/run-before_build.pl maint/tt/accessor.tt maint/tt/accessor_wrapper.tt perlcriticrc t/00_diag.t t/01_use.t t/ffi/align.c t/ffi/align_array.c t/ffi/align_fixed.c t/ffi/align_string.c t/ffi/basic.c t/ffi/closure.c t/ffi/color.c t/ffi/complex_double.c t/ffi/complex_float.c t/ffi/double.c t/ffi/float.c t/ffi/gh117.c t/ffi/gh174.c t/ffi/longdouble.c t/ffi/memcmp4.c t/ffi/meta.c t/ffi/pointer.c t/ffi/record.c t/ffi/sint16.c t/ffi/sint32.c t/ffi/sint64.c t/ffi/sint8.c t/ffi/string.c t/ffi/string_array.c t/ffi/uint16.c t/ffi/uint32.c t/ffi/uint64.c t/ffi/uint8.c t/ffi/variadic.c t/ffi_build.t t/ffi_build_file_base.t t/ffi_build_file_c.t t/ffi_build_file_cxx.t t/ffi_build_file_library.t t/ffi_build_file_object.t t/ffi_build_mm.t t/ffi_build_platform.t t/ffi_platypus.t t/ffi_platypus_api.t t/ffi_platypus_buffer.t t/ffi_platypus_bundle.t t/ffi_platypus_closure.t t/ffi_platypus_constant.t t/ffi_platypus_declare.t t/ffi_platypus_dl.t t/ffi_platypus_function.t t/ffi_platypus_function_wrapper.t t/ffi_platypus_internal.t t/ffi_platypus_lang.t t/ffi_platypus_lang_asm.t t/ffi_platypus_lang_c.t t/ffi_platypus_lang_win32.t t/ffi_platypus_legacy.t t/ffi_platypus_memory.t t/ffi_platypus_record.t t/ffi_platypus_record_meta.t t/ffi_platypus_record_tiearray.t t/ffi_platypus_shareconfig.t t/ffi_platypus_type.t t/ffi_platypus_type_pointersizebuffer.t t/ffi_platypus_type_stringarray.t t/ffi_platypus_type_stringpointer.t t/ffi_platypus_typeparser.t t/ffi_platypus_typeparser_version0.t t/ffi_platypus_typeparser_version1.t t/ffi_probe.t t/ffi_probe_runner.t t/ffi_probe_runner_builder.t t/ffi_probe_runner_result.t t/ffi_temp.t t/forks.t t/gh117.t t/gh129.t t/lib/Test/Cleanup.pm t/lib/Test/FauxAttach.pm t/lib/Test/Platypus.pm t/memory.t t/threads.t t/type_complex_double.t t/type_complex_float.t t/type_custom.t t/type_double.t t/type_float.t t/type_longdouble.t t/type_longdouble__array.t t/type_longdouble__hide.t t/type_longdouble__ptr.t t/type_opaque.t t/type_record.t t/type_record_value.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 xs/ABI.xs xs/API.xs xs/Closure.xs xs/ClosureData.xs xs/DL.xs xs/Function.xs xs/Internal.xs xs/Record.xs xs/Type.xs xs/TypeParser.xs xs/cast.c xs/closure.c xs/complex.c xs/custom.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/critic.t xt/author/eol.t xt/author/no_tabs.t xt/author/pod.t xt/author/pod_coverage.t xt/author/pod_spelling_system.t xt/author/strict.t xt/author/version.t xt/release/changes.t xt/release/fixme.t FFI-Platypus-1.10/META.json000644 000765 000024 00000006237 13616651126 015752 0ustar00ollisgstaff000000 000000 { "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.012, 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" : { "ExtUtils::CBuilder" : "0" } }, "configure" : { "requires" : { "Capture::Tiny" : "0", "ExtUtils::MakeMaker" : "7.12", "ExtUtils::ParseXS" : "3.30", "IPC::Cmd" : "0", "perl" : "5.006" } }, "develop" : { "requires" : { "Devel::Hide" : "0", "Devel::PPPort" : "3.28", "FindBin" : "0", "Perl::Critic" : "0", "Test2::Require::Module" : "0.000060", "Test2::Tools::PerlCritic" : "0", "Test2::V0" : "0.000060", "Test::CPAN::Changes" : "0", "Test::EOL" : "0", "Test::Fixme" : "0.07", "Test::More" : "0.98", "Test::NoTabs" : "0", "Test::Pod" : "0", "Test::Pod::Coverage" : "0", "Test::Spelling" : "0", "Test::Strict" : "0", "YAML" : "0" } }, "runtime" : { "requires" : { "Capture::Tiny" : "0", "ExtUtils::MakeMaker" : "7.12", "FFI::CheckLib" : "0.05", "IPC::Cmd" : "0", "JSON::PP" : "0", "List::Util" : "1.45", "constant" : "1.32", "perl" : "5.008001" } }, "test" : { "requires" : { "Capture::Tiny" : "0", "Test::More" : "0.98", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/Perl5-FFI/FFI-Platypus/issues" }, "homepage" : "https://metacpan.org/pod/FFI::Platypus", "repository" : { "type" : "git", "url" : "git://github.com/Perl5-FFI/FFI-Platypus.git", "web" : "https://github.com/Perl5-FFI/FFI-Platypus" }, "x_IRC" : "irc://irc.perl.org/#native" }, "version" : "1.10", "x_contributors" : [ "Graham Ollis ", "Bakkiaraj Murugesan (bakkiaraj)", "Dylan Cali (calid)", "pipcet", "Zaki Mughal (zmughal)", "Fitz Elliott (felliott)", "Vickenty Fesunov (vyf)", "Gregor Herrmann (gregoa)", "Shlomi Fish (shlomif)", "Damyan Ivanov", "Ilya Pavlov (Ilya33)", "Petr Pisar (ppisar)", "Mohammad S Anwar (MANWAR)", "H\u00e5kon H\u00e6gland (hakonhagland, HAKONH)", "Meredith (merrilymeredith, MHOWARD)", "Diab Jerius (DJERIUS)" ], "x_generated_by_perl" : "v5.30.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.18", "x_use_unsafe_inc" : 0 } FFI-Platypus-1.10/META.yml000644 000765 000024 00000003137 13616651126 015576 0ustar00ollisgstaff000000 000000 --- abstract: 'Write Perl bindings to non-Perl libraries with FFI. No XS required.' author: - 'Graham Ollis ' build_requires: Capture::Tiny: '0' ExtUtils::CBuilder: '0' Test::More: '0.98' perl: '5.008001' configure_requires: Capture::Tiny: '0' ExtUtils::MakeMaker: '7.12' ExtUtils::ParseXS: '3.30' IPC::Cmd: '0' perl: '5.006' dynamic_config: 1 generated_by: 'Dist::Zilla version 6.012, 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: Capture::Tiny: '0' ExtUtils::MakeMaker: '7.12' FFI::CheckLib: '0.05' IPC::Cmd: '0' JSON::PP: '0' List::Util: '1.45' constant: '1.32' perl: '5.008001' resources: IRC: irc://irc.perl.org/#native bugtracker: https://github.com/Perl5-FFI/FFI-Platypus/issues homepage: https://metacpan.org/pod/FFI::Platypus repository: git://github.com/Perl5-FFI/FFI-Platypus.git version: '1.10' x_contributors: - 'Graham Ollis ' - 'Bakkiaraj Murugesan (bakkiaraj)' - 'Dylan Cali (calid)' - pipcet - 'Zaki Mughal (zmughal)' - 'Fitz Elliott (felliott)' - 'Vickenty Fesunov (vyf)' - 'Gregor Herrmann (gregoa)' - 'Shlomi Fish (shlomif)' - 'Damyan Ivanov' - 'Ilya Pavlov (Ilya33)' - 'Petr Pisar (ppisar)' - 'Mohammad S Anwar (MANWAR)' - 'Håkon Hægland (hakonhagland, HAKONH)' - 'Meredith (merrilymeredith, MHOWARD)' - 'Diab Jerius (DJERIUS)' x_generated_by_perl: v5.30.0 x_serialization_backend: 'YAML::Tiny version 1.73' x_use_unsafe_inc: 0 FFI-Platypus-1.10/perlcriticrc000644 000765 000024 00000003642 13616651126 016736 0ustar00ollisgstaff000000 000000 severity = 1 only = 1 [Freenode::ArrayAssignAref] [Freenode::BarewordFilehandles] [Freenode::ConditionalDeclarations] [Freenode::ConditionalImplicitReturn] [Freenode::DeprecatedFeatures] [Freenode::DiscouragedModules] [Freenode::DollarAB] [Freenode::Each] [Freenode::IndirectObjectNotation] [Freenode::LexicalForeachIterator] [Freenode::LoopOnHash] [Freenode::ModPerl] [Freenode::OpenArgs] [Freenode::OverloadOptions] [Freenode::POSIXImports] [Freenode::PackageMatchesFilename] [Freenode::PreferredAlternatives] [Freenode::StrictWarnings] extra_importers = Test2::V0 [Freenode::Threads] [Freenode::Wantarray] [Freenode::WarningsSwitch] [Freenode::WhileDiamondDefaultAssignment] [BuiltinFunctions::ProhibitBooleanGrep] ;[BuiltinFunctions::ProhibitStringyEval] [BuiltinFunctions::ProhibitStringySplit] [BuiltinFunctions::ProhibitVoidGrep] [BuiltinFunctions::ProhibitVoidMap] [ClassHierarchies::ProhibitExplicitISA] [ClassHierarchies::ProhibitOneArgBless] [CodeLayout::ProhibitHardTabs] allow_leading_tabs = 0 [CodeLayout::ProhibitTrailingWhitespace] [CodeLayout::RequireConsistentNewlines] [ControlStructures::ProhibitLabelsWithSpecialBlockNames] [ControlStructures::ProhibitMutatingListFunctions] [ControlStructures::ProhibitUnreachableCode] [InputOutput::ProhibitBarewordFileHandles] [InputOutput::ProhibitJoinedReadline] [InputOutput::ProhibitTwoArgOpen] [Miscellanea::ProhibitFormats] [Miscellanea::ProhibitUselessNoCritic] [Modules::ProhibitConditionalUseStatements] ;[Modules::RequireEndWithOne] [Modules::RequireNoMatchVarsWithUseEnglish] [Objects::ProhibitIndirectSyntax] [RegularExpressions::ProhibitUselessTopic] [Subroutines::ProhibitNestedSubs] [ValuesAndExpressions::ProhibitLeadingZeros] [ValuesAndExpressions::ProhibitMixedBooleanOperators] [ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] [Variables::ProhibitPerl4PackageNames] [Variables::ProhibitUnusedVariables] FFI-Platypus-1.10/README000644 000765 000024 00000171053 13616651126 015210 0ustar00ollisgstaff000000 000000 NAME FFI::Platypus - Write Perl bindings to non-Perl libraries with FFI. No XS required. VERSION version 1.10 SYNOPSIS use FFI::Platypus; # for all new code you should use api => 1 my $ffi = FFI::Platypus->new( api => 1 ); $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. You are strongly encouraged to use API level 1 for all new code. There are a number of improvements and design fixes that you get for free. You should even consider updating existing modules to use API level 1 where feasible. How do I do that you might ask? Simply pass in the API level to the platypus constructor. my $ffi = FFI::Platypus->new( api => 1 ); The Platypus documentation has already been updated to assume API level 1. CONSTRUCTORS new my $ffi = FFI::Platypus->new( api => 1, %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 api Sets the API level. Legal values are 0 Original API level. See FFI::Platypus::TypeParser::Version0 for details on the differences. 1 Enable the next generation type parser which allows pass-by-value records and type decoration on basic types. Using API level 1 prior to Platypus version 1.00 will trigger a (noisy) warning. All new code should be written with this set to 1! The Platypus documentation assumes this api level is set. lib Either a pathname (string) or a list of pathnames (array ref of strings) to pre-populate the lib attribute. Use [undef] to search the current process for symbols. 0.48 undef (without the array reference) can be used to search the current process for symbols. 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 mangler $ffi->mangler(\&mangler); Specify a customer mangler to be used for symbol lookup. This is usually useful when you are writing bindings for a library where all of the functions have the same prefix. Example: $ffi->mangler(sub { my($symbol) = @_; return "foo_$symbol"; }); $ffi->function( get_bar => [] => 'int' ); # attaches foo_get_bar my $f = $ffi->function( set_baz => ['int'] => 'void' ); $f->call(22); # calls foo_set_baz function my $function = $ffi->function($name => \@argument_types => $return_type); my $function = $ffi->function($address => \@argument_types => $return_type); my $function = $ffi->function($name => \@argument_types => $return_type, \&wrapper); my $function = $ffi->function($address => \@argument_types => $return_type, \&wrapper); 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. [version 0.76] If the last argument is a code reference, then it will be used as a wrapper around the function when called. The first argument to the wrapper will be the inner function, or if it is later attached an xsub. This can be used if you need to verify/modify input/output data. Examples: my $function = $ffi->function('my_function_name', ['int', 'string'] => 'string'); my $return_string = $function->(1, "hi there"); [version 0.91] my $function = $ffi->function( $name => \@fixed_argument_types => \@var_argument_types => $return_type); my $function = $ffi->function( $name => \@fixed_argument_types => \@var_argument_types => $return_type, \&wrapper); Version 0.91 and later allows you to creat functions for c variadic functions (such as printf, scanf, etc) which can take a variable number of arguments. The first set of arguments are the fixed set, the second set are the variable arguments to bind with. The variable argument types must be specified in order to create a function object, so if you need to call variadic function with different set of arguments then you will need to create a new function object each time: # int printf(const char *fmt, ...); $ffi->function( printf => ['string'] => ['int'] => 'int' ) ->call("print integer %d\n", 42); $ffi->function( printf => ['string'] => ['string'] => 'int' ) ->call("print string %s\n", 'platypus'); Some older versions of libffi and possibly some platforms may not support variadic functions. If you try to create a one, then an exception will be thrown. 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, \&wrapper); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type, \&wrapper); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type, \&wrapper); 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; }); [version 0.91] $ffi->attach($name => \@fixed_argument_types => \@var_argument_types, $return_type); $ffi->attach($name => \@fixed_argument_types => \@var_argument_types, $return_type, \&wrapper); As of version 0.91 you can attach a variadic functions, if it is supported by the platform / libffi that you are using. For details see the function documentation. If not supported by the implementation then an exception will be thrown. closure my $closure = $ffi->closure($coderef); my $closure = FFI::Platypus->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 and FFI::Platypus::Closure. 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); my $size = FFI::Platypus->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). bundle [version 0.96 api = 1+] $ffi->bundle($package, \@args); $ffi->bundle(\@args); $ffi->bundle($package); $ffi->bundle; This is an interface for bundling compiled code with your distribution intended to eventually replace the package method documented above. See FFI::Platypus::Bundle for details on how this works. package [version 0.15 api = 0] $ffi->package($package, $file); # usually __PACKAGE__ and __FILE__ can be used $ffi->package; # autodetect Note: This method is officially discouraged in favor of bundle described above. If you use FFI::Build (or the older deprecated 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( api => 1 ); $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 anoter Perl FFI library and it seems to work most # of the time, but also seems to SIGSEGV sometimes. I saw the same behavior # in the old 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( api => 1 ); $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: $ffi->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( api => 1 ); 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_1(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( api => 1 ); $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). The C localtime function takes a pointer to a record, hence we suffix the type with a star: record(My::UnixTime)*. If the function takes a record in pass-by-value mode then we'd just say record(My::UnixTime) with no star suffix. libuuid use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new( api => 1 ); $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( api => 1 ); $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( api => 1 ); $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( api => 1 ); 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( api => 1 ); $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::CheckLib qw( find_lib_or_exit ); # 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 = FFI::Platypus->new( api => 1 ); $ffi->lib(find_lib_or_exit lib => 'archive'); $ffi->type('object(Archive)' => 'archive_t'); $ffi->type('object(ArchiveRead)' => 'archive_read_t'); $ffi->type('object(ArchiveWrite)' => 'archive_write_t'); $ffi->type('object(ArchiveEntry)' => 'archive_entry_t'); package Archive; # base class is "abstract" having no constructor or destructor $ffi->mangler(sub { my($name) = @_; "archive_$name"; }); $ffi->attach( error_string => ['archive_t'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_read_$name"; }); $ffi->attach( new => ['string'] => 'archive_read_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_t'] => 'void' ); $ffi->attach( support_filter_all => ['archive_t'] => 'int' ); $ffi->attach( support_format_all => ['archive_t'] => 'int' ); $ffi->attach( open_filename => ['archive_t','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive_t', 'archive_entry_t' ] => 'int' ); $ffi->attach( data_skip => ['archive_t'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_write_$name"; }); $ffi->attach( new => ['string'] => 'archive_write_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_write_t'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->mangler(sub { my($name) = @_; "archive_entry_$name"; }); $ffi->attach( new => ['string'] => 'archive_entry_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry_t'] => 'void' ); $ffi->attach( pathname => ['archive_entry_t'] => '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. We use Platypus's object type for this implementation, which is a wrapper around an opaque (can also be an integer) type that is blessed into a particular class. Another advanced feature of this example is that we define a mangler to modify the symbol resolution for each class. This means we can do this when we define a method for Archive: $ffi->attach( support_filter_all => ['archive_t'] => 'int' ); Rather than this: $ffi->attach( [ archive_read_support_filter_all => 'support_read_filter_all' ] => ['archive_t'] => 'int' ); ); unix open use FFI::Platypus; { package FD; use constant O_RDONLY => 0; use constant O_WRONLY => 1; use constant O_RDWR => 2; use constant IN => bless \do { my $in=0 }, __PACKAGE__; use constant OUT => bless \do { my $out=1 }, __PACKAGE__; use constant ERR => bless \do { my $err=2 }, __PACKAGE__; my $ffi = FFI::Platypus->new( api => 1, lib => [undef]); $ffi->type('object(FD,int)' => 'fd'); $ffi->attach( [ 'open' => 'new' ] => [ 'string', 'int', 'mode_t' ] => 'fd' => sub { my($xsub, $class, $fn, @rest) = @_; my $fd = $xsub->($fn, @rest); die "error opening $fn $!" if $$fd == -1; $fd; }); $ffi->attach( write => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( read => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( close => ['fd'] => 'int' ); } my $fd = FD->new("$0", FD::O_RDONLY); my $buffer = "\0" x 10; while(my $br = $fd->read($buffer, 10)) { FD::OUT->write($buffer, $br); } $fd->close; Discussion: The Unix file system calls use an integer handle for each open file. We can use the same object type that we used for libarchive above, except we let platypus know that the underlying type is int instead of opaque (the latter being the default for the object type). Mainly just for demonstration since Perl has much better IO libraries, but now we have an OO interface to the Unix IO functions. 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( api => 1 ); $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. bundle your own code ffi/foo.c: #include #include typedef struct { char *name; int value; } foo_t; foo_t* foo__new(const char *class_name, const char *name, int value) { (void)class_name; foo_t *self = malloc( sizeof( foo_t ) ); self->name = strdup(name); self->value = value; return self; } const char * foo__name(foo_t *self) { return self->name; } int foo__value(foo_t *self) { return self->value; } void foo__DESTROY(foo_t *self) { free(self->name); free(self); } lib/Foo.pm: package Foo; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Foo)' => 'foo_t'); $ffi->mangler(sub { my $name = shift; $name =~ s/^/foo__/; $name; }); $ffi->bundle; $ffi->attach( new => [ 'string', 'string', 'int' ] => 'foo_t' ); $ffi->attach( name => [ 'foo_t' ] => 'string' ); $ffi->attach( value => [ 'foo_t' ] => 'int' ); $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); } 1; You can bundle your own C (or other compiled language) code with your Perl extension. Sometimes this is helpful for smoothing over the interface of a C library which is not very FFI friendly. Sometimes you may want to write some code in C for a tight loop. Either way, you can do this with the Platypus bundle interface. See FFI::Platypus::Bundle for more details. Also related is the bundle constant interface, which allows you to define Perl constants in C space. See FFI::Platypus::Constant for details. FAQ How do I get constants defined as macros in C header files This turns out to be a challenge for any language calling into C, which frequently uses #define macros to define constants like so: #define FOO_STATIC 1 #define FOO_DYNAMIC 2 #define FOO_OTHER 3 As macros are expanded and their definitions are thrown away by the C pre-processor there isn't any way to get the name/value mappings from the compiled dynamic library. You can manually create equivalent constants in your Perl source: use constant FOO_STATIC => 1; use constant FOO_DYNAMIC => 2; use constant FOO_OTHER => 3; If there are a lot of these types of constants you might want to consider using a tool (Convert::Binary::C can do this) that can extract the constants for you. See also the "Integer constants" example in FFI::Platypus::Type. You can also use the new Platypus bundle interface to define Perl constants from C space. This is more reliable, but does require a compiler at install time. It is recommended mainly for writing bindings against libraries that have constants that can vary widely from platform to platform. See FFI::Platypus::Constant for details. What about enums? The C enum types are integers. The underlying type is up to the platform, so Platypus provides enum and senum types for unsigned and singed enums respectively. At least some compilers treat signed and unsigned enums as different types. The enum values are essentially the same as macro constants described above from an FFI perspective. Thus the process of defining enum values is identical to the process of defining macro constants in Perl. For more details on enumerated types see "Enum types" in FFI::Platypus::Type. Memory leaks There are a couple places where memory is allocated, but never deallocated that may look like memory leaks by tools designed to find memory leaks like valgrind. This memory is intended to be used for the lifetime of the perl process so there normally this isn't a problem unless you are embedding a Perl interpreter which doesn't closely match the lifetime of your overall application. Specifically: type cache some types are cached and not freed. These are needed as long as there are FFI functions that could be called. attached functions Attaching a function as an xsub will definitely allocate memory that won't be freed because the xsub could be called at any time, including in END blocks. The Platypus team plans on adding a hook to free some of this "leaked" memory for use cases where Perl and Platypus are embedded in a larger application where the lifetime of the Perl process is significantly smaller than the overall lifetime of the whole process. I get seg faults on some platforms but not others with a library using pthreads. On some platforms, Perl isn't linked with libpthreads if Perl threads are not enabled. On some platforms this doesn't seem to matter, libpthreads can be loaded at runtime without much ill-effect. (Linux from my experience doesn't seem to mind one way or the other). Some platforms are not happy about this, and about the only thing that you can do about it is to build Perl such that it links with libpthreads even if it isn't a threaded Perl. This is not really an FFI issue, but a Perl issue, as you will have the same problem writing XS code for the such libraries. Doesn't work on Perl 5.10.0. I try as best as possible to support the same range of Perls as the Perl toolchain. That means all the way back to 5.8.1. Unfortunately, 5.10.0 seems to have a problem that is difficult to diagnose. Patches to fix are welcome, if you want to help out on this, please see: https://github.com/Perl5-FFI/FFI-Platypus/issues/68 Since this is an older buggy version of Perl it is recommended that you instead upgrade to 5.10.1 or later. 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 older versions of Google's Go. This is a problem for C / XS code as well. Languages that do not compile to machine code Like .NET based languages and Java. 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/perl5-FFI/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/Perl5-FFI/FFI-Platypus/pulls This project is developed using Dist::Zilla. The project's git repository also comes with the Makefile.PL file 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 Makefile.PL % make % make ffi-test % 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_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 Makefile.PL DEBUG_FAKE32: + making Math::Int64 a prereq + Using Math::Int64's C API to manipulate 64 bit values Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json % 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 Makefile.PL: helix% env FFI_PLATYPUS_NO_ALLOCA=1 perl Makefile.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json V When building platypus may hide some of the excessive output when probing and building, unless you set V to a true value. % env V=1 perl Makefile.PL % make V=1 ... 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/Perl5-FFI/FFI-Performance System integrators This distribution uses Alien::FFI in fallback mode, meaning if the system doesn't provide pkg-config and libffi it will attempt to download libffi and build it from source. If you are including Platypus in a larger system (for example a Linux distribution) you only need to make sure to declare pkg-config or pkgconf and the development package for libffi as prereqs for this module. 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. 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. 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. 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. Dan Book, who goes by Grinnz on IRC for answering user questions about FFI and Platypus. In addition I'd like to thank Alessandro Ghedini (ALEXBIO) whose work on another Perl FFI library helped drive some of the development ideas for FFI::Platypus. AUTHOR Author: Graham Ollis Contributors: Bakkiaraj Murugesan (bakkiaraj) Dylan Cali (calid) pipcet Zaki Mughal (zmughal) Fitz Elliott (felliott) Vickenty Fesunov (vyf) Gregor Herrmann (gregoa) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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. FFI-Platypus-1.10/SUPPORT000644 000765 000024 00000000540 13616651126 015417 0ustar00ollisgstaff000000 000000 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/perl5-FFI/FFI-Platypus/issues FFI-Platypus-1.10/t/000755 000765 000024 00000000000 13616651126 014564 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/xs/000755 000765 000024 00000000000 13616651126 014753 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/xt/000755 000765 000024 00000000000 13616651126 014754 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/xt/author/000755 000765 000024 00000000000 13616651126 016256 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/xt/release/000755 000765 000024 00000000000 13616651126 016374 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/xt/release/changes.t000644 000765 000024 00000001113 13616651126 020165 0ustar00ollisgstaff000000 000000 use 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-1.10/xt/release/fixme.t000644 000765 000024 00000000616 13616651126 017674 0ustar00ollisgstaff000000 000000 use 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, ); FFI-Platypus-1.10/xt/author/critic.t000644 000765 000024 00000000515 13616651126 017721 0ustar00ollisgstaff000000 000000 use Test2::Require::Module 'Test2::Tools::PerlCritic'; use Test2::Require::Module 'Perl::Critic'; use Test2::Require::Module 'Perl::Critic::Freenode'; use Test2::V0; use Perl::Critic; use Test2::Tools::PerlCritic; my $critic = Perl::Critic->new( -profile => 'perlcriticrc', ); perl_critic_ok ['lib','t'], $critic; done_testing; FFI-Platypus-1.10/xt/author/eol.t000644 000765 000024 00000000510 13616651126 017216 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; BEGIN { plan skip_all => '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 )); FFI-Platypus-1.10/xt/author/no_tabs.t000644 000765 000024 00000000522 13616651126 020067 0ustar00ollisgstaff000000 000000 use 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 )); FFI-Platypus-1.10/xt/author/pod.t000644 000765 000024 00000000472 13616651126 017230 0ustar00ollisgstaff000000 000000 use 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 )); FFI-Platypus-1.10/xt/author/pod_coverage.t000644 000765 000024 00000004003 13616651126 021075 0ustar00ollisgstaff000000 000000 use 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; }; plan skip_all => 'test does not always work in cip check' if defined $ENV{CIPSTATIC} && $ENV{CIPSTATIC} eq 'true'; }; 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-1.10/xt/author/pod_spelling_system.t000644 000765 000024 00000002370 13616651126 022530 0ustar00ollisgstaff000000 000000 use 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-1.10/xt/author/strict.t000644 000765 000024 00000001031 13616651126 017746 0ustar00ollisgstaff000000 000000 use 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::V0', 'Test2::Bundle::Extended'; note "enabling strict = $_" for @Test::Strict::MODULES_ENABLING_STRICT; all_perl_files_ok( grep { -e $_ } qw( bin lib t Makefile.PL )); FFI-Platypus-1.10/xt/author/version.t000644 000765 000024 00000001473 13616651126 020135 0ustar00ollisgstaff000000 000000 use 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 YAML' unless eval q{ use YAML; 1; }; } 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; if($config->{version}->{dir}) { note "using dir " . $config->{version}->{dir} } version_all_ok($config->{version}->{dir} ? ($config->{version}->{dir}) : ()); done_testing; FFI-Platypus-1.10/xs/ABI.xs000644 000765 000024 00000001174 13616651126 015725 0ustar00ollisgstaff000000 000000 MODULE = 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 FFI-Platypus-1.10/xs/API.xs000644 000765 000024 00000015334 13616651126 015746 0ustar00ollisgstaff000000 000000 MODULE = 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 FFI-Platypus-1.10/xs/cast.c000644 000765 000024 00000000420 13616651126 016045 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" #if SIZEOF_VOIDP == 4 uint64_t cast0(void) { return 0LL; } #else void * cast0(void) { return NULL; } #endif #if SIZEOF_VOIDP == 4 uint64_t cast1(uint64_t value) { return value; } #else void * cast1(void *value) { return value; } #endif FFI-Platypus-1.10/xs/closure.c000644 000765 000024 00000015331 13616651126 016576 0ustar00ollisgstaff000000 000000 #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; if(!(flags & G_NOARGS)) { ENTER; SAVETMPS; } PUSHMARK(SP); if(!(flags & G_NOARGS)) { for(i=0; i< ffi_cif->nargs; i++) { switch(extra->argument_types[i]->type_code) { case FFI_PL_TYPE_VOID: break; case FFI_PL_TYPE_SINT8: sv = sv_newmortal(); sv_setiv(sv, *((int8_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_SINT16: sv = sv_newmortal(); sv_setiv(sv, *((int16_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_SINT32: sv = sv_newmortal(); sv_setiv(sv, *((int32_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_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_PL_TYPE_UINT8: sv = sv_newmortal(); sv_setuv(sv, *((uint8_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_UINT16: sv = sv_newmortal(); sv_setuv(sv, *((uint16_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_UINT32: sv = sv_newmortal(); sv_setuv(sv, *((uint32_t*)arguments[i])); XPUSHs(sv); break; case FFI_PL_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_PL_TYPE_FLOAT: sv = sv_newmortal(); sv_setnv(sv, *((float*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_DOUBLE: sv = sv_newmortal(); sv_setnv(sv, *((double*)arguments[i])); XPUSHs(sv); break; case FFI_PL_TYPE_OPAQUE: sv = sv_newmortal(); if( *((void**)arguments[i]) != NULL) sv_setiv(sv, PTR2IV( *((void**)arguments[i]) )); XPUSHs(sv); break; case FFI_PL_TYPE_STRING: sv = sv_newmortal(); if( *((char**)arguments[i]) != NULL) { sv_setpv(sv, *((char**)arguments[i])); } XPUSHs(sv); break; case FFI_PL_TYPE_RECORD: sv = sv_newmortal(); if( *((char**)arguments[i]) != NULL) { sv_setpvn(sv, *((char**)arguments[i]), extra->argument_types[i]->extra[0].record.size); if(extra->argument_types[i]->extra[0].record.stash) { SV *ref = newRV_inc(sv); sv_bless(ref, extra->argument_types[i]->extra[0].record.stash); SvREADONLY_on(sv); sv = ref; } else { SvREADONLY_on(sv); } } XPUSHs(sv); break; default: warn("bad type"); break; } } PUTBACK; } count = call_sv(closure->coderef, flags | G_EVAL); 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; switch(extra->return_type->type_code) { case FFI_PL_TYPE_VOID: break; case FFI_PL_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_PL_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_PL_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_PL_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_PL_TYPE_UINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ((uint32_t*)result)[1] = SvUV(sv); #else *((uint32_t*)result) = SvUV(sv); #endif break; case FFI_PL_TYPE_SINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 ((int32_t*)result)[1] = SvIV(sv); #else *((int32_t*)result) = SvIV(sv); #endif break; case FFI_PL_TYPE_UINT64: #ifdef HAVE_IV_IS_64 *((uint64_t*)result) = SvUV(sv); #else *((uint64_t*)result) = SvU64(sv); #endif break; case FFI_PL_TYPE_SINT64: #ifdef HAVE_IV_IS_64 *((int64_t*)result) = SvIV(sv); #else *((int64_t*)result) = SvI64(sv); #endif break; case FFI_PL_TYPE_FLOAT: *((float*)result) = SvNV(sv); break; case FFI_PL_TYPE_DOUBLE: *((double*)result) = SvNV(sv); break; case FFI_PL_TYPE_OPAQUE: *((void**)result) = SvOK(sv) ? INT2PTR(void*, SvIV(sv)) : NULL; break; default: warn("bad type"); break; } PUTBACK; } if(!(flags & G_NOARGS)) { FREETMPS; LEAVE; } } FFI-Platypus-1.10/xs/Closure.xs000644 000765 000024 00000001510 13616651126 016740 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Closure void _sticky(self) SV *self CODE: if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) { SvREFCNT_inc_simple_void_NN(SvRV(self)); SvREFCNT_inc_simple_void_NN(SvRV(self)); } else croak("object is not a closure"); void _unstick(self) SV *self CODE: if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) { SvREFCNT_dec(SvRV(self)); SvREFCNT_dec(SvRV(self)); } else croak("object is not a closure"); U32 _svrefcnt(self) SV *self CODE: /* used in test only */ if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) { RETVAL = SvREFCNT(SvRV(self)); } else croak("object is not a closure"); OUTPUT: RETVAL FFI-Platypus-1.10/xs/ClosureData.xs000644 000765 000024 00000000317 13616651126 017536 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::ClosureData void DESTROY(self) ffi_pl_closure *self CODE: SvREFCNT_dec(self->coderef); ffi_closure_free(self->ffi_closure); Safefree(self); FFI-Platypus-1.10/xs/complex.c000644 000765 000024 00000006612 13616651126 016573 0ustar00ollisgstaff000000 000000 #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; } static void set(SV *sv, SV *new_value, int imag) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); XPUSHs(sv); XPUSHs(new_value); PUTBACK; call_pv(imag ? "Math::Complex::Im" : "Math::Complex::Re", G_DISCARD); FREETMPS; LEAVE; } void ffi_pl_perl_to_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 if(SvOK(sv)) { ptr[0] = SvNV(sv); ptr[1] = 0.0; } else { ptr[0] = 0.0; ptr[1] = 0.0; } } void ffi_pl_complex_float_to_perl(SV *sv, float *ptr) { if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { /* the complex variable is a Math::Complex object */ set(sv, sv_2mortal(newSVnv(ptr[0])), 0); set(sv, sv_2mortal(newSVnv(ptr[1])), 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* the compex variable is already an array */ AV *av = (AV*) SvRV(sv); av_store(av, 0, newSVnv(ptr[0])); av_store(av, 1, newSVnv(ptr[1])); } else { /* the complex variable is something else and an array needs to be created */ SV *values[2]; AV *av; values[0] = newSVnv(ptr[0]); values[1] = newSVnv(ptr[1]); av = av_make(2, values); sv_setsv(sv, newRV_noinc((SV*)av)); } } void ffi_pl_perl_to_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 if(SvOK(sv)) { ptr[0] = SvNV(sv); ptr[1] = 0.0; } else { ptr[0] = 0.0; ptr[1] = 0.0; } } void ffi_pl_complex_double_to_perl(SV *sv, double *ptr) { if(SvOK(sv) && sv_isobject(sv) && sv_derived_from(sv, "Math::Complex")) { /* the complex variable is a Math::Complex object */ set(sv, sv_2mortal(newSVnv(ptr[0])), 0); set(sv, sv_2mortal(newSVnv(ptr[1])), 1); } else if(SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVAV) { /* the compex variable is already an array */ AV *av = (AV*) SvRV(sv); av_store(av, 0, newSVnv(ptr[0])); av_store(av, 1, newSVnv(ptr[1])); } else { /* the complex variable is something else and an array needs to be created */ SV *values[2]; AV *av; values[0] = newSVnv(ptr[0]); values[1] = newSVnv(ptr[1]); av = av_make(2, values); sv_setsv(sv, newRV_noinc((SV*)av)); } } FFI-Platypus-1.10/xs/custom.c000644 000765 000024 00000001520 13616651126 016427 0ustar00ollisgstaff000000 000000 #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; } FFI-Platypus-1.10/xs/DL.xs000644 000765 000024 00000002762 13616651126 015635 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::DL BOOT: { HV *stash; stash = gv_stashpv("FFI::Platypus::DL", TRUE); #ifdef RTLD_LAZY newCONSTSUB(stash, "RTLD_PLATYPUS_DEFAULT", newSViv(RTLD_LAZY)); newCONSTSUB(stash, "RTLD_LAZY", newSViv(RTLD_LAZY)); #else newCONSTSUB(stash, "RTLD_PLATYPUS_DEFAULT", newSViv(0)); #endif #ifdef RTLD_NOW newCONSTSUB(stash, "RTLD_NOW", newSViv(RTLD_NOW)); #endif #ifdef RTLD_GLOBAL newCONSTSUB(stash, "RTLD_GLOBAL", newSViv(RTLD_GLOBAL)); #endif #ifdef RTLD_LOCAL newCONSTSUB(stash, "RTLD_LOCAL", newSViv(RTLD_LOCAL)); #endif #ifdef RTLD_NODELETE newCONSTSUB(stash, "RTLD_NODELETE", newSViv(RTLD_NODELETE)); #endif #ifdef RTLD_NOLOAD newCONSTSUB(stash, "RTLD_NOLOAD", newSViv(RTLD_NOLOAD)); #endif #ifdef RTLD_DEEPBIND newCONSTSUB(stash, "RTLD_DEEPBIND", newSViv(RTLD_DEEPBIND)); #endif } void * dlopen(filename, flags); ffi_pl_string filename int flags INIT: void *ptr; CODE: ptr = dlopen(filename, flags); if(ptr == NULL) { XSRETURN_EMPTY; } else { RETVAL = ptr; } OUTPUT: RETVAL const char * dlerror(); void * dlsym(handle, symbol); void *handle const char *symbol INIT: void *ptr; CODE: ptr = dlsym(handle, symbol); if(ptr == NULL) { XSRETURN_EMPTY; } else { RETVAL = ptr; } OUTPUT: RETVAL int dlclose(handle); void *handle CODE: if(!PL_dirty) RETVAL = dlclose(handle); else RETVAL = 0; OUTPUT: RETVAL FFI-Platypus-1.10/xs/Function.xs000644 000765 000024 00000020135 13616651126 017115 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Function::Function ffi_pl_function * new(class, platypus, address, abi, var_fixed_args, return_type, ...) const char *class SV *platypus void *address int abi int var_fixed_args 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_abi ffi_abi; int extra_arguments; dMY_CXT; CODE: (void)class; #ifndef FFI_PL_PROBE_VARIADIC if(var_fixed_args != -1) { croak("variadic functions are not supported by some combination of your libffi/compiler/platypus"); } #endif #ifndef FFI_PL_PROBE_RECORDVALUE if(return_type->type_code == FFI_PL_TYPE_RECORD_VALUE) { croak("returning record values is not supported by some combination of your libffi/compiler/platypus"); } #endif ffi_abi = abi == -1 ? FFI_DEFAULT_ABI : abi; for(i=0,extra_arguments=0; i<(items-6); i++) { ffi_pl_type *arg_type; arg = ST(i+6); if(!(sv_isobject(arg) && sv_derived_from(arg, "FFI::Platypus::Type"))) { croak("non-type parameter passed in as type"); } arg_type = INT2PTR(ffi_pl_type*, SvIV((SV*) SvRV(arg))); if(arg_type->type_code == FFI_PL_TYPE_VOID) croak("void not allowed as argument type"); if((arg_type->type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL) extra_arguments += arg_type->extra[0].custom_perl.argument_count; } Newx(buffer, (sizeof(ffi_pl_function) + sizeof(ffi_pl_type*)*(items-6+extra_arguments)), char); self = (ffi_pl_function*)buffer; Newx(ffi_argument_types, items-6+extra_arguments, ffi_type*); self->address = address; self->return_type = return_type; ffi_return_type = ffi_pl_type_to_libffi_type(return_type); for(i=0,n=0; i<(items-6); i++,n++) { arg = ST(i+6); self->argument_types[n] = INT2PTR(ffi_pl_type*, SvIV((SV*) SvRV(arg))); ffi_argument_types[n] = ffi_pl_type_to_libffi_type(self->argument_types[n]); if((self->argument_types[n]->type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_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] = ffi_pl_type_to_libffi_type(self->argument_types[n]); } n += self->argument_types[n]->extra[0].custom_perl.argument_count; } if( (self->argument_types[n]->type_code & (FFI_PL_BASE_MASK|FFI_PL_SIZE_MASK)) == FFI_PL_TYPE_LONG_DOUBLE && ((self->argument_types[n]->type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_POINTER || (self->argument_types[n]->type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_ARRAY) ) { /* * For historical reasons, we return longdouble pointer and array as Math::LongDouble * if it is installed, but we need to load it when the function is created, not on * the first call */ if(!MY_CXT.loaded_math_longdouble) { require_pv("Math/LongDouble.pm"); if(SvTRUE(ERRSV)) { MY_CXT.loaded_math_longdouble = 2; } else { MY_CXT.loaded_math_longdouble = 1; } } } } if( (return_type->type_code & (FFI_PL_BASE_MASK|FFI_PL_SIZE_MASK)) == FFI_PL_TYPE_LONG_DOUBLE ) { /* * For historical reasons, we return longdouble as Math::LongDouble if it is * installed, but we need to load it when the function is created, not on * the first call */ if(!MY_CXT.loaded_math_longdouble) { require_pv("Math/LongDouble.pm"); if(SvTRUE(ERRSV)) { MY_CXT.loaded_math_longdouble = 2; } else { MY_CXT.loaded_math_longdouble = 1; } } } if(var_fixed_args == -1) { ffi_status = ffi_prep_cif( &self->ffi_cif, /* ffi_cif | */ ffi_abi, /* ffi_abi | */ items-6+extra_arguments, /* int | argument count */ ffi_return_type, /* ffi_type * | return type */ ffi_argument_types /* ffi_type ** | argument types */ ); } else { #ifdef FFI_PL_PROBE_VARIADIC ffi_status = ffi_prep_cif_var( &self->ffi_cif, /* ffi_cif | */ ffi_abi, /* ffi_abi | */ var_fixed_args, /* int | fixed argument count */ items-6+extra_arguments, /* int | total argument count */ ffi_return_type, /* ffi_type * | return type */ ffi_argument_types /* ffi_type ** | argument types */ ); #endif } 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"); } self->platypus_sv = SvREFCNT_inc_simple_NN(platypus); RETVAL = self; OUTPUT: RETVAL void call(self, ...) ffi_pl_function *self PREINIT: int i, n, perl_arg_index; SV *arg; 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; int is_ret_rv; ffi_pl_function *f; CODE: if(!(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Function"))) croak("self is not of type FFI::Platypus::Function"); f = INT2PTR(ffi_pl_function*, SvIV((SV*) SvRV(self))); is_ret_rv = f->return_type->type_code == FFI_PL_TYPE_RECORD_VALUE; if(path_name == NULL) path_name = "unknown"; if(proto == NULL) cv = newXS(perl_name, is_ret_rv ? ffi_pl_sub_call_rv : 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, is_ret_rv ? ffi_pl_sub_call_rv : ffi_pl_sub_call, path_name, proto); #else newXSproto(perl_name, is_ret_rv ? ffi_pl_sub_call_rv : ffi_pl_sub_call, path_name, proto); cv = get_cv(perl_name,0); #endif } CvXSUBANY(cv).any_ptr = (void *) f; /* * No coresponding decrement !! * once attached, you can never free the function object, or the FFI::Platypus * it was created from. */ SvREFCNT_inc_simple_void_NN(self); SV* _sub_ref(self, path_name) SV *self ffi_pl_string path_name PREINIT: CV* cv; SV *ref; int is_ret_rv; ffi_pl_function *f; CODE: f = INT2PTR(ffi_pl_function*, SvIV((SV*) SvRV(self))); is_ret_rv = f->return_type->type_code == FFI_PL_TYPE_RECORD_VALUE; cv = newXS(NULL, is_ret_rv ? ffi_pl_sub_call_rv : ffi_pl_sub_call, path_name); 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_simple_void_NN(self); RETVAL = newRV_inc((SV*)cv); OUTPUT: RETVAL void DESTROY(self) ffi_pl_function *self CODE: SvREFCNT_dec(self->platypus_sv); if(!PL_dirty) { Safefree(self->ffi_cif.arg_types); Safefree(self); } MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Function::Wrapper void _set_prototype(proto, code) SV *proto; SV *code; PROTOTYPE: $$ PREINIT: SV *cv; /* not CV */ CODE: SvGETMAGIC(code); cv = SvRV(code); sv_copypv(cv, proto); FFI-Platypus-1.10/xs/Internal.xs000644 000765 000024 00000007276 13616651126 017117 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Internal void _init() INIT: HV *stash; CODE: stash = gv_stashpv("FFI::Platypus::Internal", TRUE); newCONSTSUB(stash, "FFI_PL_SIZE_0", newSViv(FFI_PL_SIZE_0)); newCONSTSUB(stash, "FFI_PL_SIZE_8", newSViv(FFI_PL_SIZE_8)); newCONSTSUB(stash, "FFI_PL_SIZE_16", newSViv(FFI_PL_SIZE_16)); newCONSTSUB(stash, "FFI_PL_SIZE_32", newSViv(FFI_PL_SIZE_32)); newCONSTSUB(stash, "FFI_PL_SIZE_64", newSViv(FFI_PL_SIZE_64)); newCONSTSUB(stash, "FFI_PL_SIZE_128", newSViv(FFI_PL_SIZE_128)); newCONSTSUB(stash, "FFI_PL_SIZE_256", newSViv(FFI_PL_SIZE_256)); newCONSTSUB(stash, "FFI_PL_SIZE_512", newSViv(FFI_PL_SIZE_512)); newCONSTSUB(stash, "FFI_PL_SIZE_PTR", newSViv(FFI_PL_SIZE_PTR)); newCONSTSUB(stash, "FFI_PL_SIZE_MASK", newSViv(FFI_PL_SIZE_MASK)); newCONSTSUB(stash, "FFI_PL_BASE_VOID", newSViv(FFI_PL_BASE_VOID)); newCONSTSUB(stash, "FFI_PL_BASE_SINT", newSViv(FFI_PL_BASE_SINT)); newCONSTSUB(stash, "FFI_PL_BASE_UINT", newSViv(FFI_PL_BASE_UINT)); newCONSTSUB(stash, "FFI_PL_BASE_FLOAT", newSViv(FFI_PL_BASE_FLOAT)); newCONSTSUB(stash, "FFI_PL_BASE_COMPLEX", newSViv(FFI_PL_BASE_COMPLEX)); newCONSTSUB(stash, "FFI_PL_BASE_OPAQUE", newSViv(FFI_PL_BASE_OPAQUE)); newCONSTSUB(stash, "FFI_PL_BASE_STRING", newSViv(FFI_PL_BASE_STRING)); newCONSTSUB(stash, "FFI_PL_BASE_CLOSURE", newSViv(FFI_PL_BASE_CLOSURE)); newCONSTSUB(stash, "FFI_PL_BASE_RECORD", newSViv(FFI_PL_BASE_RECORD)); newCONSTSUB(stash, "FFI_PL_BASE_MASK", newSViv(FFI_PL_BASE_MASK)); newCONSTSUB(stash, "FFI_PL_SHAPE_SCALAR", newSViv(FFI_PL_SHAPE_SCALAR)); newCONSTSUB(stash, "FFI_PL_SHAPE_POINTER", newSViv(FFI_PL_SHAPE_POINTER)); newCONSTSUB(stash, "FFI_PL_SHAPE_ARRAY", newSViv(FFI_PL_SHAPE_ARRAY)); newCONSTSUB(stash, "FFI_PL_SHAPE_CUSTOM_PERL", newSViv(FFI_PL_SHAPE_CUSTOM_PERL)); newCONSTSUB(stash, "FFI_PL_SHAPE_OBJECT", newSViv(FFI_PL_SHAPE_OBJECT)); newCONSTSUB(stash, "FFI_PL_SHAPE_CUSTOM_MASK", newSViv(FFI_PL_SHAPE_MASK)); newCONSTSUB(stash, "FFI_PL_TYPE_VOID", newSViv(FFI_PL_TYPE_VOID)); newCONSTSUB(stash, "FFI_PL_TYPE_SINT8", newSViv(FFI_PL_TYPE_SINT8)); newCONSTSUB(stash, "FFI_PL_TYPE_SINT16", newSViv(FFI_PL_TYPE_SINT16)); newCONSTSUB(stash, "FFI_PL_TYPE_SINT32", newSViv(FFI_PL_TYPE_SINT32)); newCONSTSUB(stash, "FFI_PL_TYPE_SINT64", newSViv(FFI_PL_TYPE_SINT64)); newCONSTSUB(stash, "FFI_PL_TYPE_UINT8", newSViv(FFI_PL_TYPE_UINT8)); newCONSTSUB(stash, "FFI_PL_TYPE_UINT16", newSViv(FFI_PL_TYPE_UINT16)); newCONSTSUB(stash, "FFI_PL_TYPE_UINT32", newSViv(FFI_PL_TYPE_UINT32)); newCONSTSUB(stash, "FFI_PL_TYPE_UINT64", newSViv(FFI_PL_TYPE_UINT64)); newCONSTSUB(stash, "FFI_PL_TYPE_FLOAT", newSViv(FFI_PL_TYPE_FLOAT)); newCONSTSUB(stash, "FFI_PL_TYPE_DOUBLE", newSViv(FFI_PL_TYPE_DOUBLE)); newCONSTSUB(stash, "FFI_PL_TYPE_LONG_DOUBLE", newSViv(FFI_PL_TYPE_LONG_DOUBLE)); newCONSTSUB(stash, "FFI_PL_TYPE_COMPLEX_FLOAT", newSViv(FFI_PL_TYPE_COMPLEX_FLOAT)); newCONSTSUB(stash, "FFI_PL_TYPE_COMPLEX_DOUBLE", newSViv(FFI_PL_TYPE_COMPLEX_DOUBLE)); newCONSTSUB(stash, "FFI_PL_TYPE_OPAQUE", newSViv(FFI_PL_TYPE_OPAQUE)); newCONSTSUB(stash, "FFI_PL_TYPE_STRING", newSViv(FFI_PL_TYPE_STRING)); newCONSTSUB(stash, "FFI_PL_TYPE_CLOSURE", newSViv(FFI_PL_TYPE_CLOSURE)); newCONSTSUB(stash, "FFI_PL_TYPE_RECORD", newSViv(FFI_PL_TYPE_RECORD)); newCONSTSUB(stash, "FFI_PL_TYPE_RECORD_VALUE", newSViv(FFI_PL_TYPE_RECORD_VALUE)); FFI-Platypus-1.10/xs/meta.c000644 000765 000024 00000020553 13616651126 016052 0ustar00ollisgstaff000000 000000 #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #include "ppport.h" #include "ffi_platypus.h" /* * - negative shift is undefined, so while it may work somewheree we make an explicit check for the * 0 size. * - We will eventually migrate fixed strings to be internally of record type, for now we have to * check the platypus type when we have a type_code == FFI_PL_BASE_RECORD */ #define unit_size(self) \ ((self->type_code & FFI_PL_BASE_MASK) == FFI_PL_BASE_RECORD \ ? (self->extra[0].record.size) \ : ((self->type_code & FFI_PL_SIZE_MASK) == FFI_PL_SIZE_0 \ ? 0 \ : 1 << ((self->type_code & FFI_PL_SIZE_MASK)-1) \ ) \ ) size_t ffi_pl_sizeof_new(ffi_pl_type *self) { switch( self->type_code & FFI_PL_SHAPE_MASK ) { case FFI_PL_SHAPE_SCALAR: case FFI_PL_SHAPE_CUSTOM_PERL: return unit_size(self); case FFI_PL_SHAPE_POINTER: return sizeof(void*); case FFI_PL_SHAPE_ARRAY: return unit_size(self) * self->extra[0].array.element_count; default: return 0; } } size_t ffi_pl_sizeof(ffi_pl_type *self) { if(self->type_code == FFI_PL_TYPE_RECORD) { return self->extra[0].record.size; } else if(self->type_code == FFI_PL_TYPE_RECORD_VALUE) { return self->extra[0].record_value.size; } else { return ffi_pl_sizeof_new(self); } } 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); hv_store(meta, "type_code", 9, newSViv(self->type_code), 0); switch(self->type_code & FFI_PL_SHAPE_MASK) { case FFI_PL_SHAPE_SCALAR: { switch(self->type_code) { case FFI_PL_TYPE_STRING: hv_store(meta, "element_size", 12, newSViv(sizeof(void*)), 0); hv_store(meta, "type", 4, newSVpv("string",0),0); switch(self->sub_type) { case FFI_PL_TYPE_STRING_RO: hv_store(meta, "access", 6, newSVpv("ro",0), 0); break; case FFI_PL_TYPE_STRING_RW: hv_store(meta, "access", 6, newSVpv("rw",0), 0); break; } break; case FFI_PL_TYPE_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); } break; case FFI_PL_TYPE_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); break; case FFI_PL_TYPE_RECORD_VALUE: hv_store(meta, "type", 4, newSVpv("record_value",0),0); hv_store(meta, "ref", 3, newSViv(1),0); hv_store(meta, "class", 5, newSVpv(self->extra[0].record_value.class,0), 0); break; default: hv_store(meta, "element_size", 12, newSViv(unit_size(self)), 0); hv_store(meta, "type", 4, newSVpv("scalar",0),0); break; } } break; case FFI_PL_SHAPE_POINTER: hv_store(meta, "element_size", 12, newSViv(unit_size(self)), 0); hv_store(meta, "type", 4, newSVpv("pointer",0),0); break; case FFI_PL_SHAPE_ARRAY: hv_store(meta, "element_size", 12, newSViv(unit_size(self)), 0); hv_store(meta, "type", 4, newSVpv("array",0),0); hv_store(meta, "element_count", 13, newSViv(self->extra[0].array.element_count), 0); break; case FFI_PL_SHAPE_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); break; } switch(self->type_code & (FFI_PL_SIZE_MASK | FFI_PL_BASE_MASK)) { case FFI_PL_TYPE_VOID: hv_store(meta, "element_type", 12, newSVpv("void",0),0); break; case FFI_PL_TYPE_FLOAT: case FFI_PL_TYPE_DOUBLE: #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE: #endif #ifdef FFI_TARGET_HAS_COMPLEX_TYPE case FFI_PL_TYPE_COMPLEX_FLOAT: case FFI_PL_TYPE_COMPLEX_DOUBLE: #endif hv_store(meta, "element_type", 12, newSVpv("float",0),0); break; case FFI_PL_TYPE_UINT8: case FFI_PL_TYPE_UINT16: case FFI_PL_TYPE_UINT32: case FFI_PL_TYPE_UINT64: hv_store(meta, "element_type", 12, newSVpv("int",0),0); hv_store(meta, "sign", 4, newSViv(0),0); break; case FFI_PL_TYPE_SINT8: case FFI_PL_TYPE_SINT16: case FFI_PL_TYPE_SINT32: case FFI_PL_TYPE_SINT64: hv_store(meta, "element_type", 12, newSVpv("int",0),0); hv_store(meta, "sign", 4, newSViv(1),0); break; case FFI_PL_TYPE_OPAQUE: hv_store(meta, "element_type", 12, newSVpv("opaque",0),0); break; } switch(self->type_code & (FFI_PL_SIZE_MASK | FFI_PL_BASE_MASK)) { case FFI_PL_TYPE_VOID: string = "void"; break; case FFI_PL_TYPE_FLOAT: string = "float"; break; case FFI_PL_TYPE_DOUBLE: string = "double"; break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE: string = "longdouble"; break; #endif case FFI_PL_TYPE_UINT8: string = "uint8"; break; case FFI_PL_TYPE_SINT8: string = "sint8"; break; case FFI_PL_TYPE_UINT16: string = "uint16"; break; case FFI_PL_TYPE_SINT16: string = "sint16"; break; case FFI_PL_TYPE_UINT32: string = "uint32"; break; case FFI_PL_TYPE_SINT32: string = "sint32"; break; case FFI_PL_TYPE_UINT64: string = "uint64"; break; case FFI_PL_TYPE_SINT64: string = "sint64"; break; case FFI_PL_TYPE_OPAQUE: case FFI_PL_TYPE_STRING: case FFI_PL_TYPE_CLOSURE: case FFI_PL_TYPE_RECORD: string = "pointer"; break; case FFI_PL_TYPE_RECORD_VALUE: string = "struct"; break; #ifdef FFI_TARGET_HAS_COMPLEX_TYPE case FFI_PL_TYPE_COMPLEX_FLOAT: string = "complex_float"; break; case FFI_PL_TYPE_COMPLEX_DOUBLE: string = "complex_double"; break; #endif default: warn("bad type: %04x\n", self->type_code & (FFI_PL_SIZE_MASK | FFI_PL_BASE_MASK)); string = NULL; break; } hv_store(meta, "ffi_type", 8, newSVpv(string,0),0); return meta; } ffi_pl_type *ffi_pl_type_new(size_t size) { char *buffer; ffi_pl_type *self; Newx(buffer, sizeof(ffi_pl_type) + size, char); self = (ffi_pl_type*) buffer; self->type_code = 0; self->sub_type = 0; return self; } FFI-Platypus-1.10/xs/names.c000644 000765 000024 00000003471 13616651126 016227 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" #include ffi_type * ffi_pl_type_to_libffi_type(ffi_pl_type *type) { int type_code = type->type_code; if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL) type_code = type_code & ~(FFI_PL_SHAPE_MASK); if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_OBJECT) type_code = type_code & ~(FFI_PL_SHAPE_MASK); switch(type_code) { case FFI_PL_TYPE_VOID: return &ffi_type_void; case FFI_PL_TYPE_SINT8: return &ffi_type_sint8; case FFI_PL_TYPE_SINT16: return &ffi_type_sint16; case FFI_PL_TYPE_SINT32: return &ffi_type_sint32; case FFI_PL_TYPE_SINT64: return &ffi_type_sint64; case FFI_PL_TYPE_UINT8: return &ffi_type_uint8; case FFI_PL_TYPE_UINT16: return &ffi_type_uint16; case FFI_PL_TYPE_UINT32: return &ffi_type_uint32; case FFI_PL_TYPE_UINT64: return &ffi_type_uint64; case FFI_PL_TYPE_FLOAT: return &ffi_type_float; case FFI_PL_TYPE_DOUBLE: return &ffi_type_double; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE: return &ffi_type_longdouble; #endif #if FFI_PL_PROBE_COMPLEX case FFI_PL_TYPE_COMPLEX_FLOAT: return &ffi_type_complex_float; case FFI_PL_TYPE_COMPLEX_DOUBLE: return &ffi_type_complex_double; #endif case FFI_PL_TYPE_OPAQUE: case FFI_PL_TYPE_STRING: case FFI_PL_TYPE_CLOSURE: case FFI_PL_TYPE_RECORD: return &ffi_type_pointer; case FFI_PL_TYPE_RECORD_VALUE: return type->extra[0].record_value.ffi_type; } switch(type_code & (FFI_PL_SHAPE_MASK)) { case FFI_PL_SHAPE_POINTER: case FFI_PL_SHAPE_ARRAY: return &ffi_type_pointer; default: fprintf(stderr, "FFI::Platypus: internal error: type = %04x\n", type_code); fflush(stderr); return NULL; } } FFI-Platypus-1.10/xs/perl_math_int64.c000644 000765 000024 00000011032 13616651126 020113 0ustar00ollisgstaff000000 000000 #include "ffi_platypus_config.h" #ifndef HAVE_IV_IS_64 /* imported from Math::Int64 0.34 6 December 2014 by PLICEASE */ /* * perl_math_int64.c - This file is in the public domain * Author: Salvador Fandino * * 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 FFI-Platypus-1.10/xs/Record.xs000644 000765 000024 00000013067 13616651126 016554 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Record int _ffi_record_ro(self) SV* self CODE: if(SvROK(self)) self = SvRV(self); if(!SvOK(self)) croak("Null record error"); RETVAL = SvREADONLY(self) ? 1 : 0; OUTPUT: RETVAL 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=NULL; /* 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; switch(type->type_code & FFI_PL_SHAPE_MASK) { case FFI_PL_SHAPE_ARRAY: member->count = type->extra[0].array.element_count; break; default: member->count = 1; break; } switch(type->type_code) { case FFI_PL_TYPE_UINT8: function = ffi_pl_record_accessor_uint8; break; case FFI_PL_TYPE_SINT8: function = ffi_pl_record_accessor_sint8; break; case FFI_PL_TYPE_UINT16: function = ffi_pl_record_accessor_uint16; break; case FFI_PL_TYPE_SINT16: function = ffi_pl_record_accessor_sint16; break; case FFI_PL_TYPE_UINT32: function = ffi_pl_record_accessor_uint32; break; case FFI_PL_TYPE_SINT32: function = ffi_pl_record_accessor_sint32; break; case FFI_PL_TYPE_UINT64: function = ffi_pl_record_accessor_uint64; break; case FFI_PL_TYPE_SINT64: function = ffi_pl_record_accessor_sint64; break; case FFI_PL_TYPE_FLOAT: function = ffi_pl_record_accessor_float; break; case FFI_PL_TYPE_DOUBLE: function = ffi_pl_record_accessor_double; break; case FFI_PL_TYPE_OPAQUE: function = ffi_pl_record_accessor_opaque; break; case FFI_PL_TYPE_STRING: switch(type->sub_type) { case FFI_PL_TYPE_STRING_RO: member->count = 1; function = ffi_pl_record_accessor_string_ro; break; case FFI_PL_TYPE_STRING_RW: member->count = 1; function = ffi_pl_record_accessor_string_rw; break; } break; case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_uint8_array; break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_sint8_array; break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_uint16_array; break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_sint16_array; break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_uint32_array; break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_sint32_array; break; case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_uint64_array; break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_sint64_array; break; case FFI_PL_TYPE_FLOAT | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_float_array; break; case FFI_PL_TYPE_DOUBLE | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_double_array; break; case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_ARRAY: function = ffi_pl_record_accessor_opaque_array; break; case FFI_PL_TYPE_RECORD: member->count = type->extra[0].record.size; function = ffi_pl_record_accessor_string_fixed; break; default: Safefree(member); XSRETURN_PV("type not supported"); break; } 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; FFI-Platypus-1.10/xs/record_opaque.c000644 000765 000024 00000005347 13616651126 017760 0ustar00ollisgstaff000000 000000 #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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { 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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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); } FFI-Platypus-1.10/xs/record_simple.c000644 000765 000024 00000054535 13616651126 017762 0ustar00ollisgstaff000000 000000 /* 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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); } FFI-Platypus-1.10/xs/record_string.c000644 000765 000024 00000005455 13616651126 017774 0ustar00ollisgstaff000000 000000 #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; 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { 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); } FFI-Platypus-1.10/xs/Type.xs000644 000765 000024 00000007333 13616651126 016256 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Type BOOT: { HV *ft = get_hv("FFI::Platypus::TypeParser::ffi_type", GV_ADD); hv_stores(ft, "void", newSViv(PTR2IV( &ffi_type_void ))); hv_stores(ft, "sint8", newSViv(PTR2IV( &ffi_type_sint8 ))); hv_stores(ft, "sint16", newSViv(PTR2IV( &ffi_type_sint16 ))); hv_stores(ft, "sint32", newSViv(PTR2IV( &ffi_type_sint32 ))); hv_stores(ft, "sint64", newSViv(PTR2IV( &ffi_type_sint64 ))); hv_stores(ft, "uint8", newSViv(PTR2IV( &ffi_type_uint8 ))); hv_stores(ft, "uint16", newSViv(PTR2IV( &ffi_type_uint16 ))); hv_stores(ft, "uint32", newSViv(PTR2IV( &ffi_type_uint32 ))); hv_stores(ft, "uint64", newSViv(PTR2IV( &ffi_type_uint64 ))); hv_stores(ft, "pointer", newSViv(PTR2IV( &ffi_type_pointer ))); hv_stores(ft, "float", newSViv(PTR2IV( &ffi_type_float ))); hv_stores(ft, "double", newSViv(PTR2IV( &ffi_type_double ))); #ifdef FFI_PL_PROBE_LONGDOUBLE hv_stores(ft, "longdouble", newSViv(PTR2IV( &ffi_type_longdouble ))); #endif #ifdef FFI_PL_PROBE_COMPLEX hv_stores(ft, "complex_float", newSViv(PTR2IV( &ffi_type_complex_float ))); hv_stores(ft, "complex_double", newSViv(PTR2IV( &ffi_type_complex_double ))); #endif } 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 int type_code(self) ffi_pl_type *self CODE: RETVAL = self->type_code; OUTPUT: RETVAL int is_record(self) ffi_pl_type *self CODE: /* may not need this method anymore */ RETVAL = self->type_code == FFI_PL_TYPE_RECORD; OUTPUT: RETVAL int is_record_value(self) ffi_pl_type *self CODE: RETVAL = self->type_code == FFI_PL_TYPE_RECORD_VALUE; OUTPUT: RETVAL int is_object_ok(self) ffi_pl_type *self PREINIT: int shape; int base; CODE: shape = self->type_code & FFI_PL_SHAPE_MASK; base = self->type_code & FFI_PL_BASE_MASK; RETVAL = shape == FFI_PL_SHAPE_SCALAR && ( base == FFI_PL_BASE_SINT || base == FFI_PL_BASE_UINT || base == FFI_PL_BASE_OPAQUE ); OUTPUT: RETVAL int is_ro(self) ffi_pl_type *self CODE: RETVAL = self->type_code == FFI_PL_TYPE_STRING && self->sub_type == FFI_PL_TYPE_STRING_RO; OUTPUT: RETVAL void DESTROY(self) ffi_pl_type *self CODE: if(self->type_code == FFI_PL_TYPE_CLOSURE) { if(!PL_dirty) Safefree(self->extra[0].closure.ffi_cif.arg_types); } else if(self->type_code == FFI_PL_TYPE_RECORD_VALUE) { Safefree(self->extra[0].record_value.class); } else { switch(self->type_code & FFI_PL_SHAPE_MASK) { case FFI_PL_SHAPE_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); } break; case FFI_PL_SHAPE_OBJECT: { if(self->extra[0].object.class != NULL) Safefree(self->extra[0].object.class); } break; default: break; } } if(!PL_dirty) Safefree(self); FFI-Platypus-1.10/xs/TypeParser.xs000644 000765 000024 00000022241 13616651126 017426 0ustar00ollisgstaff000000 000000 MODULE = FFI::Platypus PACKAGE = FFI::Platypus::TypeParser BOOT: { HV *bt = get_hv("FFI::Platypus::TypeParser::basic_type", GV_ADD); hv_stores(bt, "void", newSViv(FFI_PL_TYPE_VOID)); hv_stores(bt, "sint8", newSViv(FFI_PL_TYPE_SINT8)); hv_stores(bt, "sint16", newSViv(FFI_PL_TYPE_SINT16)); hv_stores(bt, "sint32", newSViv(FFI_PL_TYPE_SINT32)); hv_stores(bt, "sint64", newSViv(FFI_PL_TYPE_SINT64)); hv_stores(bt, "uint8", newSViv(FFI_PL_TYPE_UINT8)); hv_stores(bt, "uint16", newSViv(FFI_PL_TYPE_UINT16)); hv_stores(bt, "uint32", newSViv(FFI_PL_TYPE_UINT32)); hv_stores(bt, "uint64", newSViv(FFI_PL_TYPE_UINT64)); hv_stores(bt, "float", newSViv(FFI_PL_TYPE_FLOAT)); hv_stores(bt, "double", newSViv(FFI_PL_TYPE_DOUBLE)); hv_stores(bt, "string", newSViv(FFI_PL_TYPE_STRING)); hv_stores(bt, "opaque", newSViv(FFI_PL_TYPE_OPAQUE)); #ifdef FFI_PL_PROBE_LONGDOUBLE hv_stores(bt, "longdouble", newSViv(FFI_PL_TYPE_LONG_DOUBLE)); #endif #ifdef FFI_PL_PROBE_COMPLEX hv_stores(bt, "complex_float", newSViv(FFI_PL_TYPE_COMPLEX_FLOAT)); hv_stores(bt, "complex_double", newSViv(FFI_PL_TYPE_COMPLEX_DOUBLE)); #endif } ffi_pl_type * create_type_basic(self, type_code) SV *self int type_code PREINIT: ffi_pl_type *type; CODE: (void)self; type = ffi_pl_type_new(0); type->type_code |= type_code; RETVAL = type; OUTPUT: RETVAL ffi_pl_type * create_type_record(self, size, record_class) SV *self size_t size ffi_pl_string record_class PREINIT: ffi_pl_type *type; CODE: (void)self; type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_record)); type->type_code |= FFI_PL_TYPE_RECORD; type->extra[0].record.size = size; if(record_class == NULL) type->extra[0].record.stash = NULL; else type->extra[0].record.stash = gv_stashpv(record_class, GV_ADD); RETVAL = type; OUTPUT: RETVAL ffi_pl_type* create_type_record_value(self, size, class, ffi_type) SV *self size_t size const char *class void* ffi_type PREINIT: ffi_pl_type *type; size_t class_name_size; CODE: (void)self; type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_record_value)); type->type_code |= FFI_PL_TYPE_RECORD_VALUE; type->extra[0].record_value.size = size; class_name_size = strlen(class)+1; type->extra[0].record_value.class = malloc(class_name_size); memcpy(type->extra[0].record_value.class, class, class_name_size); type->extra[0].record_value.ffi_type = ffi_type; RETVAL = type; OUTPUT: RETVAL ffi_pl_type* create_type_object(self, type_code, class) SV *self int type_code ffi_pl_string class PREINIT: ffi_pl_type *type; size_t class_name_size; CODE: (void)self; type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_object)); class_name_size = strlen(class)+1; type->extra[0].object.class = malloc(class_name_size); memcpy(type->extra[0].object.class, class, class_name_size); type->type_code |= type_code; type->type_code |= FFI_PL_SHAPE_OBJECT; RETVAL = type; OUTPUT: RETVAL ffi_pl_type * create_type_string(self, rw) SV *self int rw PREINIT: ffi_pl_type *type; CODE: (void)self; type = ffi_pl_type_new(0); type->type_code = FFI_PL_TYPE_STRING; if(rw) type->sub_type = FFI_PL_TYPE_STRING_RW; else type->sub_type = FFI_PL_TYPE_STRING_RO; RETVAL = type; OUTPUT: RETVAL ffi_pl_type * create_type_array(self, type_code, size) SV *self int type_code size_t size PREINIT: ffi_pl_type *type; CODE: (void)self; type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_array)); type->type_code |= FFI_PL_SHAPE_ARRAY | type_code; type->extra[0].array.element_count = size; RETVAL = type; OUTPUT: RETVAL ffi_pl_type* create_type_pointer(self, type_code) SV *self int type_code PREINIT: ffi_pl_type *type; CODE: (void)self; type = ffi_pl_type_new(0); type->type_code |= FFI_PL_SHAPE_POINTER | type_code; RETVAL = type; OUTPUT: RETVAL ffi_pl_type * _create_type_custom(self, type_code, perl_to_native, native_to_perl, perl_to_native_post, argument_count) SV *self int type_code SV *perl_to_native SV *native_to_perl SV *perl_to_native_post int argument_count PREINIT: ffi_pl_type *type; ffi_pl_type_extra_custom_perl *custom; CODE: (void)self; type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_custom_perl)); type->type_code = FFI_PL_SHAPE_CUSTOM_PERL | type_code; custom = &type->extra[0].custom_perl; custom->perl_to_native = SvOK(perl_to_native) ? SvREFCNT_inc_simple_NN(perl_to_native) : NULL; custom->perl_to_native_post = SvOK(perl_to_native_post) ? SvREFCNT_inc_simple_NN(perl_to_native_post) : NULL; custom->native_to_perl = SvOK(native_to_perl) ? SvREFCNT_inc_simple_NN(native_to_perl) : NULL; custom->argument_count = argument_count-1; RETVAL = type; OUTPUT: RETVAL ffi_pl_type * create_type_closure(self, return_type, ...) SV *self ffi_pl_type *return_type PREINIT: ffi_pl_type *type; int i; SV *arg; ffi_type *ffi_return_type; ffi_type **ffi_argument_types; ffi_status ffi_status; CODE: (void)self; switch(return_type->type_code) { case FFI_PL_TYPE_VOID: ffi_return_type = &ffi_type_void; break; case FFI_PL_TYPE_SINT8: ffi_return_type = &ffi_type_sint8; break; case FFI_PL_TYPE_SINT16: ffi_return_type = &ffi_type_sint16; break; case FFI_PL_TYPE_SINT32: ffi_return_type = &ffi_type_sint32; break; case FFI_PL_TYPE_SINT64: ffi_return_type = &ffi_type_sint64; break; case FFI_PL_TYPE_UINT8: ffi_return_type = &ffi_type_uint8; break; case FFI_PL_TYPE_UINT16: ffi_return_type = &ffi_type_uint16; break; case FFI_PL_TYPE_UINT32: ffi_return_type = &ffi_type_uint32; break; case FFI_PL_TYPE_UINT64: ffi_return_type = &ffi_type_uint64; break; case FFI_PL_TYPE_FLOAT: ffi_return_type = &ffi_type_float; break; case FFI_PL_TYPE_DOUBLE: ffi_return_type = &ffi_type_double; break; case FFI_PL_TYPE_OPAQUE: ffi_return_type = &ffi_type_pointer; break; default: croak("Only native types are supported as closure return types (%d)", return_type->type_code); break; } Newx(ffi_argument_types, items-2, ffi_type*); type = ffi_pl_type_new(sizeof(ffi_pl_type_extra_closure) + sizeof(ffi_pl_type)*(items-2)); type->type_code = FFI_PL_TYPE_CLOSURE; type->extra[0].closure.return_type = return_type; type->extra[0].closure.flags = 0; for(i=0; i<(items-2); i++) { arg = ST(2+i); type->extra[0].closure.argument_types[i] = INT2PTR(ffi_pl_type*, SvIV((SV*)SvRV(arg))); switch(type->extra[0].closure.argument_types[i]->type_code) { case FFI_PL_TYPE_VOID: ffi_argument_types[i] = &ffi_type_void; break; case FFI_PL_TYPE_SINT8: ffi_argument_types[i] = &ffi_type_sint8; break; case FFI_PL_TYPE_SINT16: ffi_argument_types[i] = &ffi_type_sint16; break; case FFI_PL_TYPE_SINT32: ffi_argument_types[i] = &ffi_type_sint32; break; case FFI_PL_TYPE_SINT64: ffi_argument_types[i] = &ffi_type_sint64; break; case FFI_PL_TYPE_UINT8: ffi_argument_types[i] = &ffi_type_uint8; break; case FFI_PL_TYPE_UINT16: ffi_argument_types[i] = &ffi_type_uint16; break; case FFI_PL_TYPE_UINT32: ffi_argument_types[i] = &ffi_type_uint32; break; case FFI_PL_TYPE_UINT64: ffi_argument_types[i] = &ffi_type_uint64; break; case FFI_PL_TYPE_FLOAT: ffi_argument_types[i] = &ffi_type_float; break; case FFI_PL_TYPE_DOUBLE: ffi_argument_types[i] = &ffi_type_double; break; case FFI_PL_TYPE_OPAQUE: case FFI_PL_TYPE_STRING: case FFI_PL_TYPE_RECORD: ffi_argument_types[i] = &ffi_type_pointer; break; default: Safefree(ffi_argument_types); croak("Only native types and strings are supported as closure argument types (%d)", return_type->type_code); break; } } ffi_status = ffi_prep_cif( &type->extra[0].closure.ffi_cif, FFI_DEFAULT_ABI, items-2, ffi_return_type, ffi_argument_types ); if(ffi_status != FFI_OK) { Safefree(type); 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 ) { type->extra[0].closure.flags |= G_NOARGS; } if(type->extra[0].closure.return_type->type_code == FFI_PL_TYPE_VOID) { type->extra[0].closure.flags |= G_DISCARD | G_VOID; } else { type->extra[0].closure.flags |= G_SCALAR; } RETVAL = type; OUTPUT: RETVAL FFI-Platypus-1.10/xs/windl.c000644 000765 000024 00000007064 13616651126 016243 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" #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); if(handle->os_handle == NULL) { free(handle); error = "Error loading file"; return NULL; } } 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 FFI-Platypus-1.10/t/00_diag.t000644 000765 000024 00000010222 13616651126 016151 0ustar00ollisgstaff000000 000000 use 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 Capture::Tiny Devel::Hide ExtUtils::CBuilder ExtUtils::MakeMaker ExtUtils::ParseXS FFI::CheckLib IPC::Cmd JSON::PP List::Util Math::LongDouble PkgConfig Test::More constant forks ); $post_diag = sub { eval { require lib; lib->import('inc'); require FFI::Platypus::ShareConfig; require My::BuildConfig; my $build_config = My::BuildConfig->new; my $share_config = 'FFI::Platypus::ShareConfig'; my $class = $build_config->get('alien')->{class}; my $pm = "$class.pm"; $pm =~ s/::/\//g; require $pm; $Alien::FFI::pkgconfig::VERBOSE = $Alien::FFI::pkgconfig::VERBOSE = 0; require FFI::Platypus; require FFI::Platypus::Memory; diag "mode : ", $build_config->get('alien')->{mode}; diag "$class->VERSION = ", $class->VERSION; diag "$class->install_type = ", $class->install_type; diag "$class->cflags = ", $class->cflags; diag "$class->libs = ", $class->libs; diag "$class->version = ", $class->config('version'); diag "my_configure = ", $class->runtime_prop->{my_configure} if defined $class->runtime_prop->{my_configure}; spacer(); my %type_map = %{ $share_config->get('type_map') }; my $diag = $build_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 ]}"; diag "ffi.platypus.memory.strndup_impl=@{[ FFI::Platypus::Memory->_strndup_impl ]}"; spacer(); my %r; foreach my $k (keys %type_map) { my $v = $type_map{$k}; 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 $@; if(-f "/proc/cpuinfo") { open my $fh, '<', '/proc/cpuinfo'; my @lines = <$fh>; close $fh; my($model_name) = grep /^model name/, @lines; my($flags) = grep /^flags/, @lines; my($address_sizes) = grep /^address sizes/, @lines; spacer(); diag "CPU Info:"; diag " $model_name"; diag " $flags" if $flags;; diag " $address_sizes" if $address_sizes; } require IPC::Cmd; require Capture::Tiny; if(IPC::Cmd::can_run('lsb_release')) { spacer(); diag Capture::Tiny::capture_merged(sub { system 'lsb_release', '-a'; (); }); } require FFI::Build::Platform; spacer(); diag "[PLATFORM]\n"; diag(FFI::Build::Platform->diag); }; 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) { my $pm = "$module.pm"; $pm =~ s{::}{/}g; if(eval { require $pm; 1 }) { my $ver = eval { $module->VERSION }; $ver = 'undef' unless defined $ver; diag sprintf $format, $module, $ver; } else { diag sprintf $format, $module, '-'; } } if($post_diag) { spacer; $post_diag->(); } spacer; FFI-Platypus-1.10/t/01_use.t000644 000765 000024 00000012532 13616651126 016050 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; require_ok 'FFI::Build'; require_ok 'FFI::Build::File::Base'; require_ok 'FFI::Build::File::C'; require_ok 'FFI::Build::File::CXX'; require_ok 'FFI::Build::File::Library'; require_ok 'FFI::Build::File::Object'; require_ok 'FFI::Build::MM'; require_ok 'FFI::Build::Platform'; require_ok 'FFI::Platypus'; require_ok 'FFI::Platypus::API'; require_ok 'FFI::Platypus::Buffer'; require_ok 'FFI::Platypus::Bundle'; require_ok 'FFI::Platypus::Closure'; require_ok 'FFI::Platypus::Constant'; require_ok 'FFI::Platypus::DL'; require_ok 'FFI::Platypus::Declare'; require_ok 'FFI::Platypus::Function'; require_ok 'FFI::Platypus::Internal'; require_ok 'FFI::Platypus::Lang'; require_ok 'FFI::Platypus::Lang::ASM'; require_ok 'FFI::Platypus::Lang::C'; require_ok 'FFI::Platypus::Lang::Win32'; require_ok 'FFI::Platypus::Legacy'; require_ok 'FFI::Platypus::Memory'; require_ok 'FFI::Platypus::Record'; require_ok 'FFI::Platypus::Record::Meta'; require_ok 'FFI::Platypus::Record::TieArray'; require_ok 'FFI::Platypus::ShareConfig'; require_ok 'FFI::Platypus::Type'; require_ok 'FFI::Platypus::Type::PointerSizeBuffer'; require_ok 'FFI::Platypus::Type::StringArray'; require_ok 'FFI::Platypus::Type::StringPointer'; require_ok 'FFI::Platypus::TypeParser'; require_ok 'FFI::Platypus::TypeParser::Version0'; require_ok 'FFI::Platypus::TypeParser::Version1'; require_ok 'FFI::Probe'; require_ok 'FFI::Probe::Runner'; require_ok 'FFI::Probe::Runner::Builder'; require_ok 'FFI::Probe::Runner::Result'; require_ok 'FFI::Temp'; ok -f 't/ffi_build.t', 'test for FFI::Build'; ok -f 't/ffi_build_file_base.t', 'test for FFI::Build::File::Base'; ok -f 't/ffi_build_file_c.t', 'test for FFI::Build::File::C'; ok -f 't/ffi_build_file_cxx.t', 'test for FFI::Build::File::CXX'; ok -f 't/ffi_build_file_library.t', 'test for FFI::Build::File::Library'; ok -f 't/ffi_build_file_object.t', 'test for FFI::Build::File::Object'; ok -f 't/ffi_build_mm.t', 'test for FFI::Build::MM'; ok -f 't/ffi_build_platform.t', 'test for FFI::Build::Platform'; ok -f 't/ffi_platypus.t', 'test for FFI::Platypus'; ok -f 't/ffi_platypus_api.t', 'test for FFI::Platypus::API'; ok -f 't/ffi_platypus_buffer.t', 'test for FFI::Platypus::Buffer'; ok -f 't/ffi_platypus_bundle.t', 'test for FFI::Platypus::Bundle'; ok -f 't/ffi_platypus_closure.t', 'test for FFI::Platypus::Closure'; ok -f 't/ffi_platypus_constant.t', 'test for FFI::Platypus::Constant'; ok -f 't/ffi_platypus_dl.t', 'test for FFI::Platypus::DL'; ok -f 't/ffi_platypus_declare.t', 'test for FFI::Platypus::Declare'; ok -f 't/ffi_platypus_function.t', 'test for FFI::Platypus::Function'; ok -f 't/ffi_platypus_internal.t', 'test for FFI::Platypus::Internal'; ok -f 't/ffi_platypus_lang.t', 'test for FFI::Platypus::Lang'; ok -f 't/ffi_platypus_lang_asm.t', 'test for FFI::Platypus::Lang::ASM'; ok -f 't/ffi_platypus_lang_c.t', 'test for FFI::Platypus::Lang::C'; ok -f 't/ffi_platypus_lang_win32.t', 'test for FFI::Platypus::Lang::Win32'; ok -f 't/ffi_platypus_legacy.t', 'test for FFI::Platypus::Legacy'; ok -f 't/ffi_platypus_memory.t', 'test for FFI::Platypus::Memory'; ok -f 't/ffi_platypus_record.t', 'test for FFI::Platypus::Record'; ok -f 't/ffi_platypus_record_meta.t', 'test for FFI::Platypus::Record::Meta'; ok -f 't/ffi_platypus_record_tiearray.t', 'test for FFI::Platypus::Record::TieArray'; ok -f 't/ffi_platypus_shareconfig.t', 'test for FFI::Platypus::ShareConfig'; ok -f 't/ffi_platypus_type.t', 'test for FFI::Platypus::Type'; ok -f 't/ffi_platypus_type_pointersizebuffer.t', 'test for FFI::Platypus::Type::PointerSizeBuffer'; ok -f 't/ffi_platypus_type_stringarray.t', 'test for FFI::Platypus::Type::StringArray'; ok -f 't/ffi_platypus_type_stringpointer.t', 'test for FFI::Platypus::Type::StringPointer'; ok -f 't/ffi_platypus_typeparser.t', 'test for FFI::Platypus::TypeParser'; ok -f 't/ffi_platypus_typeparser_version0.t', 'test for FFI::Platypus::TypeParser::Version0'; ok -f 't/ffi_platypus_typeparser_version1.t', 'test for FFI::Platypus::TypeParser::Version1'; ok -f 't/ffi_probe.t', 'test for FFI::Probe'; ok -f 't/ffi_probe_runner.t', 'test for FFI::Probe::Runner'; ok -f 't/ffi_probe_runner_builder.t', 'test for FFI::Probe::Runner::Builder'; ok -f 't/ffi_probe_runner_result.t', 'test for FFI::Probe::Runner::Result'; ok -f 't/ffi_temp.t', 'test for FFI::Temp'; done_testing; FFI-Platypus-1.10/t/ffi/000755 000765 000024 00000000000 13616651126 015330 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/t/ffi_build.t000644 000765 000024 00000012045 13616651126 016676 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use lib 't/lib'; use Test::Cleanup; use Test::Platypus; use FFI::Build; use FFI::Build::Platform; use FFI::Temp; use Capture::Tiny qw( capture_merged ); use File::Spec; use File::Path qw( rmtree ); use File::Glob qw( bsd_glob ); subtest 'basic' => sub { my $build = FFI::Build->new('foo'); isa_ok $build, 'FFI::Build'; like $build->file->path, qr/foo/, 'foo is somewhere in the native name for the lib'; note "lib.file.path = @{[ $build->file->path ]}"; ok(-d $build->file->dirname, "dir is a dir" ); isa_ok $build->platform, 'FFI::Build::Platform'; $build->source('corpus/ffi_build/source/*.c'); my($cfile) = $build->source; isa_ok $cfile, 'FFI::Build::File::C'; }; subtest 'file classes' => sub { { package FFI::Build::File::Foo1; use base qw( FFI::Build::File::Base ); $INC{'FFI/Build/File/Foo1.pm'} = __FILE__; } { package FFI::Build::File::Foo2; use base qw( FFI::Build::File::Base ); } my @list = FFI::Build::_file_classes(); ok( @list > 0, "at least one" ); note "class = $_" for @list; }; subtest 'build' => sub { foreach my $type (qw( name object array )) { subtest $type => sub { my $tempdir = FFI::Temp->newdir; my $build = FFI::Build->new('foo', dir => $tempdir, buildname => "tmpbuild.tmpbuild.$$.@{[ time ]}", verbose => 2, ); my @source; if($type eq 'name') { @source = 'corpus/ffi_build/project1/*.c'; } elsif($type eq 'object') { @source = map { FFI::Build::File::C->new($_) } bsd_glob('corpus/ffi_build/project1/*.c'); } elsif($type eq 'array') { @source = map { [ C => $_ ] } bsd_glob('corpus/ffi_build/project1/*.c'); } $build->source(@source); note "$_" for $build->source; my($out, $dll, $error) = capture_merged { my $dll = eval { $build->build }; ($dll, $@); }; ok $error eq '', 'no error'; if($error) { diag $out; return; } else { note $out; } platypus 2 => sub { my $ffi = shift; $ffi->lib($dll); is( $ffi->function(foo1 => [] => 'int')->call, 42, ); is( $ffi->function(foo2 => [] => 'string')->call, "42", ); }; $build->clean; cleanup( $build->file->dirname, File::Spec->catdir(qw( corpus ffi_build project1 ), $build->buildname) ); }; } }; subtest 'build c++' => sub { plan skip_all => 'Test requires C++ compiler' unless eval { FFI::Build::Platform->which(FFI::Build::Platform->cxx) }; my $tempdir = FFI::Temp->newdir( TEMPLATE => "tmpbuild.XXXXXX" ); my $build = FFI::Build->new('foo', dir => $tempdir, buildname => "tmpbuild.$$.@{[ time ]}",, verbose => 2, ); $build->source('corpus/ffi_build/project-cxx/*.cxx'); $build->source('corpus/ffi_build/project-cxx/*.cpp'); note "$_" for $build->source; my($out, $dll, $error) = capture_merged { my $dll = eval { $build->build }; ($dll, $@); }; ok $error eq '', 'no error'; if($error) { diag $out; return; } else { note $out; } platypus 2 => sub { my $ffi = shift; $ffi->lib($dll); my $foo1 = eval { $ffi->function( foo1 => [] => 'int' ) }; my $foo2 = eval { $ffi->function( foo2 => [] => 'string' ) }; ok defined $foo1, "foo1 found"; ok defined $foo2, "foo2 found"; SKIP: { if(defined $foo1 && defined $foo2) { is( $ffi->function(foo1 => [] => 'int')->call, 42, ); is( $ffi->function(foo2 => [] => 'string')->call, "42", ); } else { diag "[build log follows]\n"; diag $out; skip "foo1 or foo2 not found", 2 unless defined $foo1 && defined $foo2; } } }; $build->clean; cleanup( $build->file->dirname, File::Spec->catdir(qw( corpus ffi_build project-cxx ), $build->buildname) ); }; subtest 'alien' => sub { plan skip_all => 'Test requires Acme::Alien::DontPanic 1.03' unless eval { require Acme::Alien::DontPanic; Acme::Alien::DontPanic->VERSION("1.03") }; my $tempdir = FFI::Temp->newdir( TEMPLATE => "tmpbuild.XXXXXX" ); my $build = FFI::Build->new('bar', dir => $tempdir, buildname => "tmpbuild.$$.@{[ time ]}", verbose => 2, alien => ['Acme::Alien::DontPanic'], ); $build->source('corpus/ffi_build/project2/*.c'); note "$_" for $build->source; my($out, $dll, $error) = capture_merged { my $dll = eval { $build->build }; ($dll, $@); }; ok $error eq '', 'no error'; if($error) { diag $out; return; } else { note $out; } platypus 1 => sub { my $ffi = shift; $ffi->lib($dll); is( $ffi->function(myanswer => [] => 'int')->call, 42, ); }; cleanup( $build->file->dirname, File::Spec->catdir(qw( corpus ffi_build project2 ), $build->buildname) ); }; done_testing; FFI-Platypus-1.10/t/ffi_build_file_base.t000644 000765 000024 00000004715 13616651126 020674 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Build::File::Base; { package FFI::Build::File::Foo; use base qw( FFI::Build::File::Base ); use constant default_suffix => '.foo'; use constant default_encoding => ':utf8'; } subtest 'basic' => sub { subtest 'basic usage' => sub { eval { FFI::Build::File::Foo->new }; my $error = $@; like $error, qr/content is required/; note "error = $error"; }; subtest 'array filename' => sub { my $file = FFI::Build::File::Foo->new(['corpus', 'ffi_build_file_base', 'basic.foo']); isa_ok $file, 'FFI::Build::File::Base'; isa_ok $file, 'FFI::Build::File::Foo'; is("$file", $file->path, "stringifies to path"); is($file->slurp, "This is a basic foo.\n"); ok(!$file->is_temp, "is_temp"); is($file->basename, 'basic.foo', 'basename'); ok(-d $file->dirname, 'dirname'); note "dirname = @{[ $file->dirname ]}"; unlike $file->path, qr/\\/, "No forward slashes!"; if($^O eq 'MSWin32') { is($file->native, "corpus\\ffi_build_file_base\\basic.foo", "native name"); } else { is($file->native, $file->path, "native name"); } note "native = @{[ $file->native ]}"; }; subtest 'string filename' => sub { my $file = FFI::Build::File::Foo->new("corpus/ffi_build_file_base/basic.foo"); isa_ok $file, 'FFI::Build::File::Base'; isa_ok $file, 'FFI::Build::File::Foo'; is($file->slurp, "This is a basic foo.\n"); ok(!$file->is_temp, "is_temp"); unlike $file->path, qr/\\/, "No forward slashes!"; }; subtest 'string ref' => sub { my $file = FFI::Build::File::Foo->new(\"Something different!\n"); isa_ok $file, 'FFI::Build::File::Base'; isa_ok $file, 'FFI::Build::File::Foo'; like($file->basename, qr/\.foo$/, 'has the correct extension'); ok($file->is_temp, "is_temp"); is($file->slurp, "Something different!\n"); note "path: @{[ $file->path ]}"; unlike $file->path, qr/\\/, "No forward slashes!"; my $path = $file->path; ok(-f $path, "file exists"); undef $file; ok(!-f $path, "file is removed after destroy"); }; subtest 'string ref keep' => sub { my $file = FFI::Build::File::Foo->new(\"Again\n"); $file->keep; my $path = $file->path; is($file->slurp, "Again\n"); ok(-f $path, "file exists"); unlike $file->path, qr/\\/, "No forward slashes!"; undef $file; ok(-f $path, "file exists after undef"); unlink $path; }; }; done_testing; FFI-Platypus-1.10/t/ffi_build_file_c.t000644 000765 000024 00000002201 13616651126 020170 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use lib 't/lib'; use Test::Cleanup; use FFI::Build::File::C; use FFI::Build; use Capture::Tiny qw( capture_merged ); subtest 'basic' => sub { my $file = FFI::Build::File::C->new(['corpus','ffi_build_file_c','basic.c']); isa_ok $file, 'FFI::Build::File::C'; isa_ok $file, 'FFI::Build::File::Base'; is($file->default_suffix, '.c'); is($file->default_encoding, ':utf8'); }; subtest 'compile' => sub { my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_c foo1.c )]); my $object = $file->build_item; isa_ok $object, 'FFI::Build::File::Object'; is_deeply [ $object->build_item ], []; cleanup 'corpus/ffi_build_file_c/_build'; }; subtest 'headers' => sub { my $build = FFI::Build->new('foo', verbose => 2, cflags => "-Icorpus/ffi_build_file_c/include", ); note "cflags=$_" for @{ $build->cflags }; my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_c foo2.c )], build => $build ); my @deps = eval { $file->_deps }; is $@, '', 'no die'; foreach my $dep (@deps) { ok -f "$dep", "dep is a file: $dep"; } }; done_testing; FFI-Platypus-1.10/t/ffi_build_file_cxx.t000644 000765 000024 00000002524 13616651126 020560 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use lib 't/lib'; use Test::Cleanup; use FFI::Build::File::CXX; use FFI::Build; use FFI::Build::Platform; use Capture::Tiny qw( capture_merged ); plan skip_all => 'Test requires C++ compiler' unless eval { FFI::Build::Platform->which(FFI::Build::Platform->cxx) }; subtest 'basic' => sub { my $file = FFI::Build::File::CXX->new(['corpus','ffi_build_file_cxx','basic.cxx']); isa_ok $file, 'FFI::Build::File::CXX'; isa_ok $file, 'FFI::Build::File::C'; isa_ok $file, 'FFI::Build::File::Base'; is($file->default_suffix, '.cxx'); is($file->default_encoding, ':utf8'); }; subtest 'compile' => sub { my $file = FFI::Build::File::CXX->new([qw( corpus ffi_build_file_cxx foo1.cxx )]); my $object = $file->build_item; isa_ok $object, 'FFI::Build::File::Object'; is_deeply [ $object->build_item ], []; cleanup 'corpus/ffi_build_file_cxx/_build'; }; subtest 'headers' => sub { my $build = FFI::Build->new('foo', verbose => 2, cflags => "-Icorpus/ffi_build_file_cxx/include", ); note "cflags=$_" for @{ $build->cflags }; my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_cxx foo2.cpp )], build => $build ); my @deps = eval { $file->_deps }; is $@, '', 'no die'; foreach my $dep (@deps) { ok -f "$dep", "dep is afile: $dep"; } }; done_testing; FFI-Platypus-1.10/t/ffi_build_file_library.t000644 000765 000024 00000000553 13616651126 021422 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Build::File::Library; use Config (); my $dll = FFI::Build::Platform->library_suffix; subtest 'basic' => sub { my $file = FFI::Build::File::Library->new(['corpus',"basic$dll"]); is($file->default_suffix, $dll); is($file->default_encoding, ':raw'); note "path = @{[ $file->path ]}"; }; done_testing; FFI-Platypus-1.10/t/ffi_build_file_object.t000644 000765 000024 00000000523 13616651126 021221 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Build::File::Object; my $o = FFI::Build::Platform->object_suffix; subtest 'basic' => sub { my $file = FFI::Build::File::Object->new(['corpus',"basic$o"]); is($file->default_suffix, $o); is($file->default_encoding, ':raw'); note "path = @{[ $file->path ]}"; }; done_testing; FFI-Platypus-1.10/t/ffi_build_mm.t000644 000765 000024 00000007006 13616651126 017370 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Build::MM; use Capture::Tiny qw( capture_merged ); use File::Glob qw( bsd_glob ); use lib 't/lib'; use Test::Platypus; sub dont_save_prop (&) { my($code) = @_; sub { my $save = \&FFI::Build::MM::save_prop; { no warnings 'redefine'; *FFI::Build::MM::save_prop = sub {}; }; my $ret = eval { $code->() }; my $error = $@; { no warnings 'redefine'; *FFI::Build::MM::save_prop = $save; } die $error if $error; $ret; }; } sub slurp ($) { my $fn = shift; open my $fh, '<', $fn; my $content = do { local $/; <$fh> }; close $fh; $content; } subtest 'basic' => dont_save_prop { my $mm = FFI::Build::MM->new; isa_ok $mm, 'FFI::Build::MM'; $mm->mm_args( DISTNAME => 'Foo-Bar-Baz' ); is( $mm->distname, 'Foo-Bar-Baz' ); is( $mm->sharedir, 'blib/lib/auto/share/dist/Foo-Bar-Baz' ); is( $mm->archdir, 'blib/arch/auto/Foo/Bar/Baz' ); subtest 'build with fbx file' => sub { my $build = $mm->load_build('corpus/ffi_build_mm/lb1', undef, undef); isa_ok $build, 'FFI::Build'; is_deeply [sort map { $_->basename } $build->source], ['hello1.c','hello2.c'] }; subtest 'build with fbx file with errors' => sub { eval { $mm->load_build('corpus/ffi_build_mm/lb1bad', undef, undef) }; like ( $@, qr/skootch/, "caught compile error in fbx file" ); }; subtest 'build with default' => sub { my $build = $mm->load_build('corpus/ffi_build_mm/lb2', undef, undef); isa_ok $build, 'FFI::Build'; is_deeply [sort map { $_->basename } $build->source], ['hello1.c','hello2.c'] }; my $postamble = $mm->mm_postamble; ok $postamble; note "[postamble]\n$postamble\n"; $mm->sharedir('share'); is( $mm->sharedir, 'share' ); $mm->archdir(0); ok( !$mm->archdir ); }; subtest 'with a build!' => sub { chdir 'corpus/ffi_build_mm/project1'; unlink 'fbx.json' if -f 'fbx.json'; subtest 'namespace is clean' => sub { ok( ! main->can($_), "$_ not imported yet" ) for qw( fbx_build fbx_test fbx_clean ); }; subtest 'do not save on request' => sub { my $mm = FFI::Build::MM->new( save => 0 ); $mm->mm_args( DISTNAME => 'Crock-O-Stimpy' ); ok !-f 'fbx.json'; }; subtest 'perl Makefile.PL' => sub { my $mm = FFI::Build::MM->new; $mm->mm_args( DISTNAME => 'Crock-O-Stimpy' ); ok -f 'fbx.json'; }; subtest 'import' => sub { FFI::Build::MM->import('cmd'); ok( main->can($_), "$_ not imported yet" ) for qw( fbx_build fbx_test fbx_clean ); }; subtest 'make' => sub { my($out, $err) = capture_merged { eval { fbx_build() }; $@; }; note $out; is $err, ''; is slurp 'blib/arch/auto/Crock/O/Stimpy/Stimpy.txt', "FFI::Build\@auto/share/dist/Crock-O-Stimpy/lib/@{[ FFI::Build::Platform->library_prefix ]}Crock-O-Stimpy@{[ scalar FFI::Build::Platform->library_suffix]}\n"; platypus 1 => sub { my $ffi = shift; $ffi->lib(grep !/\.pdb$/, bsd_glob 'blib/lib/auto/share/dist/Crock-O-Stimpy/lib/*'); note "lib=$_" for $ffi->lib; is( $ffi->function('frooble_runtime' => [] => 'int')->call, 47, ); }; }; subtest 'make test' => sub { my($out, $err) = capture_merged { eval { fbx_test() }; $@; }; note $out; is $err, ''; }; subtest 'make clean' => sub { fbx_clean(); ok !-f 'fbx.json'; }; File::Path::rmtree('blib', 0, oct(755)); chdir(File::Spec->updir) for 1..3; }; subtest 'alien' => sub { plan skip_all => 'todo'; }; done_testing; FFI-Platypus-1.10/t/ffi_build_platform.t000644 000765 000024 00000000773 13616651126 020607 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Build::Platform; use Capture::Tiny qw( capture_merged ); subtest basic => sub { my $platform = FFI::Build::Platform->new; isa_ok $platform, 'FFI::Build::Platform'; note($platform->diag); }; subtest 'cc mm works' => sub { my $platform = FFI::Build::Platform->new; my($out, $cc_mm_works) = capture_merged { $platform->cc_mm_works(1); }; note $out; ok(defined $cc_mm_works); note "cc_mm_works = $cc_mm_works"; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus.t000644 000765 000024 00000061025 13616651126 017462 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; use Data::Dumper; use File::Spec; use FFI::Platypus::TypeParser; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; sub xdump ($) { my($object) = @_; note(Data::Dumper->new([$object])->Indent(0)->Terse(1)->Sortkeys(1)->Dump); } subtest 'constructor' => sub { subtest 'basic' => sub { my $ffi = eval { FFI::Platypus->new }; diag $@ if $@; isa_ok $ffi, 'FFI::Platypus'; }; subtest 'no arguments' => sub { my $ffi = FFI::Platypus->new; isa_ok $ffi, 'FFI::Platypus', 'FFI::Platypus.new'; is_deeply [$ffi->lib], [], 'ffi.lib'; }; subtest 'with single lib' => sub { 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 { 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'; }; }; subtest 'abi' => sub { my $ffi = FFI::Platypus->new; my %abis = %{ $ffi->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'; }; }; subtest 'alignof' => sub { my $ffi = FFI::Platypus->new; my $pointer_align = $ffi->alignof('opaque'); subtest 'ffi types' => sub { 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"; is(FFI::Platypus->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 { $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 { $ffi->type('(int)->int' => 'closure_t'); my $align = $ffi->alignof('closure_t'); is $align, $pointer_align, "sizeof closure_t = $pointer_align"; }; subtest 'record' => sub { my $align = $ffi->alignof('record(22)'); is $align, 1; xdump($ffi->type_meta('record(22)')); }; }; subtest 'custom type' => sub { my $ffi = FFI::Platypus->new; my @basic_types = (qw( float double opaque ), map { ("uint$_", "sint$_") } (8,16,32,64)); foreach my $basic (@basic_types) { subtest $basic => sub { 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") }); }; } }; subtest 'find lib' => sub { subtest 'find_lib' =>sub { my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi'); my $address = $ffi->find_symbol('f0'); ok $address, "found f0 = $address"; }; subtest external => sub { my $ffi = FFI::Platypus->new; $ffi->lib($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 { 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'; }; }; subtest 'find symbol' => sub { subtest external => sub { my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); 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 { 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'; }; }; subtest 'lib' => sub { subtest 'basic' => sub { my $ffi = FFI::Platypus->new; my($lib) = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; ok -e $lib, "exists $lib"; eval { $ffi->lib($lib) }; is $@, '', 'ffi.lib (set)'; is_deeply [eval { $ffi->lib }], [$lib], 'ffi.lib (get)'; }; subtest 'undef' => sub { subtest 'baseline' => sub { my $ffi = FFI::Platypus->new; is_deeply([$ffi->lib], []); }; subtest 'lib => [undef]' => sub { my $ffi = FFI::Platypus->new(lib => [undef]); is_deeply([$ffi->lib], [undef]); }; subtest 'lib => undef' => sub { my $ffi = FFI::Platypus->new(lib => undef); is_deeply([$ffi->lib], [undef]); }; }; subtest 'coderef' => sub { my $ffi = FFI::Platypus->new; my($lib) = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; ok -e $lib, "exists $lib"; eval { $ffi->lib(sub{ $lib }) }; is $@, '', 'ffi.lib (set)'; is_deeply [eval { $ffi->lib }], [$lib], 'ffi.lib (get)'; }; }; subtest 'sizeof' => sub { my $ffi = FFI::Platypus->new; subtest integers => sub { 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 'class methods' => sub { my $class = 'FFI::Platypus'; is $class->sizeof('uint8'), 1, 'sizeof uint8 = 1'; is $class->sizeof('uint16'), 2, 'sizeof uint16 = 2'; is $class->sizeof('uint32'), 4, 'sizeof uint32 = 4'; is $class->sizeof('uint64'), 8, 'sizeof uint64 = 8'; is $class->sizeof('sint8'), 1, 'sizeof sint8 = 1'; is $class->sizeof('sint16'), 2, 'sizeof sint16 = 2'; is $class->sizeof('sint32'), 4, 'sizeof sint32 = 4'; is $class->sizeof('sint64'), 8, 'sizeof sint64 = 8'; }; subtest floats => sub { is $ffi->sizeof('float'), 4, 'sizeof float = 4'; is $ffi->sizeof('double'), 8, 'sizeof double = 8'; }; subtest pointers => sub { 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 { 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"; } }; }; subtest 'type' => sub { subtest 'simple type' => sub { my $ffi = FFI::Platypus->new; eval { $ffi->type('sint8') }; is $@, '', 'ffi.type(sint8)'; }; subtest 'aliased type' => sub { my $ffi = FFI::Platypus->new; eval { $ffi->type('sint8', 'my_integer_8') }; is $@, '', 'ffi.type(sint8 => my_integer_8)'; isa_ok $ffi->{tp}->types->{my_integer_8}, 'FFI::Platypus::Type'; ok scalar(grep { $_ eq 'my_integer_8' } $ffi->types), 'ffi.types returns my_integer_8'; }; my @list = grep { FFI::Platypus::TypeParser->new->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 { foreach my $name (@list) { subtest $name => sub { my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; my $meta = $ffi->type_meta($name); note xdump( $meta); cmp_ok $meta->{size}, '>', 0, "size = " . $meta->{size}; }; } }; subtest 'ffi pointer types' => sub { foreach my $name (map { "$_ *" } @list) { subtest $name => sub { plan skip_all => 'ME GRIMLOCK SAY STRING CAN NO BE POINTER' if $name eq 'string *'; my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; my $meta = $ffi->type_meta($name); note xdump( $meta); cmp_ok $meta->{size}, '>', 0, "size = " . $meta->{size}; } } }; subtest 'ffi array types' => sub { 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 my $ffi = FFI::Platypus->new; eval { $ffi->type($name) }; is $@, '', "ffi.type($name)"; 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 { 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 { { package My::Record22; use constant ffi_record_size => 22 } { package My::Record44; use constant _ffi_record_size => 44 } 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 { my $meta = $ffi->type_meta($type); is $meta->{size}, $ptr_size, "sizeof $type = $ptr_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->{type}, 'record', 'is actually a record type'; is $meta->{size}, 10, "sizeof $type = 10"; note xdump($meta); }; } }; subtest 'private' => sub { # 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::TypeParser->new->have_type($name); my $type = eval { FFI::Platypus::TypeParser::Version0->new->parse($name) }; is $@, '', "type = FFI::Platypus::TypeParser::Version0->new->parse($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 { my $type = eval { FFI::Platypus::TypeParser::Version0->new->parse('string') }; is $@, '', "type = FFI::Platypus::TypeParser::Version0->new->parse(string)"; isa_ok $type, 'FFI::Platypus::Type'; is eval { $type->meta->{ffi_type} }, 'pointer', 'type.meta.ffi_type = pointer'; }; }; }; subtest 'class or instance method' => sub { 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; }; subtest 'cast' => sub { my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); subtest 'cast from string to pointer' => sub { 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 { 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 { 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"); }; }; subtest 'ignore_not_found' => sub { subtest 'ignore_not_found=undef' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); 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 { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $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 { my $ffi = FFI::Platypus->new( ignore_not_found => 0 ); $ffi->lib($libtest); 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 { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $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 { my $ffi = FFI::Platypus->new( ignore_not_found => 1 ); $ffi->lib($libtest); 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 { my $ffi = FFI::Platypus->new( ignore_not_found => 1 ); $ffi->lib($libtest); 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'; }; }; subtest 'attach basic' => sub { package attach_basic; use FFI::Platypus; use Test::More; my $ffi = FFI::Platypus->new; $ffi->lib($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'; }; subtest 'attach void' => sub { package attach_void; use FFI::Platypus; use Test::More; my $ffi = FFI::Platypus->new; $ffi->lib($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)'; }; subtest 'customer mangler' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $ffi->mangler( sub { "mystrangeprefix_$_[0]" }); is($ffi->function(bar => [] => 'int')->call, 42 ); }; subtest '->package is only allowed for api = 0' => sub { my @warnings; local $SIG{__WARN__} = sub { note "[warning]\n", $_[0]; push @warnings, $_[0]; }; subtest 'api = 0' => sub { my $ffi = FFI::Platypus->new( api => 0 ); local $@ = ''; eval { $ffi->package }; is "$@", ""; }; subtest 'api = 1' => sub { my $ffi = FFI::Platypus->new( api => 1 ); local $@ = ''; eval { $ffi->package }; like "$@", qr/^package method only available with api => 0/; }; }; subtest 'warning defaults' => sub { my @warnings; local $SIG{__WARN__} = sub { note "[warning]\n", $_[0]; push @warnings, $_[0] if $_[0] =~ /^warning: error loading/; }; subtest 'api = 0' => sub { @warnings = (); my $ffi = FFI::Platypus->new( api => 0 ); $ffi->lib('corpus/bogus.so'); is $ffi->find_symbol('foo'), undef; is_deeply \@warnings, []; }; subtest 'api = 1' => sub { @warnings = (); my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib('corpus/bogus.so'); local $@ = ''; is $ffi->find_symbol('foo'), undef; like $warnings[0], qr/^warning: error loading corpus\/bogus\.so/; }; }; subtest 'language plugin api version' => sub { my %args; my $native_type_map = sub { my $class = shift; %args = @_; {}; }; { package FFI::Platypus::Lang::Frooble; no warnings 'once'; *native_type_map = $native_type_map; } subtest 'api = 0' => sub { my $ffi = FFI::Platypus->new( lang => 'Frooble' ); is $args{api}, undef; }; subtest 'api = 1' => sub { my $ffi = FFI::Platypus->new( lang => 'Frooble', api => 1 ); is $args{api}, 1; }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_api.t000644 000765 000024 00000000702 13616651126 020306 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::API; subtest 'basic' => sub { { package FFI::Platypus::Type::C1; sub ffi_custom_type_api_1 { return { native_type => 'sint8', perl_to_native => sub { $_[0] * 2 }, } } } my $ffi = FFI::Platypus->new; $ffi->load_custom_type('::C1' => 'c1'); is( $ffi->function( 0 => ['c1'] => 'sint8' )->call(10), 20, ); }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_buffer.t000644 000765 000024 00000001626 13616651126 021014 0ustar00ollisgstaff000000 000000 use strict; use warnings; use utf8; # see https://github.com/Perl5-FFI/FFI-Platypus/issues/85 use if $^O ne 'MSWin32' || $] >= 5.018, 'open', ':std', ':encoding(utf8)'; use Test::More; use Encode qw( decode ); use FFI::Platypus::Buffer; use FFI::Platypus::Buffer qw( scalar_to_pointer ); subtest simple => sub { my $orig = 'me grimlock king'; my($ptr, $size) = scalar_to_buffer($orig); ok $ptr, "ptr = $ptr"; my $ptr2 = scalar_to_pointer($orig); is $ptr2, $ptr, "scalar to pointer matches"; is $size, 16, 'size = 16'; my $scalar = buffer_to_scalar($ptr, $size); is $scalar, 'me grimlock king', "scalar = $scalar"; }; subtest unicode => sub { 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"; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_bundle.t000644 000765 000024 00000013223 13616651126 021010 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Temp; use FFI::Build; use File::Basename qw( dirname ); use File::Path qw( mkpath ); use File::Spec; use Capture::Tiny qw( capture_merged ); subtest 'from installed' => sub { local @INC = @INC; my $root = FFI::Temp->newdir; spew("$root/lib/Foo/Bar1.pm", <<'EOF'); package Foo::Bar1; use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle; $ffi->attach("bar1" => [] => 'sint32'); 1; EOF my $build = FFI::Build->new( 'bar1', source => [ [ C => \"int bar1(void) { return 42; }\n" ]], verbose => 2, dir => "$root/lib/auto/share/dist/Foo-Bar1", export => ["bar1"], ); my($build_out,$lib) = capture_merged { $build->build; }; note $build_out; spew("$root/lib/auto/Foo/Bar1/Bar1.txt", 'FFI::Build@' . File::Spec->abs2rel("$lib", "$root/lib")); ok( ! FFI::Platypus->can('_bundle') ); unshift @INC, "$root/lib"; local $@ = ''; eval " require Foo::Bar1; "; is "$@", ''; is( Foo::Bar1::bar1(), 42 ); ok( !! FFI::Platypus->can('_bundle') ); $build->clean; }; subtest 'from blib' => sub { local @INC = @INC; my $root = FFI::Temp->newdir; spew("$root/lib/Foo/Bar2.pm", <<'EOF'); package Foo::Bar2; use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle; $ffi->attach("bar2" => [] => 'sint32'); 1; EOF my $build = FFI::Build->new( 'bar2', source => [ [ C => \"int bar2(void) { return 43; }\n" ]], verbose => 2, dir => "$root/lib/auto/share/dist/Foo-Bar2", export => ['bar2'], ); my($build_out,$lib) = capture_merged { $build->build; }; note $build_out; spew("$root/arch/auto/Foo/Bar2/Bar2.txt", 'FFI::Build@' . File::Spec->abs2rel("$lib", "$root/lib")); unshift @INC, "$root/lib"; local $@ = ''; eval " require Foo::Bar2; "; is "$@", ''; is( Foo::Bar2::bar2(), 43 ); $build->clean; }; subtest 'not loaded yet' => sub { local @INC = @INC; my $root = FFI::Temp->newdir; spew("$root/lib/Foo/Bar3.pm", <<'EOF'); package Foo::Bar3; die; 1; EOF my $build = FFI::Build->new( 'bar3', source => [ [ C => \"int bar3(void) { return 44; }\n" ]], verbose => 2, dir => "$root/lib/auto/share/dist/Foo-Bar3", export => ['bar3'], ); my($build_out,$lib) = capture_merged { $build->build; }; note $build_out; spew("$root/lib/auto/Foo/Bar3/Bar3.txt", 'FFI::Build@' . File::Spec->abs2rel("$lib", "$root/lib")); unshift @INC, "$root/lib"; my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle('Foo::Bar3'); $ffi->attach("bar3" => [] => 'sint32'); is( bar3(), 44 ); $build->clean; }; subtest 'with a ffi dir' => sub { local @INC = @INC; my $root = FFI::Temp->newdir; spew("$root/lib/Foo/Bar4.pm", <<'EOF'); package Foo::Bar4; use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle; $ffi->attach("bar4" => [] => 'sint32'); 1; EOF spew("$root/ffi/foo.c", "int bar4(void) { return 45; }" ); spew("$root/ffi/foo.fbx", <<'EOF'); use strict; use warnings; our $DIR; { export => ['bar4'], source => ["$DIR/*.c"] }; EOF unshift @INC, "$root/lib"; eval " require Foo::Bar4; "; is "$@", ''; is( Foo::Bar4::bar4(), 45 ); }; subtest 'entry points' => sub { my $root = FFI::Temp->newdir; our @log; our $log_closure = do { my $ffi = FFI::Platypus->new; $ffi->closure(sub { my($str) = @_; push @log, $str; }); }; spew("$root/lib/Foo/Bar5.pm", <<'EOF'); package Foo::Bar5; use strict; use warnings; use FFI::Platypus; our $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle([$ffi->cast('(string)->void' => 'opaque', $main::log_closure)]); 1; EOF spew("$root/ffi/foo.c", <<'EOF'); #include #include typedef void (*log_t)(const char *); log_t logit; char buffer[1024]; void ffi_pl_bundle_init(const char *package, int c, void **args) { int i; logit = (log_t) args[0]; logit("ffi_pl_bundle_init (enter)"); sprintf(buffer, "package = %s", package); logit(buffer); sprintf(buffer, "c = %d", c); logit(buffer); for(i=0; args[i] != NULL; i++) { sprintf(buffer, "args[%d] = %d", i, args[i]); logit(buffer); } logit("ffi_pl_bundle_init (leave)"); } void ffi_pl_bundle_fini(const char *package) { logit("ffi_pl_bundle_fini (enter)"); sprintf(buffer, "package = %s", package); logit(buffer); logit("ffi_pl_bundle_fini (leave)"); } EOF spew("$root/ffi/foo.fbx", <<'EOF'); use strict; use warnings; our $DIR; { export => ['ffi_pl_bundle_init','ffi_pl_bundle_fini'], source => ["$DIR/*.c"] }; EOF unshift @INC, "$root/lib"; local $@ = ''; eval " require Foo::Bar5; "; is "$@", ''; note "log:$_" for @log; is(scalar(@log), 5); is($log[0], 'ffi_pl_bundle_init (enter)'); is($log[1], 'package = Foo::Bar5'); is($log[2], 'c = 1'); like($log[3], qr/^args\[0\] = -?[0-9]+$/); is($log[4], 'ffi_pl_bundle_init (leave)'); @log = (); ok 1; { no warnings 'once'; undef $Foo::Bar5::ffi; } note "log:$_" for @log; is_deeply( \@log, [ 'ffi_pl_bundle_fini (enter)', 'package = Foo::Bar5', 'ffi_pl_bundle_fini (leave)', ], ); @log = (); }; done_testing; sub spew { my($fn, $content) = @_; note "spew(start)[$fn]\n"; note $content; note "spew(end)\n"; my $dir = dirname $fn; mkpath $dir, 0, oct(755) unless -d $dir; open my $fh, '>', $fn; print $fh $content; close $fh; } FFI-Platypus-1.10/t/ffi_platypus_closure.t000644 000765 000024 00000006526 13616651126 021223 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Closure; use FFI::CheckLib; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest 'basic' => sub { 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'; is $closure->call(1), 3, 'closure.call(1) = 3'; $closure = $ffi->closure($c); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 3, 'closure.(1) = 3'; is $closure->call(1), 3, 'closure.call(1) = 3'; }; subtest 'sticky' => sub { my $closure = FFI::Platypus::Closure->new(sub { 'foo' }); isa_ok $closure, 'FFI::Platypus::Closure'; my $refcnt = $closure->_svrefcnt; note "_svrefcnt = $refcnt"; eval { $closure->sticky }; is $@, '', 'called $closure->sticky'; is($closure->_svrefcnt, $refcnt+2); eval { $closure->sticky }; is $@, '', 'called $closure->sticky'; is($closure->_svrefcnt, $refcnt+2); eval { $closure->unstick }; is $@, '', 'called $closure->unstick'; is($closure->_svrefcnt, $refcnt); }; subtest 'private' => sub { my $closure = FFI::Platypus::Closure->new(sub { $_[0] + 1}); isa_ok $closure, 'FFI::Platypus::Closure'; is $closure->(1), 2, 'closure.(1) = 2'; }; subtest 'space' => sub { 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'; }; subtest 'die' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $closure = $ffi->closure(sub { die "omg i don't want to die!"; }); my $set_closure = $ffi->function(pointer_set_closure => ['(opaque)->opaque'] => 'void'); my $call_closure = $ffi->function(pointer_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'"; }; subtest 'reuse' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $closure = $ffi->closure(sub { if (@_) { return $_[0] * 7; } return 21; }); my $set_closure1 = $ffi->function( closure_set_closure1 => ['()->int'] => 'void'); my $set_closure2 = $ffi->function( closure_set_closure2 => ['(int)->int'] => 'void'); my $call_closure1 = $ffi->function( closure_call_closure1 => [] => 'int'); my $call_closure2 = $ffi->function( closure_call_closure2 => ['int'] => 'int'); $set_closure1->($closure); $set_closure2->($closure); is $call_closure1->(), 21; is $call_closure2->(42), 294; }; subtest 'immediate' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $ret = $ffi->function( closure_call_closure_immediate => ['()->int'] => 'int')->call( $ffi->closure(sub { return 42; }) ); is $ret, 42; }; subtest 'closure passing into a closure' => sub { my $ffi = FFI::Platypus->new; eval { $ffi->type('((int)->int)->int') }; isnt "$@", ""; note "error = $@"; $ffi->type('(int)->int' => 'foo_t'); eval { $ffi->type('()->foo_t') }; isnt "$@", ""; note "error = $@"; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_constant.t000644 000765 000024 00000003054 13616651126 021371 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Constant; use File::Path qw( mkpath ); use File::Basename qw( dirname ); use FFI::Temp; subtest 'very very basic...' => sub { my $api = FFI::Platypus::Constant->new; isa_ok $api, 'FFI::Platypus::Constant'; undef $api; ok 'did not appear to crash :tada:'; }; subtest 'create constants' => sub { my $root = FFI::Temp->newdir; spew("$root/lib/Foo/Bar1.pm", <<'EOF'); package Foo::Bar1; use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); $ffi->bundle; 1; EOF spew("$root/ffi/bar1.c", <<'EOF'); #include void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *b) { b->set_str("FOO1", "VAL1"); b->set_str("Foo::Bar1::Baz::FOO2", "VAL2"); b->set_sint("FOO3", -42); b->set_uint("FOO4", 512); b->set_double("FOO5", 2.5); b->set_str("FOO6", package); } EOF local @INC = @INC; unshift @INC, "$root/lib"; local $@ = ''; eval " require Foo::Bar1; "; is "$@", ''; is( Foo::Bar1::FOO1(), "VAL1" ); is( Foo::Bar1::Baz::FOO2(), "VAL2" ); is( Foo::Bar1::FOO3(), -42 ); is( Foo::Bar1::FOO4(), 512 ); is( Foo::Bar1::FOO5(), 2.5 ); is( Foo::Bar1::FOO6(), "Foo::Bar1" ); }; done_testing; sub spew { my($fn, $content) = @_; note "spew(start)[$fn]\n"; note $content; note "spew(end)\n"; my $dir = dirname $fn; mkpath $dir, 0, oct(755) unless -d $dir; open my $fh, '>', $fn; print $fh $content; close $fh; } FFI-Platypus-1.10/t/ffi_platypus_declare.t000644 000765 000024 00000011724 13616651126 021142 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus::Declare; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest normal => sub { { package Normal; use FFI::Platypus::Declare; lib $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; }; } 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'; }; subtest prototype => sub { my $value = eval q{ package ProtoType; use FFI::Platypus::Declare; BEGIN { lib $libtest; attach(f0 => ['uint8'] => 'uint8' => '$'); } f0 22; }; is $@, '', 'no compile error'; is $value, 22, 'f(22) = 22'; }; subtest 'with type aliases' => sub { { package WithTypeAliases; use FFI::Platypus::Declare 'string', [int => 'myint']; lib $libtest; attach [my_atoi=>'atoi'], [string] => myint; } is WithTypeAliases::atoi("42"), 42, 'atoi("42") = 42'; }; subtest 'simple closure test' => sub { { package ClosureSimple; use FFI::Platypus::Declare; our $closure = closure { $_[0]+1 }; } isa_ok $ClosureSimple::closure, 'FFI::Platypus::Closure'; is $ClosureSimple::closure->(1), 2, 'closure.(1) = 2'; }; subtest 'abis' => sub { my %abis = %{ FFI::Platypus->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'; }; }; subtest 'lang' => sub { subtest C => sub { 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 { package FFI::Platypus::Lang::Foo; sub native_type_map { { foo_t => 'sint16', bar_t => 'uint32', } } 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'; }; }; subtest 'sizeof' => sub { is sizeof 'uint32', 4, 'sizeof uint32 = 4'; is sizeof 'uint32[2]', 8, 'sizeof uint32[2] = 8'; }; subtest 'sticky' => sub { package Foo; use Test::More; use FFI::Platypus::Declare qw( uint8 void ), ['(uint8)->uint8' => 'closure_t']; lib $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'; }; subtest 'cast' => sub { package Bar; use Test::More; use FFI::Platypus::Declare; lib $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 { 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 { 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 { 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"); }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_dl.t000644 000765 000024 00000002406 13616651126 020137 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::DL; use FFI::CheckLib qw( find_lib ); my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest 'flags' => sub { ok(FFI::Platypus::DL->can('RTLD_PLATYPUS_DEFAULT'), "RTLD_PLATYPUS_DEFAULT is defined"); note sprintf "%-25s %04x %s", $_, FFI::Platypus::DL->can($_)->(), FFI::Platypus::DL->can($_)->() for sort { FFI::Platypus::DL->can($a)->() <=> FFI::Platypus::DL->can($b)->() } grep /^RTLD_/, keys %main::; }; subtest 'dlopen' => sub { subtest 'bad library' => sub { is dlopen("t/ffi/libbogus.so", RTLD_PLATYPUS_DEFAULT), undef, 'Returns undef on fail'; note "dlerror = @{[ dlerror ]}"; }; subtest 'good library' => sub { my $h = dlopen $libtest, RTLD_PLATYPUS_DEFAULT; ok($h, "Returns handle on good"); note "h = $h"; dlclose $h; }; }; subtest 'dlsym' => sub { my $h = dlopen $libtest, RTLD_PLATYPUS_DEFAULT; subtest 'good symbol' => sub { my $address = dlsym $h, 'f0'; ok $address, 'returns an address'; note "address = $address"; }; subtest 'bad symbol' => sub { my $address = dlsym $h, 'bogus'; is $address, undef, 'bad symbol returns undef'; note "dlerror = @{[ dlerror ]}"; }; dlclose $h; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_function.t000644 000765 000024 00000013376 13616651126 021375 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Function; use FFI::Platypus; use FFI::CheckLib; use FFI::Platypus::TypeParser::Version0; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest 'built in type' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $function = eval { $ffi->function('f0', [ 'uint8' ] => 'uint8') }; is $@, '', 'ffi.function(f0, [uint8] => uint8)'; isa_ok $function, 'FFI::Platypus::Function'; isa_ok $function, 'FFI::Platypus::Function::Function'; is $function->call(22), 22, 'function.call(22) = 22'; is $function->(22), 22, 'function.(22) = 22'; }; subtest 'custom type' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($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'; isa_ok $function, 'FFI::Platypus::Function::Function'; is $function->call(22), 22, 'function.call(22) = 22'; is $function->(22), 22, 'function.(22) = 22'; }; subtest 'private' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $address = $ffi->find_symbol('f0'); my $uint8 = FFI::Platypus::TypeParser::Version0->new->parse('uint8'); my $function = eval { FFI::Platypus::Function::Function->new($ffi, $address, -1, -1, $uint8, $uint8) }; is $@, '', 'FFI::Platypus::Function->new'; isa_ok $function, 'FFI::Platypus::Function'; isa_ok $function, 'FFI::Platypus::Function::Function'; is $function->call(22), 22, 'function.call(22) = 22'; $function->attach('main::fooble', 'whatever.c', undef); is fooble(22), 22, 'fooble(22) = 22'; }; subtest 'meta' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $ffi->attach(mymeta_new => [ 'int', 'string' ] => 'opaque'); $ffi->attach(mymeta_delete => [ 'opaque' ] => 'void' ); subtest 'unattached' => sub { my $meta = mymeta_new(4, "prime"); my $f = $ffi->_function_meta('mymeta_test' => $meta => [ 'string' ] => 'string' ); is($f->call(), "foo = 4, bar = prime, baz = undef, count = 0"); is($f->call("just one"), "foo = 4, bar = prime, baz = just one, count = 1"); mymeta_delete($meta); }; subtest 'attached' => sub { my $meta = mymeta_new(6, "magnus"); $ffi->_function_meta('mymeta_test' => $meta => [ 'string' ] => 'string' )->attach('mymeta_test1'); is(mymeta_test1(), "foo = 6, bar = magnus, baz = undef, count = 0"); is(mymeta_test1("stella"), "foo = 6, bar = magnus, baz = stella, count = 1"); }; }; subtest 'sub_ref' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8')->sub_ref; is $sub_ref->(99), 99, 'calls okay'; is ref($sub_ref), 'CODE', 'it is a code reference'; if(eval { require Sub::Identify; 1 }) { my $name = Sub::Identify::sub_name($sub_ref); my $package = Sub::Identify::stash_name($sub_ref); note "name = ${package}::$name"; } }; subtest 'prototype' => sub { subtest one => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->attach(['f0' => 'f0_prototyped1'], [ 'uint8' ] => 'uint8', '$'); is(f0_prototyped1(2), 2); # just make sure it attached okay is(prototype(\&f0_prototyped1), '$'); }; subtest two => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8')->attach('f0_prototyped2', '$'); is(f0_prototyped2(2), 2); # just make sure it attached okay is(prototype(\&f0_prototyped2), '$'); }; }; subtest 'variadic' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); plan skip_all => 'test requires variadic function support' unless eval { $ffi->function('variadic_return_arg' => ['int'] => ['int'] => 'int') }; my $wrapper = sub { my($xsub, @args) = @_; my $ret = $xsub->(@args); $ret*2; }; subtest 'unattached' => sub { foreach my $i (1..7) { is( $ffi->function(variadic_return_arg => ['int'] => ['int','int','int','int','int','int','int'] => 'int')->call($i,10,20,30,40,50,60,70), $i*10, 'sans wrapper' ); is( $ffi->function(variadic_return_arg => ['int'] => ['int','int','int','int','int','int','int'] => 'int', $wrapper)->call($i,10,20,30,40,50,60,70), $i*10*2, 'with wrapper' ); } }; subtest 'attached' => sub { $ffi->attach([variadic_return_arg => 'y1'] => ['int'] => ['int','int','int','int','int','int','int'] => 'int'); $ffi->attach([variadic_return_arg => 'y2'] => ['int'] => ['int','int','int','int','int','int','int'] => 'int', $wrapper); foreach my $i (1..7) { is(y1($i,10,20,30,40,50,60,70), $i*10, 'sans wrapper'); is(y2($i,10,20,30,40,50,60,70), $i*10*2, 'with wrapper'); } }; subtest 'examples' => sub { is( $ffi->function( xprintf => ['string'] => ['int'] => 'string' )->call("print integer %d\n", 42), "print integer 42\n", ); is( $ffi->function( xprintf => ['string'] => ['string'] => 'string' )->call("print string %s\n", 'platypus'), "print string platypus\n", ); is( $ffi->function( xprintf => ['string'] => ['int','string'] => 'string' )->call("print integer %d and string %s\n", 42, 'platypus'), "print integer 42 and string platypus\n", ); }; }; subtest 'void as arg should fail is arg count > 1' => sub { my $ffi = FFI::Platypus->new; eval { $ffi->function( 0 => ['int','void'] => 'void' ) }; like "$@", qr/^void not allowed as argument type/; }; subtest 'single void arg treated as no args' => sub { my $ffi = FFI::Platypus->new; eval { $ffi->function( 0 => ['void'] => 'void' ) }; is "$@", ""; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_function_wrapper.t000644 000765 000024 00000003644 13616651126 023132 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Function; use FFI::Platypus; use FFI::CheckLib; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest 'built in type' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $wrapper = sub { my($xsub, $arg1) = @_; $xsub->( $arg1 * 2 ); }; my $function = eval { $ffi->function('f0', [ 'uint8' ] => 'uint8', $wrapper ) }; is $@, '', 'ffi.function(f0, [uint8] => uint8)'; isa_ok $function, 'FFI::Platypus::Function'; isa_ok $function, 'FFI::Platypus::Function::Wrapper'; is $function->call(22), 44, 'function.call(22) = 44'; is $function->(22), 44, 'function.(22) = 44'; $function->attach('baboon'); is( baboon(11), 22, "baboon(11) = 22" ); }; subtest 'sub_ref' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8', sub { my($xsub, $arg) = @_; $arg*2})->sub_ref; is $sub_ref->(99), 99*2, 'calls okay'; is ref($sub_ref), 'CODE', 'it is a code reference'; if(eval { require Sub::Identify; 1 }) { my $name = Sub::Identify::sub_name($sub_ref); my $package = Sub::Identify::stash_name($sub_ref); note "name = ${package}::$name"; } }; subtest 'prototype' => sub { subtest one => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->attach(['f0' => 'f0_prototyped1'], [ 'uint8' ] => 'uint8', '$', sub { my($xsub, $arg) = @_; $arg*2}); is(f0_prototyped1(2), 4); # just make sure it attached okay is(prototype(\&f0_prototyped1), '$'); }; subtest two => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8', sub { my($xsub, $arg) = @_; $arg*2})->attach('f0_prototyped2', '$'); is(f0_prototyped2(2), 4); # just make sure it attached okay is(prototype(\&f0_prototyped2), '$'); }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_internal.t000644 000765 000024 00000000724 13616651126 021355 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Internal; subtest 'basic' => sub { note "alpha order:"; foreach my $const (sort @FFI::Platypus::Internal::EXPORT) { pass sprintf("%-30s 0x%04x", $const, __PACKAGE__->$const); } note "value order:"; foreach my $const (sort { __PACKAGE__->$a <=> __PACKAGE__->$b } @FFI::Platypus::Internal::EXPORT) { pass sprintf("%-30s 0x%04x", $const, __PACKAGE__->$const); } }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_lang.t000644 000765 000024 00000003764 13616651126 020471 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Lang; use FFI::CheckLib; use FFI::Platypus; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest 'Foo constructor' => sub { 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 { 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'; }; done_testing; 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-1.10/t/ffi_platypus_lang_asm.t000644 000765 000024 00000001130 13616651126 021312 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest ASM => sub { 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'; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_lang_c.t000644 000765 000024 00000001066 13616651126 020764 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; subtest C => sub { 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'; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_lang_win32.t000644 000765 000024 00000000420 13616651126 021475 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; 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'; done_testing; FFI-Platypus-1.10/t/ffi_platypus_legacy.t000644 000765 000024 00000000403 13616651126 020777 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; subtest 'only load as needed' => sub { my $ffi = FFI::Platypus->new; ok( ! FFI::Platypus->can('_package') ); $ffi->package; ok( !! FFI::Platypus->can('_package') ); }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_memory.t000644 000765 000024 00000004670 13616651126 021055 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Memory; note "lib=@{[ $_ || 'undef' ]}" for FFI::Platypus::Memory->_ffi->lib; 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'; }; subtest 'memcpy' => sub { 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'; }; subtest 'realloc' => sub { 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'; }; subtest 'strdup' => sub { 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'; }; subtest 'strndup' => sub { note "strndup implementation = @{[ FFI::Platypus::Memory->_strndup_impl ]}"; subtest 'full string' => sub { my $ptr = strndup "this and\0", 512; is($ffi->cast('opaque' => 'string', $ptr), 'this and'); free $ptr; }; subtest 'partial string' => sub { my $ptr = strndup "1234567890", 5; is($ffi->cast('opaque' => 'string', $ptr), '12345'); free $ptr; }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_record.t000644 000765 000024 00000025727 13616651126 021031 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); use Test::More; use Data::Dumper; do { package Foo1; use FFI::Platypus::Record; record_layout( uint8 => 'first', uint32 => 'second', ); }; sub xdump_meta ($) { my($type) = @_; my $ffi = FFI::Platypus->new; my $object = $ffi->type_meta($type); note(Data::Dumper->new([$object])->Indent(0)->Terse(1)->Sortkeys(1)->Dump); } subtest 'integer accessor' => sub { 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'; xdump_meta('record(Foo1)'); xdump_meta('record(8)'); }; do { package Color; use FFI::Platypus; use FFI::Platypus::Record; my $ffi = FFI::Platypus->new; $ffi->find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi'); 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 { 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 => 't/ffi'); $ffi->attach(["align_get_$_" => "get_$_"] => [ 'record(Foo2)' ] => $_) for qw( uint8 sint8 uint16 sint16 uint32 sint32 uint64 sint64 float double opaque ); }; subtest 'complex alignment' => sub { 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 { eval { package Foo3; require FFI::Platypus::Record; FFI::Platypus::Record->import; 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 => 't/ffi'); $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 { my $foo = Foo4->new; isa_ok $foo, 'Foo4'; foreach my $bits (qw( 8 16 32 64 )) { subtest "unsigned $bits integer" => sub { 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 { 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 { $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 { 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 => 't/ffi'); $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 { 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 => 't/ffi'); $ffi->attach([align_fixed_get_value=>'get_value'] => ['record(Foo6)'] => 'string'); }; subtest 'fixed string' => sub { 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 => 't/ffi'); $ffi->attach( [align_string_get_value => 'get_value'] => ['record(Foo7)'] => 'string' ); }; subtest 'string rw' => sub { 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!!!'; }; subtest 'record with custom ffi' => sub { { package Foo8; use FFI::Platypus::Record; my $ffi = FFI::Platypus->new; $ffi->type('string rw' => 'foo_t'); record_layout($ffi, qw( foo_t foo )); } my $foo8 = Foo8->new; isa_ok $foo8, 'Foo8'; $foo8->foo("yo this is a string"); is( $foo8->foo, "yo this is a string" ); }; subtest 'record with ffi args' => sub { { package FFI::Platypus::Lang::Foo9; sub native_type_map { return { foo_t => 'sint32' }; } } { package Foo9; use FFI::Platypus::Record; record_layout [ lang => 'Foo9', api => 1 ], foo_t => 'foo' ; } my $foo8 = Foo8->new; isa_ok $foo8, 'Foo8'; $foo8->foo(-42); is( $foo8->foo, -42 ); }; subtest 'api_1' => sub { my $api; my $ffi = FFI::Platypus->new; no warnings 'once'; no warnings 'redefine'; local *FFI::Platypus::new = do { my $orig = FFI::Platypus->can('new'); sub { my $class = shift; my %args = @_; $api = $args{api}; $api = 0 unless defined $args{api}; $class->$orig(@_); }; }; subtest 'no $ffi or args' => sub { local $@; undef $api; eval q{ package Foo10; use FFI::Platypus::Record; record_layout_1( string => 'a', ); }; is "$@", ''; is( $api, 1 ); }; subtest 'args' => sub { local $@; undef $api; eval q{ package Foo11; use FFI::Platypus::Record; record_layout_1( [], string => 'a', ); }; is "$@", ''; is( $api, 1 ); }; subtest '$ffi' => sub { local $@; undef $api; eval q{ package Foo12; use FFI::Platypus::Record; record_layout_1( $ffi, string => 'a', ); }; is "$@", ''; is( $api, undef ); }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_record_meta.t000644 000765 000024 00000002232 13616651126 022021 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Record::Meta; use Data::Dumper qw( Dumper ); my $ffi = FFI::Platypus->new; $ffi->lib(undef); subtest 'basic' => sub { my $meta = FFI::Platypus::Record::Meta->new( [ 'uint8', 'uint8', 'pointer', 'float', 'double' ], ); isa_ok $meta, 'FFI::Platypus::Record::Meta'; like $meta->ffi_type, qr/^-?[0-9]+$/, "meta->ffi_type = @{[ $meta->ffi_type ]}"; is $meta->size, 0, 'meta->size'; is $meta->alignment, 0, 'meta->alignment'; my $got = $meta->element_pointers; my $exp = [map { FFI::Platypus::Record::Meta::_find_symbol($_) } qw( uint8 uint8 pointer float double )]; is_deeply $got, $exp, 'meta->element_pointers' or diag Dumper([[map { sprintf "0x%x", $_ } @$got],[ map { sprintf "0x%x", $_ } @$exp]]); }; subtest 'bogus types' => sub { { local $@ = ''; eval { FFI::Platypus::Record::Meta->new(qw( completely bogsu )) }; like "$@", qr/passed something other than a array ref/; } { local $@ = ''; eval { FFI::Platypus::Record::Meta->new([qw( completely bogsu )]) }; like "$@", qr/unknown type: completely/; } }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_record_tiearray.t000644 000765 000024 00000001216 13616651126 022714 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; 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; done_testing; FFI-Platypus-1.10/t/ffi_platypus_shareconfig.t000644 000765 000024 00000000601 13616651126 022023 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::ShareConfig; use Data::Dumper; sub xdump ($) { my($object) = @_; note(Data::Dumper->new([$object])->Indent(2)->Terse(1)->Sortkeys(1)->Dump); } note(xdump(FFI::Platypus::ShareConfig->get)); is(ref(FFI::Platypus::ShareConfig->get), 'HASH'); is(FFI::Platypus::ShareConfig->get('test-key'), 'test-value'); done_testing; FFI-Platypus-1.10/t/ffi_platypus_type.t000644 000765 000024 00000007412 13616651126 020523 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus::Internal; use FFI::Platypus::Type; use Data::Dumper qw( Dumper ); my $pointer_size = FFI::Platypus->new->sizeof('opaque'); subtest 'basic type' => sub { my $type = FFI::Platypus::TypeParser->create_type_basic( FFI_PL_TYPE_SINT8, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_SINT8; is $type->sizeof, 1; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'fixed string / record (pass by reference)' => sub { my $type = FFI::Platypus::TypeParser->create_type_record( 22, undef, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_RECORD; is $type->sizeof, 22; is $type->is_record, 1; note Dumper($type->meta); }; subtest 'record' => sub { { package Foo::Bar; use FFI::Platypus::Record; record_layout(qw( int foo )); } subtest 'record class value (pass by value)' => sub { my $type = FFI::Platypus::TypeParser->create_type_record_value( Foo::Bar->_ffi_record_size, 'Foo::Bar', Foo::Bar->_ffi_meta->ffi_type, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_RECORD_VALUE; is $type->meta->{ref}, 1; is $type->meta->{class}, 'Foo::Bar'; is $type->sizeof, 4; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'record class (pass by reference)' => sub { my $type = FFI::Platypus::TypeParser->create_type_record( Foo::Bar->_ffi_record_size, 'Foo::Bar', ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_RECORD; is $type->meta->{ref}, 1; is $type->sizeof, 4; is $type->is_record, 1; note Dumper($type->meta); }; }; subtest 'string rw' => sub { my $type = FFI::Platypus::TypeParser->create_type_string( 1, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_STRING; is $type->meta->{access}, 'rw'; is $type->sizeof, $pointer_size; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'string ro' => sub { my $type = FFI::Platypus::TypeParser->create_type_string( 0, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_STRING; is $type->meta->{access}, 'ro'; is $type->sizeof, $pointer_size; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'fixed array' => sub { my $type = FFI::Platypus::TypeParser->create_type_array( FFI_PL_TYPE_SINT8, 10, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY; is $type->meta->{size}, 10; is $type->sizeof, 10; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'var array' => sub { my $type = FFI::Platypus::TypeParser->create_type_array( FFI_PL_TYPE_SINT8, 0, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY; is $type->meta->{size}, 0; is $type->is_record, 0; note Dumper($type->meta); }; subtest 'pointer' => sub { my $type = FFI::Platypus::TypeParser->create_type_pointer( FFI_PL_TYPE_SINT8, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER; is $type->sizeof, $pointer_size; is $type->is_record, 0; note Dumper($type->meta); }; #_create_type_custom(self, type_code, perl_to_native, native_to_perl, perl_to_native_post, argument_count) subtest 'custom type' => sub { my $type = FFI::Platypus::TypeParser->_create_type_custom( FFI_PL_TYPE_SINT8, sub {}, sub {}, sub {}, 1, ); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_CUSTOM_PERL; is $type->sizeof, 1; is $type->is_record, 0; note Dumper($type->meta); }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_type_pointersizebuffer.t000644 000765 000024 00000001754 13616651126 024353 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc ); my $ffi = FFI::Platypus->new; $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer_t'); $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer_t2'); $ffi->lib(undef); $ffi->attach(memcpy => ['opaque', 'buffer_t'] => 'void'); my $string = "luna park\0"; my $pointer = malloc length $string; memcpy($pointer, $string); my $string2 = $ffi->cast('opaque' => 'string', $pointer); is $string2, 'luna park'; SKIP: { eval { $ffi->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"; } $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->attach(memcmp4 => ['buffer_t', 'buffer_t'] => 'int'); my $str1 = "test"; my $str2 = "test2"; is !!memcmp4($str1, $str2), 1; is memcmp4($str1, $str1), 0; done_testing; FFI-Platypus-1.10/t/ffi_platypus_type_stringarray.t000644 000765 000024 00000005565 13616651126 023157 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; my $libtest = find_lib lib => 'test', libpath => 't/ffi'; my $ffi = FFI::Platypus->new; $ffi->lib($libtest); subtest 'fixed length input' => sub { $ffi->load_custom_type('::StringArray' => 'string_5_hey' => 5, "hey"); $ffi->load_custom_type('::StringArray' => 'string_5_undef' => 5, undef); my $a1 = $ffi->function(get_string_from_array => ['string_5_hey', 'int'] => 'string'); my $a2 = $ffi->function(get_string_from_array => ['string_5_undef', 'int'] => 'string'); my @list = ( 'foo', 'bar', 'baz', undef, 'five', 'six' ); subtest 'with default' => sub { is $a1->(\@list, 0), 'foo', 'a1(0) = foo'; is $a1->(\@list, 1), 'bar', 'a1(0) = bar'; is $a1->(\@list, 2), 'baz', 'a1(0) = baz'; is $a1->(\@list, 3), 'hey', 'a1(0) = hey'; is $a1->(\@list, 4), 'five', 'a1(0) = five'; is $a1->(\@list, 5), undef, 'a1(0) = undef'; }; subtest 'with default' => sub { is $a2->(\@list, 0), 'foo', 'a2(0) = foo'; is $a2->(\@list, 1), 'bar', 'a2(0) = bar'; is $a2->(\@list, 2), 'baz', 'a2(0) = baz'; is $a2->(\@list, 3), undef, 'a2(0) = undef'; is $a2->(\@list, 4), 'five', 'a2(0) = five'; is $a2->(\@list, 5), undef, 'a2(0) = undef'; }; }; subtest 'variable length input' => sub { $ffi->load_custom_type('::StringArray' => 'sa'); my $get_string_from_array = $ffi->function(get_string_from_array => ['sa','int'] => 'string'); my @list = qw( foo bar baz ); for(0..2) { is $get_string_from_array->(\@list, $_), $list[$_], "get_string_from_array(\@list, $_) = $list[$_]"; } is $get_string_from_array->(\@list, 3), undef, "get_string_from_array(\@list, 3) = undef"; }; subtest 'fixed length return' => sub { $ffi->load_custom_type('::StringArray' => 'sa3' => 3); $ffi->load_custom_type('::StringArray' => 'sa3x' => 3, 'x'); is( $ffi->function(pointer_null => [] => 'sa3')->call, undef, 'returns null', ); is_deeply( $ffi->function(onetwothree3 => [] => 'sa3')->call, [ qw( one two three ) ], 'returns with just strings', ); is_deeply( $ffi->function(onenullthree3 => [] => 'sa3')->call, [ 'one', undef, 'three' ], 'returns with NULL/undef in the middle', ); is_deeply( $ffi->function(onenullthree3 => [] => 'sa3x')->call, [ 'one', 'x', 'three' ], 'returns with NULL/undef in the middle with default', ); }; subtest 'null terminated return' => sub { #$ffi->load_custom_type('::StringArray' => 'sa'); is( $ffi->function(pointer_null => [] => 'sa')->call, undef, 'returns null', ); is_deeply( $ffi->function('onetwothree4', => [] => 'sa')->call, [ qw( one two three ) ], ); is_deeply( $ffi->function('onenullthree3' => [] => 'sa')->call, [ qw( one ) ], ); is_deeply( $ffi->function('ptrnull' => [] => 'sa')->call, [], ); }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_type_stringpointer.t000644 000765 000024 00000002666 13616651126 023520 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new; $ffi->load_custom_type('::StringPointer' => 'string_p'); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->attach( string_pointer_pointer_get => ['string_p'] => 'string'); $ffi->attach( string_pointer_pointer_set => ['string_p', 'string'] => 'void'); $ffi->attach( pointer_pointer_is_null => ['string_p'] => 'int'); $ffi->attach( pointer_is_null => ['string_p'] => 'int'); $ffi->attach( string_pointer_pointer_return => ['string'] => 'string_p'); $ffi->attach( pointer_null => [] => 'string_p'); subtest 'arg pass in' => sub { 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 { 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 { 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"; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_typeparser.t000644 000765 000024 00000001054 13616651126 021734 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; subtest 'basic' => sub { my $tp = FFI::Platypus::TypeParser->new; isa_ok $tp, 'FFI::Platypus::TypeParser'; }; subtest 'pick the right one' => sub { isa_ok( FFI::Platypus->new( api => 0 )->{tp}, 'FFI::Platypus::TypeParser::Version0', ); # ignore api=1 warning local $SIG{__WARN__} = sub { note "[warnings]\n", $_[0] }; isa_ok( FFI::Platypus->new( api => 1 )->{tp}, 'FFI::Platypus::TypeParser::Version1', ); }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_typeparser_version0.t000644 000765 000024 00000023277 13616651126 023574 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::Platypus::Internal; use FFI::Platypus::TypeParser::Version0; my $ffi = FFI::Platypus->new; my $type; my $pointer_size = $ffi->sizeof('opaque'); subtest basic => sub { is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('uint64')->meta, { element_size => 8, element_type => 'int', ffi_type => 'uint64', sign => 0, size => 8, type => 'scalar', type_code => FFI_PL_TYPE_UINT64, }, 'basic basic', ) or diag explain $type; subtest 'longdouble' => sub { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('longdouble')->meta, { element_size => 16, element_type => 'float', ffi_type => 'longdouble', size => 16, type => 'scalar', type_code => FFI_PL_TYPE_LONG_DOUBLE, }, 'longdouble', ) or diag explain $type; }; subtest 'complex' => sub { plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_float'); plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_double'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_float')->meta, { element_size => 8, element_type => 'float', ffi_type => 'complex_float', size => 8, type => 'scalar', type_code => FFI_PL_TYPE_COMPLEX_FLOAT, }, 'complex float', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_double')->meta, { element_size => 16, element_type => 'float', ffi_type => 'complex_double', size => 16, type => 'scalar', type_code => FFI_PL_TYPE_COMPLEX_DOUBLE, }, 'complex double', ) or diag explain $type; }; }; subtest record => sub { is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string(42)')->meta, { ffi_type => 'pointer', ref => 0, size => 42, type => 'record', type_code => FFI_PL_TYPE_RECORD, }, 'fixed string', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('record(42)')->meta, { ffi_type => 'pointer', ref => 0, size => 42, type => 'record', type_code => FFI_PL_TYPE_RECORD, }, 'unclassed record', ) or diag explain $type; { package Foo::Bar::Baz; use FFI::Platypus::Record; record_layout (qw( sint64 foo )); } is_deeply( $type =FFI::Platypus::TypeParser::Version0->new->parse('record(Foo::Bar::Baz)')->meta, { ffi_type => 'pointer', ref => 1, size => 8, type => 'record', type_code => FFI_PL_TYPE_RECORD, }, 'classed record', ) or diag explain $type; }; subtest string => sub { is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string')->meta, { access => 'ro', element_size => $pointer_size, ffi_type => 'pointer', size => $pointer_size, type => 'string', type_code => FFI_PL_TYPE_STRING, }, 'default string', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string ro')->meta, { access => 'ro', element_size => $pointer_size, ffi_type => 'pointer', size => $pointer_size, type => 'string', type_code => FFI_PL_TYPE_STRING, }, 'explicit ro string', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string_ro')->meta, { access => 'ro', element_size => $pointer_size, ffi_type => 'pointer', size => $pointer_size, type => 'string', type_code => FFI_PL_TYPE_STRING, }, 'explicit ro string with underscore', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string rw')->meta, { access => 'rw', element_size => $pointer_size, ffi_type => 'pointer', size => $pointer_size, type => 'string', type_code => FFI_PL_TYPE_STRING, }, 'explicit rw string', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('string_rw')->meta, { access => 'rw', element_size => $pointer_size, ffi_type => 'pointer', size => $pointer_size, type => 'string', type_code => FFI_PL_TYPE_STRING, }, 'explicit rw string with underscore', ) or diag explain $type; }; subtest array => sub { is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('uint64 [4]')->meta, { element_count => 4, element_size => 8, element_type => 'int', ffi_type => 'uint64', sign => 0, size => 32, type => 'array', type_code => FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_ARRAY, }, 'fixed array', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('uint64 []')->meta, { element_count => 0, element_size => 8, element_type => 'int', ffi_type => 'uint64', sign => 0, size => 0, type => 'array', type_code => FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_ARRAY, }, 'variable array', ) or diag explain $type; subtest 'longdouble' => sub { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('longdouble []')->meta, { element_count => 0, element_size => 16, element_type => 'float', ffi_type => 'longdouble', size => 0, type => 'array', type_code => FFI_PL_TYPE_LONG_DOUBLE | FFI_PL_SHAPE_ARRAY, }, 'variable array', ) or diag explain $type; }; subtest 'complex' => sub { plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_float'); plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_double'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_float []')->meta, { element_count => 0, element_size => 8, element_type => 'float', ffi_type => 'complex_float', size => 0, type => 'array', type_code => FFI_PL_TYPE_COMPLEX_FLOAT | FFI_PL_SHAPE_ARRAY, }, 'variable array', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_double []')->meta, { element_count => 0, element_size => 16, element_type => 'float', ffi_type => 'complex_double', size => 0, type => 'array', type_code => FFI_PL_TYPE_COMPLEX_DOUBLE | FFI_PL_SHAPE_ARRAY, }, 'variable array', ) or diag explain $type; }; }; subtest pointer => sub { is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('uint64 *')->meta, { element_size => 8, element_type => 'int', ffi_type => 'uint64', sign => 0, size => $pointer_size, type => 'pointer', type_code => FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_POINTER, }, 'pointer', ) or diag explain $type; subtest 'longdouble' => sub { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('longdouble *')->meta, { element_size => 16, element_type => 'float', ffi_type => 'longdouble', size => $pointer_size, type => 'pointer', type_code => FFI_PL_TYPE_LONG_DOUBLE | FFI_PL_SHAPE_POINTER, }, 'longdouble pointer', ) or diag explain $type; }; subtest 'complex' => sub { plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_float'); plan skip_all => 'test requires support for complex' unless FFI::Platypus::TypeParser->have_type('complex_double'); is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_float *')->meta, { element_size => 8, element_type => 'float', ffi_type => 'complex_float', size => $pointer_size, type => 'pointer', type_code => FFI_PL_TYPE_COMPLEX_FLOAT | FFI_PL_SHAPE_POINTER, }, 'complex float pointer', ) or diag explain $type; is_deeply( $type = FFI::Platypus::TypeParser::Version0->new->parse('complex_double *')->meta, { element_size => 16, element_type => 'float', ffi_type => 'complex_double', size => $pointer_size, type => 'pointer', type_code => FFI_PL_TYPE_COMPLEX_DOUBLE | FFI_PL_SHAPE_POINTER, }, 'complex double pointer', ) or diag explain $type; }; }; done_testing; FFI-Platypus-1.10/t/ffi_platypus_typeparser_version1.t000644 000765 000024 00000022532 13616651126 023566 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::Internal; use FFI::Platypus::TypeParser::Version1; use Data::Dumper qw( Dumper ); my $tp = FFI::Platypus::TypeParser::Version1->new; my $pointer_size = FFI::Platypus->new->sizeof('opaque'); subtest 'bad types' => sub { eval { $tp->parse("bogus") }; like "$@", qr/^unknown type: bogus/; eval { $tp->parse("*(^^%*%I(*&&^") }; like "$@", qr/^bad type name:/; }; subtest 'basic types' => sub { subtest 'void' => sub { my $void = $tp->parse('void'); isa_ok $void, 'FFI::Platypus::Type'; is $void->type_code, FFI_PL_TYPE_VOID; eval { $tp->parse('void*') }; like "$@", qr/^void pointer not allowed/; eval { $tp->parse('void[]') }; like "$@", qr/^void array not allowed/; }; subtest 'non-void' => sub { is( $tp->parse('sint8')->type_code, FFI_PL_TYPE_SINT8, ); is( $tp->parse('sint8*')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('sint8[]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('sint8[]')->meta->{size}, 0, ); is( $tp->parse('sint8[10]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('sint8[10]')->meta->{size}, 10, ); }; subtest 'string' => sub { is( $tp->parse('string')->type_code, FFI_PL_TYPE_STRING, ); is($tp->parse('string')->is_ro, 1); is( $tp->parse('string rw')->type_code, FFI_PL_TYPE_STRING, ); is( $tp->parse('string ro')->type_code, FFI_PL_TYPE_STRING, ); is($tp->parse('string ro')->is_ro, 1); is($tp->parse('string rw')->is_ro, 0); is( $tp->parse('string*')->type_code, FFI_PL_TYPE_STRING | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('string[]')->type_code, FFI_PL_TYPE_STRING | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('string[]')->meta->{size}, 0, ); is( $tp->parse('string[10]')->type_code, FFI_PL_TYPE_STRING | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('string[10]')->meta->{size}, 10 * $pointer_size, ); }; subtest 'bogus' => sub { eval { $tp->parse('sint8[0]') }; like "$@", qr/^array size must be larger than 0/; }; }; subtest 'type map' => sub { my $tp = FFI::Platypus::TypeParser::Version1->new; $tp->type_map({ 'char' => 'sint8', 'int' => 'sint32', 'unsigned int' => 'uint32', 'intptr' => 'sint32*', }); is( $tp->parse('char')->type_code, FFI_PL_TYPE_SINT8, ); is( $tp->parse('int')->type_code, FFI_PL_TYPE_SINT32, ); is( $tp->parse('unsigned int')->type_code, FFI_PL_TYPE_UINT32, ); is( $tp->parse('char*')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('int*')->type_code, FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('unsigned int *')->type_code, FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('char[]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('int[]')->type_code, FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('unsigned int []')->type_code, FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('char[]')->meta->{size}, 0, ); is( $tp->parse('int[]')->meta->{size}, 0, ); is( $tp->parse('unsigned int []')->meta->{size}, 0, ); is( $tp->parse('char[22]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('int[22]')->type_code, FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('unsigned int [22]')->type_code, FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('char[22]')->meta->{size}, 22, ); is( $tp->parse('int[22]')->meta->{size}, 88, ); is( $tp->parse('unsigned int [22]')->meta->{size}, 88, ); eval { $tp->parse('int[0]') }; like "$@", qr/^array size must be larger than 0/; is( $tp->parse('intptr')->type_code, FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_POINTER, ); eval { $tp->parse('intptr*') }; like "$@", qr/^bad type name: sint32\* \*/; eval { $tp->parse('intptr[]') }; like "$@", qr/^bad type name: sint32\* \[\]/; eval { $tp->parse('intptr[10]') }; like "$@", qr/^bad type name: sint32\* \[10\]/; }; subtest 'fixed record / fixed string' => sub { subtest 'zero bad' => sub { my @bad = ( 'string(0)', 'record(0)', ' string(0)', 'string(0) ', 'string (0)', ' string (0) ', ); foreach my $bad (@bad) { eval { $tp->parse( $bad ) }; like "$@", qr{^fixed record / fixed string size must be larger than 0}; } }; subtest 'ten good' => sub { my @good = ( 'string(10)*', 'record(10)*', ' string(10)*', 'string(10) *', 'string (10)*', ' string (10)* ', ); foreach my $good (@good) { my $type = $tp->parse($good); isa_ok $type, 'FFI::Platypus::Type'; is $type->type_code, FFI_PL_TYPE_RECORD; is $type->meta->{size}, 10; is $type->meta->{ref}, 0; } }; subtest 'ten pass-by-value' => sub { my @good = ( 'string(10)', 'record(10)', ' string(10)', 'string(10) ', 'string (10)', ' string (10) ', ); foreach my $good (@good) { eval { $tp->parse($good) }; like "$@", qr{^fixed string / classless record not allowed as value type}; } }; }; subtest 'record class' => sub { { package Foo::Bar1; sub ffi_record_size { 220 }; } { package Foo::Bar2; sub _ffi_record_size { 220 }; } { package Foo::Bar3; } subtest 'good with size' => sub { my @good = qw( record(Foo::Bar1)* record(Foo::Bar2)* ); foreach my $good (@good) { my $type = $tp->parse($good); isa_ok $type, 'FFI::Platypus::Type'; } }; subtest 'bad without size' => sub { my @bad = qw( record(Foo::Bar3)* record(Foo::Bar4)* ); foreach my $bad (@bad) { eval { $tp->parse($bad) }; like "$@", qr/^Foo::Bar[34] has no ffi_record_size or _ffi_record_size method/; } }; { package Foo::Bar5; use FFI::Platypus::Record; record_layout(qw( string(67) foo )); } subtest 'pass-by-value' => sub { my @bad = qw( record(Foo::Bar5) ); foreach my $bad (@bad) { my $type = $tp->parse($bad); isa_ok $type, 'FFI::Platypus::Type'; } }; subtest 'alias' => sub { local $@ = ''; my $check = eval { $tp->check_alias('foo_bar5_t') }; is "$@", ""; is $check, 1; eval { $tp->set_alias('foo_bar5_t', $tp->parse('record(Foo::Bar5)') ) }; is "$@", ""; is $tp->parse('foo_bar5_t')->type_code, FFI_PL_TYPE_RECORD_VALUE; is $tp->parse('foo_bar5_t*')->type_code, FFI_PL_TYPE_RECORD; is $tp->parse('foo_bar5_t*')->sizeof, 67; }; }; subtest 'check alias' => sub { is( $tp->check_alias('foo_bar_baz_1239_XOR'), 1, ); eval { $tp->check_alias('foo bar') }; like "$@", qr/^spaces not allowed in alias/; eval { $tp->check_alias('!$#!$#') }; like "$@", qr/^allowed characters for alias: \[A-Za-z0-9_\]/; eval { $tp->check_alias('void') }; like "$@", qr/^alias "void" conflicts with existing type/; eval { $tp->check_alias('struct') }; like "$@", qr/^reserved world "struct" cannot be used as an alias/; eval { $tp->check_alias('enum') }; like "$@", qr/^reserved world "enum" cannot be used as an alias/; my $tp = FFI::Platypus::TypeParser::Version1->new; $tp->type_map({ 'foo_t' => 'sint16', }); eval { $tp->check_alias('foo_t') }; like "$@", qr/^alias "foo_t" conflicts with existing type/; $tp->set_alias('bar_t' => $tp->parse('sint32')); eval { $tp->check_alias('bar_t') }; like "$@", qr/^alias "bar_t" conflicts with existing type/; }; subtest 'use alias' => sub { my $tp = FFI::Platypus::TypeParser::Version1->new; $tp->set_alias('foo_t' => $tp->parse('sint8')); $tp->set_alias('bar_t' => $tp->parse('sint8*')); is( $tp->parse('foo_t')->type_code, FFI_PL_TYPE_SINT8, ); is( $tp->parse('foo_t*')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER, ); is( $tp->parse('foo_t[]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('foo_t[]')->meta->{size}, 0, ); is( $tp->parse('foo_t[99]')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_ARRAY, ); is( $tp->parse('foo_t[99]')->meta->{size}, 99, ); is( $tp->parse('bar_t')->type_code, FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER, ); eval { $tp->parse('bar_t*') }; like "$@", qr/^cannot make a pointer to bar_t/; eval { $tp->parse('bar_t[]') }; like "$@", qr/^cannot make an array of bar_t/; eval { $tp->parse('bar_t[200]') }; like "$@", qr/^cannot make an array of bar_t/; }; subtest 'object' => sub { { package Roger; } is( $tp->parse('object(Roger)')->type_code, FFI_PL_SHAPE_OBJECT | FFI_PL_TYPE_OPAQUE, ); is( $tp->parse('object(Roger,sint32)')->type_code, FFI_PL_SHAPE_OBJECT | FFI_PL_TYPE_SINT32, ); local $@ = ''; eval { $tp->parse('object(Roger,float)') }; like "$@", qr/^cannot make an object of float/; }; done_testing; FFI-Platypus-1.10/t/ffi_probe.t000644 000765 000024 00000007137 13616651126 016714 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Probe; use FFI::Probe::Runner; use Capture::Tiny qw( capture_merged ); use FFI::Temp; use File::Basename qw( basename ); use Config; sub n (&) { my($code) = @_; my($out, @ret) = capture_merged { $code->(); }; note $out; @ret; } sub f (@) { foreach my $filename (@_) { note "==@{[ basename $filename ]}=="; my $fh; open $fh, '<', $filename; note do { local $/; <$fh> }; close $fh; } } my $runner = do { my $exe = "blib/lib/auto/share/dist/FFI-Platypus/probe/bin/dlrun$Config{exe_ext}"; unless(-f $exe) { require FFI::Probe::Runner::Builder; my $out; my $exception; ($out, $exe, $exception) = capture_merged { my $exe = eval { FFI::Probe::Runner::Builder->new( dir => FFI::Temp->newdir( CLEANUP => 1, TEMPLATE => 'test-probe-XXXXXX' ) )->build; }; ($exe, $exception); }; note $out; die $exception if $exception; } FFI::Probe::Runner->new( exe => $exe, ); }; subtest 'check_header' => sub { my $dir = FFI::Temp->newdir; my $probe = FFI::Probe->new( log => "$dir/probe.log", data_filename => "$dir/probe.pl", runner => $runner, ); isa_ok $probe, 'FFI::Probe'; n { $probe->check_header('stdio.h'); $probe->check_header('bogus/does/not/exist.h'); }; is($probe->data->{header}->{"stdio.h"}, 1); is($probe->data->{header}->{"bogus/does/not/exist.h"}, 0); undef $probe; f "$dir/probe.log", "$dir/probe.pl"; # make sure that we cache that data correctly. my $probe2 = FFI::Probe->new( log => "$dir/probe2.log", data_filename => "$dir/probe.pl", runner => $runner, ); is($probe2->data->{header}->{"stdio.h"}, 1); is($probe2->data->{header}->{"bogus/does/not/exist.h"}, 0); n { $probe2->check_header('stdio.h'); $probe2->check_header('bogus/does/not/exist.h'); }; is($probe2->data->{header}->{"stdio.h"}, 1); is($probe2->data->{header}->{"bogus/does/not/exist.h"}, 0); f "$dir/probe2.log", "$dir/probe.pl"; }; subtest check_eval => sub { my $dir = FFI::Temp->newdir; # make sure that we cache that data correctly. my $probe = FFI::Probe->new( log => "$dir/probe.log", data_filename => "$dir/probe.pl", runner => $runner, ); my $ret; n { $ret = $probe->check_eval( eval => { 'foo.bar.baz' => [ '%d' => '1+2' ], }, ); }; ok $ret, 'foo.bar.baz'; is_deeply $probe->data, { foo => { bar => { baz => 3 } } }; n { $ret = $probe->check_eval( decl => ['char buffer[256];'], stmt => ['sprintf(buffer, "hello world %d", 3+4);'], eval => { 'foo.bar.string' => [ '%s' => 'buffer' ], }, ); }; ok $ret, 'foo.bar.string'; is_deeply $probe->data, { foo => { bar => { baz => 3, string => 'hello world 7' } } }; n { $ret = $probe->check_type_int('unsigned char'); }; is $ret, 'uint8'; is $probe->data->{type}->{'unsigned char'}->{size}, 1; is $probe->data->{type}->{'unsigned char'}->{sign}, 'unsigned'; like $probe->data->{type}->{'unsigned char'}->{align}, qr/^[0-9]+$/; n { $ret = $probe->check_type_float('float'); }; is $ret, 'float'; is $probe->data->{type}->{'float'}->{size}, 4; like $probe->data->{type}->{'float'}->{align}, qr/^[0-9]+$/; n { $ret = $probe->check_type_pointer; }; is $ret, 'pointer'; like $probe->data->{type}->{pointer}->{size}, qr/^[0-9]+$/; like $probe->data->{type}->{pointer}->{align}, qr/^[0-9]+$/; $probe->save; undef $probe; f "$dir/probe.log", "$dir/probe.pl"; }; done_testing; FFI-Platypus-1.10/t/ffi_probe_runner.t000644 000765 000024 00000005262 13616651126 020302 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use Config; use FFI::Probe::Runner; use Capture::Tiny qw( capture_merged ); use FFI::Build; use FFI::Build::File::C; use FFI::Temp; use lib 't/lib'; use Test::Cleanup; my $runner; my $tempdir = FFI::Temp->newdir( TEMPLATE => 'test-probe-XXXXXX' ); subtest basic => sub { my $exe = "blib/lib/auto/share/dist/FFI-Platypus/probe/bin/dlrun$Config{exe_ext}"; unless(-f $exe) { require FFI::Probe::Runner::Builder; my $out; my $exception; ($out, $exe, $exception) = capture_merged { my $exe = eval { FFI::Probe::Runner::Builder->new( dir => $tempdir )->build; }; ($exe, $exception); }; note $out; die $exception if $exception; } note "exe=$exe"; $runner = FFI::Probe::Runner->new( exe => $exe, ); isa_ok $runner, 'FFI::Probe::Runner'; is($runner->flags, '-'); is($runner->verify, 1); }; subtest 'run not pass' => sub { my $dir = FFI::Temp->newdir( TEMPLATE => 'test-probe-XXXXXX' ); my $lib = do { my $build = FFI::Build->new( 'frooble1', dir => $dir, buildname => "test-probe-$$-@{[ time ]}", verbose => 1, source => 'corpus/ffi_probe_runner/foo.c', export => ['dlmain'], ); note capture_merged { $build->build; (); }; cleanup("corpus/ffi_probe_runner/@{[ $build->buildname ]}"); $build->file->path; }; note "lib=$lib"; my $res = $runner->run($lib, 'one','two','three'); is($res->rv, 12); is($res->signal, 0); like($res->stdout, qr!argc=4!ms); like($res->stdout, qr!argv\[0\]=.*/bin/dlrun!ms); like($res->stdout, qr!argv\[1\]=one!ms); like($res->stdout, qr!argv\[2\]=two!ms); like($res->stdout, qr!argv\[3\]=three!ms); like($res->stderr, qr/something to std error/); ok(!$res->pass); }; subtest 'run pass' => sub { my $dir = FFI::Temp->newdir( TEMPLATE => 'test-probe-XXXXXX' ); my $lib = do { my $build = FFI::Build->new( 'frooble2', verbose => 1, dir => $dir, buildname => "test-probe-$$-@{[ time ]}", source => 'corpus/ffi_probe_runner/bar.c', export => ['dlmain'], ); note capture_merged { $build->build; (); }; cleanup("corpus/ffi_probe_runner/@{[ $build->buildname ]}"); $build->file->path; }; note "lib=$lib"; my $res = $runner->run($lib, 'one','two','three'); is($res->rv, 0); is($res->signal, 0); like($res->stdout, qr!argc=4!ms); like($res->stdout, qr!argv\[0\]=.*/bin/dlrun!ms); like($res->stdout, qr!argv\[1\]=one!ms); like($res->stdout, qr!argv\[2\]=two!ms); like($res->stdout, qr!argv\[3\]=three!ms); like($res->stderr, qr/something to std error/); ok(!!$res->pass); }; done_testing; FFI-Platypus-1.10/t/ffi_probe_runner_builder.t000644 000765 000024 00000001704 13616651126 022005 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Temp; use Capture::Tiny qw( capture_merged ); use FFI::Probe::Runner::Builder; use IPC::Cmd qw( can_run ); $FFI::Probe::Runner::Builder::VERBOSE = 1; my $dir = FFI::Temp->newdir( TEMPLATE => 'test-probe-XXXXXX' ); note "dir = $dir"; my $builder = FFI::Probe::Runner::Builder->new( dir => $dir, ); foreach my $lib (@{ $builder->libs }) { note "libs=" . join(' ', @$lib) } isa_ok $builder, 'FFI::Probe::Runner::Builder'; my($out1, $exe, $error) = capture_merged { my $exe = eval { $builder->build }; ($exe, $@); }; note $out1; is $error, '', 'no error'; ok -f $exe, "executable exists"; note "exe = $exe"; my($out2, $ret) = capture_merged { print "+ $exe verify self\n"; system $exe, 'verify', 'self'; $?; }; note $out2; is $ret, 0, 'verify ok'; if($^O eq 'linux' && can_run('ldd')) { note capture_merged { print "+ ldd $exe\n"; system "ldd", $exe; (); }; } done_testing; FFI-Platypus-1.10/t/ffi_probe_runner_result.t000644 000765 000024 00000001152 13616651126 021672 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Probe::Runner::Result; my %std = ( stdout => "foo\n", stderr => "bar\n", rv => 0, signal => 0 ); my $result1 = FFI::Probe::Runner::Result->new( %std ); isa_ok $result1, 'FFI::Probe::Runner::Result'; ok($result1->pass); my $result2 = FFI::Probe::Runner::Result->new( %std, rv => 2, ); isa_ok $result2, 'FFI::Probe::Runner::Result'; is($result2->rv, 2); ok(!$result2->pass); my $result3 = FFI::Probe::Runner::Result->new( %std, signal => 9, ); isa_ok $result3, 'FFI::Probe::Runner::Result'; is($result3->signal, 9); ok(!$result3->pass); done_testing; FFI-Platypus-1.10/t/ffi_temp.t000644 000765 000024 00000000316 13616651126 016542 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Temp; my $dir = FFI::Temp->newdir; ok -d $dir; note "dir = $dir"; my $fh = FFI::Temp->new; close $fh; note "file = @{[ $fh->filename ]}"; done_testing; FFI-Platypus-1.10/t/forks.t000644 000765 000024 00000001235 13616651126 016076 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; use File::Spec; BEGIN { my $path; foreach my $inc (@INC) { $path = File::Spec->catfile($inc, 'forks.pm'); last if -f $path; } plan skip_all => 'Test requires forks' unless defined $path && -f $path; } use forks; my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi' )); 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'; done_testing; FFI-Platypus-1.10/t/gh117.t000644 000765 000024 00000000547 13616651126 015606 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib qw( find_lib ); use FFI::Platypus; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; my $ffi = FFI::Platypus->new; $ffi->lib($libtest); my $value64 = $ffi->function('gh117' => [] => 'uint64')->call; note "value64 = $value64"; is($value64, "1099511627775"); done_testing; FFI-Platypus-1.10/t/gh129.t000644 000765 000024 00000003652 13616651126 015611 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib qw( find_lib ); use FFI::Platypus; use Carp (); my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); subtest 'attached function' => sub { $ffi->attach( f0 => ['uint8'] => 'uint8' => sub { package Foo::Bar; my($xsub, $arg) = @_; Carp::croak "here"; $xsub->($arg); }); local $@ = ''; eval { f0(1) }; my $line = __LINE__; like "$@", qr/^here .*gh129\.t line \Q$line\E/; }; subtest 'dynamic function' => sub { my $f0 = $ffi->function( f0 => ['uint8'] => 'uint8' => sub { package Foo::Bar; my($xsub, $arg) = @_; Carp::croak "here"; $xsub->($arg); }); local $@ = ''; eval { $f0->call(1) }; my $line = __LINE__; like "$@", qr/^here .*gh129\.t line \Q$line\E/; }; subtest 'type wrapper argument' => sub { $ffi->custom_type( foo_t => { native_type => 'uint8', perl_to_native => sub { package Foo::Bar; Carp::croak "here"; }, }); my $f0 = $ffi->function( f0 => ['foo_t'] => 'uint8'); local $@ = ''; eval { $f0->call(22) }; my $line = __LINE__; like "$@", qr/^here .*gh129\.t line \Q$line\E/; }; subtest 'type wrapper argument post' => sub { $ffi->custom_type( baz_t => { native_type => 'uint8', perl_to_native_post => sub { package Foo::Bar; Carp::croak "here"; }, }); my $f0 = $ffi->function( f0 => ['baz_t'] => 'uint8'); local $@ = ''; eval { $f0->call(22) }; my $line = __LINE__; like "$@", qr/^here .*gh129\.t line \Q$line\E/; }; subtest 'type wrapper return type' => sub { $ffi->custom_type( bar_t => { native_type => 'uint8', native_to_perl => sub { package Foo::Bar; Carp::croak "here"; }, }); my $f0 = $ffi->function( f0 => ['uint8'] => 'bar_t'); local $@ = ''; eval { $f0->call(22) }; my $line = __LINE__; like "$@", qr/^here .*gh129\.t line \Q$line\E/; }; done_testing;FFI-Platypus-1.10/t/lib/000755 000765 000024 00000000000 13616651126 015332 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/t/memory.t000644 000765 000024 00000003156 13616651126 016266 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use Config; use Capture::Tiny qw( capture_merged ); use FFI::Temp; # libexpat1-dev plan skip_all => 'tested only in CI' if ($ENV{CIPSOMETHING}||'') ne 'true'; plan skip_all => 'tested only in CI -debug' if $Config{ccflags} !~ /-DDEBUG_LEAKING_SCALARS/; my %exfail = map { $_ => 1 } qw( attach.pl ); # you can run this on just one (or more) test file in corpus/memory by # perl -Mblib t/memory.t foo.pl my @list = @ARGV ? @ARGV : do { my $dh; opendir $dh, 'corpus/memory'; grep /\.pl$/, sort readdir $dh; }; my @supp = do { my $dh; opendir $dh, 'corpus/memory/supp'; map { "--suppressions=corpus/memory/supp/$_" } grep /\.supp/, sort readdir $dh; }; foreach my $name (@list) { subtest $name => sub { local $ENV{PERL_DESTRUCT_LEVEL} = 2; my $log = FFI::Temp->new; my @command = ( 'valgrind', '--leak-check=yes', "--log-file=$log", '--error-exitcode=2', #'--gen-suppressions=all', #'-v', @supp, $^X, '-Mblib', "corpus/memory/$name", ); my($out, $exit) = capture_merged { print "+ @command\n"; system @command; $?; }; if($exfail{$name}) { note "expected fail"; TODO: { local $TODO = 'expected fail'; is($exit, 0, 'valgrind') or do { note "[output]\n$out"; note "[log]\n", do { local $/; <$log> }; }; }; } else { note "expected pass"; is($exit, 0, 'valgrind') or do { diag "[output]\n$out"; diag "[log]\n", do { local $/; <$log> }; }; } }; } done_testing; FFI-Platypus-1.10/t/threads.t000644 000765 000024 00000002030 13616651126 016376 0ustar00ollisgstaff000000 000000 use 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; if("$^V" eq "v5.10.0") { diag ''; diag ''; diag ''; diag "Note that there are known but unresolved issues with Platypus on threaded 5.10.0 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/Perl5-FFI/FFI-Platypus/issues/68"; diag ''; diag ''; } my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi' )); 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'; done_testing; FFI-Platypus-1.10/t/type_complex_double.t000644 000765 000024 00000012211 13616651126 021010 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; use Data::Dumper qw( Dumper ); BEGIN { plan skip_all => 'Test requires support for double complex' unless FFI::Platypus::TypeParser->have_type('complex_double'); } foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->attach(['complex_double_get_real' => 'creal'] => ['complex_double'] => 'double'); $ffi->attach(['complex_double_get_imag' => 'cimag'] => ['complex_double'] => 'double'); $ffi->attach(['complex_double_to_string' => 'to_string'] => ['complex_double'] => 'string'); subtest 'standard argument' => sub { subtest 'with a real number' => sub { 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 { 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 }; 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->attach(['complex_double_ptr_get_real' => 'creal_ptr'] => ['complex_double *'] => 'double'); $ffi->attach(['complex_double_ptr_get_imag' => 'cimag_ptr'] => ['complex_double *'] => 'double'); $ffi->attach(['complex_double_ptr_set' => 'complex_set'] => ['complex_double *','double','double'] => 'void'); subtest 'pointer argument' => sub { subtest 'with a real number' => sub { note "to_string(10.5) = ", to_string(10.5); is creal_ptr(\10.5), 10.5, "creal_ptr(\\10.5) = 10.5"; is cimag_ptr(\10.5), 0.0, "cimag_ptr(\\10.5) = 0.0"; }; subtest 'with an array ref' => sub { note "to_string([10.5,20.5]) = ", to_string([10.5,20.5]); is creal_ptr(\[10.5,20.5]), 10.5, "creal_ptr(\\[10.5,20.5]) = 10.5"; is cimag_ptr(\[10.5,20.5]), 20.5, "cimag_ptr(\\[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 }; my $c = Math::Complex->make(10.5, 20.5); note "to_string(\$c) = ", to_string($c); is creal_ptr(\$c), 10.5, "creal_ptr(\\$c) = 10.5"; is cimag_ptr(\$c), 20.5, "cimag_ptr(\\$c) = 20.5"; }; subtest 'values set on out (array)' => sub { my @c; complex_set(\\@c, 1.0, 2.0); is_deeply \@c, [ 1.0, 2.0 ]; }; subtest 'values set on out (object)' => sub { plan skip_all => 'test requires Math::Complex' unless eval q{ use Math::Complex (); 1 }; my $c = Math::Complex->make(0.0, 0.0); complex_set(\$c, 1.0, 2.0); is_deeply( [ $c->Re, $c->Im ], [1.0,2.0] ); }; subtest 'values set on out (other)' => sub { my $c; complex_set(\$c, 1.0, 2.0); is_deeply( $c, [1.0, 2.0]); }; }; $ffi->attach(['pointer_null' => 'complex_null'] => [] => 'complex_double*'); $ffi->attach(['complex_double_ret' => 'complex_ret'] => ['double','double'] => 'complex_double'); $ffi->attach(['complex_double_ptr_ret' => 'complex_ptr_ret'] => ['double','double'] => 'complex_double*'); subtest 'return value' => sub { is_deeply(complex_ret(1.0,2.0), [1.0,2.0], 'standard'); is_deeply(complex_ptr_ret(1.0,2.0), \[1.0,2.0], 'pointer'); is_deeply([complex_null()], [], 'null'); }; subtest 'complex array arg' => sub { my $f = $ffi->function(complex_double_array_get => ['complex_double[]','int'] => 'complex_double' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); my $ret; is_deeply( $ret = $f->call(\@a, 0), [0.0,0.0] ) or diag Dumper($ret); is_deeply( $ret = $f->call(\@a, 1), [1.0,2.0] ) or diag Dumper($ret); is_deeply( $ret = $f->call(\@a, 2), [3.0,4.0] ) or diag Dumper($ret); }; subtest 'complex array arg set' => sub { my $f = $ffi->function(complex_double_array_set => ['complex_double[]','int','double','double'] => 'void' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); $f->call(\@a, 1, 5.0, 6.0); is_deeply(\@a, [[0.0,0.0], [5.0,6.0], [3.0,4.0]]); }; subtest 'complex array ret' => sub { my $f = $ffi->function(complex_double_array_ret => [] => 'complex_double[3]' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); my $ret; is_deeply( $ret = $f->call( \@a ), \@a, ) or diag Dumper($ret); }; }; } done_testing; FFI-Platypus-1.10/t/type_complex_float.t000644 000765 000024 00000012144 13616651126 020650 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; use Data::Dumper qw( Dumper ); BEGIN { plan skip_all => 'Test requires support for float complex' unless FFI::Platypus::TypeParser->have_type('complex_float'); } foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->attach(['complex_float_get_real' => 'creal'] => ['complex_float'] => 'float'); $ffi->attach(['complex_float_get_imag' => 'cimag'] => ['complex_float'] => 'float'); $ffi->attach(['complex_float_to_string' => 'to_string'] => ['complex_float'] => 'string'); subtest 'standard argument' => sub { subtest 'with a real number' => sub { 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 { 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 }; 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->attach(['complex_float_ptr_get_real' => 'creal_ptr'] => ['complex_float *'] => 'float'); $ffi->attach(['complex_float_ptr_get_imag' => 'cimag_ptr'] => ['complex_float *'] => 'float'); $ffi->attach(['complex_float_ptr_set' => 'complex_set'] => ['complex_float *','float','float'] => 'void'); subtest 'pointer argument' => sub { subtest 'with a real number' => sub { note "to_string(10.5) = ", to_string(10.5); is creal_ptr(\10.5), 10.5, "creal_ptr(\\10.5) = 10.5"; is cimag_ptr(\10.5), 0.0, "cimag_ptr(\\10.5) = 0.0"; }; subtest 'with an array ref' => sub { note "to_string([10.5,20.5]) = ", to_string([10.5,20.5]); is creal_ptr(\[10.5,20.5]), 10.5, "creal_ptr(\\[10.5,20.5]) = 10.5"; is cimag_ptr(\[10.5,20.5]), 20.5, "cimag_ptr(\\[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 }; my $c = Math::Complex->make(10.5, 20.5); note "to_string(\$c) = ", to_string($c); is creal_ptr(\$c), 10.5, "creal_ptr(\\$c) = 10.5"; is cimag_ptr(\$c), 20.5, "cimag_ptr(\\$c) = 20.5"; }; subtest 'values set on out (array)' => sub { my @c; complex_set(\\@c, 1.0, 2.0); is_deeply \@c, [ 1.0, 2.0 ]; }; subtest 'values set on out (object)' => sub { plan skip_all => 'test requires Math::Complex' unless eval q{ use Math::Complex (); 1 }; my $c = Math::Complex->make(0.0, 0.0); complex_set(\$c, 1.0, 2.0); is_deeply( [ $c->Re, $c->Im ], [1.0,2.0] ); }; subtest 'values set on out (other)' => sub { my $c; complex_set(\$c, 1.0, 2.0); is_deeply( $c, [1.0, 2.0]); }; }; $ffi->attach(['pointer_null' => 'complex_null'] => [] => 'complex_float*'); $ffi->attach(['complex_float_ret' => 'complex_ret'] => ['float','float'] => 'complex_float'); $ffi->attach(['complex_float_ptr_ret' => 'complex_ptr_ret'] => ['float','float'] => 'complex_float*'); subtest 'return value' => sub { is_deeply(complex_ret(1.0,2.0), [1.0,2.0], 'standard'); is_deeply(complex_ptr_ret(1.0,2.0), \[1.0,2.0], 'pointer'); is_deeply([complex_null()], [], 'null'); }; subtest 'complex array arg' => sub { my $f = $ffi->function(complex_float_array_get => ['complex_float[]','int'] => 'complex_float' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); my $ret; is_deeply( $ret = $f->call(\@a, 0), [0.0,0.0] ) or diag Dumper($ret); is_deeply( $ret = $f->call(\@a, 1), [1.0,2.0] ) or diag Dumper($ret); is_deeply( $ret = $f->call(\@a, 2), [3.0,4.0] ) or diag Dumper($ret); }; subtest 'complex array arg set' => sub { my $f = $ffi->function(complex_float_array_set => ['complex_float[]','int','float','float'] => 'void' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); $f->call(\@a, 1, 5.0, 6.0); is_deeply(\@a, [[0.0,0.0], [5.0,6.0], [3.0,4.0]]); }; subtest 'complex array ret' => sub { my $f = $ffi->function(complex_float_array_ret => [] => 'complex_float[3]' ); my @a = ([0.0,0.0], [1.0,2.0], [3.0,4.0]); my $ret; is_deeply( $ret = $f->call( \@a ), \@a, ) or diag Dumper($ret); }; }; } done_testing; FFI-Platypus-1.10/t/type_custom.t000644 000765 000024 00000001623 13616651126 017326 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; my @legal = qw( float double opaque ); push @legal, map { ("sint$_","uint$_") } qw( 8 16 32 64 ); subtest 'legal custom types' => sub { my $ffi = FFI::Platypus->new( api => 1 ); foreach my $type (@legal) { local $@ = ""; eval { $ffi->custom_type( "foo_$type" => { native_type => $type, native_to_perl => sub {}, }); }; is "$@", ""; } }; subtest 'illegal types' => sub { my $ffi = FFI::Platypus->new( api => 1 ); foreach my $type (qw( sint8[32] sint8* )) { local $@ = ""; my $alias = "foo_$type"; $alias =~ s/[\*\[\]]/_/g; note "alias = $alias"; eval { $ffi->custom_type( $alias => { native_type => $type, native_to_perl => sub {}, }); }; like "$@", qr/\Q$type\E is not a legal native type for a custom type/; } }; done_testing; FFI-Platypus-1.10/t/type_double.t000644 000765 000024 00000007043 13616651126 017270 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_float.t # all instances of "float" have been changed to "double" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('double *' => 'double_p'); $ffi->type('double [10]' => 'double_a'); $ffi->type('double []' => 'double_a2'); $ffi->type('(double)->double' => 'double_c'); $ffi->attach( [double_add => 'add'] => ['double', 'double'] => 'double'); $ffi->attach( [double_inc => 'inc'] => ['double_p', 'double'] => 'double_p'); $ffi->attach( [double_sum => 'sum'] => ['double_a'] => 'double'); $ffi->attach( [double_sum2 => 'sum2'] => ['double_a2','size_t'] => 'double'); $ffi->attach( [double_array_inc => 'array_inc'] => ['double_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'double_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['double_p'] => 'int'); $ffi->attach( [double_static_array => 'static_array'] => [] => 'double_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2.25 }); $ffi->attach( [double_set_closure => 'set_closure'] => ['double_c'] => 'void'); $ffi->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 = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2.5) }, 0, 'call_closure(2.5) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'double', perl_to_native => sub { is $_[0], 1.25; $_[0]+0.25 } }); $ffi->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 { $ffi->custom_type(type2 => { native_type => 'double', native_to_perl => sub { is $_[0], 2.0; $_[0]+0.25 } }); $ffi->attach( [double_add => 'custom_add2'] => ['double','double'] => 'type2'); is custom_add2(1,1), 2.25, 'custom_add2(1,1) = 2.25'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } done_testing; FFI-Platypus-1.10/t/type_float.t000644 000765 000024 00000006551 13616651126 017126 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('float *' => 'float_p'); $ffi->type('float [10]' => 'float_a'); $ffi->type('float []' => 'float_a2'); $ffi->type('(float)->float' => 'float_c'); $ffi->attach( [float_add => 'add'] => ['float', 'float'] => 'float'); $ffi->attach( [float_inc => 'inc'] => ['float_p', 'float'] => 'float_p'); $ffi->attach( [float_sum => 'sum'] => ['float_a'] => 'float'); $ffi->attach( [float_sum2 => 'sum2'] => ['float_a2','size_t'] => 'float'); $ffi->attach( [float_array_inc => 'array_inc'] => ['float_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'float_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['float_p'] => 'int'); $ffi->attach( [float_static_array => 'static_array'] => [] => 'float_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2.25 }); $ffi->attach( [float_set_closure => 'set_closure'] => ['float_c'] => 'void'); $ffi->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 = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2.5) }, 0, 'call_closure(2.5) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'float', perl_to_native => sub { is $_[0], 1.25; $_[0]+0.25 } }); $ffi->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 { $ffi->custom_type(type2 => { native_type => 'float', native_to_perl => sub { is $_[0], 2.0; $_[0]+0.25 } }); $ffi->attach( [float_add => 'custom_add2'] => ['float','float'] => 'type2'); is custom_add2(1,1), 2.25, 'custom_add2(1,1) = 2.25'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } done_testing; FFI-Platypus-1.10/t/type_longdouble.t000644 000765 000024 00000012231 13616651126 020143 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; use Config; BEGIN { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); } subtest 'Math::LongDouble is loaded when needed for return type' => sub { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); $ffi->function( longdouble_add => ['longdouble','longdouble'] => 'longdouble' ); my $pm = $INC{'Math/LongDouble.pm'}; if(eval q{ use Math::LongDouble; 1 }) { is($pm, $INC{'Math/LongDouble.pm'}); isnt $pm, undef; } else { is($pm, undef); is($INC{'Math/LongDouble.pm'}, undef); } }; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); $ffi->type('longdouble*' => 'longdouble_p'); $ffi->type('longdouble[3]' => 'longdouble_a3'); $ffi->type('longdouble[]' => 'longdouble_a'); $ffi->attach( [longdouble_add => 'add'] => ['longdouble','longdouble'] => 'longdouble'); $ffi->attach( longdouble_pointer_test => ['longdouble_p', 'longdouble_p'] => 'int'); $ffi->attach( longdouble_array_test => ['longdouble_a', 'int'] => 'int'); $ffi->attach( [longdouble_array_test => 'longdouble_array_test3'] => ['longdouble_a3', 'int'] => 'int'); $ffi->attach( longdouble_array_return_test => [] => 'longdouble_a3'); $ffi->attach( pointer_is_null => ['longdouble_p'] => 'int'); $ffi->attach( longdouble_pointer_return_test => ['longdouble'] => 'longdouble_p'); $ffi->attach( pointer_null => [] => 'longdouble_p'); subtest 'with Math::LongDouble' => sub { plan skip_all => 'test requires Math::LongDouble' if $Config{uselongdouble} || !eval q{ use Math::LongDouble; 1 }; 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 { my $result = add($ld15, $ld25); isa_ok $result, 'Math::LongDouble'; ok $result == $ld40, "add(1.5,2.5) = 4.0"; }; subtest 'pointer' => sub { my $x = Math::LongDouble->new(1.5); my $y = Math::LongDouble->new(2.5); ok longdouble_pointer_test(\$x, \$y); ok $x == $ld40; ok $y == $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 { 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 { 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 { 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 skip_all => 'test requires Math::LongDouble' if ! $Config{uselongdouble} || ! eval q{ use Math::LongDouble; 1 }; subtest 'scalar' => sub { is add(1.5, 2.5), 4.0, "add(1.5,2.5) = 4"; }; subtest 'pointer' => sub { my $x = 1.5; my $y = 2.5; ok longdouble_pointer_test(\$x, \$y); ok $x == 4.0; ok $y == 8.0; ok pointer_is_null(undef); my $c = longdouble_pointer_return_test(1.5); ok $$c == 1.5; }; subtest 'array fixed' => sub { 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 { 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 { 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; }; }; }; } done_testing; FFI-Platypus-1.10/t/type_longdouble__array.t000644 000765 000024 00000001543 13616651126 021504 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; use Config; BEGIN { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); } my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); subtest 'Math::LongDouble is loaded when needed for return type' => sub { $ffi->function( 0 => ['longdouble'] => 'int'); $ffi->function( 0 => ['int'] => 'int'); is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); $ffi->function( 0 => ['longdouble[]'] => 'int' ); my $pm = $INC{'Math/LongDouble.pm'}; if(eval q{ use Math::LongDouble; 1 }) { is($pm, $INC{'Math/LongDouble.pm'}); isnt $pm, undef; } else { is($pm, undef); is($INC{'Math/LongDouble.pm'}, undef); } }; done_testing; FFI-Platypus-1.10/t/type_longdouble__hide.t000644 000765 000024 00000005436 13616651126 021304 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; BEGIN { local $SIG{__WARN__} = sub { my $message = shift; return note $message if $message =~ /hides Math\/LongDouble\.pm/; warn $message; }; plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); plan skip_all => 'test requires Devel::Hide 0.0010' unless eval q{ use Devel::Hide 0.0010 qw( Math::LongDouble ); 1; }; } my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); subtest 'Math::LongDouble is loaded when needed for return type' => sub { is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); $ffi->function( longdouble_add => ['longdouble','longdouble'] => 'longdouble' ); my $loaded = Math::LongDouble->can("new"); ok !$loaded; }; $ffi->type('longdouble*' => 'longdouble_p'); $ffi->type('longdouble[3]' => 'longdouble_a3'); $ffi->type('longdouble[]' => 'longdouble_a'); $ffi->attach( [longdouble_add => 'add'] => ['longdouble','longdouble'] => 'longdouble'); $ffi->attach( longdouble_pointer_test => ['longdouble_p', 'longdouble_p'] => 'int'); $ffi->attach( longdouble_array_test => ['longdouble_a', 'int'] => 'int'); $ffi->attach( [longdouble_array_test => 'longdouble_array_test3'] => ['longdouble_a3', 'int'] => 'int'); $ffi->attach( longdouble_array_return_test => [] => 'longdouble_a3'); $ffi->attach( pointer_is_null => ['longdouble_p'] => 'int'); $ffi->attach( longdouble_pointer_return_test => ['longdouble'] => 'longdouble_p'); $ffi->attach( pointer_null => [] => 'longdouble_p'); subtest 'without Math::LongDouble' => sub { plan skip_all => 'test requires Math::LongDouble' if eval q{ use Math::LongDouble; 1 }; subtest 'scalar' => sub { is add(1.5, 2.5), 4.0, "add(1.5,2.5) = 4"; }; subtest 'pointer' => sub { my $x = 1.5; my $y = 2.5; ok longdouble_pointer_test(\$x, \$y); ok $x == 4.0; ok $y == 8.0; ok pointer_is_null(undef); my $c = longdouble_pointer_return_test(1.5); ok $$c == 1.5; }; subtest 'array fixed' => sub { 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 { 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 { 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; }; }; done_testing; FFI-Platypus-1.10/t/type_longdouble__ptr.t000644 000765 000024 00000001542 13616651126 021172 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::Platypus::TypeParser; use FFI::CheckLib; use Config; BEGIN { plan skip_all => 'test requires support for long double' unless FFI::Platypus::TypeParser->have_type('longdouble'); } my $ffi = FFI::Platypus->new; $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); subtest 'Math::LongDouble is loaded when needed for return type' => sub { $ffi->function( 0 => ['longdouble'] => 'int'); $ffi->function( 0 => ['int'] => 'int'); is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); $ffi->function( 0 => ['longdouble*'] => 'int' ); my $pm = $INC{'Math/LongDouble.pm'}; if(eval q{ use Math::LongDouble; 1 }) { is($pm, $INC{'Math/LongDouble.pm'}); isnt $pm, undef; } else { is($pm, undef); is($INC{'Math/LongDouble.pm'}, undef); } }; done_testing; FFI-Platypus-1.10/t/type_opaque.t000644 000765 000024 00000013461 13616651126 017311 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->attach( [pointer_null => 'null'] => [] => 'opaque'); $ffi->attach( [pointer_is_null => 'is_null'] => ['opaque'] => 'int'); $ffi->attach( [pointer_set_my_pointer => 'setp'] => ['opaque'] => 'void'); $ffi->attach( [pointer_get_my_pointer => 'getp'] => [] => 'opaque'); $ffi->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; $ffi->attach( [pointer_arg_array_in => 'aa_in'] => ['opaque[3]'] => 'int'); $ffi->attach( [pointer_arg_array_null_in => 'aa_null_in'] => ['opaque[3]'] => 'int'); $ffi->attach( [pointer_arg_array_out => 'aa_out'] => ['opaque[3]'] => 'void'); $ffi->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 { $ffi->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; }; $ffi->attach( [pointer_ret_array_out => 'ra_out'] => [] => 'opaque[3]'); $ffi->attach( [pointer_ret_array_out_null_terminated => 'ra_out_nt'] => [] => 'opaque[]'); $ffi->attach( [pointer_ret_array_null_out => 'ra_null_out'] => [] => 'opaque[3]'); is_deeply [map { $ffi->cast('opaque' => 'string', $_) } @{ ra_out() } ], [qw( seven eight nine )], "ra_out()"; is_deeply [map { $ffi->cast('opaque' => 'string', $_) } @{ ra_out_nt() } ], [qw( seven eight nine )], "ra_out_nt()"; is_deeply ra_null_out(), [undef,undef,undef], 'ra_null_out'; $ffi->attach( [pointer_pointer_pointer_to_pointer => 'pp2p'] => ['opaque*'] => 'opaque'); $ffi->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; }; $ffi->attach( [pointer_set_closure => 'set_closure'] => ['(opaque)->opaque'] => 'void'); $ffi->attach( [pointer_call_closure => 'call_closure'] => ['opaque'] => 'opaque'); my $save = 1; my $closure = $ffi->closure(sub { $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 { $ffi->custom_type(type1 => { perl_to_native => sub { is $ffi->cast('opaque'=>'string',$_[0]), "abc"; free $_[0]; perl_to_c_string_copy("def"); } }); $ffi->attach(['pointer_set_my_pointer' => 'custom1_setp'] => ['type1'] => 'void'); custom1_setp(perl_to_c_string_copy("abc")); my $ptr = getp(); is $ffi->cast('opaque'=>'string',$ptr), "def"; free $ptr; }; subtest 'custom type output' => sub { setp(perl_to_c_string_copy("ABC")); $ffi->custom_type(type2 => { native_to_perl => sub { is $ffi->cast('opaque'=>'string',$_[0]), "ABC"; free $_[0]; "DEF"; } }); $ffi->attach([pointer_get_my_pointer => 'custom2_getp'] => [] => 'type2'); is custom2_getp(), "DEF"; setp(undef); }; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger)', 'roger_t'); $ffi->type('object(Roger,opaque)', 'roger2_t'); my $ptr = malloc 200; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'opaque', bless(\$ptr, 'Roger')), $ptr; is $ffi->cast('roger2_t' => 'opaque', bless(\$ptr, 'Roger')), $ptr; }; subtest 'return value' => sub { is $ffi->cast('opaque' => 'roger_t', undef), undef; my $obj1 = $ffi->cast('opaque' => 'roger_t', $ptr); isa_ok $obj1, 'Roger'; is $$obj1, $ptr; my $obj2 = $ffi->cast('opaque' => 'roger2_t', $ptr); isa_ok $obj2, 'Roger'; is $$obj2, $ptr; }; free $ptr; }; done_testing; package MyPerlStrDup; use FFI::Platypus::Memory qw( malloc memcpy ); sub main::perl_to_c_string_copy { my($string) = @_; my $ptr = malloc(length($string)+1); memcpy($ptr, FFI::Platypus->new->cast('string' => 'opaque', $string), length($string)+1); $ptr; }; FFI-Platypus-1.10/t/type_record.t000644 000765 000024 00000014246 13616651126 017277 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib qw( find_lib ); use FFI::Platypus::Memory qw( malloc free ); my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; my $record_size = My::FooRecord->ffi_record_size; note "record size = $record_size"; subtest 'not a reference' => sub { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $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 { 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 { 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 { my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $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 { 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 { 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'; }; }; subtest 'closure' => sub { { package Closture::Record::RW; use FFI::Platypus::Record; record_layout( 'string_rw' => 'one', 'string_rw' => 'two', 'int' => 'three', 'string_rw' => 'four', 'int[2]' => 'myarray1', 'opaque' => 'opaque1', 'opaque[2]' => 'myarray2', 'string(5)' => 'fixedfive', ); } my $ffi = FFI::Platypus->new; $ffi->lib($libtest); $ffi->type('record(Closture::Record::RW)' => 'cx_struct_rw_t'); eval { $ffi->type('(cx_struct_rw_t,int)->void' => 'cx_closure_t') }; is $@, '', 'allow record type as arg'; my $cx_closure_set = $ffi->function(cx_closure_set => [ 'cx_closure_t' ] => 'void' ); my $cx_closure_call = $ffi->function(cx_closure_call => [ 'cx_struct_rw_t', 'int' ] => 'void' ); my $r = Closture::Record::RW->new; $r->one("one"); $r->two("two"); $r->three(3); $r->four("four"); $r->myarray1([1,2]); $r->opaque1(malloc(22)); $r->myarray2([malloc(33),malloc(44)]); $r->fixedfive("five\0"); is($r->_ffi_record_ro, 0); my $here = 0; my $f = $ffi->closure(sub { my($r2,$num) = @_; is($r2->_ffi_record_ro, 1); is($r2->one, "one"); is($r2->two, "two"); is($r2->three, 3); { local $@ = ''; eval { $r2->three(64) }; isnt $@, ''; note "error = $@"; } is($r2->three, 3); is($r2->four, "four"); is_deeply($r2->myarray1, [1,2]); { local $@ = ''; eval { $r2->myarray1([3,4]) }; isnt $@, ''; note "error = $@"; } is_deeply($r2->myarray1, [1,2]); { local $@ = ''; eval { $r2->myarray1(3,4) }; isnt $@, ''; note "error = $@"; } is_deeply($r2->myarray1, [1,2]); is($r2->opaque1, $r->opaque1); { local $@ = ''; eval { $r2->opaque1(undef) }; isnt $@, ''; note "error = $@"; } is($r2->opaque1, $r->opaque1); is_deeply($r2->myarray2, $r->myarray2); { local $@ = ''; eval { $r2->myarray2([undef,undef]) }; isnt $@, ''; note "error = $@"; } is_deeply($r2->myarray2, $r->myarray2); { local $@ = ''; eval { $r2->myarray2(undef,undef) }; isnt $@, ''; note "error = $@"; } is_deeply($r2->myarray2, $r->myarray2); { local $@ = ''; eval { $r2->one("new string!") }; isnt $@, ''; note "error = $@"; } is($r2->one, "one"); is($r2->fixedfive, "five\0"); { local $@ = ''; eval { $r2->fixedfive("xxxxx") }; isnt $@, ''; note "error = $@"; } is($r2->fixedfive, "five\0"); is($num, 42); $here = 1; }); $cx_closure_set->($f); $cx_closure_call->($r, 42); is($here, 1); $here = 0; my $f2 = $ffi->closure(sub { my($r2, $num) = @_; is($r2, undef); is($num, 0); $here = 1; }); $cx_closure_set->($f2); $cx_closure_call->(undef, undef); is($here, 1); }; subtest 'api = 1 fixed string' => sub { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib($libtest); { package My::FooRecord2; use FFI::Platypus::Record; eval { record_layout( $ffi, qw( string(5)* foo string(5) bar )) }; } is "$@", ""; my $r = My::FooRecord2->new( foo => '12345', bar => '67890' ); is $r->foo, '12345'; is $r->bar, '67890'; }; done_testing; 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" } FFI-Platypus-1.10/t/type_record_value.t000644 000765 000024 00000004551 13616651126 020471 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib qw( find_lib ); use FFI::Platypus::Memory qw( malloc free ); use FFI::Platypus::ShareConfig; my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; my $return_ok = FFI::Platypus::ShareConfig->get('probe')->{recordvalue}; { package FooRecord; use FFI::Platypus::Record; record_layout(qw( string(16) name sint32 value )); } subtest 'is a reference' => sub { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib($libtest); $ffi->type("record(FooRecord)" => 'foo_record_t'); my $get_name = $ffi->function( foo_value_get_name => [ 'foo_record_t' ] => 'string' ); my $get_value = $ffi->function( foo_value_get_value => [ 'foo_record_t' ] => 'sint32' ); subtest 'argument' => sub { subtest 'bad' => sub { my $data = "\0" x 100; my $bad1 = bless \$data, 'FooRecordBad'; eval { $get_name->call($bad1) }; like "$@", qr/^argument 0 is not an instance of FooRecord/; eval { $get_name->call(\42) }; like "$@", qr/^argument 0 is not an instance of FooRecord/; eval { $get_name->call(42) }; like "$@", qr/^argument 0 is not an instance of FooRecord/; }; subtest 'good' => sub { my $rv = FooRecord->new( name => "hello", value => 42, ); is $get_name->call($rv), "hello"; is $get_value->call($rv), 42; }; }; subtest 'return value' => sub { plan skip_all => 'test requires working return records-by-value' unless $return_ok; subtest 'function object' => sub { my $create = $ffi->function( foo_value_create => [ 'string', 'sint32' ] => 'foo_record_t' ); my $rv = $create->call("laters", 47); is $rv->name, "laters\0\0\0\0\0\0\0\0\0\0"; is $rv->value, 47; }; subtest 'xsub_ref' => sub { my $create = $ffi->function( foo_value_create => [ 'string', 'sint32' ] => 'foo_record_t' )->sub_ref; my $rv = $create->("laters", 47); is $rv->name, "laters\0\0\0\0\0\0\0\0\0\0"; is $rv->value, 47; }; subtest 'attach' => sub { $ffi->attach( foo_value_create => [ 'string', 'sint32' ] => 'foo_record_t' ); my $rv = foo_value_create("laters", 47); is $rv->name, "laters\0\0\0\0\0\0\0\0\0\0"; is $rv->value, 47; }; }; }; done_testing; FFI-Platypus-1.10/t/type_sint16.t000644 000765 000024 00000007521 13616651126 017143 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int16" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('sint16 *' => 'sint16_p'); $ffi->type('sint16 [10]' => 'sint16_a'); $ffi->type('sint16 []' => 'sint16_a2'); $ffi->type('(sint16)->sint16' => 'sint16_c'); $ffi->attach( [sint16_add => 'add'] => ['sint16', 'sint16'] => 'sint16'); $ffi->attach( [sint16_inc => 'inc'] => ['sint16_p', 'sint16'] => 'sint16_p'); $ffi->attach( [sint16_sum => 'sum'] => ['sint16_a'] => 'sint16'); $ffi->attach( [sint16_sum2 => 'sum2'] => ['sint16_a2','size_t'] => 'sint16'); $ffi->attach( [sint16_array_inc => 'array_inc'] => ['sint16_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'sint16_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['sint16_p'] => 'int'); $ffi->attach( [sint16_static_array => 'static_array'] => [] => 'sint16_a'); $ffi->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 = $ffi->closure(sub { $_[0]-2 }); $ffi->attach( [sint16_set_closure => 'set_closure'] => ['sint16_c'] => 'void'); $ffi->attach( [sint16_call_closure => 'call_closure'] => ['sint16'] => 'sint16'); set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint16', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }); $ffi->attach( [sint16_add => 'custom_add'] => ['type1','sint16'] => 'sint16'); is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'sint16', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }); $ffi->attach( [sint16_add => 'custom_add2'] => ['sint16','sint16'] => 'type2'); is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,sint16)', 'roger_t'); my $int = -22; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'sint16', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('sint16' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_sint32.t000644 000765 000024 00000007521 13616651126 017141 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int32" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('sint32 *' => 'sint32_p'); $ffi->type('sint32 [10]' => 'sint32_a'); $ffi->type('sint32 []' => 'sint32_a2'); $ffi->type('(sint32)->sint32' => 'sint32_c'); $ffi->attach( [sint32_add => 'add'] => ['sint32', 'sint32'] => 'sint32'); $ffi->attach( [sint32_inc => 'inc'] => ['sint32_p', 'sint32'] => 'sint32_p'); $ffi->attach( [sint32_sum => 'sum'] => ['sint32_a'] => 'sint32'); $ffi->attach( [sint32_sum2 => 'sum2'] => ['sint32_a2','size_t'] => 'sint32'); $ffi->attach( [sint32_array_inc => 'array_inc'] => ['sint32_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'sint32_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['sint32_p'] => 'int'); $ffi->attach( [sint32_static_array => 'static_array'] => [] => 'sint32_a'); $ffi->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 = $ffi->closure(sub { $_[0]-2 }); $ffi->attach( [sint32_set_closure => 'set_closure'] => ['sint32_c'] => 'void'); $ffi->attach( [sint32_call_closure => 'call_closure'] => ['sint32'] => 'sint32'); set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint32', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }); $ffi->attach( [sint32_add => 'custom_add'] => ['type1','sint32'] => 'sint32'); is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'sint32', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }); $ffi->attach( [sint32_add => 'custom_add2'] => ['sint32','sint32'] => 'type2'); is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,sint32)', 'roger_t'); my $int = -22; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'sint32', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('sint32' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_sint64.t000644 000765 000024 00000007521 13616651126 017146 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_sint8.t # all instances of "int8" have been changed to "int64" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('sint64 *' => 'sint64_p'); $ffi->type('sint64 [10]' => 'sint64_a'); $ffi->type('sint64 []' => 'sint64_a2'); $ffi->type('(sint64)->sint64' => 'sint64_c'); $ffi->attach( [sint64_add => 'add'] => ['sint64', 'sint64'] => 'sint64'); $ffi->attach( [sint64_inc => 'inc'] => ['sint64_p', 'sint64'] => 'sint64_p'); $ffi->attach( [sint64_sum => 'sum'] => ['sint64_a'] => 'sint64'); $ffi->attach( [sint64_sum2 => 'sum2'] => ['sint64_a2','size_t'] => 'sint64'); $ffi->attach( [sint64_array_inc => 'array_inc'] => ['sint64_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'sint64_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['sint64_p'] => 'int'); $ffi->attach( [sint64_static_array => 'static_array'] => [] => 'sint64_a'); $ffi->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 = $ffi->closure(sub { $_[0]-2 }); $ffi->attach( [sint64_set_closure => 'set_closure'] => ['sint64_c'] => 'void'); $ffi->attach( [sint64_call_closure => 'call_closure'] => ['sint64'] => 'sint64'); set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint64', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }); $ffi->attach( [sint64_add => 'custom_add'] => ['type1','sint64'] => 'sint64'); is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'sint64', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }); $ffi->attach( [sint64_add => 'custom_add2'] => ['sint64','sint64'] => 'type2'); is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,sint64)', 'roger_t'); my $int = -22; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'sint64', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('sint64' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_sint8.t000644 000765 000024 00000007226 13616651126 017066 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('sint8 *' => 'sint8_p'); $ffi->type('sint8 [10]' => 'sint8_a'); $ffi->type('sint8 []' => 'sint8_a2'); $ffi->type('(sint8)->sint8' => 'sint8_c'); $ffi->attach( [sint8_add => 'add'] => ['sint8', 'sint8'] => 'sint8'); $ffi->attach( [sint8_inc => 'inc'] => ['sint8_p', 'sint8'] => 'sint8_p'); $ffi->attach( [sint8_sum => 'sum'] => ['sint8_a'] => 'sint8'); $ffi->attach( [sint8_sum2 => 'sum2'] => ['sint8_a2','size_t'] => 'sint8'); $ffi->attach( [sint8_array_inc => 'array_inc'] => ['sint8_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'sint8_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['sint8_p'] => 'int'); $ffi->attach( [sint8_static_array => 'static_array'] => [] => 'sint8_a'); $ffi->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 = $ffi->closure(sub { $_[0]-2 }); $ffi->attach( [sint8_set_closure => 'set_closure'] => ['sint8_c'] => 'void'); $ffi->attach( [sint8_call_closure => 'call_closure'] => ['sint8'] => 'sint8'); set_closure($closure); is call_closure(-2), -4, 'call_closure(-2) = -4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint8', perl_to_native => sub { is $_[0], -2; $_[0]*2 } }); $ffi->attach( [sint8_add => 'custom_add'] => ['type1','sint8'] => 'sint8'); is custom_add(-2,-1), -5, 'custom_add(-2,-1) = -5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'sint8', native_to_perl => sub { is $_[0], -3; $_[0]*2 } }); $ffi->attach( [sint8_add => 'custom_add2'] => ['sint8','sint8'] => 'type2'); is custom_add2(-2,-1), -6, 'custom_add2(-2,-1) = -6'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,sint8)', 'roger_t'); my $int = -22; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'sint8', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('sint8' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_string.t000644 000765 000024 00000014011 13616651126 017315 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $p = $api == 1 ? '*' : ''; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type("string(10)$p" => 'string_10'); $ffi->type("string(5)$p" => 'string_5'); $ffi->attach( 'string_matches_foobarbaz' => ['string'] => 'int'); $ffi->attach( 'string_return_foobarbaz' => [] => 'string'); $ffi->attach( [pointer_null => 'null'] => [] => 'string'); $ffi->attach( [pointer_is_null => 'is_null'] => ['string'] => 'int'); $ffi->attach( 'string_write_to_string' => ['string','string'] => 'void'); 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'; $ffi->attach( [string_set_closure => 'set_closure'] => ['(string)->void'] => 'void'); $ffi->attach( [string_call_closure => 'call_closure'] => ['string']=>'void'); my $save = 1; my $closure = $ffi->closure(sub { $save = $_[0] }); set_closure($closure); call_closure("hey there"); is $save, "hey there", "\$save = hey there"; call_closure(undef); is $save, undef, "\$save = undef"; $ffi->attach( ['string_matches_foobarbaz' => 'fixed_input_test'] => ['string_10'] => 'int'); $ffi->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)"; $ffi->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"; $ffi->attach( [pointer_null => 'fixed_output_null'] => [] => 'string_5'); is fixed_output_null(), undef, 'fixed_output_null()'; $ffi->attach( [string_set_closure => 'set_closure_fixed'] => ['(string_5)->void'] => 'void'); my $closure_fixed = $ffi->closure(sub { $save = $_[0] }); set_closure_fixed($closure_fixed); call_closure("zero one two three"); is $save, "zero ", "save=zero "; $ffi->attach( string_test_pointer_arg => [ 'string*' ] => 'string' ); { my $arg = "foo"; is( string_test_pointer_arg(\$arg), "*arg==foo"); is( $arg, "out" ); } { my $arg; is( string_test_pointer_arg(\$arg), "*arg==NULL"); is( $arg, "out" ); } is( string_test_pointer_arg(undef), "arg==NULL"); $ffi->attach( string_test_pointer_ret => [ 'string' ] => 'string*' ); $ffi->attach( [ pointer_null => 'string_test_pointer_ret_null' ] => [] => 'string*' ); is_deeply( string_test_pointer_ret("foo"), \"foo" ); is_deeply( string_test_pointer_ret(undef), \undef ); is_deeply( [string_test_pointer_ret_null()], [] ); subtest 'fixed length input' => sub { $ffi->type('string[5]' => 'string_5_undef'); my $a2 = $ffi->function(get_string_from_array => ['string_5_undef', 'int'] => 'string'); my @list = ( 'foo', 'bar', 'baz', undef, 'five', 'six' ); subtest 'with default' => sub { is $a2->(\@list, 0), 'foo', 'a2(0) = foo'; is $a2->(\@list, 1), 'bar', 'a2(0) = bar'; is $a2->(\@list, 2), 'baz', 'a2(0) = baz'; is $a2->(\@list, 3), undef, 'a2(0) = undef'; is $a2->(\@list, 4), 'five', 'a2(0) = five'; }; }; subtest 'variable length input' => sub { $ffi->type('string[]' => 'sa'); my $get_string_from_array = $ffi->function(get_string_from_array => ['sa','int'] => 'string'); my @list = ('foo', 'bar', 'baz', undef ); for(0..2) { is $get_string_from_array->(\@list, $_), $list[$_], "get_string_from_array(\@list, $_) = $list[$_]"; } is $get_string_from_array->(\@list, 3), undef, "get_string_from_array(\@list, 3) = undef"; }; subtest 'fixed length return' => sub { $ffi->type('string[3]' => 'sa3'); is( $ffi->function(pointer_null => [] => 'sa3')->call, undef, 'returns null', ); is_deeply( $ffi->function(onetwothree3 => [] => 'sa3')->call, [ qw( one two three ) ], 'returns with just strings', ); is_deeply( $ffi->function(onenullthree3 => [] => 'sa3')->call, [ 'one', undef, 'three' ], 'returns with NULL/undef in the middle', ); }; subtest 'null terminated return' => sub { is( $ffi->function(pointer_null => [] => 'sa')->call, undef, 'returns null', ); is_deeply( $ffi->function('onetwothree4', => [] => 'sa')->call, [ qw( one two three ) ], ); is_deeply( $ffi->function('onenullthree3' => [] => 'sa')->call, [ qw( one ) ], ); is_deeply( $ffi->function('ptrnull' => [] => 'sa')->call, [], ); }; subtest 'argument update' => sub { my @args = ( undef, 'six', 'xx' ); $ffi->function( string_array_arg_update => [ 'string[3]' ] => 'void' )->call(\@args); is_deeply( \@args, [ "one", "two", "xx" ], ); }; subtest 'write to string' => sub { my $src = 'hello world'; my $dst = ' ' x (length($src)+1); string_write_to_string($dst, $src); is($dst, "hello world\0"); }; }; } done_testing; FFI-Platypus-1.10/t/type_uint16.t000644 000765 000024 00000010142 13616651126 017136 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int16" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('uint16 *' => 'uint16_p'); $ffi->type('uint16 [10]' => 'uint16_a'); $ffi->type('uint16 []' => 'uint16_a2'); $ffi->type('(uint16)->uint16' => 'uint16_c'); $ffi->attach( [uint16_add => 'add'] => ['uint16', 'uint16'] => 'uint16'); $ffi->attach( [uint16_inc => 'inc'] => ['uint16_p', 'uint16'] => 'uint16_p'); $ffi->attach( [uint16_sum => 'sum'] => ['uint16_a'] => 'uint16'); $ffi->attach( [uint16_sum2 => 'sum2'] => ['uint16_a2','size_t'] => 'uint16'); $ffi->attach( [uint16_array_inc => 'array_inc'] => ['uint16_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'uint16_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['uint16_p'] => 'int'); $ffi->attach( [uint16_static_array => 'static_array'] => [] => 'uint16_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2 }); $ffi->attach( [uint16_set_closure => 'set_closure'] => ['uint16_c'] => 'void'); $ffi->attach( [uint16_call_closure => 'call_closure'] => ['uint16'] => 'uint16'); set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint16', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint16_add => 'custom_add'] => ['type1','uint16'] => 'uint16'); is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'uint16', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint16_add => 'custom_add2'] => ['uint16','uint16'] => 'type2'); is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { $ffi->custom_type(type3 => { native_type => 'uint16', perl_to_native_post => sub { is $_[0], 1 } }); $ffi->attach( [uint16_add => 'custom_add3'] => ['type3','uint16'] => 'uint16'); is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,uint16)', 'roger_t'); my $int = 211; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'uint16', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('uint16' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_uint32.t000644 000765 000024 00000010142 13616651126 017134 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int32" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('uint32 *' => 'uint32_p'); $ffi->type('uint32 [10]' => 'uint32_a'); $ffi->type('uint32 []' => 'uint32_a2'); $ffi->type('(uint32)->uint32' => 'uint32_c'); $ffi->attach( [uint32_add => 'add'] => ['uint32', 'uint32'] => 'uint32'); $ffi->attach( [uint32_inc => 'inc'] => ['uint32_p', 'uint32'] => 'uint32_p'); $ffi->attach( [uint32_sum => 'sum'] => ['uint32_a'] => 'uint32'); $ffi->attach( [uint32_sum2 => 'sum2'] => ['uint32_a2','size_t'] => 'uint32'); $ffi->attach( [uint32_array_inc => 'array_inc'] => ['uint32_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'uint32_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['uint32_p'] => 'int'); $ffi->attach( [uint32_static_array => 'static_array'] => [] => 'uint32_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2 }); $ffi->attach( [uint32_set_closure => 'set_closure'] => ['uint32_c'] => 'void'); $ffi->attach( [uint32_call_closure => 'call_closure'] => ['uint32'] => 'uint32'); set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint32', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint32_add => 'custom_add'] => ['type1','uint32'] => 'uint32'); is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'uint32', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint32_add => 'custom_add2'] => ['uint32','uint32'] => 'type2'); is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { $ffi->custom_type(type3 => { native_type => 'uint32', perl_to_native_post => sub { is $_[0], 1 } }); $ffi->attach( [uint32_add => 'custom_add3'] => ['type3','uint32'] => 'uint32'); is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,uint32)', 'roger_t'); my $int = 211; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'uint32', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('uint32' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_uint64.t000644 000765 000024 00000010142 13616651126 017141 0ustar00ollisgstaff000000 000000 # # DO NOT MODIFY THIS FILE. # This file generated from similar file t/type_uint8.t # all instances of "int8" have been changed to "int64" # use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('uint64 *' => 'uint64_p'); $ffi->type('uint64 [10]' => 'uint64_a'); $ffi->type('uint64 []' => 'uint64_a2'); $ffi->type('(uint64)->uint64' => 'uint64_c'); $ffi->attach( [uint64_add => 'add'] => ['uint64', 'uint64'] => 'uint64'); $ffi->attach( [uint64_inc => 'inc'] => ['uint64_p', 'uint64'] => 'uint64_p'); $ffi->attach( [uint64_sum => 'sum'] => ['uint64_a'] => 'uint64'); $ffi->attach( [uint64_sum2 => 'sum2'] => ['uint64_a2','size_t'] => 'uint64'); $ffi->attach( [uint64_array_inc => 'array_inc'] => ['uint64_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'uint64_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['uint64_p'] => 'int'); $ffi->attach( [uint64_static_array => 'static_array'] => [] => 'uint64_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2 }); $ffi->attach( [uint64_set_closure => 'set_closure'] => ['uint64_c'] => 'void'); $ffi->attach( [uint64_call_closure => 'call_closure'] => ['uint64'] => 'uint64'); set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint64', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint64_add => 'custom_add'] => ['type1','uint64'] => 'uint64'); is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'uint64', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint64_add => 'custom_add2'] => ['uint64','uint64'] => 'type2'); is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { $ffi->custom_type(type3 => { native_type => 'uint64', perl_to_native_post => sub { is $_[0], 1 } }); $ffi->attach( [uint64_add => 'custom_add3'] => ['type3','uint64'] => 'uint64'); is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,uint64)', 'roger_t'); my $int = 211; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'uint64', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('uint64' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/type_uint8.t000644 000765 000024 00000007643 13616651126 017073 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use FFI::Platypus; use FFI::CheckLib; foreach my $api (0, 1) { subtest "api = $api" => sub { local $SIG{__WARN__} = sub { my $message = shift; return if $message =~ /^Subroutine main::.* redefined/; warn $message; }; my $ffi = FFI::Platypus->new( api => $api ); $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); $ffi->type('uint8 *' => 'uint8_p'); $ffi->type('uint8 [10]' => 'uint8_a'); $ffi->type('uint8 []' => 'uint8_a2'); $ffi->type('(uint8)->uint8' => 'uint8_c'); $ffi->attach( [uint8_add => 'add'] => ['uint8', 'uint8'] => 'uint8'); $ffi->attach( [uint8_inc => 'inc'] => ['uint8_p', 'uint8'] => 'uint8_p'); $ffi->attach( [uint8_sum => 'sum'] => ['uint8_a'] => 'uint8'); $ffi->attach( [uint8_sum2 => 'sum2'] => ['uint8_a2','size_t'] => 'uint8'); $ffi->attach( [uint8_array_inc => 'array_inc'] => ['uint8_a'] => 'void'); $ffi->attach( [pointer_null => 'null'] => [] => 'uint8_p'); $ffi->attach( [pointer_is_null => 'is_null'] => ['uint8_p'] => 'int'); $ffi->attach( [uint8_static_array => 'static_array'] => [] => 'uint8_a'); $ffi->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 = $ffi->closure(sub { $_[0]+2 }); $ffi->attach( [uint8_set_closure => 'set_closure'] => ['uint8_c'] => 'void'); $ffi->attach( [uint8_call_closure => 'call_closure'] => ['uint8'] => 'uint8'); set_closure($closure); is call_closure(2), 4, 'call_closure(2) = 4'; $closure = $ffi->closure(sub { undef }); set_closure($closure); is do { no warnings; call_closure(2) }, 0, 'call_closure(2) = 0'; subtest 'custom type input' => sub { $ffi->custom_type(type1 => { native_type => 'uint8', perl_to_native => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint8_add => 'custom_add'] => ['type1','uint8'] => 'uint8'); is custom_add(2,1), 5, 'custom_add(2,1) = 5'; }; subtest 'custom type output' => sub { $ffi->custom_type(type2 => { native_type => 'uint8', native_to_perl => sub { is $_[0], 2; $_[0]*2 } }); $ffi->attach( [uint8_add => 'custom_add2'] => ['uint8','uint8'] => 'type2'); is custom_add2(1,1), 4, 'custom_add2(1,1) = 4'; }; subtest 'custom type post' => sub { $ffi->custom_type(type3 => { native_type => 'uint8', perl_to_native_post => sub { is $_[0], 1 } }); $ffi->attach( [uint8_add => 'custom_add3'] => ['type3','uint8'] => 'uint8'); is custom_add3(1,2), 3, 'custom_add3(1,2) = 3'; }; $ffi->attach( [pointer_is_null => 'closure_pointer_is_null'] => ['()->void'] => 'int'); is closure_pointer_is_null(), 1, 'closure_pointer_is_null() = 1'; }; } subtest 'object' => sub { { package Roger } my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Roger,uint8)', 'roger_t'); my $int = 211; subtest 'argument' => sub { is $ffi->cast('roger_t' => 'uint8', bless(\$int, 'Roger')), $int; }; subtest 'return value' => sub { my $obj1 = $ffi->cast('uint8' => 'roger_t', $int); isa_ok $obj1, 'Roger'; is $$obj1, $int; }; }; done_testing; FFI-Platypus-1.10/t/lib/Test/000755 000765 000024 00000000000 13616651126 016251 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/t/lib/Test/Cleanup.pm000644 000765 000024 00000000420 13616651126 020172 0ustar00ollisgstaff000000 000000 package Test::Cleanup; use strict; use warnings; use base qw( Exporter ); use File::Path qw( rmtree ); our @EXPORT = qw( cleanup ); my @cleanup; sub cleanup { push @cleanup, @_; } END { foreach my $dir (@cleanup) { rmtree($dir, { verbose => 0 }); } } 1; FFI-Platypus-1.10/t/lib/Test/FauxAttach.pm000644 000765 000024 00000002156 13616651126 020643 0ustar00ollisgstaff000000 000000 package Test::FauxAttach; use strict; use warnings; use Test::More; my @funcs; # This plugin implements an alternative to attach/sub_ref # without the process level-leak which makes it easier to # find real leaks. It relies on no attached sub being called # in END, etc. blocks, which we cannot normally rely on. # it's also probably a lot slower than a real xsub. sub import { die "load Test::FauxAttach before FFI::Platypus::Function" if $INC{'FFI/Platypus/Function.pm'}; require FFI::Platypus::Function; no warnings 'redefine'; *FFI::Platypus::Function::Function::_sub_ref = sub { my($self, $location) = @_; push @funcs, $self; my $i = $#funcs; sub { $funcs[$i]->call(@_) }; }; *FFI::Platypus::Function::Function::_attach = sub { my($self, $perl_name, $location, $proto) = @_; note " attaching: $perl_name"; my $xsub = $self->_sub_ref($location); FFI::Platypus::Function::Wrapper::_set_prototype($proto, $xsub) if defined $proto; no strict 'refs'; *{"$perl_name"} = $xsub; }; } END { note "deleting @{[ scalar @funcs ]} attached functions"; @funcs = (); } 1; FFI-Platypus-1.10/t/lib/Test/Platypus.pm000644 000765 000024 00000000607 13616651126 020433 0ustar00ollisgstaff000000 000000 package Test::Platypus; use strict; use warnings; use Test::More (); use base qw( Exporter ); our @EXPORT = qw( platypus ); sub platypus { my($count, $code) = @_; my $ffi = eval { require FFI::Platypus; FFI::Platypus->VERSION(0.51); FFI::Platypus->new; }; SKIP: { Test::More::skip "Test requires FFI::Platypus", $count unless $ffi; $code->($ffi); } } 1; FFI-Platypus-1.10/t/ffi/align.c000644 000765 000024 00000002565 13616651126 016576 0ustar00ollisgstaff000000 000000 #include "libtest.h" typedef struct _my_struct { char x1; uint64_t my_uint64; char x2; uint32_t my_uint32; char x3; uint16_t my_uint16; char x4; uint8_t my_uint8; char x5; int64_t my_sint64; char x6; int32_t my_sint32; char x7; int16_t my_sint16; char x8; int8_t my_sint8; char x9; float my_float; char x10; double my_double; char x11; void *my_opaque; } my_struct; EXTERN uint64_t align_get_uint64(my_struct *my_struct) { return my_struct->my_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; } FFI-Platypus-1.10/t/ffi/align_array.c000644 000765 000024 00000002755 13616651126 017775 0ustar00ollisgstaff000000 000000 #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; } FFI-Platypus-1.10/t/ffi/align_fixed.c000644 000765 000024 00000000262 13616651126 017745 0ustar00ollisgstaff000000 000000 #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-1.10/t/ffi/align_string.c000644 000765 000024 00000000610 13616651126 020151 0ustar00ollisgstaff000000 000000 #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-1.10/t/ffi/basic.c000644 000765 000024 00000000410 13616651126 016550 0ustar00ollisgstaff000000 000000 #include "libtest.h" EXTERN uint8_t f0(uint8_t input) { return input; } EXTERN int my_atoi(const char *string) { return atoi(string); } EXTERN void f1(void) { } EXTERN void f2(int *i) { *i = *i+1; } EXTERN int mystrangeprefix_bar(void) { return 42; } FFI-Platypus-1.10/t/ffi/closure.c000644 000765 000024 00000001730 13616651126 017151 0ustar00ollisgstaff000000 000000 #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); } EXTERN int closure_call_closure_immediate(closure2_t closure, int arg) { return closure(arg); } typedef struct { const char *one; const char *two; int three; const char *four; int myarray1[2]; void *opaque1; void *myarray2[2]; char fixedfive[5]; } cx_struct_t; typedef void (*cx_closure_t)(cx_struct_t *, int); static cx_closure_t my_cx_closure; EXTERN void cx_closure_set(cx_closure_t closure) { my_cx_closure = closure; } EXTERN void cx_closure_call(cx_struct_t *s, int i) { my_cx_closure(s, i); } FFI-Platypus-1.10/t/ffi/color.c000644 000765 000024 00000001471 13616651126 016615 0ustar00ollisgstaff000000 000000 #include "libtest.h" typedef struct _color { uint8_t red, green, blue; } color; EXTERN color * color_new(int red, int green, int blue) { static color _self; color *self = &_self; self->red = 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); } FFI-Platypus-1.10/t/ffi/complex_double.c000644 000765 000024 00000002351 13616651126 020476 0ustar00ollisgstaff000000 000000 #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; } EXTERN double complex_double_ptr_get_real(double complex *f) { return crealf(*f); } EXTERN double complex_double_ptr_get_imag(double complex *f) { return cimagf(*f); } EXTERN void complex_double_ptr_set(double complex *f, double r, double i) { *f = r + i*I; } EXTERN double complex complex_double_ret(double r, double i) { return r + i*I; } EXTERN double complex * complex_double_ptr_ret(double r, double i) { static double complex f; f = r + i*I; return &f; } EXTERN double complex complex_double_array_get(double complex *f, int index) { return f[index]; } EXTERN void complex_double_array_set(double complex *f, int index, double r, double i) { f[index] = r + i*I; } EXTERN double complex * complex_double_array_ret(void) { static double complex ret[3]; ret[0] = 0.0 + 0.0*I; ret[1] = 1.0 + 2.0*I; ret[2] = 3.0 + 4.0*I; return ret; } #endif FFI-Platypus-1.10/t/ffi/complex_float.c000644 000765 000024 00000002307 13616651126 020332 0ustar00ollisgstaff000000 000000 #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; } EXTERN float complex_float_ptr_get_real(float complex *f) { return crealf(*f); } EXTERN float complex_float_ptr_get_imag(float complex *f) { return cimagf(*f); } EXTERN void complex_float_ptr_set(float complex *f, float r, float i) { *f = r + i*I; } EXTERN float complex complex_float_ret(float r, float i) { return r + i*I; } EXTERN float complex * complex_float_ptr_ret(float r, float i) { static float complex f; f = r + i*I; return &f; } EXTERN float complex complex_float_array_get(float complex *f, int index) { return f[index]; } EXTERN void complex_float_array_set(float complex *f, int index, float r, float i) { f[index] = r + i*I; } EXTERN float complex * complex_float_array_ret(void) { static float complex ret[3]; ret[0] = 0.0 + 0.0*I; ret[1] = 1.0 + 2.0*I; ret[2] = 3.0 + 4.0*I; return ret; } #endif FFI-Platypus-1.10/t/ffi/double.c000644 000765 000024 00000002156 13616651126 016752 0ustar00ollisgstaff000000 000000 /* * DO NOT MODIFY THIS FILE. * This file generated from similar file t/ffi/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; ifoo = foo; self->bar = malloc(strlen(bar)+1); strcpy(self->bar, bar); return self; } EXTERN void mymeta_delete(struct mymeta_t *self) { free(self->bar); free(self); } EXTERN const char * mymeta_test(struct mymeta_t *self, int count, const char *baz) { static char buffer[1024]; sprintf(buffer, "foo = %d, bar = %s, baz = %s, count = %d", self->foo, self->bar != NULL ? self->bar : "undef", baz != NULL ? baz : "undef", count ); return buffer; } FFI-Platypus-1.10/t/ffi/pointer.c000644 000765 000024 00000003451 13616651126 017157 0ustar00ollisgstaff000000 000000 #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_out_null_terminated(void) { static char *array[4] = { "seven", "eight", "nine", NULL }; 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); } FFI-Platypus-1.10/t/ffi/record.c000644 000765 000024 00000001730 13616651126 016753 0ustar00ollisgstaff000000 000000 #include #include "libtest.h" typedef struct { char name[16]; int32_t value; } foo_record_t; EXTERN const char * foo_get_name(foo_record_t *self) { if(self == NULL) return NULL; return self->name; } EXTERN const char * foo_value_get_name(foo_record_t self) { static char name[16]; strcpy(name, self.name); return name; } EXTERN int32_t foo_get_value(foo_record_t *self) { if(self == NULL) return 0; return self->value; } EXTERN int32_t foo_value_get_value(foo_record_t self) { return self.value; } EXTERN foo_record_t * foo_create(const char *name, int32_t value) { static foo_record_t self; int i; for(i=0; i<16; i++) self.name[i] = '\0'; strcpy(self.name, name); self.value = value; return &self; } EXTERN foo_record_t foo_value_create(const char *name, int32_t value) { foo_record_t self; int i; for(i=0; i<16; i++) self.name[i] = '\0'; strcpy(self.name, name); self.value = value; return self; } FFI-Platypus-1.10/t/ffi/sint16.c000644 000765 000024 00000002144 13616651126 016621 0ustar00ollisgstaff000000 000000 /* * DO NOT MODIFY THIS FILE. * This file generated from similar file t/ffi/sint8.c * all instances of "int8" have been changed to "int16" */ #include "libtest.h" EXTERN int16_t sint16_add(int16_t a, int16_t b) { return a + b; } EXTERN int16_t* sint16_inc(int16_t *a, int16_t b) { static int16_t keeper; keeper = *a += b; return &keeper; } EXTERN int16_t sint16_sum(int16_t list[10]) { int i; int16_t total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN int16_t sint16_sum2(int16_t *list, size_t size) { int i; int16_t total; for(i=0,total=0; i EXTERN const char * get_string_from_array(const char **array, int index) { static char buffer[512]; if(array[index] == NULL) return NULL; strcpy(buffer, array[index]); return buffer; } EXTERN const char ** onetwothree3() { static char *buffer[4] = { "one", "two", "three" }; return (const char **) buffer; } EXTERN const char ** onetwothree4() { static char *buffer[4] = { "one", "two", "three", NULL }; return (const char **) buffer; } EXTERN const char ** onenullthree3() { static char *buffer[3] = { "one", NULL, "three" }; return (const char **) buffer; } EXTERN const char ** ptrnull() { static char *buffer[1] = { NULL }; return (const char **) buffer; } EXTERN void string_array_arg_update(char **arg) { arg[0] = "one"; arg[1] = "two"; } FFI-Platypus-1.10/t/ffi/uint16.c000644 000765 000024 00000002170 13616651126 016622 0ustar00ollisgstaff000000 000000 /* * DO NOT MODIFY THIS FILE. * This file generated from similar file t/ffi/uint8.c * all instances of "int8" have been changed to "int16" */ #include "libtest.h" EXTERN uint16_t uint16_add(uint16_t a, uint16_t b) { return a + b; } EXTERN uint16_t* uint16_inc(uint16_t *a, uint16_t b) { static uint16_t keeper; keeper = *a += b; return &keeper; } EXTERN uint16_t uint16_sum(uint16_t list[10]) { int i; uint16_t total; for(i=0,total=0; i<10; i++) { total += list[i]; } return total; } EXTERN uint16_t uint16_sum2(uint16_t *list, size_t size) { int i; uint16_t total; for(i=0,total=0; i #ifdef FFI_PL_PROBE_VARIADIC #include #include #include "libtest.h" EXTERN int variadic_return_arg(int which, ...) { va_list ap; int i, val; va_start(ap, which); for(i=0; i 5.010) { $skip = "ZMQ::FFI requires Perl 5.10" if $module eq 'ZMQ::FFI'; } if($skip) { print $skip, "\n"; exit; } my $build_root = bsd_glob( "~/test-build-root-tmp"); mkdir $build_root unless -d $build_root; my $lib = FFI::Temp->newdir; 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 } FFI-Platypus-1.10/maint/cip-test-examples000755 000765 000024 00000001502 13616651126 020721 0ustar00ollisgstaff000000 000000 #!/usr/bin/env perl # i've disabled this for now as it is a little broken. use 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::TinyCC::Inline', '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 $?; } }; FFI-Platypus-1.10/maint/generate-abw000755 000765 000024 00000000477 13616651126 017730 0ustar00ollisgstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use Alien::Base::Wrapper 1.49; use File::Path qw( mkpath ); use File::Copy qw( copy ); mkpath 'inc/Alien/Base', 0, 0755; my $from = $INC{'Alien/Base/Wrapper.pm'}; my $to = 'inc/Alien/Base/Wrapper.pm'; print "+cp $from $to\n"; copy $from, $to or die "copy failed: $!"; FFI-Platypus-1.10/maint/generate-readme000755 000765 000024 00000000757 13616651126 020415 0ustar00ollisgstaff000000 000000 #!/usr/bin/env perl use 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; } FFI-Platypus-1.10/maint/generate-record-accessor000755 000765 000024 00000001271 13616651126 022226 0ustar00ollisgstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use autodie; use Template; my $tt2 = Template->new( INCLUDE_PATH => 'maint/tt', ); 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; FFI-Platypus-1.10/maint/run-after_build.pl000644 000765 000024 00000000477 13616651126 021060 0ustar00ollisgstaff000000 000000 use strict; use warnings; use autodie qw( :all ); my $content; open my $in, '<', 'Makefile.PL'; while(<$in>) { s/^(# This file was automatically generated by Dist::Zilla::Plugin::Author::Plicease::MakeMaker).*$/$1/; $content .= $_; } close $in; open my $out, '>', 'Makefile.PL'; print $out $content; close $out; FFI-Platypus-1.10/maint/run-before_build.pl000644 000765 000024 00000005612 13616651126 021215 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 'inc'; use My::Config; use File::Spec; if(@ARGV > 0) { if(-e 'Makefile') { if($^O eq 'MSWin32') { print "> gmake realclean\n"; system 'gmake', 'realclean'; } else { print "% make realclean\n"; system 'make', 'realclean'; } } My::Config->new->clean; } foreach my $bits (qw( 16 32 64 )) { foreach my $orig (qw( t/ffi/uint8.c t/ffi/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.", " * This file 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.", "# This file 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( t/ffi/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.", " * This file generated from similar file $orig", " * all instances of \"float\" have been changed to \"$type\"", " */", ""; } else { print $out join "\n", "#", "# DO NOT MODIFY THIS FILE.", "# This file 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; } } { my @list = sort map { chomp; s/\.pm$//; s/^lib\///; s/\//::/g; $_ } `find lib -name \*.pm`; open my $fh, '>', 't/01_use.t'; print $fh <<'EOM'; use strict; use warnings; use Test::More; EOM foreach my $module (@list) { print $fh "require_ok '$module';\n"; } foreach my $module (@list) { my $test = lc $module; $test =~ s/::/_/g; $test = "t/$test.t"; printf $fh "ok -f %-55s %s\n", "'$test',", "'test for $module';"; } print $fh <<'EOM'; done_testing; EOM close $fh; } FFI-Platypus-1.10/maint/tt/000755 000765 000024 00000000000 13616651126 016060 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/maint/tt/accessor.tt000644 000765 000024 00000004532 13616651126 020237 0ustar00ollisgstaff000000 000000 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) { if(SvREADONLY(self)) { croak("record is read-only"); } else { *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 > 1 && SvREADONLY(self)) { croak("record is read-only"); } 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); } FFI-Platypus-1.10/maint/tt/accessor_wrapper.tt000644 000765 000024 00000000476 13616651126 022002 0ustar00ollisgstaff000000 000000 /* 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-1.10/lib/FFI/000755 000765 000024 00000000000 13616651126 015473 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Build/000755 000765 000024 00000000000 13616651126 016532 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Build.pm000644 000765 000024 00000032412 13616651126 017072 0ustar00ollisgstaff000000 000000 package FFI::Build; use strict; use warnings; use 5.008001; use FFI::Build::File::Library; use Carp (); use File::Glob (); use File::Basename (); use List::Util 1.45 (); use Capture::Tiny (); use File::Path (); # ABSTRACT: Build shared libraries for use with FFI our $VERSION = '1.10'; # VERSION sub _native_name { my($self, $name) = @_; join '', $self->platform->library_prefix, $name, scalar $self->platform->library_suffix; } sub new { my($class, $name, %args) = @_; Carp::croak "name is required" unless defined $name; my $self = bless { source => [], cflags_I => [], cflags => [], libs_L => [], libs => [], alien => [], }, $class; my $platform = $self->{platform} = $args{platform} || FFI::Build::Platform->default; my $file = $self->{file} = $args{file} || FFI::Build::File::Library->new([$args{dir} || '.', $self->_native_name($name)], platform => $self->platform); my $buildname = $self->{buildname} = $args{buildname} || '_build'; my $verbose = $self->{verbose} = $args{verbose} || 0; my $export = $self->{export} = $args{export} || []; if(defined $args{cflags}) { my @flags = ref $args{cflags} ? @{ $args{cflags} } : $self->platform->shellwords($args{cflags}); push @{ $self->{cflags} }, grep !/^-I/, @flags; push @{ $self->{cflags_I} }, grep /^-I/, @flags; } if(defined $args{libs}) { my @flags = ref $args{libs} ? @{ $args{libs} } : $self->platform->shellwords($args{libs}); push @{ $self->{libs} }, grep !/^-L/, @flags; push @{ $self->{libs_L} }, grep /^-L/, @flags; } if(defined $args{alien}) { my @aliens = ref $args{alien} ? @{ $args{alien} } : ($args{alien}); foreach my $alien (@aliens) { unless(eval { $alien->can('cflags') && $alien->can('libs') }) { my $pm = "$alien.pm"; $pm =~ s/::/\//g; require $pm; } push @{ $self->{alien} }, $alien; push @{ $self->{cflags} }, grep !/^-I/, $self->platform->shellwords($alien->cflags); push @{ $self->{cflags_I} }, grep /^-I/, $self->platform->shellwords($alien->cflags); push @{ $self->{libs} }, grep !/^-L/, $self->platform->shellwords($alien->libs); push @{ $self->{libs_L} }, grep /^-L/, $self->platform->shellwords($alien->libs); } } $self->source(ref $args{source} ? @{ $args{source} } : ($args{source})) if $args{source}; $self; } sub buildname { shift->{buildname} } sub export { shift->{export} } sub file { shift->{file} } sub platform { shift->{platform} } sub verbose { shift->{verbose} } sub cflags { shift->{cflags} } sub cflags_I { shift->{cflags_I} } sub libs { shift->{libs} } sub libs_L { shift->{libs_L} } sub alien { shift->{alien} } my @file_classes; sub _file_classes { unless(@file_classes) { if(defined $FFI::Build::VERSION) { foreach my $inc (@INC) { push @file_classes, map { my $f = $_; $f =~ s/\.pm$//; "FFI::Build::File::$f" } grep !/^Base\.pm$/, map { File::Basename::basename($_) } File::Glob::bsd_glob( File::Spec->catfile($inc, 'FFI', 'Build', 'File', '*.pm') ); } } else { # When building out of git without dzil, $VERSION will not # usually be defined and any file plugins that require a # specific version will break, so we only use core file # classes for that. push @file_classes, map { "FFI::Build::File::$_" } qw( C CXX Library Object ); } # also anything already loaded, that might not be in the # @INC path (for testing ususally) push @file_classes, map { my $f = $_; $f =~ s/::$//; "FFI::Build::File::$f" } grep !/Base::/, grep /::$/, keys %{FFI::Build::File::}; @file_classes = List::Util::uniq(@file_classes); foreach my $class (@file_classes) { next if(eval { $class->can('new') }); my $pm = $class . ".pm"; $pm =~ s/::/\//g; require $pm; } } @file_classes; } sub source { my($self, @file_spec) = @_; foreach my $file_spec (@file_spec) { if(eval { $file_spec->isa('FFI::Build::File::Base') }) { push @{ $self->{source} }, $file_spec; next; } if(ref $file_spec eq 'ARRAY') { my($type, $content, @args) = @$file_spec; my $class = "FFI::Build::File::$type"; unless($class->can('new')) { my $pm = "FFI/Build/File/$type.pm"; require $pm; } push @{ $self->{source} }, $class->new( $content, build => $self, platform => $self->platform, @args ); next; } my @paths = File::Glob::bsd_glob($file_spec); path: foreach my $path (@paths) { foreach my $class (_file_classes) { foreach my $regex ($class->accept_suffix) { if($path =~ $regex) { push @{ $self->{source} }, $class->new($path, platform => $self->platform, build => $self); next path; } } } Carp::croak("Unknown file type: $path"); } } @{ $self->{source} }; } sub build { my($self) = @_; my @objects; my $ld = $self->platform->ld; foreach my $source ($self->source) { if($source->can('build_all')) { my $count = scalar $self->source; if($count == 1) { return $source->build_all($self->file); } else { die "@{[ ref $source ]} has build_all method, but there is not exactly one source"; } } $ld = $source->ld if $source->ld; my $output; while(my $next = $source->build_item) { $ld = $next->ld if $next->ld; $output = $source = $next; } push @objects, $output; } my $needs_rebuild = sub { my(@objects) = @_; return 1 unless -f $self->file->path; my $target_time = [stat $self->file->path]->[9]; foreach my $object (@objects) { my $object_time = [stat "$object"]->[9]; return 1 if $object_time > $target_time; } return 0; }; return $self->file unless $needs_rebuild->(@objects); File::Path::mkpath($self->file->dirname, 0, oct(755)); my @cmd = ( $ld, $self->libs_L, $self->platform->ldflags, (map { "$_" } @objects), $self->libs, $self->platform->flag_export(@{ $self->export }), $self->platform->flag_library_output($self->file->path), ); my($out, $exit) = Capture::Tiny::capture_merged(sub { $self->platform->run(@cmd); }); if($exit || !-f $self->file->path) { print $out; die "error building @{[ $self->file->path ]} from @objects"; } elsif($self->verbose >= 2) { print $out; } elsif($self->verbose >= 1) { print "LD @{[ $self->file->path ]}\n"; } $self->file; } sub clean { my($self) = @_; my $dll = $self->file->path; unlink $dll if -f $dll; foreach my $source ($self->source) { my $dir = File::Spec->catdir($source->dirname, $self->buildname); if(-d $dir) { unlink $_ for File::Glob::bsd_glob("$dir/*"); rmdir $dir; } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build - Build shared libraries for use with FFI =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Platypus; use FFI::Build; my $build = FFI::Build->new( 'frooble', source => 'ffi/*.c', ); # $lib is an instance of FFI::Build::File::Library my $lib = $build->build; my $ffi = FFI::Platypus->new( api => 1 ); # The filename will be platform dependant, but something like libfrooble.so or frooble.dll $ffi->lib($lib->path); ... # use $ffi to attach functions in ffi/*.c =head1 DESCRIPTION Using libffi based L is a great alternative to XS for writing library bindings for Perl. Sometimes, however, you need to bundle a little C code with your FFI module, but this has never been that easy to use. L was an early attempt to address this use case, but it uses the now out of fashion L. This module itself doesn't directly integrate with CPAN installers like L or L, but there is a light weight layer L that will allow you to easily use this module with L. If you are using L as your dist builder, then there is also L, which will help with the connections. There is some functional overlap with L, which was in fact used by L. For this iteration I have decided not to use that module because although it will generate dynamic libraries that can sometimes be used by L, it is really designed for building XS modules, and trying to coerce it into a more general solution has proved difficult in the past. Supported languages out of the box are C, C++ and Fortran. Rust is supported via a language plugin, see L. =head1 CONSTRUCTOR =head2 new my $build = FFI::Build->new($name, %options); Create an instance of this class. The C<$name> argument is used when computing the file name for the library. The actual name will be something like C or C<$name.dll>. The following options are supported: =over 4 =item alien List of Aliens to compile/link against. L will work with any L based alien, or modules that provide a compatible API. =item buildname Directory name that will be used for building intermediate files, such as object files. This is C<_build> by default. =item cflags Extra compiler flags to use. Things like C<-I/foo/include> or C<-DFOO=1>. =item dir The directory where the library will be written. This is C<.> by default. =item export Functions that should be exported (Windows + Visual C++ only) =item file An instance of L to which the library will be written. Normally not needed. =item libs Extra library flags to use. Things like C<-L/foo/lib -lfoo>. =item platform An instance of L. Usually you want to omit this and use the default instance. =item source List of source files. You can use wildcards supported by C from L. =item verbose By default this class does not print out the actual compiler and linker commands used in building the library unless there is a failure. You can alter this behavior with this option. Set to one of these values: =over 4 =item zero (0) Default, quiet unless there is a failure. =item one (1) Output the operation (compile, link, etc) and the file, but nothing else =item two (2) Output the complete commands run verbatim. =back =back =head1 METHODS =head2 dir my $dir = $build->dir; Returns the directory where the library will be written. =head2 buildname my $builddir = $build->builddir; Returns the build name. This is used in computing a directory to save intermediate files like objects. For example, if you specify a file like C, then the object file will be stored in C by default. C<_build> in this example (the default) is the build name. =head2 export my $exports = $build->export; Returns a array reference of the exported functions (Windows + Visual C++ only) =head2 file my $file = $build->file; Returns an instance of L corresponding to the library being built. This is also returned by the C method below. =head2 platform my $platform = $build->platform; An instance of L, which contains information about the platform on which you are building. The default is usually reasonable. =head2 verbose my $verbose = $build->verbose; Returns the verbose flag. =head2 cflags my @cflags = @{ $build->cflags }; Returns the compiler flags. =head2 cflags_I my @cflags_I = @{ $build->cflags_I }; Returns the C<-I> cflags. =head2 libs my @libs = @{ $build->libs }; Returns the library flags. =head2 libs_L my @libs = @{ $build->libs }; Returns the C<-L> library flags. =head2 alien my @aliens = @{ $build->alien }; Returns a the list of aliens being used. =head2 source $build->source(@files); Add the C<@files> to the list of source files that will be used in building the library. The format is the same as with the C attribute above. =head2 build my $lib = $build->build; This compiles the source files and links the library. Files that have already been compiled or linked may be reused without recompiling/linking if the timestamps are newer than the source files. An instance of L is returned which can be used to get the path to the library, which can be feed into L or similar. =head2 clean $build->clean; Removes the library and intermediate files. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/000755 000765 000024 00000000000 13616651126 017314 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Platypus.pm000644 000765 000024 00000210157 13616651126 017660 0ustar00ollisgstaff000000 000000 package FFI::Platypus; use strict; use warnings; use 5.008001; use Carp qw( croak ); use FFI::Platypus::Function; use FFI::Platypus::Type; # ABSTRACT: Write Perl bindings to non-Perl libraries with FFI. No XS required. our $VERSION = '1.10'; # 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 FFI::Platypus::Record ); require XSLoader; XSLoader::load( 'FFI::Platypus', $FFI::Platypus::VERSION || 0 ); sub new { my($class, %args) = @_; my @lib; if(exists $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"; } } my $api = $args{api} || 0; my $experimental = $args{experimental} || 0; if($experimental == 1) { Carp::croak("Please do not use the experimental version of api = 1, instead require FFI::Platypus 1.00 or better"); } if(defined $api && $api > 1 && $experimental != $api) { Carp::cluck("Enabling development API version $api prior to FFI::Platypus $api.00"); } my $tp; if($api == 0) { $tp = 'Version0'; } elsif($api == 1) { $tp = 'Version1'; } else { Carp::croak("API version $api not (yet) implemented"); } require "FFI/Platypus/TypeParser/$tp.pm"; $tp = "FFI::Platypus::TypeParser::$tp"; my $self = bless { lib => \@lib, lang => '', handles => {}, abi => -1, api => $api, tp => $tp->new, fini => [], ignore_not_found => defined $args{ignore_not_found} ? $args{ignore_not_found} : 0, }, $class; $self->lang($args{lang} || 'C'); $self; } sub _lang_class ($) { my($lang) = @_; my $class = $lang =~ m/^=(.*)$/ ? $1 : "FFI::Platypus::Lang::$lang"; unless($class->can('native_type_map')) { my $pm = "$class.pm"; $pm =~ s/::/\//g; require $pm; } croak "$class does not provide native_type_map method" unless $class->can("native_type_map"); $class; } sub lib { my($self, @new) = @_; if(@new) { push @{ $self->{lib} }, map { ref $_ eq 'CODE' ? $_->() : $_ } @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 && $value ne $self->{lang}) { $self->{lang} = $value; my $class = _lang_class($self->{lang}); $self->abi($class->abi) if $class->can('abi'); { my %type_map; my $map = $class->native_type_map( $self->{api} > 0 ? (api => $self->{api}) : () ); foreach my $key (keys %$map) { my $value = $map->{$key}; next unless $self->{tp}->have_type($value); $type_map{$key} = $value; } $type_map{$_} = $_ for grep { $self->{tp}->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' if $self->{tp}->isa('FFI::Platypus::TypeParser::Version0'); $self->{tp}->type_map(\%type_map); } } $self->{lang}; } sub type { my($self, $name, $alias) = @_; croak "usage: \$ffi->type(name => alias) (alias is optional)" unless defined $self && defined $name; $self->{tp}->check_alias($alias) if defined $alias; my $type = $self->{tp}->parse($name); $self->{tp}->set_alias($alias, $type) if defined $alias; $self; } sub custom_type { my($self, $alias, $cb) = @_; my $argument_count = $cb->{argument_count} || 1; croak "argument_count must be >= 1" unless $argument_count >= 1; croak "Usage: \$ffi->custom_type(\$alias, { ... })" unless defined $alias && 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}; $self->{tp}->check_alias($alias); my $type = $self->{tp}->create_type_custom( $cb->{native_type}, $cb->{perl_to_native}, $cb->{native_to_perl}, $cb->{perl_to_native_post}, $argument_count, ); $self->{tp}->set_alias($alias, $type); $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")) { my $pm = "$name.pm"; $pm =~ s/::/\//g; eval { require $pm }; 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 types { my($self) = @_; $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') }; sort $self->{tp}->list_types; } sub type_meta { my($self, $name) = @_; $self = $self->new unless ref $self && eval { $self->isa('FFI::Platypus') }; $self->{tp}->parse($name)->meta; } sub mangler { my($self, $sub) = @_; $self->{mangler} = $self->{mymangler} = $sub; } sub function { my $wrapper; $wrapper = pop if ref $_[-1] eq 'CODE'; croak "usage \$ffi->function( name, [ arguments ], return_type)" unless @_ >= 4 && @_ <= 6; my $self = shift; my $name = shift; my $fixed_args = shift; my $var_args; $var_args = shift if defined $_[0] && ref($_[0]) eq 'ARRAY'; my $ret = shift; # special case: treat a single void argument type as an empty list of # arguments, a la olde timey C compilers. if( (!defined $var_args) && @$fixed_args == 1 && $fixed_args->[0] eq 'void' ) { $fixed_args = []; } my $args = [@$fixed_args, @{ $var_args || [] } ]; my $fixed_arg_count = defined $var_args ? scalar(@$fixed_args) : -1; my @args = map { $self->{tp}->parse($_) || croak "unknown type: $_" } @$args; $ret = $self->{tp}->parse($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; $address = @args > 0 ? _cast1() : _cast0() if $address == 0; my $function = FFI::Platypus::Function::Function->new($self, $address, $self->{abi}, $fixed_arg_count, $ret, @args); $wrapper ? FFI::Platypus::Function::Wrapper->new($function, $wrapper) : $function; } sub _function_meta { # NOTE: may be upgraded to a documented function one day, # but shouldn't be used externally as we will rename it # if that happens. my($self, $name, $meta, $args, $ret) = @_; $args = ['opaque','int',@$args]; $self->function( $name, $args, $ret, sub { my $xsub = shift; $xsub->($meta, scalar(@_), @_); }, ); } sub attach { my $wrapper; $wrapper = pop if ref $_[-1] eq 'CODE'; my $self = shift; my $name = shift; my $args = shift; my $varargs; $varargs = shift if defined $_[0] && ref($_[0]) eq 'ARRAY'; my $ret = shift; my $proto = shift; $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 = $varargs ? $self->function($c_name, $args, $varargs, $ret, $wrapper) : $self->function($c_name, $args, $ret, $wrapper); if(defined $function) { $function->attach($perl_name, $proto); } $self; } sub closure { my($self, $coderef) = @_; croak "not a coderef" unless ref $coderef eq 'CODE'; require FFI::Platypus::Closure; 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) = @_; ref $self ? $self->{tp}->parse($name)->sizeof : $self->new->sizeof($name); } sub alignof { my($self, $name) = @_; ref $self ? $self->{tp}->parse($name)->alignof : $self->new->alignof($name); } sub find_lib { my $self = shift; require FFI::CheckLib; $self->lib(FFI::CheckLib::find_lib(@_)); $self; } sub find_symbol { my($self, $name) = @_; $self->{mangler} ||= $self->{mymangler}; 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, FFI::Platypus::DL::RTLD_PLATYPUS_DEFAULT()); unless($handle) { warn "warning: error loading $path: ", FFI::Platypus::DL::dlerror() if $self->{api} > 0 || $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 bundle { croak "bundle method only available with api => 1 or better" if $_[0]->{api} < 1; require FFI::Platypus::Bundle; goto &_bundle; } sub package { croak "package method only available with api => 0" if $_[0]->{api} > 0; require FFI::Platypus::Legacy; goto &_package; } 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 $fini (@{ $self->{fini} }) { $fini->($self); } foreach my $handle (values %{ $self->{handles} }) { next unless $handle; FFI::Platypus::DL::dlclose($handle); } delete $self->{handles}; } 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 1.10 =head1 SYNOPSIS use FFI::Platypus; # for all new code you should use api => 1 my $ffi = FFI::Platypus->new( api => 1 ); $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. You are B encouraged to use API level 1 for all new code. There are a number of improvements and design fixes that you get for free. You should even consider updating existing modules to use API level 1 where feasible. How do I do that you might ask? Simply pass in the API level to the platypus constructor. my $ffi = FFI::Platypus->new( api => 1 ); The Platypus documentation has already been updated to assume API level 1. =for stopwords ØMQ =head1 CONSTRUCTORS =head2 new my $ffi = FFI::Platypus->new( api => 1, %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 api Sets the API level. Legal values are =over =item C<0> Original API level. See L for details on the differences. =item C<1> Enable the next generation type parser which allows pass-by-value records and type decoration on basic types. Using API level 1 prior to Platypus version 1.00 will trigger a (noisy) warning. All new code should be written with this set to 1! The Platypus documentation assumes this api level is set. =back =item lib Either a pathname (string) or a list of pathnames (array ref of strings) to pre-populate the L attribute. Use C<[undef]> to search the current process for symbols. 0.48 C (without the array reference) can be used to search the current process for symbols. =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 mangler $ffi->mangler(\&mangler); Specify a customer mangler to be used for symbol lookup. This is usually useful when you are writing bindings for a library where all of the functions have the same prefix. Example: $ffi->mangler(sub { my($symbol) = @_; return "foo_$symbol"; }); $ffi->function( get_bar => [] => 'int' ); # attaches foo_get_bar my $f = $ffi->function( set_baz => ['int'] => 'void' ); $f->call(22); # calls foo_set_baz =head2 function my $function = $ffi->function($name => \@argument_types => $return_type); my $function = $ffi->function($address => \@argument_types => $return_type); my $function = $ffi->function($name => \@argument_types => $return_type, \&wrapper); my $function = $ffi->function($address => \@argument_types => $return_type, \&wrapper); 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. [version 0.76] If the last argument is a code reference, then it will be used as a wrapper around the function when called. The first argument to the wrapper will be the inner function, or if it is later attached an xsub. This can be used if you need to verify/modify input/output data. Examples: my $function = $ffi->function('my_function_name', ['int', 'string'] => 'string'); my $return_string = $function->(1, "hi there"); [version 0.91] my $function = $ffi->function( $name => \@fixed_argument_types => \@var_argument_types => $return_type); my $function = $ffi->function( $name => \@fixed_argument_types => \@var_argument_types => $return_type, \&wrapper); Version 0.91 and later allows you to creat functions for c variadic functions (such as printf, scanf, etc) which can take a variable number of arguments. The first set of arguments are the fixed set, the second set are the variable arguments to bind with. The variable argument types must be specified in order to create a function object, so if you need to call variadic function with different set of arguments then you will need to create a new function object each time: # int printf(const char *fmt, ...); $ffi->function( printf => ['string'] => ['int'] => 'int' ) ->call("print integer %d\n", 42); $ffi->function( printf => ['string'] => ['string'] => 'int' ) ->call("print string %s\n", 'platypus'); Some older versions of libffi and possibly some platforms may not support variadic functions. If you try to create a one, then an exception will be thrown. =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, \&wrapper); $ffi->attach([$c_name => $perl_name] => \@argument_types => $return_type, \&wrapper); $ffi->attach([$address => $perl_name] => \@argument_types => $return_type, \&wrapper); 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; }); [version 0.91] $ffi->attach($name => \@fixed_argument_types => \@var_argument_types, $return_type); $ffi->attach($name => \@fixed_argument_types => \@var_argument_types, $return_type, \&wrapper); As of version 0.91 you can attach a variadic functions, if it is supported by the platform / libffi that you are using. For details see the C documentation. If not supported by the implementation then an exception will be thrown. =head2 closure my $closure = $ffi->closure($coderef); my $closure = FFI::Platypus->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 and 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); my $size = FFI::Platypus->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 bundle [version 0.96 api = 1+] $ffi->bundle($package, \@args); $ffi->bundle(\@args); $ffi->bundle($package); $ffi->bundle; This is an interface for bundling compiled code with your distribution intended to eventually replace the C method documented above. See L for details on how this works. =head2 package [version 0.15 api = 0] $ffi->package($package, $file); # usually __PACKAGE__ and __FILE__ can be used $ffi->package; # autodetect B: This method is officially discouraged in favor of C described above. If you use L (or the older deprecated 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( api => 1 ); $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 anoter Perl FFI library and it seems to work most # of the time, but also seems to SIGSEGV sometimes. I saw the same behavior # in the old 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( api => 1 ); $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: $ffi->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( api => 1 ); 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_1(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( api => 1 ); $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). The C C function takes a pointer to a record, hence we suffix the type with a star: C. If the function takes a record in pass-by-value mode then we'd just say C with no star suffix. =head2 libuuid use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new( api => 1 ); $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( api => 1 ); $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( api => 1 ); $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( api => 1 ); 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( api => 1 ); $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::CheckLib qw( find_lib_or_exit ); # 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 = FFI::Platypus->new( api => 1 ); $ffi->lib(find_lib_or_exit lib => 'archive'); $ffi->type('object(Archive)' => 'archive_t'); $ffi->type('object(ArchiveRead)' => 'archive_read_t'); $ffi->type('object(ArchiveWrite)' => 'archive_write_t'); $ffi->type('object(ArchiveEntry)' => 'archive_entry_t'); package Archive; # base class is "abstract" having no constructor or destructor $ffi->mangler(sub { my($name) = @_; "archive_$name"; }); $ffi->attach( error_string => ['archive_t'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_read_$name"; }); $ffi->attach( new => ['string'] => 'archive_read_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_t'] => 'void' ); $ffi->attach( support_filter_all => ['archive_t'] => 'int' ); $ffi->attach( support_format_all => ['archive_t'] => 'int' ); $ffi->attach( open_filename => ['archive_t','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive_t', 'archive_entry_t' ] => 'int' ); $ffi->attach( data_skip => ['archive_t'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_write_$name"; }); $ffi->attach( new => ['string'] => 'archive_write_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_write_t'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->mangler(sub { my($name) = @_; "archive_entry_$name"; }); $ffi->attach( new => ['string'] => 'archive_entry_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry_t'] => 'void' ); $ffi->attach( pathname => ['archive_entry_t'] => '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. We use Platypus's C type for this implementation, which is a wrapper around an C (can also be an integer) type that is blessed into a particular class. Another advanced feature of this example is that we define a mangler to modify the symbol resolution for each class. This means we can do this when we define a method for Archive: $ffi->attach( support_filter_all => ['archive_t'] => 'int' ); Rather than this: $ffi->attach( [ archive_read_support_filter_all => 'support_read_filter_all' ] => ['archive_t'] => 'int' ); ); =head2 unix open use FFI::Platypus; { package FD; use constant O_RDONLY => 0; use constant O_WRONLY => 1; use constant O_RDWR => 2; use constant IN => bless \do { my $in=0 }, __PACKAGE__; use constant OUT => bless \do { my $out=1 }, __PACKAGE__; use constant ERR => bless \do { my $err=2 }, __PACKAGE__; my $ffi = FFI::Platypus->new( api => 1, lib => [undef]); $ffi->type('object(FD,int)' => 'fd'); $ffi->attach( [ 'open' => 'new' ] => [ 'string', 'int', 'mode_t' ] => 'fd' => sub { my($xsub, $class, $fn, @rest) = @_; my $fd = $xsub->($fn, @rest); die "error opening $fn $!" if $$fd == -1; $fd; }); $ffi->attach( write => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( read => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( close => ['fd'] => 'int' ); } my $fd = FD->new("$0", FD::O_RDONLY); my $buffer = "\0" x 10; while(my $br = $fd->read($buffer, 10)) { FD::OUT->write($buffer, $br); } $fd->close; B: The Unix file system calls use an integer handle for each open file. We can use the same C type that we used for libarchive above, except we let platypus know that the underlying type is C instead of C (the latter being the default for the C type). Mainly just for demonstration since Perl has much better IO libraries, but now we have an OO interface to the Unix IO functions. =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( api => 1 ); $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 bundle your own code C: #include #include typedef struct { char *name; int value; } foo_t; foo_t* foo__new(const char *class_name, const char *name, int value) { (void)class_name; foo_t *self = malloc( sizeof( foo_t ) ); self->name = strdup(name); self->value = value; return self; } const char * foo__name(foo_t *self) { return self->name; } int foo__value(foo_t *self) { return self->value; } void foo__DESTROY(foo_t *self) { free(self->name); free(self); } C: package Foo; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Foo)' => 'foo_t'); $ffi->mangler(sub { my $name = shift; $name =~ s/^/foo__/; $name; }); $ffi->bundle; $ffi->attach( new => [ 'string', 'string', 'int' ] => 'foo_t' ); $ffi->attach( name => [ 'foo_t' ] => 'string' ); $ffi->attach( value => [ 'foo_t' ] => 'int' ); $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); } 1; You can bundle your own C (or other compiled language) code with your Perl extension. Sometimes this is helpful for smoothing over the interface of a C library which is not very FFI friendly. Sometimes you may want to write some code in C for a tight loop. Either way, you can do this with the Platypus bundle interface. See L for more details. Also related is the bundle constant interface, which allows you to define Perl constants in C space. See L for details. =head1 FAQ =head2 How do I get constants defined as macros in C header files This turns out to be a challenge for any language calling into C, which frequently uses C<#define> macros to define constants like so: #define FOO_STATIC 1 #define FOO_DYNAMIC 2 #define FOO_OTHER 3 As macros are expanded and their definitions are thrown away by the C pre-processor there isn't any way to get the name/value mappings from the compiled dynamic library. You can manually create equivalent constants in your Perl source: use constant FOO_STATIC => 1; use constant FOO_DYNAMIC => 2; use constant FOO_OTHER => 3; If there are a lot of these types of constants you might want to consider using a tool (L can do this) that can extract the constants for you. See also the "Integer constants" example in L. You can also use the new Platypus bundle interface to define Perl constants from C space. This is more reliable, but does require a compiler at install time. It is recommended mainly for writing bindings against libraries that have constants that can vary widely from platform to platform. See L for details. =head2 What about enums? The C enum types are integers. The underlying type is up to the platform, so Platypus provides C and C types for unsigned and singed enums respectively. At least some compilers treat signed and unsigned enums as different types. The enum I are essentially the same as macro constants described above from an FFI perspective. Thus the process of defining enum values is identical to the process of defining macro constants in Perl. For more details on enumerated types see L. =head2 Memory leaks There are a couple places where memory is allocated, but never deallocated that may look like memory leaks by tools designed to find memory leaks like valgrind. This memory is intended to be used for the lifetime of the perl process so there normally this isn't a problem unless you are embedding a Perl interpreter which doesn't closely match the lifetime of your overall application. Specifically: =over 4 =item type cache some types are cached and not freed. These are needed as long as there are FFI functions that could be called. =item attached functions Attaching a function as an xsub will definitely allocate memory that won't be freed because the xsub could be called at any time, including in C blocks. =back The Platypus team plans on adding a hook to free some of this "leaked" memory for use cases where Perl and Platypus are embedded in a larger application where the lifetime of the Perl process is significantly smaller than the overall lifetime of the whole process. =head2 I get seg faults on some platforms but not others with a library using pthreads. On some platforms, Perl isn't linked with C if Perl threads are not enabled. On some platforms this doesn't seem to matter, C can be loaded at runtime without much ill-effect. (Linux from my experience doesn't seem to mind one way or the other). Some platforms are not happy about this, and about the only thing that you can do about it is to build Perl such that it links with C even if it isn't a threaded Perl. This is not really an FFI issue, but a Perl issue, as you will have the same problem writing XS code for the such libraries. =head2 Doesn't work on Perl 5.10.0. I try as best as possible to support the same range of Perls as the Perl toolchain. That means all the way back to 5.8.1. Unfortunately, 5.10.0 seems to have a problem that is difficult to diagnose. Patches to fix are welcome, if you want to help out on this, please see: L Since this is an older buggy version of Perl it is recommended that you instead upgrade to 5.10.1 or later. =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 older versions of Google's Go. This is a problem for C / XS code as well. =item Languages that do not compile to machine code Like .NET based languages and Java. =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 the C file 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 Makefile.PL % make % make ffi-test % 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_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 Makefile.PL DEBUG_FAKE32: + making Math::Int64 a prereq + Using Math::Int64's C API to manipulate 64 bit values Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json % =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: helix% env FFI_PLATYPUS_NO_ALLOCA=1 perl Makefile.PL NO_ALLOCA: + alloca() will not be used, even if your platform supports it. Generating a Unix-style Makefile Writing Makefile for FFI::Platypus Writing MYMETA.yml and MYMETA.json =item V When building platypus may hide some of the excessive output when probing and building, unless you set C to a true value. % env V=1 perl Makefile.PL % make V=1 ... =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 This distribution uses L in fallback mode, meaning if the system doesn't provide C and C it will attempt to download C and build it from source. If you are including Platypus in a larger system (for example a Linux distribution) you only need to make sure to declare C or C and the development package for C as prereqs for this module. =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 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 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 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 C not only helped me get started with FFI but significantly influenced the design of Platypus. Dan Book, who goes by Grinnz on IRC for answering user questions about FFI and Platypus. In addition I'd like to thank Alessandro Ghedini (ALEXBIO) whose work on another Perl FFI library helped drive some of the development ideas for L. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus.xs000644 000765 000024 00000003414 13616651126 017672 0ustar00ollisgstaff000000 000000 #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; /* * 0 not loaded * 1 loaded ok * 2 attempted load, but errored */ int loaded_math_longdouble; } my_cxt_t; START_MY_CXT XS(ffi_pl_sub_call) { ffi_pl_function *self; int i,n, perl_arg_index; SV *arg; ffi_pl_arguments *arguments; void **argument_pointers; dMY_CXT; dVAR; dXSARGS; self = (ffi_pl_function*) CvXSUBANY(cv).any_ptr; { #define EXTRA_ARGS 0 #define FFI_PL_CALL_NO_RECORD_VALUE 1 #include "ffi_platypus_call.h" } } XS(ffi_pl_sub_call_rv) { ffi_pl_function *self; int i,n, perl_arg_index; SV *arg; ffi_pl_arguments *arguments; void **argument_pointers; dMY_CXT; dVAR; dXSARGS; self = (ffi_pl_function*) CvXSUBANY(cv).any_ptr; { #define EXTRA_ARGS 0 #define FFI_PL_CALL_RET_NO_NORMAL 1 #include "ffi_platypus_call.h" } } MODULE = FFI::Platypus PACKAGE = FFI::Platypus BOOT: { HV *stash; MY_CXT_INIT; MY_CXT.current_argv = NULL; MY_CXT.loaded_math_longdouble = 0; #ifndef HAVE_IV_IS_64 PERL_MATH_INT64_LOAD_OR_CROAK; #endif stash = gv_stashpv("FFI::Platypus", TRUE); newCONSTSUB(stash, "_cast0", newSVuv(PTR2UV(cast0))); newCONSTSUB(stash, "_cast1", newSVuv(PTR2UV(cast1))); } void CLONE(...) CODE: MY_CXT_CLONE; INCLUDE: ../../xs/DL.xs INCLUDE: ../../xs/Internal.xs INCLUDE: ../../xs/Type.xs INCLUDE: ../../xs/TypeParser.xs INCLUDE: ../../xs/Function.xs INCLUDE: ../../xs/ClosureData.xs INCLUDE: ../../xs/API.xs INCLUDE: ../../xs/ABI.xs INCLUDE: ../../xs/Record.xs INCLUDE: ../../xs/Closure.xs FFI-Platypus-1.10/lib/FFI/Probe/000755 000765 000024 00000000000 13616651126 016542 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Probe.pm000644 000765 000024 00000030622 13616651126 017103 0ustar00ollisgstaff000000 000000 package FFI::Probe; use strict; use warnings; use File::Basename qw( dirname ); use Data::Dumper (); use FFI::Probe::Runner; use FFI::Build; use FFI::Build::File::C; use Capture::Tiny qw( capture_merged capture ); use FFI::Temp; # ABSTRACT: System detection and probing for FFI extensions. our $VERSION = '1.10'; # VERSION sub new { my($class, %args) = @_; $args{log} ||= "ffi-probe.log"; $args{data_filename} ||= "ffi-probe.pl"; unless(ref $args{log}) { my $fn = $args{log}; my $fh; open $fh, '>>', $fn; $args{log} = $fh; } my $data; if(-r $args{data_filename}) { my $fn = $args{data_filename}; unless($data = do $fn) { die "couldn't parse configuration $fn $@" if $@; die "couldn't do $fn $!" if $!; die "bad or missing config file $fn"; } } $data ||= {}; my $self = bless { headers => [], log => $args{log}, data_filename => $args{data_filename}, data => $data, dir => FFI::Temp->newdir( TEMPLATE => 'ffi-probe-XXXXXX' ), counter => 0, runner => $args{runner}, alien => $args{alien} || [], cflags => $args{cflags}, libs => $args{libs}, }, $class; $self; } sub _runner { my($self) = @_; $self->{runner} ||= FFI::Probe::Runner->new; } sub check_header { my($self, $header) = @_; return if defined $self->{data}->{header}->{$header}; my $code = ''; $code .= "#include <$_>\n" for @{ $self->{headers} }, $header; my $build = FFI::Build->new("hcheck@{[ ++$self->{counter} ]}", verbose => 2, dir => $self->{dir}, alien => $self->{alien}, cflags => $self->{cflags}, libs => $self->{libs}, ); my $file = FFI::Build::File::C->new( \$code, dir => $self->{dir}, build => $build, ); my($out, $o) = capture_merged { eval { $file->build_item }; }; $self->log_code($code); $self->log($out); if($o) { $self->set('header', $header => 1); push @{ $self->{headers} }, $header; return 1; } else { $self->set('header', $header => 0); return; } } sub check_cpp { my($self, $code) = @_; my $build = FFI::Build->new("hcheck@{[ ++$self->{counter} ]}", verbose => 2, dir => $self->{dir}, alien => $self->{alien}, cflags => $self->{cflags}, libs => $self->{libs}, ); my $file = FFI::Build::File::C->new( \$code, dir => $self->{dir}, build => $build, ); my($out, $i) = capture_merged { eval { $file->build_item_cpp }; }; $self->log_code($code); $self->log($out); if($i && -f $i->path) { return $i->slurp; } else { return; } } sub check_eval { my($self, %args) = @_; my $code = $args{_template} || $self->template; my $headers = join "", map { "#include <$_>\n" } (@{ $self->{headers} }, @{ $args{headers} || [] }); my @decl = @{ $args{decl} || [] }; my @stmt = @{ $args{stmt} || [] }; my %eval = %{ $args{eval} || {} }; $code =~ s/##HEADERS##/$headers/; $code =~ s/##DECL##/join "\n", @decl/e; $code =~ s/##STMT##/join "\n", @stmt/e; my $eval = ''; my $i=0; my %map; foreach my $key (sort keys %eval) { $i++; $map{$key} = "eval$i"; my($format,$expression) = @{ $eval{$key} }; $eval .= " printf(\"eval$i=<<<$format>>>\\n\", $expression);\n"; } $code =~ s/##EVAL##/$eval/; my $build = FFI::Build->new("eval@{[ ++$self->{counter} ]}", verbose => 2, dir => $self->{dir}, alien => $self->{alien}, cflags => $self->{cflags}, libs => $self->{libs}, export => ['dlmain'], ); $build->source( FFI::Build::File::C->new( \$code, dir => $self->{dir}, build => $build, ), ); my $lib = do { my($out, $lib, $error) = capture_merged { my $lib = eval { $build->build; }; ($lib, $@); }; $self->log_code($code); $self->log("[build]"); $self->log($out); if($error) { $self->log("exception: $error"); return; } elsif(!$lib) { $self->log("failed"); return; } $lib; }; my $result = $self->_runner->run($lib->path); $self->log("[stdout]"); $self->log($result->stdout); $self->log("[stderr]"); $self->log($result->stderr); $self->log("rv = @{[ $result->rv ]}"); $self->log("sig = @{[ $result->signal ]}") if $result->signal; if($result->pass) { foreach my $key (sort keys %eval) { my $eval = $map{$key}; if($result->stdout =~ /$eval=<<<(.*?)>>>/) { my $value = $1; my @key = split /\./, $key; $self->set(@key, $value); } } return 1; } else { return; } } sub check { my($self, $name, $code) = @_; if($self->check_eval(_template => $code)) { $self->set('probe', $name, 1); return 1; } else { $self->set('probe', $name, 0); return; } } sub check_type_int { my($self, $type) = @_; $self->check_header('stddef.h'); my $ret = $self->check_eval( decl => [ '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"', "struct align { char a; $type b; };", ], eval => { "type.$type.size" => [ '%d' => "(int)sizeof($type)" ], "type.$type.sign" => [ '%s' => "signed($type)" ], "type.$type.align" => [ '%d' => '(int)offsetof(struct align, b)' ], }, ); return unless $ret; my $size = $self->data->{type}->{$type}->{size}; my $sign = $self->data->{type}->{$type}->{sign}; sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8); } sub check_type_enum { my($self) = @_; $self->check_header('stddef.h'); my $ret = $self->check_eval( decl => [ '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"', "typedef enum { ONE, TWO } myenum;", "struct align { char a; myenum b; };", ], eval => { "type.enum.size" => [ '%d' => '(int)sizeof(myenum)' ], "type.enum.sign" => [ '%s' => 'signed(myenum)' ], "type.enum.align" => [ '%d' => '(int)offsetof(struct align, b)' ], }, ); return unless $ret; my $size = $self->data->{type}->{enum}->{size}; my $sign = $self->data->{type}->{enum}->{sign}; sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8); } sub check_type_signed_enum { my($self) = @_; $self->check_header('stddef.h'); my $ret = $self->check_eval( decl => [ '#define signed(type) (((type)-1) < 0) ? "signed" : "unsigned"', "typedef enum { NEG = -1, ONE = 1, TWO = 2 } myenum;", "struct align { char a; myenum b; };", ], eval => { "type.senum.size" => [ '%d' => '(int)sizeof(myenum)' ], "type.senum.sign" => [ '%s' => 'signed(myenum)' ], "type.senum.align" => [ '%d' => '(int)offsetof(struct align, b)' ], }, ); return unless $ret; my $size = $self->data->{type}->{senum}->{size}; my $sign = $self->data->{type}->{senum}->{sign}; sprintf("%sint%d", $sign eq 'signed' ? 's' : 'u', $size*8); } sub check_type_float { my($self, $type) = @_; $self->check_header('stddef.h'); my $ret = $self->check_eval( decl => [ "struct align { char a; $type b; };", ], eval => { "type.$type.size" => [ '%d' => "(int)sizeof($type)" ], "type.$type.align" => [ '%d' => '(int)offsetof(struct align, b)' ], }, ); return unless $ret; my $size = $self->data->{type}->{$type}->{size}; my $complex = !!$type =~ /complex/; if($complex) { $size /= 2; } my $t; if($size == 4) { $t = 'float' } elsif($size == 8) { $t = 'double' } elsif($size > 9) { $t = 'longdouble' } $t = "complex_$t" if $complex; $t; } sub check_type_pointer { my($self) = @_; $self->check_header('stddef.h'); my $ret = $self->check_eval( decl => [ "struct align { char a; void* b; };", ], eval => { "type.pointer.size" => [ '%d' => '(int)sizeof(void *)' ], "type.pointer.align" => [ '%d' => '(int)offsetof(struct align, b)' ], }, ); return unless $ret; 'pointer'; } sub _set { my($data, $value, @key) = @_; my $key = shift @key; if(@key > 0) { _set($data->{$key} ||= {}, $value, @key); } else { $data->{$key} = $value; } } sub set { my $self = shift; my $value = pop; my @key = @_; my $print_value = $value; if(ref $print_value) { my $d = Data::Dumper->new([$value], [qw($value)]); $d->Indent(0); $d->Terse(1); $print_value = $d->Dump; } my $key = join ".", map { /\./ ? "\"$_\"" : $_ } @key; print "PR $key=$print_value\n"; $self->log("$key=$print_value"); _set($self->{data}, $value, @key); } sub save { my($self) = @_; my $dir = dirname($self->{data_filename}); my $dd = Data::Dumper->new([$self->{data}],['x']) ->Indent(1) ->Terse(0) ->Purity(1) ->Sortkeys(1) ->Dump; mkpath( $dir, 0, oct(755) ) unless -d $dir; my $fh; open($fh, '>', $self->{data_filename}) || die "error writing @{[ $self->{data_filename} ]}"; print $fh 'do { my '; print $fh $dd; print $fh '$x;}'; close $fh; } sub data { shift->{data} } sub log { my($self, $string) = @_; my $fh = $self->{log}; chomp $string; print $fh $string, "\n"; } sub log_code { my($self, $code) = @_; my @code = split /\n/, $code; chomp for @code; $self->log("code: $_") for @code; } sub DESTROY { my($self) = @_; $self->save; my $fh = $self->{log}; return unless defined $fh; close $fh; } my $template; sub template { unless(defined $template) { local $/; $template = ; } $template; } 1; =pod =encoding UTF-8 =head1 NAME FFI::Probe - System detection and probing for FFI extensions. =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Probe; my $probe = FFI::Probe->new; $probe->check_header('foo.h'); ... =head1 DESCRIPTION This class provides an interface for probing for system capabilities. It is used internally as part of the L build process, but it may also be useful for extensions that use Platypus as well. =head1 CONSTRUCTOR =head2 new my $probe = FFI::Probe->new(%args); Creates a new instance. =over 4 =item log Path to a log or file handle to write to. =item data_filename Path to a file which will be used to store/cache results. =back =head1 METHODS =head2 check_header my $bool = $probe->check_header($header); Checks that the given C header file is available. Stores the result, and returns a true/false value. =head2 check_cpp =head2 check_eval my $bool = $probe>check_eval(%args); =over 4 =item headers Any additional headers. =item decl Any C declarations that need to be made before the C function. =item stmt Any C statements that should be made before the evaluation. =item eval Any evaluations that should be returned. =back =head2 check =head2 check_type_int my $type = $probe->check_type_int($type); =head2 check_type_enum my $type = $probe->check_type_enum; =head2 check_type_enum my $type = $probe->check_type_enum; =head2 check_type_float my $type = $probe->check_type_float($type); =head2 check_type_pointer my $type = $probe->check_type_pointer; =head2 set $probe->set(@key, $value); Used internally to store a value. =head2 save $probe->save; Saves the values already detected. =head2 data my $data = $probe->data; Returns a hashref of the data already detected. =head2 log $probe->log($string); Sends the given string to the log. =head2 log_code $prbe->log_code($string); Sends the given multi-line code block to the log. =head2 template my $template = $probe->template; Returns the C code template used for C and other C methods. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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 __DATA__ #include ##HEADERS## ##DECL## int dlmain(int argc, char *argv[]) { ##STMT## ##EVAL## return 0; } FFI-Platypus-1.10/lib/FFI/Temp.pm000644 000765 000024 00000004327 13616651126 016744 0ustar00ollisgstaff000000 000000 package FFI::Temp; use strict; use warnings; use Carp qw( croak ); use File::Spec; use File::Temp qw( tempdir ); # ABSTRACT: Temp Dir support for FFI::Platypus our $VERSION = '1.10'; # VERSION # problem with vanilla File::Temp is that is often uses # as /tmp that has noexec turned on. Workaround is to # create a temp directory in the build directory, but # we have to be careful about cleanup. This puts all that # (attempted) carefulness in one place so that when we # later discover it isn't so careful we can fix it in # one place rather thabn alllll the places that we need # temp directories. my %root; sub _root { my $root = File::Spec->rel2abs(File::Spec->catdir(".tmp")); unless(-d $root) { mkdir $root or die "unable to create temp root $!"; } # TODO: doesn't account for fork... my $lock = File::Spec->catfile($root, "l$$"); unless(-f $lock) { open my $fh, '>', $lock; close $fh; } $root{$root} = 1; $root; } END { foreach my $root (keys %root) { my $lock = File::Spec->catfile($root, "l$$"); unlink $lock; # try to delete if possible. # if not possible then punt rmdir $root if -d $root; } } sub newdir { my $class = shift; croak "uneven" if @_ % 2; File::Temp->newdir(DIR => _root, @_); } sub new { my $class = shift; croak "uneven" if @_ % 2; File::Temp->new(DIR => _root, @_); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Temp - Temp Dir support for FFI::Platypus =head1 VERSION version 1.10 =head1 DESCRIPTION This class is private to L. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/typemap000644 000765 000024 00000003021 13616651126 017071 0ustar00ollisgstaff000000 000000 ffi_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::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::Function\")) $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); else Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::Function::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\"); FFI-Platypus-1.10/lib/FFI/Probe/Runner/000755 000765 000024 00000000000 13616651126 020013 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Probe/Runner.pm000644 000765 000024 00000006176 13616651126 020363 0ustar00ollisgstaff000000 000000 package FFI::Probe::Runner; use strict; use warnings; use Capture::Tiny qw( capture ); use FFI::Probe::Runner::Result; # ABSTRACT: Probe runner for FFI our $VERSION = '1.10'; # VERSION sub new { my($class, %args) = @_; $args{exe} ||= do { require FFI::Platypus::ShareConfig; require File::Spec; require Config; File::Spec->catfile(FFI::Platypus::ShareConfig::dist_dir('FFI::Platypus'), 'probe', 'bin', "dlrun$Config::Config{exe_ext}"); }; defined $args{flags} or $args{flags} = '-'; die "probe runner executable not found at: $args{exe}" unless -f $args{exe}; my $self = bless { exe => $args{exe}, flags => $args{flags}, }, $class; $self; } sub exe { shift->{exe} } sub flags { shift->{flags} } sub verify { my($self) = @_; my $exe = $self->exe; my($out, $err, $ret) = capture { $! = 0; system $exe, 'verify', 'self'; }; return 1 if $ret == 0 && $out =~ /dlrun verify self ok/; print $out; print STDERR $err; die "verify failed"; } sub run { my($self, $dll, @args) = @_; my $exe = $self->exe; my $flags = $self->flags; my($out, $err, $ret) = capture { my @cmd = ($exe, $dll, $flags, @args); $! = 0; system @cmd; $?; }; FFI::Probe::Runner::Result->new( stdout => $out, stderr => $err, rv => $ret >> 8, signal => $ret & 127, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Probe::Runner - Probe runner for FFI =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Probe::Runner; my $runner = FFI::Probe::Runner->new; $runner->run('foo.so'); =head1 DESCRIPTION This class executes code in a dynamic library for probing and detecting platform properties. =head1 CONSTRUCTOR =head2 new my $runner = FFI::Probe::Runner->new(%args); Creates a new instance. =over 4 =item exe The path to the dlrun wrapper. The default is usually correct. =item flags The flags to pass into C. The default is C on Unix and C<0> on windows.. =back =head1 METHODS =head2 exe my $exe = $runner->exe; The path to the dlrun wrapper. =head2 flags my $flags = $runner->flags; The flags to pass into C. =head2 verify $runner->verify; Verifies the dlrun wrapper is working. Throws an exception in the event of failure. =head2 run $runner->run($dll, @args); Runs the C function in the given dynamic library, passing in the given arguments. Returns a L object which contains the results. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Probe/Runner/Builder.pm000644 000765 000024 00000022267 13616651126 021750 0ustar00ollisgstaff000000 000000 package FFI::Probe::Runner::Builder; use strict; use warnings; use Config; use Capture::Tiny qw( capture_merged ); use Text::ParseWords (); use FFI::Build::Platform; # ABSTRACT: Probe runner builder for FFI our $VERSION = '1.10'; # VERSION sub new { my($class, %args) = @_; $args{dir} ||= 'blib/lib/auto/share/dist/FFI-Platypus/probe'; my $platform = FFI::Build::Platform->new; my $self = bless { dir => $args{dir}, platform => $platform, # we don't use the platform ccflags, etc because they are geared # for building dynamic libs not exes cc => [$platform->shellwords($Config{cc})], ld => [$platform->shellwords($Config{ld})], ccflags => [$platform->shellwords($Config{ccflags})], optimize => [$platform->shellwords($Config{optimize})], ldflags => [$platform->shellwords($Config{ldflags})], libs => $^O eq 'MSWin32' ? [[]] : [['-ldl'], [], map { [$_] } grep !/^-ldl/, $platform->shellwords($Config{perllibs})], }, $class; $self; } sub dir { my($self, @subdirs) = @_; my $dir = $self->{dir}; if(@subdirs) { require File::Spec; $dir = File::Spec->catdir($dir, @subdirs); } unless(-d $dir) { require File::Path; File::Path::mkpath($dir, 0, oct(755)); } $dir; } sub cc { shift->{cc} } sub ccflags { shift->{ccflags} } sub optimize { shift->{optimize} } sub ld { shift->{ld} } sub ldflags { shift->{ldflags} } sub libs { shift->{libs} } sub file { my($self, @sub) = @_; @sub >= 1 or die 'usage: $builder->file([@subdirs], $filename)'; my $filename = pop @sub; require File::Spec; File::Spec->catfile($self->dir(@sub), $filename); } my $source; sub exe { my($self) = @_; my $xfn = $self->file('bin', "dlrun$Config{exe_ext}"); } sub source { unless($source) { local $/; $source = ; } $source; } our $VERBOSE = !!$ENV{V}; sub extract { my($self) = @_; # the source src/dlrun.c { print "XX src/dlrun.c\n" unless $VERBOSE; my $fh; my $fn = $self->file('src', 'dlrun.c'); my $source = $self->source; open $fh, '>', $fn or die "unable to write $fn $!"; print $fh $source; close $fh; } # the bin directory bin { print "XX bin/\n" unless $VERBOSE; $self->dir('bin'); } } sub run { my($self, $type, @cmd) = @_; @cmd = map { ref $_ ? @$_ : $_ } @cmd; my($out, $ret) = capture_merged { $self->{platform}->run(@cmd); }; if($ret) { print STDERR $out; die "$type failed"; } print $out if $VERBOSE; $out; } sub run_list { my($self, $type, @commands) = @_; my $log = ''; foreach my $cmd (@commands) { my($out, $ret) = capture_merged { $self->{platform}->run(@$cmd); }; if($VERBOSE) { print $out; } else { $log .= $out; } return if !$ret; } print $log; die "$type failed"; } sub build { my($self) = @_; $self->extract; # this should really be done in `new` but the build # scripts for FFI-Platypus edit the ldfalgs from there # so. Also this may actually belong in FFI::Build::Platform # which would resolve the problem. if($^O eq 'MSWin32' && $Config{ccname} eq 'cl') { $self->{ldflags} = [ grep !/^-nodefaultlib$/i, @{ $self->{ldflags} } ]; } my $cfn = $self->file('src', 'dlrun.c'); my $ofn = $self->file('src', "dlrun$Config{obj_ext}"); my $xfn = $self->exe; # compile print "CC src/dlrun.c\n" unless $VERBOSE; $self->run( compile => $self->cc, $self->ccflags, $self->optimize, '-c', $self->{platform}->flag_object_output($ofn), $cfn, ); # link print "LD src/dlrun$Config{obj_ext}\n" unless $VERBOSE; $self->run_list(link => map { [ $self->ld, $self->ldflags, $self->{platform}->flag_exe_output($xfn), $ofn, @$_ ] } @{ $self->libs }, ); ## FIXME if($^O eq 'MSWin32' && $Config{ccname} eq 'cl') { if(-f 'dlrun.exe' && ! -f $xfn) { rename 'dlrun.exe', $xfn; } } # verify print "VV bin/dlrun$Config{exe_ext}\n" unless $VERBOSE; my $out = $self->run(verify => $xfn, 'verify', 'self'); if($out !~ /dlrun verify self ok/) { print $out; die "verify failed string match"; } # remove object print "UN src/dlrun$Config{obj_ext}\n" unless $VERBOSE; unlink $ofn; $xfn; } 1; =pod =encoding UTF-8 =head1 NAME FFI::Probe::Runner::Builder - Probe runner builder for FFI =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Probe::Runner::Builder; my $builder = FFI::Probe::Runner::Builder->new dir => "/foo/bar", ); my $exe = $builder->build; =head1 DESCRIPTION This is a builder class for the FFI probe runner. It is mostly only of interest if you are hacking on L itself. The interface may and will change over time without notice. Use in external dependencies at your own peril. =head1 CONSTRUCTORS =head2 new my $builder = FFI::Probe::Runner::Builder->new(%args); Create a new instance. =over 4 =item dir The root directory for where to place the probe runner files. Will be created if it doesn't already exist. The default makes sense for when L is being built. =back =head1 METHODS =head2 dir my $dir = $builder->dir(@subdirs); Returns a subdirectory from the builder root. Directory will be created if it doesn't already exist. =head2 cc my @cc = @{ $builder->cc }; The C compiler to use. Returned as an array reference so that it may be modified. =head2 ccflags my @ccflags = @{ $builder->ccflags }; The C compiler flags to use. Returned as an array reference so that it may be modified. =head2 optimize The C optimize flags to use. Returned as an array reference so that it may be modified. =head2 ld my @ld = @{ $builder->ld }; The linker to use. Returned as an array reference so that it may be modified. =head2 ldflags my @ldflags = @{ $builder->ldflags }; The linker flags to use. Returned as an array reference so that it may be modified. =head2 libs my @libs = @{ $builder->libs }; The library flags to use. Returned as an array reference so that it may be modified. =head2 file my $file = $builder->file(@subdirs, $filename); Returns a file in a subdirectory from the builder root. Directory will be created if it doesn't already exist. File will not be created. =head2 exe my $exe = $builder->exe; The name of the executable, once it is built. =head2 source my $source = $builder->source; The C source for the probe runner. =head2 extract $builder->extract; Extract the source for the probe runner. =head2 run $builder->run($type, @command); Runs the given command. Dies if the command fails. =head2 run_list $builder->run($type, \@command, \@command, ...); Runs the given commands in order until one succeeds. Dies if they all fail. =head2 build my $exe = $builder->build; Builds the probe runner. Returns the path to the executable. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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 __DATA__ #if defined __CYGWIN__ #include #elif defined _WIN32 #include #else #include #endif #include #include #include #if defined __CYGWIN__ typedef void * dlib; #elif defined _WIN32 #define RTLD_LAZY 0 typedef HMODULE dlib; dlib dlopen(const char *filename, int flags) { (void)flags; return LoadLibrary(filename); } void * dlsym(dlib handle, const char *symbol_name) { return GetProcAddress(handle, symbol_name); } int dlclose(dlib handle) { FreeLibrary(handle); return 0; } const char * dlerror() { return "an error"; } #else typedef void * dlib; #endif int main(int argc, char **argv) { char *filename; int flags; int (*dlmain)(int, char **); char **dlargv; dlib handle; int n; int ret; if(argc < 3) { fprintf(stderr, "usage: %s dlfilename dlflags [ ... ]\n", argv[0]); return 1; } if(!strcmp(argv[1], "verify") && !strcmp(argv[2], "self")) { printf("dlrun verify self ok\n"); return 0; } #if defined WIN32 SetErrorMode(SetErrorMode(0) | SEM_NOGPFAULTERRORBOX); #endif dlargv = malloc(sizeof(char*)*(argc-2)); dlargv[0] = argv[0]; filename = argv[1]; flags = !strcmp(argv[2], "-") ? RTLD_LAZY : atoi(argv[2]); for(n=3; n{stdout} } sub stderr { shift->{stderr} } sub rv { shift->{rv} } sub signal { shift->{signal} } sub pass { my($self) = @_; $self->rv == 0 && $self->signal == 0; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Probe::Runner::Result - The results from a probe run. =head1 VERSION version 1.10 =head1 SYNOPSIS =head1 DESCRIPTION =head1 CONSTRUCTOR =head2 new my $result = FFI::Probe::Runner::Result->new(%args); Creates a new instance of the class. =head1 METHODS =head2 stdout my $stdout = $result->stdout; =head2 stderr my $stderr = $result->stderr; =head2 rv my $rv = $result->rv; =head2 signal my $signal = $result->signal; =head2 pass my $pass = $result->pass; =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/API.pm000644 000765 000024 00000013274 13616651126 020272 0ustar00ollisgstaff000000 000000 package 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 = '1.10'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::API - Platypus arguments and return value API for custom types =head1 VERSION version 1.10 =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 B: I added this interface early on to L, but haven't used it much, generally finding function wrappers to be a more powerful (although possibly not as fast) interface. It has thus not been tested as much as the rest of Platypus. If you feel the need to use this interface please coordinate with the Platypus developers. 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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Buffer.pm000644 000765 000024 00000011135 13616651126 021064 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Buffer; use strict; use warnings; use base qw( Exporter ); our @EXPORT = qw( scalar_to_buffer buffer_to_scalar ); our @EXPORT_OK = qw ( scalar_to_pointer ); # ABSTRACT: Convert scalars to C buffers our $VERSION = '1.10'; # VERSION use constant _incantation => $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ } ? 'Q' : 'L!'; sub scalar_to_buffer ($) { (unpack(_incantation, pack 'P', $_[0]), do { use bytes; length $_[0] }); } sub scalar_to_pointer ($) { unpack(_incantation, pack 'P', $_[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 1.10 =head1 SYNOPSIS use FFI::Platypus::Buffer; my($pointer, $size) = scalar_to_buffer $scalar; my $scalar2 = buffer_to_scalar $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. B: This module provides great power in the way that you interact with C code, but with that power comes great responsibility. Since you are dealing with blocks of memory you need to take care to understand the underlying ownership model of these pointers. =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. You should NEVER try to free C<$pointer>. When you pass this pointer and size into a C function, it has direct access to the data stored in your scalar, so it is important that you not resize or free the scalar while it is in use by the C code. Typically if you are passing a buffer into a C function which reads or writes to the buffer, but does not keep the pointer for later use you are okay. If the buffer is in use long term by the C code, then you should consider copying the buffer instead. For example: use FFI::Platypus::Buffer qw( scalar_to_buffer ); use FFI::Platypus::Memory qw( malloc memcpy free ) my($ptr, $size) = scalar_to_buffer $string; c_function_thaat_does_not_keep_ptr( $ptr, $size); # okay my($ptr, $size) = scalar_to_buffer $string; my $ptr_copy = malloc($size); memcpy($ptr_copy, $ptr, $size); c_function_that_DOES_keep_ptr( $ptr_copy, $size); # also okay ... # later when you know that the c code is no longer using the pointer # Since you allocated the copy, you are responsible for free'ing it. free($ptr_copy); =head2 scalar_to_pointer my $pointer = scalar_to_pointer $scalar; Get the pointer to the scalar. (Similar to C above, but the size of the scalar is not computed or returned). Not exported by default, but may be exported on request. =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. Because of the way memory management works in Perl, the buffer is copied from the buffer into the scalar. If this pointer was returned from C land, then you should only free it if you allocated it. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Bundle.pm000644 000765 000024 00000037177 13616651126 021102 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Bundle; use strict; use warnings; use Carp (); # ABSTRACT: Bundle foreign code with your Perl module our $VERSION = '1.10'; # VERSION package FFI::Platypus; sub _bundle { my @arg_ptrs; if(defined $_[-1] && ref($_[-1]) eq 'ARRAY') { @arg_ptrs = @{ pop @_ }; } push @arg_ptrs, undef; my($self, $package) = @_; $package = caller unless defined $package; require List::Util; my($pm) = do { my $pm = "$package.pm"; $pm =~ s{::}{/}g; # if the module is already loaded, we can use %INC # otherwise we can go through @INC and find the first .pm # this doesn't handle all edge cases, but probably enough List::Util::first(sub { (defined $_) && (-f $_) }, ($INC{$pm}, map { "$_/$pm" } @INC)); }; Carp::croak "unable to find module $package" unless $pm; my @parts = split /::/, $package; my $incroot = $pm; { my $c = @parts; $incroot =~ s![\\/][^\\/]+$!! while $c--; } my $txtfn = List::Util::first(sub { -f $_ }, do { my $dir = join '/', @parts; my $file = $parts[-1] . ".txt"; ( "$incroot/auto/$dir/$file", "$incroot/../arch/auto/$dir/$file", ); }); my $lib; if($txtfn) { $lib = do { my $fh; open($fh, '<', $txtfn) or die "unable to read $txtfn $!"; my $line = <$fh>; close $fh; $line =~ /^FFI::Build\@(.*)$/ ? "$incroot/$1" : Carp::croak "bad format $txtfn"; }; Carp::croak "bundle code is missing: $lib" unless -f $lib; } elsif(-d "$incroot/../ffi") { require FFI::Build::MM; require Capture::Tiny; require Cwd; require File::Spec; my $save = Cwd::getcwd(); chdir "$incroot/.."; my($output, $error) = Capture::Tiny::capture_merged(sub { $lib = eval { my $dist_name = $package; $dist_name =~ s/::/-/; my $fbmm = FFI::Build::MM->new( save => 0 ); $fbmm->mm_args( DISTNAME => $dist_name ); my $build = $fbmm->load_build('ffi', undef, 'ffi/_build'); $build->build; }; $@; }); if($error) { chdir $save; print STDERR $output; die $error; } else { $lib = File::Spec->rel2abs($lib); chdir $save; } } else { Carp::croak "unable to find bundle code for $package"; } my $handle = FFI::Platypus::DL::dlopen($lib, FFI::Platypus::DL::RTLD_PLATYPUS_DEFAULT()) or Carp::croak "error loading bundle code: $lib @{[ FFI::Platypus::DL::dlerror() ]}"; $self->{handles}->{$lib} = $handle; $self->lib($lib); if(my $init = eval { $self->function( 'ffi_pl_bundle_init' => [ 'string', 'sint32', 'opaque[]' ] => 'void' ) }) { $init->call($package, scalar(@arg_ptrs)-1, \@arg_ptrs); } if(my $init = eval { $self->function( 'ffi_pl_bundle_constant' => [ 'string', 'opaque' ] => 'void' ) }) { require FFI::Platypus::Constant; my $api = FFI::Platypus::Constant->new($package); $init->call($package, $api->ptr); } if(my $address = $self->find_symbol( 'ffi_pl_bundle_fini' )) { push @{ $self->{fini} }, sub { my $self = shift; $self->function( $address => [ 'string' ] => 'void' ) ->call( $package ); }; } $self; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Bundle - Bundle foreign code with your Perl module =head1 VERSION version 1.10 =head1 SYNOPSIS C: #include #include typedef struct { char *name; int value; } foo_t; foo_t* foo__new(const char *class_name, const char *name, int value) { (void)class_name; foo_t *self = malloc( sizeof( foo_t ) ); self->name = strdup(name); self->value = value; return self; } const char * foo__name(foo_t *self) { return self->name; } int foo__value(foo_t *self) { return self->value; } void foo__DESTROY(foo_t *self) { free(self->name); free(self); } C: package Foo; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Foo)' => 'foo_t'); $ffi->mangler(sub { my $name = shift; $name =~ s/^/foo__/; $name; }); $ffi->bundle; $ffi->attach( new => [ 'string', 'string', 'int' ] => 'foo_t' ); $ffi->attach( name => [ 'foo_t' ] => 'string' ); $ffi->attach( value => [ 'foo_t' ] => 'int' ); $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); } 1; C use Test::More; use Foo; my $foo = Foo->new("platypus", 10); isa_ok $foo, 'Foo'; is $foo->name, "platypus"; is $foo->value, 10; done_testing; C: use ExtUtils::MakeMaker; use FFI::Build::MM; my $fbmm = FFI::Build::MM->new; WriteMakefile( $fbmm->mm_args( NAME => 'Foo', DISTNAME => 'Foo', VERSION => '1.00', # ... ) ); sub MY::postamble { $fbmm->mm_postamble; } or C: name = Foo version = 0.01 ... [FFI::Build] version = 1.04 =head1 DESCRIPTION This document serves as a tutorial for using the new bundling interface provided by L as of api version 1. It requires L of at least 1.00. Sometimes when writing FFI bindings you need to include a little C code (or your favorite compiled language) to finish things off. Alternatively, you might just want to write some C code (or your favorite compiled language) to include with your Perl module to make a tight loop faster. The bundling interface has you covered. =head2 Basic example To illustrate we will go through the files in the synopsis and explain how and why they work. To start with we have some C code which emulates object oriented code using C as a prefix. We use a C struct that we call C to store our object data. On the C level the struct acts as a class, when combined with its functions that act as methods. The constructor just allocates the memory it needs for the C instance, fills in the appropriate fields and returns the pointer: foo_t* foo__new(const char *class_name, const char *name, int value) { (void) class_name; foo_t *self = malloc( sizeof( foo_t ) ); self->name = strdup(name); self->value = value; return self; } We include a class name as the first argument, because Perl will include that when calling the constructor, but we do not use it here. An exercise for the reader would be to add hierarchical inheritance. There are also some methods which return member values. This class has only read only members, but you could have read/write or other methods depending on your needs. const char * foo__name(foo_t *self) { return self->name; } We also include a destructor so that the memory owned by the object can be freed when it is no longer needed. void foo__DESTROY(foo_t *self) { free(self->name); free(self); } This might start to look a little like a Perl module, and when we look at the Perl code that binds to this code, you will see why. First lets prepare the L instance and specify the correct api version: my $ffi = FFI::Platypus->new( api => 1 ); The bundle interface is only supported with api version 1, so if you try to use version 0 it will not work. Next we define an object type for C which will associate it with the Perl class C. $ffi->type('object(Foo)' => 'foo_t'); As object type is a blessed reference to an opaque (default) or integer type which can be used as a Perl object. Platypus does the translating of Perl object to and from the foo_t pointers that the C code understands. For more details on Platypus types see L. Next we set the mangler on the Platypus instance so that we can refer to function names without the C prefix. You could just not use the prefix in your C code and skip this step, or you could refer to the function names in their full in your Perl code, however, this saves extra typing and allows you to bundle more than one class with your Perl code without having to worry about name conflicts. $ffi->mangler(sub { my $name = shift; $name =~ s/^/foo__/; $name; }); Finally we let Platypus know that we will be bundling code. $ffi->bundle; By default, this searches for the appropriate place for your dynamic libraries using the current package. In some cases you may need to override this, for example if your dist is named C but your specific class is named C, you'd want something like this: package Foo::Bar::Baz; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->bundle('Foo::Bar'); ... Now, finally we can attach the methods for our class: $ffi->attach( new => [ 'string', 'int' ] => 'foo_t' ); $ffi->attach( name => [ 'foo_t' ] => 'string' ); $ffi->attach( value => [ 'foo_t' ] => 'int' ); $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); Note that we do not have to include the C prefix because of the way we set up the mangler. If we hadn't done that then we could instead attach with the full names: $ffi->attach( [ 'foo__new' => 'new' ] => [ 'string', 'int' ] => 'foo_t' ); $ffi->attach( [ 'foo__name' => 'name' ] => [ 'foo_t' ] => 'string' ); ... You're done! You can now use this class. Lets write a test to make sure it works, use strict; use warnings; use Test::More; use Foo; my $foo = Foo->new("platypus", 10); isa_ok $foo, 'Foo'; is $foo->name, "platypus"; is $foo->value, 10; done_testing; and use C to check that it works: % prove -lvm t/foo.t .. ok 1 - An object of class 'Foo' isa 'Foo' ok 2 ok 3 1..3 ok All tests successful. Files=1, Tests=3, 0 wallclock secs ( 0.02 usr 0.00 sys + 0.14 cusr 0.03 csys = 0.19 CPU) Result: PASS Platypus automatically compiles and links the dynamic library for you: % ls ffi/_build foo.c.o libFoo.so The C code will be rebuilt next time if the source code is newer than the object or dynamic libraries files. If the source files are not changed, then it won't be rebuilt to save time. If you are using the code without MakeMaker, or another build system you are responsible for cleaning up these files. This is intended as a convenience to allow you to test your code without having to invoke MakeMaker, or C or whatever build system you are using. When you distribute your module though, you will want the dynamic library built just once at build-time and installed correctly so that it can be found at run-time. You don't need to make any changes to your C or Perl code, but you do need to tell MakeMaker to build and install the appropriate files using L: use ExtUtils::MakeMaker; use FFI::Build::MM; my $fbmm = FFI::Build::MM->new; WriteMakefile( $fbmm->mm_args( NAME => 'Foo', DISTNAME => 'Foo', VERSION => '1.00', # ... ) ); sub MY::postamble { $fbmm->mm_postamble; } And we can invoke all the normal MakeMaker style stuff and our C code will be compiled, linked and installed at the appropriate steps. % perl Makefile.PL Generating a Unix-style Makefile Writing Makefile for Foo Writing MYMETA.yml and MYMETA.json % make cp lib/Foo.pm blib/lib/Foo.pm "/Users/ollisg/perl5/perlbrew/perls/perl-5.30.0/bin/perl" -MFFI::Build::MM=cmd -e fbx_build CC ffi/foo.c LD blib/lib/auto/share/dist/Foo/lib/libFoo.dylib % make test "/Users/ollisg/perl5/perlbrew/perls/perl-5.30.0/bin/perl" -MFFI::Build::MM=cmd -e fbx_build "/Users/ollisg/perl5/perlbrew/perls/perl-5.30.0/bin/perl" -MFFI::Build::MM=cmd -e fbx_test PERL_DL_NONLAZY=1 "/Users/ollisg/perl5/perlbrew/perls/perl-5.30.0/bin/perl" "-MExtUtils::Command::MM" "-MTest::Harness" "-e" "undef *Test::Harness::Switches; test_harness(0, 'blib/lib', 'blib/arch')" t/*.t t/foo.t .. ok All tests successful. Files=1, Tests=3, 0 wallclock secs ( 0.01 usr 0.00 sys + 0.06 cusr 0.01 csys = 0.08 CPU) Result: PASS If the C file above looks overly complicated, you can use the L plugin to simplify your life if you are using L: [FFI::Build] version = 1.04 Specifying version 1.04 will ensure that any C<.o> or C<.so> files are pruned from your build tree and not distributed by mistake. =head2 Initialization example The bundle interface also gives you entry points which will be called automatically when your code is loaded and unloaded if they are found. =over 4 =item C void ffi_pl_bundle_init(const char *package, int argc, void *argv[]); Called when the dynamic library is loaded. C is the Perl package that called C from Perl space. C and C represents an array of opaque pointers that can be passed as an array to bundle as the last argument. (the count C is a little redundant because C is also NULL terminated). =item C void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c); Called immediately after C, and is intended to allow you to set Perl constants from C space. For details on how this works and what methods you can call on the C instance, see L. =item C void ffi_pl_bundle_fini(const char *package); Called when the dynamic library is unloaded. C is the Perl package that called C from Perl space when the library was loaded. B: if you attach any functions then this will never be called, because attaching functions locks the Platypus instance into memory along with the libraries which it is using. =back Here is an example that passes the version and a callback back into Perl space that emulates the Perl 5.10 C feature. C: #include char buffer[512]; const char *version; void (*say)(const char *); void ffi_pl_bundle_init(const char *package, int argc, void *argv[]) { version = argv[0]; say = argv[1]; say("in init!"); snprintf(buffer, 512, "package = %s, version = %s", package, version); say(buffer); snprintf(buffer, 512, "args = %d", argc); say(buffer); } void ffi_pl_bundle_fini(const char *package) { say("in fini!"); } C: package Init; use strict; use warnings; use FFI::Platypus; our $VERSION = '1.00'; { my $ffi = FFI::Platypus->new( api => 1 ); my $say = $ffi->closure(sub { my $string = shift; print "$string\n"; }); $ffi->bundle([ $ffi->cast( 'string' => 'opaque', $VERSION ), $ffi->cast( '(string)->void' => 'opaque', $say ), ]); undef $ffi; undef $say; } 1; The deinitialization order for the C<$say> callback and the C<$ffi> instance is essential here, so we do it manually with C: undef $ffi; undef $say; First we deallocate C<$ffi> which calls C, which calls C<$say>, so we want to make sure the latter is still allocated. Once C is done, we can safely deallocate C<$say>. If C didn't call back into Perl space like this then we don't have to be as careful about deallocating things in Perl space. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Closure.pm000644 000765 000024 00000006616 13616651126 021277 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Closure; use strict; use warnings; use FFI::Platypus; use Scalar::Util qw( refaddr); use Carp qw( croak ); use overload '&{}' => sub { my $self = shift; sub { $self->{code}->(@_) }; }, bool => sub { 1 }, fallback => 1; # ABSTRACT: Platypus closure object our $VERSION = '1.10'; # VERSION sub new { my($class, $coderef) = @_; croak "not a coderef" unless ref($coderef) eq 'CODE'; my $self = bless { code => $coderef, cbdata => {}, sticky => 0 }, $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; } sub call { my $self = shift; $self->{code}->(@_) } sub sticky { my($self) = @_; return if $self->{sticky}; $self->{sticky} = 1; $self->_sticky; } sub unstick { my($self) = @_; return unless $self->{sticky}; $self->{sticky} = 0; $self->_unstick; } package FFI::Platypus::ClosureData; our $VERSION = '1.10'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Closure - Platypus closure object =head1 VERSION version 1.10 =head1 SYNOPSIS create closure with OO interface use FFI::Platypus::Closure; my $closure = FFI::Platypus::Closure->new(sub { print "hello world\n" }); create closure from Platypus object use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); my $closure = $ffi->closure(sub { print "hello world\n" }); use closure $ffi->function(foo => ['()->void'] => 'void')->call($closure); =head1 DESCRIPTION This class represents a Perl code reference that can be called from compiled code. When you create a closure object, you can pass it into any function that expects a function pointer. Care needs to be taken with closures because compiled languages typically have a different way of handling lifetimes of objects. You have to make sure that if the compiled code is going to call a closure that the closure object is still in scope somewhere, or has been made sticky, otherwise you may get a segment violation or other mysterious crash. =head1 CONSTRUCTOR =head2 new my $closure = FFI::Platypus::Closure->new($coderef); Create a new closure object; C<$coderef> must be a subroutine code reference. =head1 METHODS =head2 call $closure->call(@arguments); $closure->(@arguments); Call the closure from Perl space. May also be invoked by treating the closure object as a code reference. =head2 sticky $closure->sticky; Mark the closure sticky, meaning that it won't be free'd even if all the reference of the object fall out of scope. =head2 unstick $closure->unstick; Unmark the closure as sticky. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Constant.pm000644 000765 000024 00000011104 13616651126 021440 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Constant; use strict; use warnings; use constant 1.32 (); use FFI::Platypus; # ABSTRACT: Define constants in C space for Perl our $VERSION = '1.10'; # VERSION { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->bundle; $ffi->type( 'opaque' => 'ffi_platypus_constant_t' ); $ffi->type( '(string,string)->void' => 'set_str_t' ); $ffi->type( '(string,sint64)->void' => 'set_sint_t' ); $ffi->type( '(string,uint64)->void' => 'set_uint_t' ); $ffi->type( '(string,double)->void' => 'set_double_t' ); $ffi->mangler(sub { my($name) = @_; $name =~ s/^/ffi_platypus_constant__/; $name; }); $ffi->attach( new => [ 'set_str_t', 'set_sint_t', 'set_uint_t', 'set_double_t' ] => 'ffi_platypus_constant_t' => sub { my($xsub, $class, $default_package) = @_; my $f = $ffi->closure(sub { my($name, $value) = @_; if($name !~ /::/) { $name = join('::', $default_package, $name); } constant->import($name, $value); }); bless { ptr => $xsub->($f, $f, $f, $f), f => $f, }, $class; }); $ffi->attach( DESTROY => ['ffi_platypus_constant_t'] => 'void' => sub { my($xsub, $self) = @_; $xsub->($self->ptr); }); sub ptr { shift->{ptr} } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Constant - Define constants in C space for Perl =head1 VERSION version 1.10 =head1 SYNOPSIS C: #include void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c) { c->set_str("FOO", "BAR"); /* sets $package::FOO to "BAR" */ c->set_str("ABC::DEF", "GHI"); /* sets ABC::DEF to GHI */ } C: package Foo; use strict; use warnings; use FFI::Platypus; use base qw( Exporter ); my $ffi = FFI::Platypus->new; # sets constatns Foo::FOO and ABC::DEF from C $ffi->bundle; 1; =head1 DESCRIPTION The Platypus bundle interface (see L) has an entry point C that lets you define constants in Perl space from C. void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c); The first argument C is the name of the Perl package. The second argument C is a struct with function pointers that lets you define constants of different types. The first argument for each function is the name of the constant and the second is the value. If C<::> is included in the constant name then it will be defined in that package space. If it isn't then the constant will be defined in whichever package called C. =over 4 =item set_str c->set_str(name, value); Sets a string constant. =item set_sint c->set_sint(name, value); Sets a 64-bit signed integer constant. =item set_uint c->set_uint(name, value); Sets a 64-bit unsigned integer constant. =item set_double c->set_double(name, value); Sets a double precision floating point constant. =back =head2 Example Suppose you have a header file C: #ifndef MYHEADER_H #define MYHEADER_H #define MYVERSION_STRING "1.2.3" #define MYVERSION_MAJOR 1 #define MYVERSION_MINOR 2 #define MYVERSION_PATCH 3 enum { MYBAD = -1, MYOK = 1 }; #define MYPI 3.14 #endif You can define these constants from C: #include #include "myheader.h" void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c) { c->set_str("MYVERSION_STRING", MYVERSION_STRING); c->set_uint("MYVERSION_MAJOR", MYVERSION_MAJOR); c->set_uint("MYVERSION_MINOR", MYVERSION_MINOR); c->set_uint("MYVERSION_PATCH", MYVERSION_PATCH); c->set_sint("MYBAD", MYBAD); c->set_sint("MYOK", MYOK); c->set_double("MYPI", MYPI); } Your Perl code doesn't have to do anything when calling bundle: package Const; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->bundle; } 1; =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Declare.pm000644 000765 000024 00000025461 13616651126 021221 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Declare; use strict; use warnings; use Carp (); use FFI::Platypus; # ABSTRACT: Declarative interface to FFI::Platypus our $VERSION = '1.10'; # 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 $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, $wrapper); $function->attach($perl_name, $proto); (); } sub closure (&) { my($coderef) = @_; require FFI::Platypus::Closure; FFI::Platypus::Closure->new($coderef); } sub sticky ($) { my($closure) = @_; Carp::croak("usage: sticky \$closure") unless defined $closure && ref($closure) eq 'FFI::Platypus::Closure'; $closure->sticky; $closure; } 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 1.10 =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. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/DL.pm000644 000765 000024 00000012732 13616651126 020156 0ustar00ollisgstaff000000 000000 package FFI::Platypus::DL; use strict; use warnings; use 5.008001; use base qw( Exporter ); require FFI::Platypus; our @EXPORT = qw( dlopen dlerror dlsym dlclose ); push @EXPORT, grep /RTLD_/, keys %FFI::Platypus::DL::; # ABSTRACT: Slightly non-portable interface to libdl our $VERSION = '1.10'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::DL - Slightly non-portable interface to libdl =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Platypus; use FFI::Platypus::DL; my $handle = dlopen("./libfoo.so", RTLD_PLATYPUS_DEFAULT); my $address = dlsym($handle, "my_function_named_foo"); my $ffi = FFI::Platypus->new( api => 1 ); $ffi->function($address => [] => 'void')->call; dlclose($handle); =head1 DESCRIPTION This module provides an interface to libdl, the dynamic loader on UNIX. The underlying interface has always been used by L, but it wasn't a public interface until version 0.52. The name was changed with that version when it became a public interface, so be sure to specify that version if you are going to use it. It is somewhat non-portable for these reasons: =over 4 =item GNU extensions It provides some GNU extensions to platforms such as Linux that support them. =item Windows It provides an emulation layer on Windows. The emulation layer only supports C as a flag. The emulation layer emulates the convention described below of passing C as the dynamic library name to mean, use the currently running executable. I've used it without any problems for years, but Windows is not my main development platform. =back =head1 FUNCTIONS =head2 dlopen my $handle = dlopen($filename, $flags); This opens a dynamic library in the context of the dynamic loader. C<$filename> is the full or relative path to a dynamic library (usually a C<.so> on Linux and some other UNIXen, a C<.dll> on Windows and a C<.dylib> on OS X). C<$flags> are flags that can be used to alter the behavior of the library and the symbols it contains. The return value is an opaque pointer or C<$handle> which can be used to look up symbols with C. The handle should be closed with C when you are done with it. By convention if you pass in C for the filename, the currently loaded executable will be used instead of a separate dynamic library. This is the easiest and most portable way to find the address of symbols in the standard C library. This convention is baked into most UNIXen, but this capability is emulated in Windows which doesn't come with the capability out of the box. If there is an error in opening the library then C will be returned and the diagnostic for the failure can be retrieved with C as described below. Not all flags are supported on all platforms. You can test if a flag is available using can: if(FFI::Platypus::DL->can('RTLD_LAZY')) { ... } Typically where flags are not mutually exclusive, they can be or'd together: my $handle = dlopen("libfoo.so", RTLD_LAZY | RTLD_GLOBAL); Check your operating system documentation for detailed descriptions of these flags. =over 4 =item RTLD_PLATYPUS_DEFAULT This is the L default for C (NOTE: NOT the libdl default). This is the only flag supported on Windows. For historical reasons, this is usually C on Unix and C<0> on Windows. =item RTLD_LAZY Perform lazy binding. =item RTLD_NOW Resolve all symbols before returning from C. Error if all symbols cannot resolve. =item RTLD_GLOBAL Symbols are shared. =item RTLD_LOCAL Symbols are NOT shared. =item RTLD_NODELETE glibc 2.2 extension. =item RTLD_NOLOAD glibc 2.2 extension. =item RTLD_DEEPBIND glibc 2.3.4 extension. =back =head2 dlsym my $opaque = dlsym($handle, $symbol); This looks up the given C<$symbol> in the library pointed to by C<$handle>. If the symbol is found, the address for that symbol is returned as an opaque pointer. This pointer can be passed into the L C and C methods instead of a function name. If the symbol cannot be found then C will be returned and the diagnostic for the failure can be retrieved with C as described below. =head2 dlclose my $status = dlclose($handle); On success, C returns 0; on error, it returns a nonzero value, and the diagnostic for the failure can be retrieved with C as described below. =head2 dlerror my $error_string = dlerror; Returns the human readable diagnostic for the reason for the failure for the most recent C
prefixed function call. =head1 CAVEATS Some flags for C are not portable. This module may not be supported platforms added to L in the future. It does work as far as I know on all of the currently supported platforms. =head1 SEE ALSO =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Function.pm000644 000765 000024 00000007410 13616651126 021441 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Function; use strict; use warnings; use FFI::Platypus; # ABSTRACT: An FFI function object our $VERSION = '1.10'; # VERSION use overload '&{}' => sub { my $ffi = shift; sub { $ffi->call(@_) }; }, 'bool' => sub { my $ffi = shift; return $ffi; }, fallback => 1; package FFI::Platypus::Function::Function; use base qw( FFI::Platypus::Function ); sub attach { my($self, $perl_name, $proto) = @_; my $frame = -1; my($caller, $filename, $line); do { ($caller, $filename, $line) = caller(++$frame); } while( $caller =~ /^FFI::Platypus(|::Function|::Function::Wrapper|::Declare)$/ ); $perl_name = join '::', $caller, $perl_name unless $perl_name =~ /::/; $self->_attach($perl_name, "$filename:$line", $proto); $self; } sub sub_ref { my($self) = @_; my $frame = -1; my($caller, $filename, $line); do { ($caller, $filename, $line) = caller(++$frame); } while( $caller =~ /^FFI::Platypus(|::Function|::Function::Wrapper|::Declare)$/ ); $self->_sub_ref("$filename:$line"); } package FFI::Platypus::Function::Wrapper; use base qw( FFI::Platypus::Function ); sub new { my($class, $function, $wrapper) = @_; bless [ $function, $wrapper ], $class; } sub call { my($function, $wrapper) = @{ shift() }; @_ = ($function, @_); goto &$wrapper; } sub attach { my($self, $perl_name, $proto) = @_; my($function, $wrapper) = @{ $self }; unless($perl_name =~ /::/) { my $caller; my $frame = -1; do { $caller = caller(++$frame) } while( $caller =~ /^FFI::Platypus(|::Declare)$/ ); $perl_name = join '::', $caller, $perl_name } my $xsub = $function->sub_ref; { my $code = sub { unshift @_, $xsub; goto &$wrapper; }; if(defined $proto) { _set_prototype($proto, $code); } no strict 'refs'; *{$perl_name} = $code; } $self; } sub sub_ref { my($self) = @_; my($function, $wrapper) = @{ $self }; my $xsub = $function->sub_ref; return sub { unshift @_, $xsub; goto &$wrapper; }; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Function - An FFI function object =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Platypus; # call directly my $ffi = FFI::Platypus->new( api => 1 ); my $f = $ffi->function(puts => ['string'] => 'int'); $f->call("hello there"); # attach as xsub and call (faster for repeated calls) $f->attach('puts'); puts('hello there'); =head1 DESCRIPTION This class represents an unattached platypus function. For more context and better examples see L. =head1 METHODS =head2 attach $f->attach($name); $f->attach($name, $prototype); Attaches the function as an xsub (similar to calling attach directly from an L instance). You may optionally include a prototype. =head2 call my $ret = $f->call(@arguments); my $ret = $f->(@arguments); Calls the function and returns the result. You can also use the function object B a code reference. =head2 sub_ref my $code = $f->sub_ref; Returns an anonymous code reference. This will usually be faster than using the C method above. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Internal.pm000644 000765 000024 00000002443 13616651126 021431 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Internal; use strict; use warnings; use 5.008001; use FFI::Platypus; use base qw( Exporter ); require FFI::Platypus; _init(); our @EXPORT = grep /^FFI_PL/, keys %FFI::Platypus::Internal::; # ABSTRACT: For internal use only our $VERSION = '1.10'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Internal - For internal use only =head1 VERSION version 1.10 =head1 SYNOPSIS perldoc FFI::Platypus =head1 DESCRIPTION This module is for internal use only. Do not rely on it having any particular behavior, or even existing in future versions. You have been warned. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Lang/000755 000765 000024 00000000000 13616651126 020175 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Platypus/Lang.pm000644 000765 000024 00000002673 13616651126 020543 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Lang; use strict; use warnings; use 5.008001; # ABSTRACT: Language specific customizations our $VERSION = '1.10'; # VERSION 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Lang - Language specific customizations =head1 VERSION version 1.10 =head1 SYNOPSIS perldoc FFI::Platypus::Lang; =head1 DESCRIPTION This namespace is reserved for language specific customizations of L. This usually involves providing native type maps. It can also involve computing mangled names. The default language is C, and is defined in L. This package itself doesn't do anything, it serves only as documentation. =head1 SEE ALSO =over 4 =item L =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Legacy.pm000644 000765 000024 00000004245 13616651126 021063 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Legacy; use strict; use warnings; # ABSTRACT: Legacy Platypus interfaces our $VERSION = '1.10'; # VERSION package FFI::Platypus; sub _package { my($self, $module, $modlibname) = @_; ($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 { my @maybe = ( "$modlibname/auto/$modpname/$modfname.txt", "$modlibname/../arch/auto/$modpname/$modfname.txt", ); foreach my $file (@maybe) { if(-f $file) { open my $fh, '<', $file; my $line = <$fh>; close $fh; if($line =~ /^FFI::Build\@(.*)$/) { $self->lib("$modlibname/$1"); return $self; } } } } require FFI::Platypus::ShareConfig; my @dlext = @{ FFI::Platypus::ShareConfig->get("config_dlext") }; 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; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Legacy - Legacy Platypus interfaces =head1 VERSION version 1.10 =head1 DESCRIPTION This class is private to L. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Memory.pm000644 000765 000024 00000011316 13616651126 021124 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Memory; use strict; use warnings; use FFI::Platypus; use base qw( Exporter ); # ABSTRACT: Memory functions for FFI our $VERSION = '1.10'; # VERSION our @EXPORT = qw( malloc free calloc realloc memcpy memset strdup strndup ); my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib(undef); $ffi->bundle; sub _ffi { $ffi } $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' => '$$$'); my $_strdup_impl = 'not-loaded'; sub _strdup_impl { $_strdup_impl } eval { die "do not use c impl" if ($ENV{FFI_PLATYPUS_MEMORY_STRDUP_IMPL}||'libc') eq 'ffi'; $ffi->attach(strdup => ['string'] => 'opaque' => '$'); $_strdup_impl = 'libc'; }; if($@) { $_strdup_impl = 'ffi'; $ffi->attach([ ffi_platypus_memory__strdup => 'strdup' ] => ['string'] => 'opaque' => '$'); } my $_strndup_impl = 'not-loaded'; sub _strndup_impl { $_strndup_impl } eval { die "do not use c impl" if ($ENV{FFI_PLATYPUS_MEMORY_STRDUP_IMPL}||'libc') eq 'ffi'; $ffi->attach(strndup => ['string','size_t'] => 'opaque' => '$$'); $_strndup_impl = 'libc'; }; if($@) { $_strndup_impl = 'ffi'; $ffi->attach([ ffi_platypus_memory__strndup => 'strndup' ] => ['string','size_t'] => 'opaque' => '$$'); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Memory - Memory functions for FFI =head1 VERSION version 1.10 =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. It works mostly with the C type and it is worth reviewing the section on opaque pointers in L. =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. =head2 strndup my $pointer = strndup $string, $max; The same as C above, except at most C<$max> characters will be copied in the new string. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Record/000755 000765 000024 00000000000 13616651126 020532 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Platypus/Record.pm000644 000765 000024 00000024541 13616651126 021076 0ustar00ollisgstaff000000 000000 package 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 record_layout_1 ); # ABSTRACT: FFI support for structured records data our $VERSION = '1.10'; # VERSION sub record_layout_1 { if(@_ % 2 == 0) { my $ffi = FFI::Platypus->new( api => 1 ); unshift @_, $ffi; goto &record_layout; } elsif(defined $_[0] && ref($_[0]) eq 'ARRAY') { my @args = @{ shift @_ }; unshift @args, api => 1; unshift @_, \@args; goto &record_layout; } elsif(defined $_[0] && eval { $_[0]->isa('FFI::Platypus') }) { goto &record_layout; } else { croak "odd number of arguments, but first argument is not either an array reference or Platypus instance"; } } sub record_layout { my $ffi; if(defined $_[0]) { if(ref($_[0]) eq 'ARRAY') { my @args = @{ shift() }; $ffi = FFI::Platypus->new(@args); } elsif(eval { $_[0]->isa('FFI::Platypus') }) { $ffi = shift; } } $ffi ||= 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; my @ffi_types; while(@_) { my $spec = shift; my $name = shift; my $type = $ffi->{tp}->parse( $spec, { member => 1 } ); 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 = $type->sizeof; my $align = $type->alignof; $record_align = $align if $align > $record_align; my $meta = $type->meta; $offset++ while $offset % $align; { my $count; my $ffi_type; if($meta->{type} eq 'record') # this means fixed string atm { $ffi_type = 'sint8'; $count = $size; } else { $ffi_type = $meta->{ffi_type}; $count = $meta->{element_count}; $count = 1 unless defined $count; } push @ffi_types, $ffi_type for 1..$count; } if($name ne ':') { if($meta->{type} eq 'string' && $meta->{access} eq 'rw') { push @destroy, eval '# line '. __LINE__ . ' "' . __FILE__ . qq("\n) .qq{ sub { shift->$name(undef); }; }; die $@ if $@; } my $full_name = join '::', $caller, $name; my $error_str = _accessor $full_name, "$filename:$line", $type, $offset; croak("$error_str ($spec $name)") 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, '_ffi_record_ro'} = \&_ffi_record_ro; *{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; }; { require FFI::Platypus::Record::Meta; my $ffi_meta = FFI::Platypus::Record::Meta->new( \@ffi_types, ); *{join '::', $caller, '_ffi_meta'} = sub { $ffi_meta }; } my $destroy_sub = sub {}; if(@destroy) { $destroy_sub = sub { return if _ffi_record_ro($_[0]); $_->($_[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 1.10 =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_1(qw( int age string(3) title string_rw name )); package main; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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_1 record_layout_1($ffi, $type => $name, ... ); record_layout_1(\@ffi_args, $type => $name, ... ); record_layout_1($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. Alternatively you may provide constructor arguments that will be passed to the internal platypus instance. Thus this is the same: my $ffi = FFI::Platypus->new( lang => 'Rust', api => 1 ); record_layout_1( $ffi, ... ); # same as: record_layout_1( [ lang => 'Rust' ], ... ); and this is the same: my $ffi = FFI::Platypus->new( api => 1 ); record_layout_1( $ffi, ... ); # same as: record_layout_1( ... ); 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_1( 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_1( '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_1( '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_1( '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_1( '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 =head2 record_layout record_layout($ffi, $type => $name, ... ); record_layout(\@ffi_args, $type => $name, ... ); record_layout($type => $name, ... ); This function works like C except that C 0> is used instead of C 1>. All new code should use C instead. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/ShareConfig.pm000644 000765 000024 00000003451 13616651126 022045 0ustar00ollisgstaff000000 000000 package FFI::Platypus::ShareConfig; use strict; use warnings; use File::Spec; our $VERSION = '1.10'; # VERSION sub dist_dir ($) { my($dist_name) = @_; my @pm = split /-/, $dist_name; $pm[-1] .= ".pm"; foreach my $inc (@INC) { if(-f File::Spec->catfile($inc, @pm)) { my $share = File::Spec->catdir($inc, qw( auto share dist ), $dist_name ); if(-d $share) { return File::Spec->rel2abs($share); } last; } } Carp::croak("unable to find dist share directory for $dist_name"); } sub get { my(undef, $name) = @_; my $config; unless($config) { my $fn = File::Spec->catfile(dist_dir('FFI-Platypus'), 'config.pl'); $fn = File::Spec->rel2abs($fn) unless File::Spec->file_name_is_absolute($fn); local $@; unless($config = do $fn) { die "couldn't parse configuration $fn $@" if $@; die "couldn't do $fn $!" if $!; die "bad or missing config file $fn"; }; } defined $name ? $config->{$name} : $config; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::ShareConfig =head1 VERSION version 1.10 =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Type/000755 000765 000024 00000000000 13616651126 020235 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Platypus/Type.pm000644 000765 000024 00000117660 13616651126 020606 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Type; use strict; use warnings; use Carp qw( croak ); require FFI::Platypus; # ABSTRACT: Defining types for FFI::Platypus our $VERSION = '1.10'; # VERSION # The TypeParser and Type classes are used internally ONLY and # are not to be exposed to the user. External users should # not under any circumstances rely on the implementation of # these classes. sub alignof { my($self) = @_; my $meta = $self->meta; # TODO: it is possible, though complicated # to compute the alignment of a struct # type record. croak "cannot determine alignment of record" if $meta->{type} eq 'record' && $meta->{ref} == 1; my $ffi_type; if($meta->{type} eq 'pointer') { $ffi_type = 'pointer'; } elsif($meta->{type} eq 'record') { $ffi_type = 'uint8'; } else { $ffi_type = $meta->{ffi_type}; } require FFI::Platypus::ShareConfig; FFI::Platypus::ShareConfig->get('align')->{$ffi_type}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Type - Defining types for FFI::Platypus =head1 VERSION version 1.10 =head1 SYNOPSIS OO Interface: use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('int' => 'my_int'); =head1 DESCRIPTION B: This document assumes that you are using C 1>, which you should be using for all new code. This document describes how to define types using L. Types may be "defined" ahead of time, or simply used when defining or attaching functions. # Example of defining types use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('int'); $ffi->type('string'); # Example of simply using types in function declaration or attachment my $f = $ffi->function(puts => ['string'] => 'int'); $ffi->attach(puts => ['string'] => 'int'); Unless you are using aliases the L method is not necessary, but they will throw an exception if the type is incorrectly specified or not supported, which may be helpful for determining if the types are available or not. 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. my $intsize = $ffi->sizeof('int'); # usually 4 my $intarraysize = $ffi->sizeof('int[64]'); # usually 256 =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: my $address = $ffi->cast('string' => 'opaque', $string); This converts a Perl string to a pointer address that can be used by functions that take an C type. Be carefully though that the Perl string is not resized or free'd while in use from C code. my $string = $ffi->cast('opaque' => 'string', $pointer); This does the opposite, converting a null terminated string (the type of strings used by C) into a Perl string. In this case the string is copied, so the other language is free to deallocate or otherwise manipulate the string after the conversion without adversely affecting the Perl. =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 can be used to define a type alias that can later be used by function declaration and attachment. use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('int' => 'myint'); $ffi->type('string' => 'mystring'); my $f = $ffi->function( puts => ['mystring'] => 'myint' ); $ffi->attach( puts => ['mystring'] => 'myint' ); Aliases are contained without the L object, so feel free to define your own crazy types without stepping on the toes of other CPAN developers using Platypus. One useful application of an alias is when you know types are different on two different platforms: if($^O eq 'MSWin32') { $type->type('sint16' => 'foo_t'); } elsif($^O eq 'linux') { $type->type('sint32' => 'foo_t'); } # function foo takes 16 bit signed integer on Windows # and a 32 bit signed integer on Linux. $ffi->attach( foo => [ 'foo_t' ] => 'void' ); =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). $ffi->type( foo => [] => 'void' ); Newer versions of Platypus also allow you to omit the return type and C is assumed. $ffi->type( foo => [] ); It doesn't really make sense to use C in any other context. However, because of historical reasons involving older versions of Perl. It doesn't really make sense for C to be passed in as an argument. However, because C functions that take no arguments frequently are specified as taking C as this was required by older C compilers, as a special case you can specify a function's arguments as taking a single C to mean it takes no arguments. # C: void foo(void); $ffi->type( foo => ['void'] ); # same (but probably better) $ffi->type( foo => [] ); =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: $ffi->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 Enum types C provides enumerated types, which are typically implemented as integer types. enum { BAR = 1, BAZ = 2 } foo_t; void f(enum foo_t foo); Platypus provides C and C types for the integer types used to represent enum and signed enum types respectively. use constant BAR => 1; use constant BAZ => 2; $ffi->attach( f => [ 'enum' ] => 'void' ); f(BAR); f(BAZ); When do you use C? Anytime the enum has negative values: enum { BAR = -1; BAZ = 2; } foo_t; void f(enum foo_t foo); Perl: use constant BAR => -1; use constant BAZ => 2; $ffi->attach( f => [ 'senum' ] => 'void' ); f(BAR); f(BAZ); Dealing with enumerated values with FFI can be tricky because these are usually defined in C header files and cannot be found in dynamic libraries. For trivial usage you can do as illustrated above, simply define your own Perl constants. For more complicated usage, or where the values might vary from platform to platform you may want to consider the new Platypus bundle interface to define Perl constants (essentially the same as an enumerated value) from C space. This is more reliable, but does require a compiler at install time. See L for details. The main FAQ (L) also has a discussion on dealing with constants and enumerated types. =head3 Boolean types At install time Platypus attempts to detect the correct type for C for your platform, and you can use that. C is really an integer type, but the type used varies from platform to platform. C header: #include bool foo(); Platypus $ffi->attach( foo => [] => 'bool' ); If you get an exception when trying to use this type it means you either have a very old version of Platypus, or for some reason it was unable to detect the correct type at install time. Please open a ticket if that is the case. =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 =head3 opaque pointers Opaque pointers are simply a pointer to a region of memory that you do not manage, and do not know or care about its structure. 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, although this is discouraged. (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. C header: struct archive; struct archive *archive_read_new(void); struct archive *archive_write_new(void); int archive_free(struct archive *); int archive_write_free(struct archive *); Perl code: $lib->find_lib( lib => 'archive' ); $ffi->attach(archive_read_new => [] => 'opaque'); $ffi->attach(archive_write_new => [] => 'opaque'); $ffi->attach(archive_read_free => ['opaque'] => 'int'); $ffi->attach(archive_write_free => ['opaque'] => 'int'); It is often useful to alias an C type like this so that you know what the object represents: $lib->find_lib( lib => 'archive' ); $ffi->type('opaque' => 'archive'); $ffi->attach(archive_read_new => [] => 'archive'); $ffi->attach(archive_read_free => ['archive'] => '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. There are a number of useful utility functions for dealing with opaque types in the L module. =head2 Objects Object types are thin wrappers around two native types: integer and C types. They are just blessed references around either of those two types so that methods can be defined on them, but when they get passed to a Platypus xsub they are converted into the native integer or C types. This type is most useful when a API provides an OO style interface with an integer or C value acting as an instance of a class. There are two detailed examples in the main Platypus documentation using libarchive and unix open: =over 4 =item L =item L =back =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. $ffi->attach( puts => [ 'string' ] => 'int' ); The pointer passed into C (or other language) is to the content of the actual scalar, which means it can modify the content of a scalar. B: When used as a return type, the string is I into a new scalar rather than using the original address. This is due to the ownership model of scalars in Perl, but it is also most of the time what you want. This can be problematic when a function returns a string that the callee is expected to free. Consider the functions: char * get_string() { char *buffer; buffer = malloc(20); strcpy(buffer, "Perl"); } void free_string(char *buffer) { free(buffer); } This API returns a string that you are expected to free when you are done with it. (At least they have provided an API for freeing the string instead of expecting you to call libc free)! A simple binding to get the string would be: $ffi->attach( get_string => [] => 'string' ); # memory leak my $str = get_string(); Which will work to a point, but the memory allocated by get_string will leak. Instead you need to get the opaque pointer, cast it to a string and then free it. $ffi->attach( get_string => [] => 'opaque' ); $ffi->attach( free_string => ['opaque'] => 'void' ); my $ptr = get_string(); my $str = $ffi->cast( 'opaque' => 'string', $ptr ); # copies the string free_string($ptr); If you are doing this sort of thing a lot, it can be worth adding a custom type: $ffi->attach( free_string => ['opaque'] => 'void' ); $ffi->custom_type( 'my_string' => { native_type => 'opaque', native_to_perl => sub { my($ptr) = @_; my $str = $ffi->cast( 'opaque' => 'string', $ptr ); # copies the string free_string($ptr); $str; } }); $ffi->attach( get_string => [] => 'my_string' ); my $str = get_string(); Since version 0.62, pointers and arrays to strings are supported as a first class type. Prior to that L and L could be used, though their use in new code is discouraged. $ffi->attach( foo => ['string[]'] => 'void' ); foo( [ 'array', 'of', 'strings' ] ); $ffi->attach( bar => ['string*'] => 'void' ); my $string = 'baz'; bar( \$string ); # $string may be modified. Strings are not allowed as return types from closure. This, again is due to the ownership model of scalars in Perl. (There is no way for Perl to know when calling language is done with the memory allocated to the string). Consider the API: typedef const char *(*get_message_t)(void); void print_message(get_message_t get_message) { const char *str; str = get_message(); printf("message = %s\n", str); } It feels like this should be able to work: $ffi->type('()->string' => 'get_message_t'); # not ok $ffi->attach( print_message => ['get_message_t'] => 'void' ); my $get_message = $ffi->closure(sub { return "my message"; }); print_message($get_message); If the type declaration for C were legal, then this script would likely segfault or in the very least corrupt memory. The problem is that once C<"my message"> is returned from the closure Perl doesn't have a reference to it anymore and will free it. To do this safely, you have to keep a reference to the scalar around and return an opaque pointer to the string using a cast. $ffi->type('()->opaque' => 'get_message_t'); $ffi->attach( print_message => ['get_message_t'] => 'void' ); my $get_message => $ffi->closure(sub { our $message = "my message"; # needs to be our so that it doesn't # get free'd my $ptr = $ffi->cast('string' => 'opaque', $message); return $ptr; }); print_message($get_message); =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 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 to any native, string or record type. You cannot (at least not yet) define a pointer to a pointer or a pointer to an array or any other type not otherwise supported. When passing in a pointer to something you must make sure to pass in a reference to a scalar, or C (C will be translated int 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; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib('libfoo.so'); # change to reflect the dynamic lib # that contains foo.c $ffi->type('int*' => 'int_p'); $ffi->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" Older versions of Platypus did not support pointers to strings or records. =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_1(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( api => 1 ); $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( api => 1 ); $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( api => 1 ); $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. The examples in this section actually use pointers to records (note the trailing star C<*> in the declarations). Most programming languages allow you to pass or return a record as either pass-by-value or as a pointer (pass-by-reference). C code: struct { int a; } foo_t; void pass_by_value_example( struct foo_t foo ); void pass_by_reference_example( struct foo_t *foo ); Perl code: { package Foo; use FFI::Platypus::Record; record_layout_1( int => 'a' ); } $ffi->type( 'Record(Foo)' => 'foo_t' ); $ffi->attach( pass_by_value_example => [ 'foo_t' ] => 'void' ); $ffi->attach( pass_by_reference_example => [ 'foo_t*' ] => 'void' ); As with strings, functions that return a pointer to a record are actually copied. C code: struct foo_t *return_struct_pointer_example(); Perl code: $ffi->attach( return_struct_pointer_example => [] => 'foo_t*' ); my $foo = return_struct_pointer_example(); # $foo is a copy of the record returned by the function. As with strings, if the API expects you to free the record it returns (it is misbehaving a little, but lets set that aside), then you can work around this by returning an C type, casting to the record, and finally freeing the original pointer. use FFI::Platypus::Memory qw( free ); $ffi->attach( return_struct_pointer_example => [] => 'opaque' ); my $foo_ptr = return_struct_pointer_example(); my $foo = $ffi->cast( 'opaque' => 'foo_t*', $foo_ptr ); free $foo_ptr; =head2 Fixed length arrays Fixed length arrays of native types and strings 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( api => 1 ); $ffi->lib(undef); $ffi->attach([pipe=>'mypipe'] => ['int[2]'] => 'int'); my @fd = (0,0); mypipe(\@fd); my($fd1,$fd2) = @fd; print "$fd1 $fd2\n"; Because of the way records are implemented, an array of records does not make sense and is not currently supported. =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; i < size; i++) { total += array[i]; } return total; } Can be called from Perl like this: use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ) $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. Because of the way records are implemented, an array of records does not make sense and is not currently supported. =head2 Closures A closure (sometimes called a "callback", 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: [ version 0.54 ] EXPERIMENTAL: As of version 0.54, the record type (see L) is also experimentally supported as a closure argument type. One caveat is that the record member type string_rw is NOT supported and probably never will be. /* * 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( api => 1 ); $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( api => 1 ); $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($ffi->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 method to keep the closure, without the need to keep a reference of the closure: { my $closure = $ffi->closure(sub { $_[0] * 2 }); $closure->sticky; set_closure($closure); # OKAY } # closure still exists and is accesible from C, but # not from Perl land. =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(); The challenge is here that once the source is processed by the C pre-processor the name/value mappings for these C constants are lost. There is no way to fetch them from the library once it is compiled and linked. One common way of implementing this would be to create and export constants in your Perl module, like this: package Foo; use FFI::Platypus; 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; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->attach(foo => ['int'] => 'void'); $ffi->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; our @EXPORT_OK = qw( foo get_foo ); my %foo_types = ( static => 1, dynamic => 2, other => 3, ); my %foo_types_reverse = reverse %foo_types; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->custom_type(foo_t => { native_type => 'int', native_to_perl => sub { $foo_types{$_[0]}; }, perl_to_native => sub { $foo_types_reverse{$_[0]}; }, }); $ffi->attach(foo => ['foo_t'] => 'void'); $ffi->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'); If the library that you are using has a lot of these constants you can try using L or another C header parser to obtain the appropriate name/value pairings for the constants that you need. =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; use FFI::Platypus::API qw( arguments_get_string ); my $ffi = FFI::Platypus->new( api => 1 ); $ffi->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]} }, }); $ffi->attach([ foo_new => 'new' ] => [ 'string' ] => 'foo_t' ); $ffi->attach([ foo_method => 'method' ] => [ 'foo_t', 'int' ] => 'void'); $ffi->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. A 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. =head1 SEE ALSO =over 4 =item L Main platypus documentation. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/TypeParser/000755 000765 000024 00000000000 13616651126 021412 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Platypus/TypeParser.pm000644 000765 000024 00000006151 13616651126 021753 0ustar00ollisgstaff000000 000000 package FFI::Platypus::TypeParser; use strict; use warnings; use List::Util 1.45 qw( uniqstr ); use Carp qw( croak ); # ABSTRACT: FFI Type Parser our $VERSION = '1.10'; # VERSION # The TypeParser and Type classes are used internally ONLY and # are not to be exposed to the user. External users should # not under any circumstances rely on the implementation of # these classes. sub new { my($class) = @_; my $self = bless { types => {}, type_map => {} }, $class; $self->build; $self; } sub build {} our %basic_type; # this just checks if the underlying libffi/platypus implementation # has the basic type. It is used mainly to verify that exotic types # like longdouble and complex_float are available before the test # suite tries to use them. sub have_type { my(undef, $name) = @_; !!$basic_type{$name}; } sub create_type_custom { my($self, $basic_type_name, @rest) = @_; my $tm = $self->type_map->{$basic_type_name||'opaque'}; croak "$basic_type_name is not a legal native type for a custom type" unless $tm; my $basic = $self->global_types->{basic}->{$tm} || croak "$basic_type_name is not a legal native type for a custom type"; $self->_create_type_custom($basic->type_code, @rest); } # this is the type map provided by the language plugin, if any # in addition to the basic types (which map to themselves). sub type_map { my($self, $new) = @_; if(defined $new) { $self->{type_map} = $new; } $self->{type_map}; } # this stores the types that have been mentioned so far. It also # usually includes aliases. sub types { shift->{types}; } { my %store; foreach my $name (keys %basic_type) { my $type_code = $basic_type{$name}; $store{basic}->{$name} = __PACKAGE__->create_type_basic($type_code); $store{ptr}->{$name} = __PACKAGE__->create_type_pointer($type_code); $store{rev}->{$type_code} = $name; } sub global_types { \%store; } } # list all the types that this type parser knows about, including # those provided by the language plugin (if any), those defined # by the user, and the basic types that everyone gets. sub list_types { my($self) = @_; uniqstr( ( keys %{ $self->type_map } ), ( keys %{ $self->types } ) ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::TypeParser - FFI Type Parser =head1 VERSION version 1.10 =head1 DESCRIPTION This class is private to FFI::Platypus. See L for the public interface to Platypus types. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/TypeParser/Version0.pm000644 000765 000024 00000015043 13616651126 023460 0ustar00ollisgstaff000000 000000 package FFI::Platypus::TypeParser::Version0; use strict; use warnings; use Carp qw( croak ); use base qw( FFI::Platypus::TypeParser ); # ABSTRACT: FFI Type Parser Version Zero our $VERSION = '1.10'; # VERSION our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser ); # The type parser is responsible for deciding if something is a legal # alias name. Since this needs to be checked before the type is parsed # it is separate from set_alias below. sub check_alias { my($self, $alias) = @_; croak "spaces not allowed in alias" if $alias =~ /\s/; croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/; croak "alias \"$alias\" conflicts with existing type" if defined $self->type_map->{$alias} || $self->types->{$alias}; return 1; } sub set_alias { my($self, $alias, $type) = @_; $self->types->{$alias} = $type; } # This method takes a string representation of the a type and # returns the internal platypus type representation. sub parse { my($self, $name) = @_; return $self->types->{$name} if defined $self->types->{$name}; # Darmock and Legacy Code at Tanagra unless($name =~ /-\>/ || $name =~ /^record\s*\([0-9A-Z:a-z_]+\)$/ || $name =~ /^string(_rw|_ro|\s+rw|\s+ro|\s*\([0-9]+\))$/) { my $basic = $name; my $extra = ''; if($basic =~ s/\s*((\*|\[|\<).*)$//) { $extra = " $1"; } if(defined $self->type_map->{$basic}) { my $new_name = $self->type_map->{$basic} . $extra; if($new_name ne $name) { # hopefully no recursion here. return $self->types->{$name} = $self->parse($new_name); } } } if($name =~ m/^ \( (.*) \) \s* -\> \s* (.*) \s* $/x) { my @argument_types = map { $self->parse($_) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $1; my $return_type = $self->parse($2); return $self->types->{$name} = $self->create_type_closure($return_type, @argument_types); } if($name =~ /^ string \s* \( ([0-9]+) \) $/x) { return $self->types->{$name} = $self->create_type_record( $1, # size undef, # record_class ); } if($name =~ /^ string ( _rw | _ro | \s+ro | \s+rw | ) $/x) { return $self->types->{$name} = $self->create_type_string( defined $1 && $1 =~ /rw/ ? 1 : 0, # rw ); } if($name =~ /^ record \s* \( ([0-9]+) \) $/x) { return $self->types->{$name} = $self->create_type_record( $1, # size undef, # record_class ); } if($name =~ /^ record \s* \( ([0-9:A-Za-z_]+) \) $/x) { my $size; my $classname = $1; unless($classname->can('ffi_record_size') || $classname->can('_ffi_record_size')) { my $pm = "$classname.pm"; $pm =~ s/\//::/g; require $pm; } 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"; } return $self->global_types->{record}->{$classname} ||= $self->create_type_record( $size, # size $classname, # record_class ); } # array types if($name =~ /^([\S]+)\s+ \[ ([0-9]*) \] $/x) { my $size = $2 || ''; my $basic = $self->global_types->{basic}->{$1} || croak("unknown ffi/platypus type $name [$size]"); if($size) { return $self->types->{$name} = $self->create_type_array( $basic->type_code, $size, ); } else { return $self->global_types->{array}->{$name} ||= $self->create_type_array( $basic->type_code, 0 ); } } # pointer types if($name =~ s/\s+\*$//) { return $self->global_types->{ptr}->{$name} || croak("unknown ffi/platypus type $name *"); } # basic types return $self->global_types->{basic}->{$name} || croak("unknown ffi/platypus type $name"); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::TypeParser::Version0 - FFI Type Parser Version Zero =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 0 ); $ffi->type('record(Foo::Bar)' => 'foo_bar_t'); $ffi->type('opaque' => 'baz_t'); $ffi->type('opaque*' => 'baz_ptr'); =head1 DESCRIPTION This documents the original L type parser. It was the default and only type parser used by L starting with version C<0.02>. Starting with version C<1.00> L comes with a new type parser with design fixes that are not backward compatibility. =head2 Interface differences =over =item Pass-by-value records are not allowed Originally L only supported passing records as a pointer. The type C actually passes a pointer to the record. In the version 1.00 parser allows C which is pass-by-value (the contents of the record is copied onto the stack) and C which is pass-by-reference or pointer (a pointer to the record is passed to the callee so that it can make modifications to the record). TL;DR C in version 0 is equivalent to C in the version 1 API. There is no equivalent to C in the version 0 API. =item decorate aliases of basic types This is not allowed in the version 0 API: $ffi->type('opaque' => 'foo_t'); # ok! $ffi->type('foo_t*' => 'foo_ptr'); # not ok! in version 0, ok! in version 1 Instead you need to use the basic type in the second type definition: $ffi->type('opaque' => 'foo_t'); # ok! $ffi->type('opaque*' => 'foo_ptr'); # ok! =item object types are not allowed $ffi->type('object(Foo::Bar)'); # not ok! in version 0, ok! in version 1 =back =head1 SEE ALSO =over 4 =item L The core L documentation. =item L The API C<1.00> type parser. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/TypeParser/Version1.pm000644 000765 000024 00000027501 13616651126 023463 0ustar00ollisgstaff000000 000000 package FFI::Platypus::TypeParser::Version1; use strict; use warnings; use Carp qw( croak ); use base qw( FFI::Platypus::TypeParser ); # ABSTRACT: FFI Type Parser Version One our $VERSION = '1.10'; # VERSION our @CARP_NOT = qw( FFI::Platypus FFI::Platypus::TypeParser ); my %reserved = map { $_ => 1 } qw( string object type role union class struct record array senum enum ); # The type parser is responsible for deciding if something is a legal # alias name. Since this needs to be checked before the type is parsed # it is separate from set_alias below. sub check_alias { my($self, $alias) = @_; croak "spaces not allowed in alias" if $alias =~ /\s/; croak "allowed characters for alias: [A-Za-z0-9_]" if $alias !~ /^[A-Za-z0-9_]+$/; croak "reserved world \"$alias\" cannot be used as an alias" if $reserved{$alias}; croak "alias \"$alias\" conflicts with existing type" if defined $self->type_map->{$alias} || $self->types->{$alias} || $self->global_types->{basic}->{$alias}; return 1; } sub set_alias { my($self, $alias, $type) = @_; $self->types->{$alias} = $type; } use constant type_regex => qr/^ # # \s* # prefix white space # (?: # # \( ([^)]*) \) -> (.*) # closure $1 argument types, $2 return type | # (?: string | record ) \s* \( \s* ([0-9]+) \s* \) (?: \s* (\*) | ) # fixed record, fixed string $3, ponter $4 | # record \s* \( ( \s* (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* ) \s* \) (?: \s* (\*) | ) # record class $5, pointer $6 | # ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* ) \s* # unit type name $7 # (?: (\*) | \[ ([0-9]*) \] | ) # pointer $8, array $9 | # object \s* \( \s* ( (?: [A-Za-z_] [A-Za-z_0-9]* :: )* [A-Za-z_] [A-Za-z_0-9]* ) # object class $10 (?: \s*,\s* ( (?: [A-Za-z_] [A-Za-z_0-9]* \s+ )* [A-Za-z_] [A-Za-z_0-9]* ) )? # type $11 \s* \) # ) # # \s* # trailing white space # $/x; # sub parse { my($self, $name, $opt) = @_; $opt ||= {}; return $self->types->{$name} if $self->types->{$name}; $name =~ type_regex or croak "bad type name: $name"; if(defined (my $at = $1)) # closure { my $rt = $2; return $self->types->{$name} = $self->create_type_closure( $self->parse($rt, $opt), map { $self->parse($_, $opt) } map { my $t = $_; $t =~ s/^\s+//; $t =~ s/\s+$//; $t } split /,/, $at, ); } if(defined (my $size = $3)) # fixed record / fixed string { croak "fixed record / fixed string size must be larger than 0" unless $size > 0; if(my $pointer = $4) { return $self->types->{$name} = $self->create_type_record( $size, undef, ); } elsif($opt->{member}) { return $self->types->{"$name *"} = $self->create_type_record( $size, undef, ); } else { croak "fixed string / classless record not allowed as value type"; } } if(defined (my $class = $5)) # class record { my $size_method = $class->can('ffi_record_size') || $class->can('_ffi_record_size') || croak "$class has no ffi_record_size or _ffi_record_size method"; if(my $pointer = $6) { return $self->types->{$name} = $self->create_type_record( $class->$size_method, $class, ); } else { return $self->types->{$name} = $self->create_type_record_value( $class->$size_method, $class, $class->_ffi_meta->ffi_type, ); } } if(defined (my $unit_name = $7)) # basic type { if($self->global_types->{basic}->{$unit_name}) { if(my $pointer = $8) { croak "void pointer not allowed" if $unit_name eq 'void'; return $self->types->{$name} = $self->global_types->{ptr}->{$unit_name}; } if(defined (my $size = $9)) # array { croak "void array not allowed" if $unit_name eq 'void'; if($size ne '') { croak "array size must be larger than 0" if $size < 1; return $self->types->{$name} = $self->create_type_array( $self->global_types->{basic}->{$unit_name}->type_code, $size, ); } else { return $self->global_types->{array}->{$unit_name} ||= $self->create_type_array( $self->global_types->{basic}->{$unit_name}->type_code, 0, ); } } # basic type with no decorations return $self->global_types->{basic}->{$unit_name}; } if(my $map_name = $self->type_map->{$unit_name}) { if(my $pointer = $8) { return $self->types->{$name} = $self->parse("$map_name *", $opt); } if(defined (my $size = $9)) { if($size ne '') { croak "array size must be larger than 0" if $size < 1; return $self->types->{$name} = $self->parse("$map_name [$size]", $opt); } else { return $self->types->{$name} = $self->parse("$map_name []", $opt); } } return $self->types->{$name} = $self->parse("$map_name", $opt); } if(my $pointer = $8) { my $unit_type = $self->parse($unit_name, $opt); if($unit_type->is_record_value) { my $meta = $unit_type->meta; return $self->types->{$name} = $self->create_type_record( $meta->{size}, $meta->{class}, ); } my $basic_name = $self->global_types->{rev}->{$unit_type->type_code}; if($basic_name) { return $self->types->{$name} = $self->parse("$basic_name *", $opt); } else { croak "cannot make a pointer to $unit_name"; } } if(defined (my $size = $9)) { my $unit_type = $self->parse($unit_name, $opt); my $basic_name = $self->global_types->{rev}->{$unit_type->type_code}; if($basic_name) { if($size ne '') { croak "array size must be larger than 0" if $size < 1; return $self->types->{$name} = $self->parse("$basic_name [$size]", $opt); } else { return $self->types->{$name} = $self->parse("$basic_name []", $opt); } } else { croak "cannot make an array of $unit_name"; } } if($name eq 'string ro') { return $self->global_types->{basic}->{string}; } elsif($name eq 'string rw') { return $self->global_types->{v2}->{string_rw} ||= $self->create_type_string(1); } return $self->types->{$name} || croak "unknown type: $unit_name"; } if(defined (my $class = $10)) # object type { my $basic_name = $11 || 'opaque'; my $basic_type = $self->parse($basic_name); if($basic_type->is_object_ok) { return $self->types->{$name} = $self->create_type_object( $basic_type->type_code, $class, ); } else { croak "cannot make an object of $basic_name"; } } croak "internal error parsing: $name"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::TypeParser::Version1 - FFI Type Parser Version One =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('record(Foo::Bar)' => 'foo_bar_t'); $ffi->type('record(Foo::Bar)*' => 'foo_bar_ptr'); $ffi->type('opaque' => 'baz_t'); $ffi->type('bar_t*' => 'baz_ptr'); =head1 DESCRIPTION This documents the second (version 1) type parser for L. This type parser was included with L starting with version C<0.91> in an experimental capability, and C<1.00> as a stable interface. Starting with version C<1.00> the main L documentation describes the version 1 API and you can refer to L for details on the version0 API. =head1 SEE ALSO =over 4 =item L The core L documentation. =item L The API C<0.02> type parser. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Type/PointerSizeBuffer.pm000644 000765 000024 00000005426 13616651126 024207 0ustar00ollisgstaff000000 000000 package 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 = '1.10'; # VERSION my @stack; *arguments_set_size_t = FFI::Platypus->new( api => 1 )->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 1.10 =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( api => 1 ); $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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Type/StringArray.pm000644 000765 000024 00000014220 13616651126 023037 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Type::StringArray; use strict; use warnings; use FFI::Platypus; # ABSTRACT: Platypus custom type for arrays of strings our $VERSION = '1.10'; # VERSION use constant _incantation => $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ } ? 'Q' : 'L!'; use constant _size_of_pointer => FFI::Platypus->new( api => 1 )->sizeof('opaque'); use constant _pointer_buffer => "P" . _size_of_pointer; my @stack; sub perl_to_native { # this is the variable length version # and is actually simpler than the # fixed length version my $count = scalar @{ $_[0] }; my $pointers = pack(('P' x $count)._incantation, @{ $_[0] }, 0); my $array_pointer = unpack _incantation, pack 'P', $pointers; push @stack, [ \$_[0], \$pointers ]; $array_pointer; } sub perl_to_native_post { pop @stack; (); } sub native_to_perl { return unless defined $_[0]; my @list; my $i=0; while(1) { my $pointer_pointer = unpack( _incantation, unpack( _pointer_buffer, pack( _incantation, $_[0]+_size_of_pointer*$i ) ) ); last unless $pointer_pointer; push @list, unpack('p', pack(_incantation, $pointer_pointer)); $i++; } \@list; } sub ffi_custom_type_api_1 { # arg0 = class # arg1 = FFI::Platypus instance # arg2 = array size # arg3 = default value my(undef, undef, $count, $default) = @_; my $config = { native_type => 'opaque', perl_to_native => \&perl_to_native, perl_to_native_post => \&perl_to_native_post, native_to_perl => \&native_to_perl, }; if(defined $count) { my $end = $count-1; $config->{perl_to_native} = sub { my $incantation = ''; my @list = ((map { defined $_ ? do { $incantation .= 'P'; $_ } : defined $default ? do { $incantation .= 'P'; $default } : do { $incantation .= _incantation; 0 }; } @{ $_[0] }[0..$end]), 0); $incantation .= _incantation; my $pointers = pack $incantation, @list; my $array_pointer = unpack _incantation, pack 'P', $pointers; push @stack, [ \@list, $pointers ]; $array_pointer; }; my $pointer_buffer = "P@{[ FFI::Platypus->new( api => 1 )->sizeof('opaque') * $count ]}"; my $incantation_count = _incantation.$count; $config->{native_to_perl} = sub { return unless defined $_[0]; my @pointer_pointer = unpack($incantation_count, unpack($pointer_buffer, pack(_incantation, $_[0]))); [map { $_ ? unpack('p', pack(_incantation, $_)) : $default } @pointer_pointer]; }; } $config; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Type::StringArray - Platypus custom type for arrays of strings =head1 VERSION version 1.10 =head1 SYNOPSIS In your C code: void takes_string_array(const char **array) { ... } void takes_fixed_string_array(const char *array[5]) { ... } In your L code: use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->load_custom_type('::StringArray' => 'string_array'); $ffi->load_custom_type('::StringArray' => 'string_5' => 5); $ffi->attach(takes_string_array => ['string_array'] => 'void'); $ffi->attach(takes_fixed_string_array => ['string_5'] => 'void'); my @list = qw( foo bar baz ); takes_string_array(\@list); takes_fixed_string_array([qw( s1 s2 s3 s4 s5 )]); =head1 DESCRIPTION B: The primary motivation for this custom type was originally to fill the void left by the fact that L did not support arrays of strings by itself. Since 0.62 this support has been added, and that is probably what you want to use, but the semantics and feature set are slightly different, so there are cases where you might want to use this custom type. This module provides a L custom type for arrays of strings. The array is always NULL terminated. Return types are supported! This custom type takes two optional arguments. The first is the size of arrays and the second is a default value to fill in any values that aren't provided when the function is called. If not default is provided then C will be passed in for those values. =head1 SUPPORT 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'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. =head1 SEE ALSO =over 4 =item L =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Type/StringPointer.pm000644 000765 000024 00000006316 13616651126 023410 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Type::StringPointer; use strict; use warnings; use FFI::Platypus; use Scalar::Util qw( readonly ); # ABSTRACT: Convert a pointer to a string and back our $VERSION = '1.10'; # VERSION use constant _incantation => $^O eq 'MSWin32' && do { require Config; $Config::Config{archname} =~ /MSWin32-x64/ } ? 'Q' : 'L!'; use constant _pointer_buffer => "P" . FFI::Platypus->new( api => 1 )->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 1.10 =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( api => 1 ); $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 B: As of version 0.61, this custom type is now deprecated since pointers to strings are supported in the L directly without custom types. 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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Record/Meta.pm000644 000765 000024 00000005016 13616651126 021760 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Record::Meta; use strict; use warnings; # ABSTRACT: FFI support for structured records data our $VERSION = '1.10'; # VERSION { require FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1, ); $ffi->bundle; $ffi->mangler(sub { my($name) = @_; $name =~ s/^/ffi_platypus_record_meta__/; $name; }); $ffi->type('opaque' => 'ffi_type'); $ffi->custom_type('meta_t' => { native_type => 'opaque', perl_to_native => sub { ${ $_[0] }; }, }); $ffi->attach( _find_symbol => ['string'] => 'ffi_type'); $ffi->attach( new => ['ffi_type[]'] => 'meta_t', sub { my($xsub, $class, $elements) = @_; if(ref($elements) ne 'ARRAY') { require Carp; Carp::croak("passed something other than a array ref to @{[ __PACKAGE__ ]}"); } my @element_type_pointers; foreach my $element_type (@$elements) { my $ptr = _find_symbol($element_type); if($ptr) { push @element_type_pointers, $ptr; } else { require Carp; Carp::croak("unknown type: $element_type"); } } push @element_type_pointers, undef; my $ptr = $xsub->(\@element_type_pointers); bless \$ptr, $class; }); $ffi->attach( ffi_type => ['meta_t'] => 'ffi_type' ); $ffi->attach( size => ['meta_t'] => 'size_t' ); $ffi->attach( alignment => ['meta_t'] => 'uint' ); $ffi->attach( element_pointers => ['meta_t'] => 'ffi_type[]' ); $ffi->attach( DESTROY => ['meta_t'] => 'void' ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Platypus::Record::Meta - FFI support for structured records data =head1 VERSION version 1.10 =head1 DESCRIPTION This class is private to FFI::Platypus. See L for the public interface to Platypus records. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Record/TieArray.pm000644 000765 000024 00000005157 13616651126 022620 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Record::TieArray; use strict; use warnings; use Carp qw( croak ); # ABSTRACT: Tied array interface for record array members our $VERSION = '1.10'; # 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 1.10 =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Lang/ASM.pm000644 000765 000024 00000003706 13616651126 021161 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Lang::ASM; use strict; use warnings; # ABSTRACT: Documentation and tools for using Platypus with the Assembly our $VERSION = '1.10'; # 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 1.10 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Lang/C.pm000644 000765 000024 00000003531 13616651126 020717 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Lang::C; use strict; use warnings; # ABSTRACT: Documentation and tools for using Platypus with the C programming language our $VERSION = '1.10'; # 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 1.10 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Platypus/Lang/Win32.pm000644 000765 000024 00000015330 13616651126 021437 0ustar00ollisgstaff000000 000000 package FFI::Platypus::Lang::Win32; use strict; use warnings; use Config; # ABSTRACT: Documentation and tools for using Platypus with the Windows API our $VERSION = '1.10'; # 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 1.10 =head1 SYNOPSIS use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/000755 000765 000024 00000000000 13616651126 017411 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/lib/FFI/Build/MM.pm000644 000765 000024 00000020777 13616651126 017416 0ustar00ollisgstaff000000 000000 package FFI::Build::MM; use strict; use warnings; use 5.008001; use Carp (); use FFI::Build; use JSON::PP (); use File::Glob (); use File::Basename (); use File::Path (); use File::Copy (); use ExtUtils::MakeMaker 7.12; # ABSTRACT: FFI::Build installer code for ExtUtils::MakeMaker our $VERSION = '1.10'; # VERSION sub new { my($class, %opt) = @_; my $save = defined $opt{save} ? $opt{save} : 1; my $self = bless { save => $save }, $class; $self->load_prop; $self; } sub mm_args { my($self, %args) = @_; if($args{DISTNAME}) { $self->{prop}->{distname} ||= $args{DISTNAME}; $self->{prop}->{share} ||= "blib/lib/auto/share/dist/@{[ $self->distname ]}"; $self->{prop}->{arch} ||= "blib/arch/auto/@{[ join '/', split /-/, $self->distname ]}"; $self->save_prop; } else { Carp::croak "DISTNAME is required"; } if(my $build = $self->build) { foreach my $alien (@{ $build->alien }) { next if ref $alien; $args{BUILD_REQUIRES}->{$alien} ||= 0; } } if(my $test = $self->test) { foreach my $alien (@{ $test->alien }) { next if ref $alien; $args{TEST_REQUIRES}->{$alien} ||= 0; } } %args; } sub distname { shift->{prop}->{distname} } sub sharedir { my($self, $new) = @_; if(defined $new) { $self->{prop}->{share} = $new; $self->save_prop; } $self->{prop}->{share}; } sub archdir { my($self, $new) = @_; if(defined $new) { $self->{prop}->{arch} = $new; $self->save_prop; } $self->{prop}->{arch}; } sub load_build { my($self, $dir, $name, $install) = @_; return unless -d $dir; my($fbx) = File::Glob::bsd_glob("./$dir/*.fbx"); my $options; my $platform = FFI::Build::Platform->default; if($fbx) { $name = File::Basename::basename($fbx); $name =~ s/\.fbx$//; $options = do { package FFI::Build::MM::FBX; our $DIR = $dir; our $PLATFORM = $platform; # make sure we catch all of the errors # code copied from `perldoc -f do` my $return = do $fbx; unless ( $return ) { Carp::croak( "couldn't parse $fbx: $@" ) if $@; Carp::croak( "couldn't do $fbx: $!" ) unless defined $return; Carp::croak( "couldn't run $fbx" ) unless $return; } $return; }; } else { $name ||= $self->distname; $options = { source => ["$dir/*.c", "$dir/*.cxx", "$dir/*.cpp"], }; # if we see a Go, Rust control file then we assume the # ffi mod is written in that language. foreach my $control_file ("$dir/Cargo.toml", "$dir/go.mod") { if(-f $control_file) { $options->{source} = [$control_file]; last; } } } $options->{platform} ||= $platform; $options->{dir} ||= ref $install ? $install->($options) : $install; $options->{verbose} = 1 unless defined $options->{verbose}; FFI::Build->new($name, %$options); } sub build { my($self) = @_; $self->{build} ||= $self->load_build('ffi', undef, $self->sharedir . "/lib"); } sub test { my($self) = @_; $self->{test} ||= $self->load_build('t/ffi', 'test', sub { my($opt) = @_; my $buildname = $opt->{buildname} || '_build'; "t/ffi/$buildname"; }); } sub save_prop { my($self) = @_; return unless $self->{save}; open my $fh, '>', 'fbx.json'; print $fh JSON::PP::encode_json($self->{prop}); close $fh; } sub load_prop { my($self) = @_; return unless $self->{save}; unless(-f 'fbx.json') { $self->{prop} = {}; return; } open my $fh, '<', 'fbx.json'; $self->{prop} = JSON::PP::decode_json(do { local $/; <$fh> }); close $fh; } sub clean { my($self) = @_; foreach my $stage (qw( build test )) { my $build = $self->$stage; $build->clean if $build; } unlink 'fbx.json' if -f 'fbx.json'; } sub mm_postamble { my($self) = @_; my $postamble = ".PHONY: fbx_build ffi fbx_test ffi-test fbc_clean ffi-clean\n\n"; # make fbx_realclean ; make clean $postamble .= "realclean :: fbx_clean\n" . "\n" . "fbx_clean ffi-clean:\n" . "\t\$(FULLPERL) -MFFI::Build::MM=cmd -e fbx_clean\n\n"; # make fbx_build; make $postamble .= "pure_all :: fbx_build\n" . "\n" . "fbx_build ffi:\n" . "\t\$(FULLPERL) -MFFI::Build::MM=cmd -e fbx_build\n\n"; # make fbx_test; make test $postamble .= "subdirs-test_dynamic subdirs-test_static subdirs-test :: fbx_test\n" . "\n" . "fbx_test ffi-test:\n" . "\t\$(FULLPERL) -MFFI::Build::MM=cmd -e fbx_test\n\n"; $postamble; } sub action_build { my($self) = @_; my $build = $self->build; if($build) { my $lib = $build->build; if($self->archdir) { File::Path::mkpath($self->archdir, 0, oct(755)); my $archfile = File::Spec->catfile($self->archdir, File::Basename::basename($self->archdir) . ".txt"); open my $fh, '>', $archfile; my $lib_path = $lib->path; $lib_path =~ s/^blib\/lib\///; print $fh "FFI::Build\@$lib_path\n"; close $fh; } } return; } sub action_test { my($self) = @_; my $build = $self->test; $build->build if $build; } sub action_clean { my($self) = @_; my $build = $self->clean; (); } sub import { my(undef, @args) = @_; foreach my $arg (@args) { if($arg eq 'cmd') { package main; my $mm = sub { my($action) = @_; my $build = FFI::Build::MM->new; $build->$action; }; no warnings 'once'; *fbx_build = sub { $mm->('action_build'); }; *fbx_test = sub { $mm->('action_test'); }; *fbx_clean = sub { $mm->('action_clean'); }; } } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::MM - FFI::Build installer code for ExtUtils::MakeMaker =head1 VERSION version 1.10 =head1 SYNOPSIS In your Makefile.PL: use ExtUtils::MakeMaker; use FFI::Build::MM; my $fbmm = FFI::Build::MM->new; WriteMakefile($fbmm->mm_args( ABSTRACT => 'My FFI extension', DISTNAME => 'Foo-Bar-Baz-FFI', NAME => 'Foo::Bar::Baz::FFI', VERSION_FROM => 'lib/Foo/Bar/Baz/FFI.pm', ... )); sub MY::postamble { $fbmm->mm_postamble; } Then put the C, C++ or Fortran files in C<./ffi> for your runtime library and C<./t/ffi> for your test time library. =head1 DESCRIPTION This module provides a thin layer between L and L. Its interface is influenced by the design of L. The idea is that for your distribution you throw some C, C++ or Fortran source files into a directory called C and these files will be compiled and linked into a library that can be used by your module. There is a control file C which can be used to control the compiler and linker options. (options passed directly into L). The interface for this file is still under development. =head1 CONSTRUCTOR =head2 new my $fbmm = FFI::Build::MM->new; Create a new instance of L. =head1 METHODS =head2 mm_args my %new_args = $fbmm->mm_args(%old_args); This method does two things: =over 4 =item reads the arguments to determine sensible defaults (library name, install location, etc). =item adjusts the arguments as necessary and returns an updated set of arguments. =back =head2 mm_postamble my $postamble = $fbmm->mm_postamble; This returns the Makefile postamble used by L. The synopsis above for how to invoke it properly. It adds the following Make targets: =over 4 =item fbx_build / ffi build the main runtime library in C<./ffi>. =item fbx_test / ffi-test Build the test library in C<./t/ffi>. =item fbx_clean / ffi-clean Clean any runtime or test libraries already built. =back Normally you do not need to build these targets manually, they will be built automatically at the appropriate stage. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/Platform.pm000644 000765 000024 00000030151 13616651126 020654 0ustar00ollisgstaff000000 000000 package FFI::Build::Platform; use strict; use warnings; use 5.008001; use Carp (); use Text::ParseWords (); use List::Util 1.45 (); use FFI::Temp; use Capture::Tiny (); use File::Spec; use FFI::Platypus::ShareConfig; # ABSTRACT: Platform specific configuration. our $VERSION = '1.10'; # VERSION sub new { my($class, $config) = @_; $config ||= do { require Config; \%Config::Config; }; my $self = bless { config => $config, }, $class; $self; } my $default; sub default { $default ||= FFI::Build::Platform->new; } sub _self { my($self) = @_; ref $self ? $self : $self->default; } sub osname { _self(shift)->{config}->{osname}; } sub object_suffix { _self(shift)->{config}->{obj_ext}; } sub library_suffix { my $self = _self(shift); my $osname = $self->osname; my @suffix; if($osname eq 'darwin') { push @suffix, '.dylib', '.bundle'; } elsif($osname =~ /^(MSWin32|msys|cygwin)$/) { push @suffix, '.dll'; } else { push @suffix, '.' . $self->{config}->{dlext}; } wantarray ? @suffix : $suffix[0]; ## no critic (Freenode::Wantarray) } sub library_prefix { my $self = _self(shift); # this almost certainly requires refinement. if($self->osname eq 'cygwin') { return 'cyg'; } elsif($self->osname eq 'msys') { return 'msys-'; } elsif($self->osname eq 'MSWin32') { return ''; } else { return 'lib'; } } sub cc { my $self = _self(shift); my $cc = $self->{config}->{cc}; [$self->shellwords($cc)]; } sub cpp { my $self = _self(shift); my $cpp = $self->{config}->{cpprun}; [$self->shellwords($cpp)]; } sub cxx { my $self = _self(shift); my @cc = @{ $self->cc }; if($self->{config}->{ccname} eq 'gcc') { if($cc[0] =~ /gcc$/) { my @maybe = @cc; $maybe[0] =~ s/gcc$/g++/; return \@maybe if $self->which($maybe[0]); } if($cc[0] =~ /clang/) { my @maybe = @cc; $maybe[0] =~ s/clang/clang++/; return \@maybe if $self->which($maybe[0]); } # TODO: there are probably situations, eg solaris # where we don't want to try c++ in the case of # a ccname = gcc ? my @maybe = qw( c++ g++ clang++ ); foreach my $maybe (@maybe) { return [$maybe] if $self->which($maybe); } } elsif($self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl') { # TODO: see https://github.com/Perl5-FFI/FFI-Platypus/issues/203 #return \@cc; } Carp::croak("unable to detect corresponding C++ compiler"); } sub for { my $self = _self(shift); my @cc = @{ $self->cc }; if($self->{config}->{ccname} eq 'gcc') { if($cc[0] =~ /gcc$/) { my @maybe = @cc; $maybe[0] =~ s/gcc$/gfortran/; return \@maybe if $self->which($maybe[0]); } foreach my $maybe (qw( gfortran )) { return [$maybe] if $self->which($maybe); } } else { Carp::croak("unable to detect correspnding Fortran Compiler"); } } sub ld { my($self) = @_; my $ld = $self->{config}->{ld}; [$self->shellwords($ld)]; } sub shellwords { my $self = _self(shift); my $win = !!$self->osname eq 'MSWin32'; grep { defined $_ } map { ref $_ # if we have an array ref then it has already been shellworded ? @$_ : do { # remove leading whitespace, confuses some older versions of shellwords my $str = /^\s*(.*)$/ && $1; # escape things on windows $str =~ s,\\,\\\\,g if $win; Text::ParseWords::shellwords($str); } } @_; } sub ccflags { my $self = _self(shift); my @ccflags; push @ccflags, $self->shellwords($self->{config}->{cccdlflags}); push @ccflags, $self->shellwords($self->{config}->{ccflags}); push @ccflags, $self->shellwords($self->{config}->{optimize}); my $dist_include = eval { File::Spec->catdir(FFI::Platypus::ShareConfig::dist_dir('FFI-Platypus'), 'include') }; push @ccflags, "-I$dist_include" unless $@; \@ccflags; } sub ldflags { my $self = _self(shift); my @ldflags = $self->shellwords($self->{config}->{lddlflags}); if($self->osname eq 'cygwin') { no warnings 'qw'; # doesn't appear to be necessary, Perl has this in lddlflags already on cygwin #push @ldflags, qw( -Wl,--enable-auto-import -Wl,--export-all-symbols -Wl,--enable-auto-image-base ); } elsif($self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl') { push @ldflags, qw( -dll ); @ldflags = grep !/^-nodefaultlib$/, @ldflags; } elsif($self->osname eq 'MSWin32') { no warnings 'qw'; push @ldflags, qw( -Wl,--enable-auto-import -Wl,--export-all-symbols -Wl,--enable-auto-image-base ); } elsif($self->osname eq 'darwin') { # we want to build a .dylib instead of a .bundle @ldflags = map { $_ eq '-bundle' ? '-shared' : $_ } @ldflags; } \@ldflags; } sub cc_mm_works { my $self = _self(shift); my $verbose = shift; $verbose ||= 0; unless(defined $self->{cc_mm_works}) { require FFI::Build::File::C; my $c = FFI::Build::File::C->new(\"#include \"foo.h\"\n"); my $dir = FFI::Temp->newdir; { open my $fh, '>', "$dir/foo.h"; print $fh "\n"; close $fh; } my @cmd = ( $self->cc, $self->ccflags, "-I$dir", '-MM', $c->path, ); my($out, $exit) = Capture::Tiny::capture_merged(sub { $self->run(@cmd); }); if($verbose >= 2) { print $out; } elsif($verbose >= 1) { print "CC (checkfor -MM)\n"; } if(!$exit && $out =~ /foo\.h/) { $self->{cc_mm_works} = '-MM'; } else { $self->{cc_mm_works} = 0; } } $self->{cc_mm_works}; } sub flag_object_output { my $self = _self(shift); my $file = shift; if($self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl') { return ("-Fo$file"); } else { return ('-o' => $file); } } sub flag_library_output { my $self = _self(shift); my $file = shift; if($self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl') { return ("-OUT:$file"); } elsif($self->osname eq 'darwin') { return ('-install_name' => "\@rpath/$file", -o => $file); } else { return ('-o' => $file); } } sub flag_exe_output { my $self = _self(shift); my $file = shift; if($self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl') { my $file = File::Spec->rel2abs($file); return ("/Fe:$file"); } else { return ('-o' => $file); } } sub flag_export { my $self = _self(shift); return () unless $self->osname eq 'MSWin32' && $self->{config}->{ccname} eq 'cl'; return map { "/EXPORT:$_" } @_; } sub which { my(undef, $command) = @_; require IPC::Cmd; my @command = ref $command ? @$command : ($command); IPC::Cmd::can_run($command[0]); } sub run { my $self = shift; my @command = map { ref $_ ? @$_ : $_ } grep { defined $_ } @_; print "+@command\n"; system @command; $?; } sub _c { join ',', @_ } sub _l { join ' ', map { ref $_ ? @$_ : $_ } @_ } sub diag { my $self = _self(shift); my @diag; push @diag, "osname : ". _c($self->osname); push @diag, "cc : ". _l($self->cc); push @diag, "cxx : ". (eval { _l($self->cxx) } || '---' ); push @diag, "for : ". (eval { _l($self->for) } || '---' ); push @diag, "ld : ". _l($self->ld); push @diag, "ccflags : ". _l($self->ccflags); push @diag, "ldflags : ". _l($self->ldflags); push @diag, "object suffix : ". _c($self->object_suffix); push @diag, "library prefix : ". _c($self->library_prefix); push @diag, "library suffix : ". _c($self->library_suffix); push @diag, "cc mm works : ". $self->cc_mm_works; join "\n", @diag; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::Platform - Platform specific configuration. =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Build::Platform; =head1 DESCRIPTION This class is used to abstract out the platform specific parts of the L system. You shouldn't need to use it directly in most cases, unless you are working on L itself. =head1 CONSTRUCTOR =head2 new my $platform = FFI::Build::Platform->new; Create a new instance of L. =head2 default my $platform = FFI::Build::Platform->default; Returns the default instance of L. =head1 METHODS All of these methods may be called either as instance or classes methods. If called as a class method, the default instance will be used. =head2 osname my $osname = $platform->osname; The "os name" as understood by Perl. This is the same as C<$^O>. =head2 object_suffix my $suffix = $platform->object_suffix; The object suffix for the platform. On UNIX this is usually C<.o>. On Windows this is usually C<.obj>. =head2 library_suffix my(@suffix) = $platform->library_suffix; my $suffix = $platform->library_suffix; The library suffix for the platform. On Linux and some other UNIX this is often C<.so>. On OS X, this is C<.dylib> and C<.bundle>. On Windows this is C<.dll>. =head2 library_prefix my $prefix = $platform->library_prefix; The library prefix for the platform. On Unix this is usually C, as in C. =head2 cc my @cc = @{ $platform->cc }; The C compiler =head2 cpp my @cpp = @{ $platform->cpp }; The C pre-processor =head2 cxx my @cxx = @{ $platform->cxx }; The C++ compiler that naturally goes with the C compiler. =head2 for my @for = @{ $platform->for }; The Fortran compiler that naturally goes with the C compiler. =head2 ld my $ld = $platform->ld; The C linker =head2 shellwords my @words = $platform->shellwords(@strings); This is a wrapper around L's C with some platform workarounds applied. =head2 ccflags my @ccflags = @{ $platform->cflags}; The compiler flags, including those needed to compile object files that can be linked into a dynamic library. On Linux, for example, this is usually includes C<-fPIC>. =head2 ldflags my @ldflags = @{ $platform->ldflags }; The linker flags needed to link object files into a dynamic library. This is NOT the C style library flags that specify the location and name of a library to link against, this is instead the flags that tell the linker to generate a dynamic library. On Linux, for example, this is usually C<-shared>. =head2 cc_mm_works my $bool = $platform->cc_mm_works; Returns the flags that can be passed into the C compiler to compute dependencies. =head2 flag_object_output my @flags = $platform->flag_object_output($object_filename); Returns the flags that the compiler recognizes as being used to write out to a specific object filename. =head2 flag_library_output my @flags = $platform->flag_library_output($library_filename); Returns the flags that the compiler recognizes as being used to write out to a specific library filename. =head2 flag_exe_output my @flags = $platform->flag_exe_output($library_filename); Returns the flags that the compiler recognizes as being used to write out to a specific exe filename. =head2 flag_export my @flags = $platform->flag_export(@symbols); Returns the flags that the linker recognizes for exporting functions. =head2 which my $path = $platform->which($command); Returns the full path of the given command, if it is available, otherwise C is returned. =head2 run $platform->run(@command); =head2 diag Diagnostic for the platform as a string. This is for human consumption only, and the format may and will change over time so do not attempt to use is programmatically. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/Base.pm000644 000765 000024 00000015540 13616651126 020626 0ustar00ollisgstaff000000 000000 package FFI::Build::File::Base; use strict; use warnings; use 5.008001; use Carp (); use FFI::Temp; use File::Basename (); use FFI::Build::Platform; use overload '""' => sub { $_[0]->path }, bool => sub { 1 }, fallback => 1; # ABSTRACT: Base class for File::Build files our $VERSION = '1.10'; # VERSION sub new { my($class, $content, %config) = @_; my $base = $config{base} || 'ffi_build_'; my $dir = $config{dir}; my $build = $config{build}; my $platform = $config{platform} || FFI::Build::Platform->new; my $self = bless { platform => $platform, build => $build, }, $class; if(!defined $content) { Carp::croak("content is required"); } elsif(ref($content) eq 'ARRAY') { $self->{path} = File::Spec->catfile(@$content); } elsif(ref($content) eq 'SCALAR') { my %args; $args{TEMPLATE} = "${base}XXXXXX"; $args{DIR} = $dir if $dir; $args{SUFFIX} = $self->default_suffix; $args{UNLINK} = 0; my $fh = $self->{fh} = FFI::Temp->new(%args); binmode( $fh, $self->default_encoding ); print $fh $$content; close $fh; $self->{path} = $fh->filename; $self->{temp} = 1; } elsif(ref($content) eq '') { $self->{path} = $content; } if($self->platform->osname eq 'MSWin32') { $self->{native} = File::Spec->catfile($self->{path}); $self->{path} =~ s{\\}{/}g; } $self; } sub default_suffix { die "must define a default extension in subclass" } sub default_encoding { die "must define an encoding" } sub accept_suffix { () } sub path { shift->{path} } sub basename { File::Basename::basename shift->{path} } sub dirname { File::Basename::dirname shift->{path} } sub is_temp { shift->{temp} } sub platform { shift->{platform} } sub build { shift->{build} } sub native { my($self) = @_; $self->platform->osname eq 'MSWin32' ? $self->{native} : $self->{path}; } sub slurp { my($self) = @_; my $fh; open($fh, '<', $self->path) || Carp::croak "Error opening @{[ $self->path ]} for read $!"; binmode($fh, $self->default_encoding); my $content = do { local $/; <$fh> }; close $fh; $content; } sub keep { delete shift->{temp}; } sub build_item { Carp::croak("Not implemented!"); } sub needs_rebuild { my($self, @source) = @_; # if the target doesn't exist, then we definitely # need a rebuild. return 1 unless -f $self->path; my $target_time = [stat $self->path]->[9]; foreach my $source (@source) { my $source_time = [stat "$source"]->[9]; return 1 if ! defined $source_time; return 1 if $source_time > $target_time; } return 0; } sub ld { return undef; } sub DESTROY { my($self) = @_; if($self->{temp}) { unlink($self->path); } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::File::Base - Base class for File::Build files =head1 VERSION version 1.10 =head1 SYNOPSIS Create your own file class package FFI::Build::File::Foo; use base qw( FFI::Build::File::Base ); use constant default_suffix => '.foo'; use constant default_encoding => ':utf8'; Use it: # use an existing file in the filesystem my $file = FFI::Build::File::Foo->new('src/myfile.foo'); # generate a temp file with provided content # file will be deletd when $file falls out of scope. my $file = FFI::Build::File::Foo->new(\'content for a temp foo'); =head1 DESCRIPTION This class is the base class for other L classes. =head1 CONSTRUCTOR =head2 new my $file = FFI::Build::File::Base->new(\$content, %options); my $file = FFI::Build::File::Base->new($filename, %options); Create a new instance of the file class. You may provide either the content of the file as a scalar reference, or the path to an existing filename. Options: =over 4 =item base The base name for any temporary file C by default. =item build The L instance to use. =item dir The directory to store any temporary file. =item platform The L instance to use. =back =head1 METHODS =head2 default_suffix my $suffix = $file->default_suffix; B be overridden in the subclass. This is the standard extension for the file type. C<.c> for a C file, C<.o> or C<.obj> for an object file depending on platform. etc. =head2 default_encoding my $encoding = $file->default_encoding; B be overridden in the subclass. This is the passed to C when the file is opened for reading or writing. =head2 accept_suffix my @suffix_list = $file->accept_suffix; Returns a list of regexes that recognize the file type. =head2 path my $path = $file->path; The full or relative path to the file. =head2 basename my $basename = $file->basename; The base filename part of the path. =head2 dirname my $dir = $file->dirname; The directory part of the path. =head2 is_temp my $bool = $file->is_temp; Returns true if the file is temporary, that is, it will be deleted when the file object falls out of scope. You can call C, to keep the file. =head2 platform my $platform = $file->platform; The L instance used for this file object. =head2 build my $build = $file->build; The L instance used for this file object, if any. =head2 native my $path = $file->native; Returns the operating system native version of the filename path. On Windows, this means that forward slash C<\> is used instead of backslash C. =head2 slurp my $content = $file->slurp; Returns the content of the file. =head2 keep $file->keep; Turns off the temporary flag on the file object, meaning it will not automatically be deleted when the file object is deallocated or falls out of scope. =head2 build_item $file->build_item; Builds the file into its natural output type, usually an object file. It returns a new file instance, or if the file is an object file then it returns empty list. =head2 build_all $file->build_all; If implemented the file in question can directly create a shared or dynamic library without needing a link step. This is useful for languages that have their own build systems. =head2 needs_rebuild my $bool = $file->needs_rebuild =head2 ld =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/C.pm000644 000765 000024 00000010624 13616651126 020134 0ustar00ollisgstaff000000 000000 package FFI::Build::File::C; use strict; use warnings; use 5.008001; use base qw( FFI::Build::File::Base ); use constant default_suffix => '.c'; use constant default_encoding => ':utf8'; use Capture::Tiny (); use File::Path (); use FFI::Build::File::Object; # ABSTRACT: Class to track C source file in FFI::Build our $VERSION = '1.10'; # VERSION sub accept_suffix { (qr/\.(c|i)$/) } sub build_item { my($self) = @_; my $oname = $self->basename; $oname =~ s/\.(c(xx|pp)|i)?$//; $oname .= $self->platform->object_suffix; my $buildname = '_build'; $buildname = $self->build->buildname if $self->build; my $object = FFI::Build::File::Object->new( [ $self->dirname, $buildname, $oname ], platform => $self->platform, build => $self->build, ); return $object if -f $object->path && !$object->needs_rebuild($self->_deps); File::Path::mkpath($object->dirname, { verbose => 0, mode => oct(700) }); my @cmd = ( $self->_base_args, -c => $self->path, $self->platform->flag_object_output($object->path), ); my($out, $exit) = Capture::Tiny::capture_merged(sub { $self->platform->run(@cmd); }); if($exit || !-f $object->path) { print $out; die "error building $object from $self"; } elsif($self->build && $self->build->verbose >= 2) { print $out; } elsif($self->build && $self->build->verbose >= 1) { print "CC @{[ $self->path ]}\n"; } $object; } sub cc { my($self) = @_; $self->platform->cc; } sub _base_args { my($self) = @_; my @cmd = ($self->cc); push @cmd, $self->build->cflags_I if $self->build; push @cmd, $self->platform->ccflags; push @cmd, @{ $self->build->cflags } if $self->build; @cmd; } sub _base_args_cpp { my($self) = @_; my @cmd = ($self->platform->cpp); push @cmd, $self->build->cflags_I if $self->build; push @cmd, grep /^-[DI]/, $self->platform->ccflags; push @cmd, grep /^-D/, @{ $self->build->cflags } if $self->build; @cmd; } sub build_item_cpp { my($self) = @_; my $oname = $self->basename; $oname =~ s/\.(c(xx|pp)|i)$?$//; $oname .= '.i'; my $buildname = '_build'; $buildname = $self->build->buildname if $self->build; my $ifile = FFI::Build::File::C->new( [ $self->dirname, $buildname, $oname ], platform => $self->platform, build => $self->build, ); File::Path::mkpath($ifile->dirname, { verbose => 0, mode => oct(700) }); my @cmd = ( $self->_base_args_cpp, $self->path, ); my($out, $err, $exit) = Capture::Tiny::capture(sub { $self->platform->run(@cmd); }); if($exit) { print "[out]\n$out\n" if defined $out && $out ne ''; print "[err]\n$err\n" if defined $err && $err ne ''; die "error building $ifile from $self"; } else { my $fh; open($fh, '>', $ifile->path); print $fh $out; close $fh; } $ifile; } sub _deps { my($self) = @_; return $self->path unless $self->platform->cc_mm_works; my @cmd = ( $self->_base_args, '-MM', $self->path, ); my($out,$err,$exit) = Capture::Tiny::capture(sub { $self->platform->run(@cmd); }); if($exit) { print $out; print $err; warn "error computing dependencies for $self"; return ($self->path); } else { $out =~ s/^\+.*\n//; # remove the command line # which on windows could have an confusing : my(undef, $deps) = split /:/, $out, 2; $deps =~ s/^\s+//; $deps =~ s/\s+$//; return grep !/^\\$/, split /\s+/, $deps; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::File::C - Class to track C source file in FFI::Build =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Build::File::C; my $c = FFI::Build::File::C->new('src/foo.c'); =head1 DESCRIPTION File class for C source files. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/CXX.pm000644 000765 000024 00000002620 13616651126 020411 0ustar00ollisgstaff000000 000000 package FFI::Build::File::CXX; use strict; use warnings; use 5.008001; use base qw( FFI::Build::File::C ); use constant default_suffix => '.cxx'; use constant default_encoding => ':utf8'; # ABSTRACT: Class to track C source file in FFI::Build our $VERSION = '1.10'; # VERSION sub accept_suffix { (qr/\.c(xx|pp)$/) } sub cc { my($self) = @_; $self->platform->cxx; } sub ld { my($self) = @_; $self->platform->cxx; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::File::CXX - Class to track C source file in FFI::Build =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Build::File::CXX; my $c = FFI::Build::File::CXX->new('src/foo.cxx'); =head1 DESCRIPTION File class for C++ source files. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/Library.pm000644 000765 000024 00000003310 13616651126 021350 0ustar00ollisgstaff000000 000000 package FFI::Build::File::Library; use strict; use warnings; use 5.008001; use base qw( FFI::Build::File::Base ); use constant default_encoding => ':raw'; # ABSTRACT: Class to track object file in FFI::Build our $VERSION = '1.10'; # VERSION sub default_suffix { shift->platform->library_suffix; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::File::Library - Class to track object file in FFI::Build =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Build; my $build = FFI::Build->new(source => 'src/*.c'); # $lib is an instance of FFI::Build::File::Library my $lib = $build->build; =head1 DESCRIPTION This is a class to track a library generated by L. This is returned by L's build method. This class is a subclass of L. The most important method is probably C, which returns the path to the library which can be passed into L for immediate use. =head1 METHODS =head2 path my $path = $lib->path; Returns the path of the library. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/lib/FFI/Build/File/Object.pm000644 000765 000024 00000002713 13616651126 021160 0ustar00ollisgstaff000000 000000 package FFI::Build::File::Object; use strict; use warnings; use 5.008001; use base qw( FFI::Build::File::Base ); use constant default_encoding => ':raw'; use Carp (); # ABSTRACT: Class to track object file in FFI::Build our $VERSION = '1.10'; # VERSION sub default_suffix { shift->platform->object_suffix; } sub build_item { my($self) = @_; unless(-f $self->path) { Carp::croak "File not built" } return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME FFI::Build::File::Object - Class to track object file in FFI::Build =head1 VERSION version 1.10 =head1 SYNOPSIS use FFI::Build::File::Object; my $o = FFI::Build::File::Object->new('src/_build/foo.o'); =head1 DESCRIPTION This class represents an object file. You normally do not need to use it directly. =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) Shlomi Fish (shlomif) Damyan Ivanov Ilya Pavlov (Ilya33) Petr Pisar (ppisar) Mohammad S Anwar (MANWAR) Håkon Hægland (hakonhagland, HAKONH) Meredith (merrilymeredith, MHOWARD) Diab Jerius (DJERIUS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2015,2016,2017,2018,2019 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-1.10/include/ffi_platypus.h000644 000765 000024 00000027545 13616651126 020637 0ustar00ollisgstaff000000 000000 #ifndef FFI_PLATYPUS_H #define FFI_PLATYPUS_H #include #include "ffi_platypus_config.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 #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 _ffi_pl_type_code { /* * the first three bits represent the * native unit size for each type. */ FFI_PL_SIZE_0 = 0x0000, FFI_PL_SIZE_8 = 0x0001, FFI_PL_SIZE_16 = 0x0002, FFI_PL_SIZE_32 = 0x0003, FFI_PL_SIZE_64 = 0x0004, FFI_PL_SIZE_128 = 0x0005, FFI_PL_SIZE_256 = 0x0006, FFI_PL_SIZE_512 = 0x0007, #if SIZEOF_VOIDP == 4 FFI_PL_SIZE_PTR = FFI_PL_SIZE_32, #elif SIZEOF_VOIDP == 8 FFI_PL_SIZE_PTR = FFI_PL_SIZE_64, #else #error "strange pointer size" #endif FFI_PL_SIZE_MASK = 0x0007, /* * The next nine bits represent the type: * basics: void, integer, float, complex * * opaque is a pointer to something, a void* * * string is a pointer to a null terminated string * (a c string, basically) * * closure is a pointer to a function, usually a * Perl function, enclosed within a FFI::Platypus::Closure * * record is a fixed bitmap, could be either a struct, * or a fixed length string. */ FFI_PL_BASE_VOID = 0x0008, FFI_PL_BASE_SINT = 0x0010, FFI_PL_BASE_UINT = 0x0020, FFI_PL_BASE_FLOAT = 0x0040, FFI_PL_BASE_COMPLEX = 0x0080, FFI_PL_BASE_OPAQUE = 0x0100, FFI_PL_BASE_STRING = 0x0200, FFI_PL_BASE_CLOSURE = 0x0400, FFI_PL_BASE_RECORD = 0x0800, FFI_PL_BASE_MASK = 0x0ff8, /* * The shape describes how the data is organized. * sclar is a simple value, pointer is usually used * for pass by reference, array is a list of objects * and custom types allow users to create their own * custom types. */ FFI_PL_SHAPE_SCALAR = 0x0000, FFI_PL_SHAPE_POINTER = 0x1000, FFI_PL_SHAPE_ARRAY = 0x2000, FFI_PL_SHAPE_CUSTOM_PERL = 0x3000, FFI_PL_SHAPE_OBJECT = 0x4000, FFI_PL_SHAPE_MASK = 0xf000, /* * You can or together the different bit fields above to * describe a type. An int for example (usually signed 32 bit integer) * is `FFI_PL_SIZE_32 | FFI_PL_BASE_SINT`. Not all combinations * have meaning, for example `FFI_PL_SIZE_8 | FFI_PL_BASE_FLOAT` * is gibberish */ FFI_PL_TYPE_VOID = FFI_PL_SIZE_0 | FFI_PL_BASE_VOID, FFI_PL_TYPE_SINT8 = FFI_PL_SIZE_8 | FFI_PL_BASE_SINT, FFI_PL_TYPE_SINT16 = FFI_PL_SIZE_16 | FFI_PL_BASE_SINT, FFI_PL_TYPE_SINT32 = FFI_PL_SIZE_32 | FFI_PL_BASE_SINT, FFI_PL_TYPE_SINT64 = FFI_PL_SIZE_64 | FFI_PL_BASE_SINT, FFI_PL_TYPE_UINT8 = FFI_PL_SIZE_8 | FFI_PL_BASE_UINT, FFI_PL_TYPE_UINT16 = FFI_PL_SIZE_16 | FFI_PL_BASE_UINT, FFI_PL_TYPE_UINT32 = FFI_PL_SIZE_32 | FFI_PL_BASE_UINT, FFI_PL_TYPE_UINT64 = FFI_PL_SIZE_64 | FFI_PL_BASE_UINT, FFI_PL_TYPE_FLOAT = FFI_PL_SIZE_32 | FFI_PL_BASE_FLOAT, FFI_PL_TYPE_DOUBLE = FFI_PL_SIZE_64 | FFI_PL_BASE_FLOAT, FFI_PL_TYPE_LONG_DOUBLE = FFI_PL_SIZE_128 | FFI_PL_BASE_FLOAT, FFI_PL_TYPE_COMPLEX_FLOAT = FFI_PL_SIZE_64 | FFI_PL_BASE_COMPLEX, FFI_PL_TYPE_COMPLEX_DOUBLE = FFI_PL_SIZE_128 | FFI_PL_BASE_COMPLEX, FFI_PL_TYPE_OPAQUE = FFI_PL_SIZE_PTR | FFI_PL_BASE_OPAQUE, /* * These types are passed as pointers, and act like opaque types * in terms of sizeof, alignof, etc, but get passed differently. */ FFI_PL_TYPE_STRING = FFI_PL_TYPE_OPAQUE | FFI_PL_BASE_STRING, FFI_PL_TYPE_CLOSURE = FFI_PL_TYPE_OPAQUE | FFI_PL_BASE_CLOSURE, FFI_PL_TYPE_RECORD = FFI_PL_TYPE_OPAQUE | FFI_PL_BASE_RECORD, FFI_PL_TYPE_RECORD_VALUE = FFI_PL_BASE_RECORD, } ffi_pl_type_code; typedef enum _platypus_string_type { FFI_PL_TYPE_STRING_RO = 0, FFI_PL_TYPE_STRING_RW = 1 } platypus_string_type; typedef struct _ffi_pl_type_extra_object { char *class; /* base class */ } ffi_pl_type_extra_object; typedef struct _ffi_pl_type_extra_record { size_t size; void *stash; /* really an HV* pointing to the package stash, or NULL */ } ffi_pl_type_extra_record; typedef struct _ffi_pl_type_extra_record_value { size_t size; char *class; /* base class */ ffi_type *ffi_type; } ffi_pl_type_extra_record_value; 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 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_record_value record_value; ffi_pl_type_extra_object object; } ffi_pl_type_extra; typedef struct _ffi_pl_type { unsigned short type_code; unsigned short sub_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]) typedef struct _ffi_pl_heap { void *_this; void *_next; } ffi_pl_heap; #define ffi_pl_heap_add(ptr, count, type) { \ ffi_pl_heap *n; \ Newx(ptr, count, type); \ Newx(n, 1, ffi_pl_heap); \ n->_this = ptr; \ n->_next = (void*) heap; \ heap = n; \ } #define ffi_pl_heap_add_ptr(ptr) { \ ffi_pl_heap *n; \ Newx(n, 1, ffi_pl_heap); \ n->_this = ptr; \ n->_next = (void*) heap; \ heap = n; \ } #define ffi_pl_heap_free() { \ while(heap != NULL) \ { \ ffi_pl_heap *old = heap; \ heap = (ffi_pl_heap *) old->_next; \ Safefree(old->_this); \ Safefree(old); \ } \ } #define ffi_pl_croak \ ffi_pl_heap_free(); \ croak #if defined(_MSC_VER) #define Newx_or_alloca(ptr, count, type) ptr = _alloca(sizeof(type)*count) #elif defined(FFI_PL_PROBE_ALLOCA) #define Newx_or_alloca(ptr, count, type) ptr = alloca(sizeof(type)*count) #else #define Newx_or_alloca(ptr, count, type) ffi_pl_heap_add(ptr, count, type) #endif ffi_type *ffi_pl_type_to_libffi_type(ffi_pl_type *type); ffi_pl_type *ffi_pl_type_new(size_t size); #if SIZEOF_VOIDP == 4 uint64_t cast0(void); #else void *cast0(void); #endif #if SIZEOF_VOIDP == 4 uint64_t cast1(uint64_t value); #else void *cast1(void *value); #endif #ifdef __cplusplus } #endif #endif FFI-Platypus-1.10/include/ffi_platypus_bundle.h000644 000765 000024 00000001436 13616651126 022157 0ustar00ollisgstaff000000 000000 #ifndef FFI_PLATYPUS_BUNDLE_H #define FFI_PLATYPUS_BUNDLE_H #include "ffi_platypus_config.h" #ifdef HAVE_STDDEF_H #include #endif #ifdef HAVE_STDINT_H #include #endif #ifdef HAVE_STDLIB_H #include #endif typedef struct { void (*set_str) (const char *name, const char *value); void (*set_sint) (const char *name, int64_t value ); void (*set_uint) (const char *name, uint64_t value ); void (*set_double) (const char *name, double value ); } ffi_platypus_constant_t; #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif EXPORT void ffi_pl_bundle_init(const char *, int, void **); EXPORT void ffi_pl_bundle_constant(const char *, ffi_platypus_constant_t *); EXPORT void ffi_pl_bundle_fini(const char *); #endif FFI-Platypus-1.10/include/ffi_platypus_call.h000644 000765 000024 00000175234 13616651126 021631 0ustar00ollisgstaff000000 000000 /* * Philosophy: FFI dispatch should be as fast as possible considering * reasonable trade offs. * * - don't allocate memory for small things using `malloc`, instead use * alloca on platforms that allow it (most modern platforms do). * - don't make function calls. You shouldn't have to make a function * calls to call a function. Exceptions are for custom types and * some of the more esoteric types. * - one way we avoid making function calls is by putting the FFI dispatch * in this header file so that it can be "called" twice without an * extra function call. (`$ffi->function(...)->call(...)` and * `$ffi->attach(foo => ...); foo(...)`). This is obviously absurd. * * Maybe all each of these weird trade offs each save only a few ms on * each call, but in the end the can add up. As a result of this * priority set, FFI::Platypus does seem to perform considerably better * than any other FFI implementations available in Perl ( see * https://github.com/perl5-FFI/FFI-Performance ) and is even competitive * with XS tbh. */ ffi_pl_heap *heap = NULL; #if FFI_PL_CALL_NO_RECORD_VALUE #define RESULT &result ffi_pl_result result; #elif FFI_PL_CALL_RET_NO_NORMAL #define RESULT result_ptr void *result_ptr; Newx_or_alloca(result_ptr, self->return_type->extra[0].record_value.size, char); #else #define RESULT result_ptr ffi_pl_result result; void *result_ptr; if(self->return_type->type_code == FFI_PL_TYPE_RECORD_VALUE) { Newx_or_alloca(result_ptr, self->return_type->extra[0].record_value.size, char); } else { result_ptr = &result; } #endif { /* buffer contains the memory required for the arguments structure */ char *buffer; size_t buffer_size = sizeof(ffi_pl_argument) * self->ffi_cif.nargs + sizeof(void*) * self->ffi_cif.nargs + sizeof(ffi_pl_arguments); ffi_pl_heap_add(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 type_code = self->argument_types[i]->type_code; argument_pointers[i] = (void*) &arguments->slot[i]; arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; switch(type_code) { /* * ARGUMENT IN - SCALAR TYPES */ case FFI_PL_TYPE_UINT8: ffi_pl_arguments_set_uint8(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_PL_TYPE_SINT8: ffi_pl_arguments_set_sint8(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; case FFI_PL_TYPE_UINT16: ffi_pl_arguments_set_uint16(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_PL_TYPE_SINT16: ffi_pl_arguments_set_sint16(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; case FFI_PL_TYPE_UINT32: ffi_pl_arguments_set_uint32(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_PL_TYPE_SINT32: ffi_pl_arguments_set_sint32(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; #ifdef HAVE_IV_IS_64 case FFI_PL_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvOK(arg) ? SvUV(arg) : 0); break; case FFI_PL_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvOK(arg) ? SvIV(arg) : 0); break; #else case FFI_PL_TYPE_UINT64: ffi_pl_arguments_set_uint64(arguments, i, SvOK(arg) ? SvU64(arg) : 0); break; case FFI_PL_TYPE_SINT64: ffi_pl_arguments_set_sint64(arguments, i, SvOK(arg) ? SvI64(arg) : 0); break; #endif case FFI_PL_TYPE_FLOAT: ffi_pl_arguments_set_float(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0); break; case FFI_PL_TYPE_DOUBLE: ffi_pl_arguments_set_double(arguments, i, SvOK(arg) ? SvNV(arg) : 0.0); break; case FFI_PL_TYPE_OPAQUE: ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg) ? INT2PTR(void*, SvIV(arg)) : NULL); break; case FFI_PL_TYPE_STRING: ffi_pl_arguments_set_string(arguments, i, SvOK(arg) ? SvPV_nolen(arg) : NULL); break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE: { 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_PL_TYPE_COMPLEX_FLOAT: { float *ptr; Newx_or_alloca(ptr, 2, float); argument_pointers[i] = ptr; ffi_pl_perl_to_complex_float(arg, ptr); } break; case FFI_PL_TYPE_COMPLEX_DOUBLE: { double *ptr; Newx_or_alloca(ptr, 2, double); argument_pointers[i] = ptr; ffi_pl_perl_to_complex_double(arg, ptr); } break; #endif case FFI_PL_TYPE_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); } break; case FFI_PL_TYPE_RECORD_VALUE: { const char *record_class = self->argument_types[i]->extra[0].record_value.class; /* TODO if object is read-onyl ? */ if(sv_isobject(arg) && sv_derived_from(arg, record_class)) { argument_pointers[i] = SvPV_nolen(SvRV(arg)); } else { ffi_pl_croak("argument %d is not an instance of %s", i, record_class); } } break; case FFI_PL_TYPE_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); SvREFCNT_inc(SvRV(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 { SV **svp; svp = hv_fetch((HV *)SvRV(arg), "code", 4, 0); if(svp != NULL) { closure->coderef = *svp; SvREFCNT_inc(closure->coderef); ffi_pl_closure_add_data(arg, closure); ffi_pl_arguments_set_pointer(arguments, i, closure->function_pointer); } else { ffi_closure_free(closure->ffi_closure); Safefree(closure); ffi_pl_arguments_set_pointer(arguments, i, NULL); warn("closure has no coderef"); } } } } } } break; default: switch(type_code & FFI_PL_SHAPE_MASK) { /* * ARGUMENT IN - POINTER TYPES */ case FFI_PL_SHAPE_POINTER: { void *ptr; if(SvROK(arg)) /* TODO: and a scalar ref */ { SV *arg2 = SvRV(arg); if(SvTYPE(arg2) < SVt_PVAV) { switch(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, uint8_t); *((uint8_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, int8_t); *((int8_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, uint16_t); *((uint16_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, int16_t); *((int16_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, uint32_t); *((uint32_t*)ptr) = SvOK(arg2) ? SvUV(arg2) : 0; break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, int32_t); *((int32_t*)ptr) = SvOK(arg2) ? SvIV(arg2) : 0; break; case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_POINTER: 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_PL_TYPE_SINT64 | FFI_PL_SHAPE_POINTER: 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_PL_TYPE_FLOAT | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, float); *((float*)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0; break; case FFI_PL_TYPE_DOUBLE | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, double); *((double*)ptr) = SvOK(arg2) ? SvNV(arg2) : 0.0; break; case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_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_PL_TYPE_LONG_DOUBLE | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, long double); ffi_pl_perl_to_long_double(arg2, (long double*)ptr); break; #endif #ifdef FFI_PL_PROBE_COMPLEX case FFI_PL_TYPE_COMPLEX_FLOAT | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, float complex); ffi_pl_perl_to_complex_float(arg2, (float *)ptr); break; case FFI_PL_TYPE_COMPLEX_DOUBLE | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, double complex); ffi_pl_perl_to_complex_double(arg2, (double *)ptr); break; #endif case FFI_PL_TYPE_STRING | FFI_PL_SHAPE_POINTER: Newx_or_alloca(ptr, 1, char *); if(SvOK(arg2)) { char *pv; STRLEN len; char *str; pv = SvPV(arg2, len); /* TODO: this should probably be a malloc since it could be arbitrarily large */ Newx_or_alloca(str, len+1, char); memcpy(str, pv, len+1); *((char**)ptr) = str; } else { *((char**)ptr) = NULL; } break; default: warn("argument type not supported (%d)", i); Newx_or_alloca(ptr, 1, void*); *((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); } break; /* * ARGUMENT IN - ARRAY TYPES */ case FFI_PL_SHAPE_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(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_ARRAY: Newx(ptr, count, uint8_t); for(n=0; nargument_types[i]->extra[0].custom_perl.perl_to_native, arg, i ); if(arg2 != NULL) { switch(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_uint8(arguments, i, SvUV(arg2)); break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_sint8(arguments, i, SvIV(arg2)); break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_uint16(arguments, i, SvUV(arg2)); break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_sint16(arguments, i, SvIV(arg2)); break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_uint32(arguments, i, SvUV(arg2)); break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_sint32(arguments, i, SvIV(arg2)); break; #ifdef HAVE_IV_IS_64 case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_uint64(arguments, i, SvUV(arg2)); break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_sint64(arguments, i, SvIV(arg2)); break; #else case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_uint64(arguments, i, SvU64(arg2)); break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_sint64(arguments, i, SvI64(arg2)); break; #endif case FFI_PL_TYPE_FLOAT | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_float(arguments, i, SvNV(arg2)); break; case FFI_PL_TYPE_DOUBLE | FFI_PL_SHAPE_CUSTOM_PERL: ffi_pl_arguments_set_double(arguments, i, SvNV(arg2)); break; case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_CUSTOM_PERL: 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]; } } break; /* * ARGUMENT IN - OBJECT */ case FFI_PL_SHAPE_OBJECT: { if(sv_isobject(arg) && sv_derived_from(arg, self->argument_types[i]->extra[0].object.class)) { SV *arg2 = SvRV(arg); switch(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_uint8(arguments, i, SvUV(arg2) ); break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_sint8(arguments, i, SvIV(arg2) ); break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_uint16(arguments, i, SvUV(arg2) ); break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_sint16(arguments, i, SvIV(arg2) ); break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_uint32(arguments, i, SvUV(arg2) ); break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_sint32(arguments, i, SvIV(arg2) ); break; #ifdef HAVE_IV_IS_64 case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_uint64(arguments, i, SvUV(arg2) ); break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_sint64(arguments, i, SvIV(arg2) ); break; #else case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_uint64(arguments, i, SvU64(arg2) ); break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_sint64(arguments, i, SvI64(arg2) ); break; #endif case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_OBJECT: ffi_pl_arguments_set_pointer(arguments, i, SvOK(arg2) ? INT2PTR(void*, SvIV(arg2)) : NULL); break; default: ffi_pl_croak("Object argument %d type not supported %d", i, type_code); } } else { ffi_pl_croak("Object argument %d must be an object of class %s", i, self->argument_types[i]->extra[0].object.class); } } break; /* * ARGUMENT IN - UNSUPPORTED */ default: warn("FFI::Platypus: argument %d type not supported (%04x)", i, type_code); break; } } } /* * CALL */ #if 0 fprintf(stderr, "# ===[%p]===\n", self->address); for(i=0; i < self->ffi_cif.nargs; i++) { fprintf(stderr, "# [%d] <%04x> %p %p", i, self->argument_types[i]->code_type, argument_pointers[i], &arguments->slot[i] ); switch(self->argument_types[i]->type_code) { case FFI_PL_TYPE_LONG_DOUBLE: fprintf(stderr, " %Lg", *((long double*)argument_pointers[i])); break; case FFI_PL_TYPE_COMPLEX_FLOAT: fprintf(stderr, " %g + %g * i", crealf(*((float complex*)argument_pointers[i])), cimagf(*((float complex*)argument_pointers[i])) ); break; case FFI_PL_TYPE_COMPLEX_DOUBLE: fprintf(stderr, " %g + %g * i", creal(*((double complex*)argument_pointers[i])), cimag(*((double complex*)argument_pointers[i])) ); break; default: fprintf(stderr, "%016llx", ffi_pl_arguments_get_uint64(arguments, i)); break; } fprintf(stderr, "\n"); } fprintf(stderr, "# === ===\n"); fflush(stderr); #endif MY_CXT.current_argv = NULL; ffi_call(&self->ffi_cif, self->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--) { int type_code = self->argument_types[i]->type_code; switch(type_code) { /* * ARGUMENT OUT - SCALAR TYPES */ case FFI_PL_TYPE_CLOSURE: { arg = perl_arg_index < items ? ST(perl_arg_index) : &PL_sv_undef; if(SvROK(arg)) { SvREFCNT_dec(arg); SvREFCNT_dec(SvRV(arg)); } } break; default: switch(type_code & FFI_PL_SHAPE_MASK) { /* * ARGUMENT OUT - POINTER TYPES */ case FFI_PL_SHAPE_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(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_POINTER: sv_setuv(SvRV(arg), *((uint8_t*)ptr)); break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER: sv_setiv(SvRV(arg), *((int8_t*)ptr)); break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_POINTER: sv_setuv(SvRV(arg), *((uint16_t*)ptr)); break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_POINTER: sv_setiv(SvRV(arg), *((int16_t*)ptr)); break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_POINTER: sv_setuv(SvRV(arg), *((uint32_t*)ptr)); break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_POINTER: sv_setiv(SvRV(arg), *((int32_t*)ptr)); break; case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_POINTER: #ifdef HAVE_IV_IS_64 sv_setuv(SvRV(arg), *((uint64_t*)ptr)); #else sv_setu64(SvRV(arg), *((uint64_t*)ptr)); #endif break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_POINTER: #ifdef HAVE_IV_IS_64 sv_setiv(SvRV(arg), *((int64_t*)ptr)); #else sv_seti64(SvRV(arg), *((int64_t*)ptr)); #endif break; case FFI_PL_TYPE_FLOAT | FFI_PL_SHAPE_POINTER: sv_setnv(SvRV(arg), *((float*)ptr)); break; case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_POINTER: if( *((void**)ptr) == NULL) sv_setsv(SvRV(arg), &PL_sv_undef); else sv_setiv(SvRV(arg), PTR2IV(*((void**)ptr))); break; case FFI_PL_TYPE_DOUBLE | FFI_PL_SHAPE_POINTER: sv_setnv(SvRV(arg), *((double*)ptr)); break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE | FFI_PL_SHAPE_POINTER: ffi_pl_long_double_to_perl(SvRV(arg),(long double*)ptr); break; #endif #ifdef FFI_PL_PROBE_COMPLEX case FFI_PL_TYPE_COMPLEX_FLOAT | FFI_PL_SHAPE_POINTER: ffi_pl_complex_float_to_perl(SvRV(arg), (float *)ptr); break; case FFI_PL_TYPE_COMPLEX_DOUBLE | FFI_PL_SHAPE_POINTER: ffi_pl_complex_double_to_perl(SvRV(arg), (double *)ptr); break; #endif case FFI_PL_TYPE_STRING | FFI_PL_SHAPE_POINTER: { char **pv = ptr; if(*pv == NULL) { sv_setsv(SvRV(arg), &PL_sv_undef); } else { sv_setpv(SvRV(arg), *pv); } } break; } } } } break; /* * ARGUMENT OUT - ARRAY TYPES */ case FFI_PL_SHAPE_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(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_ARRAY: 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); } } } break; default: break; } } } { int type_code = self->return_type->type_code; /* * TODO: This should always happen later if possible */ if((type_code & FFI_PL_SHAPE_MASK) != FFI_PL_SHAPE_CUSTOM_PERL && type_code != FFI_PL_TYPE_RECORD_VALUE) ffi_pl_heap_free(); MY_CXT.current_argv = NULL; /* * RETURN VALUE */ switch(type_code) { /* * RETURN VALUE - TYPE SCALAR */ #if ! FFI_PL_CALL_NO_RECORD_VALUE case FFI_PL_TYPE_RECORD_VALUE: { SV *value, *ref; value = newSV(0); sv_setpvn(value, result_ptr, self->return_type->extra[0].record_value.size); ref = ST(0) = sv_2mortal(newRV_noinc(value)); sv_bless(ref, gv_stashpv(self->return_type->extra[0].record_value.class, GV_ADD)); ffi_pl_heap_free(); XSRETURN(1); } break; #endif #if ! FFI_PL_CALL_RET_NO_NORMAL case FFI_PL_TYPE_VOID: XSRETURN_EMPTY; break; case FFI_PL_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_PL_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_PL_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_PL_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_PL_TYPE_UINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_UV(result.uint32_array[1]); #else XSRETURN_UV(result.uint32); #endif break; case FFI_PL_TYPE_SINT32: #if defined FFI_PL_PROBE_BIGENDIAN64 XSRETURN_IV(result.sint32_array[1]); #else XSRETURN_IV(result.sint32); #endif break; case FFI_PL_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_PL_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_PL_TYPE_FLOAT: XSRETURN_NV(result.xfloat); break; case FFI_PL_TYPE_DOUBLE: XSRETURN_NV(result.xdouble); break; case FFI_PL_TYPE_OPAQUE: case FFI_PL_TYPE_STRING: if(result.pointer == NULL) { XSRETURN_EMPTY; } else { switch(type_code) { case FFI_PL_TYPE_OPAQUE: XSRETURN_IV(PTR2IV(result.pointer)); break; case FFI_PL_TYPE_STRING: XSRETURN_PV(result.pointer); break; } } break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE: { #if !(defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)) if(MY_CXT.loaded_math_longdouble == 1) { 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 { #endif XSRETURN_NV((NV) result.longdouble); #if !(defined(USE_LONG_DOUBLE) && defined(HAS_LONG_DOUBLE)) } #endif } #endif #ifdef FFI_PL_PROBE_COMPLEX case FFI_PL_TYPE_COMPLEX_FLOAT: { SV *c[2]; AV *av; c[0] = sv_2mortal(newSVnv( ((float*)&result.complex_float)[0]) ); c[1] = sv_2mortal(newSVnv( ((float*)&result.complex_float)[1]) ); av = av_make(2,c); ST(0) = sv_2mortal(newRV_noinc((SV*) av)); XSRETURN(1); } break; case FFI_PL_TYPE_COMPLEX_DOUBLE: { SV *c[2]; AV *av; c[0] = sv_2mortal(newSVnv( ((double*)&result.complex_double)[0]) ); c[1] = sv_2mortal(newSVnv( ((double*)&result.complex_double)[1]) ); av = av_make(2,c); ST(0) = sv_2mortal(newRV_noinc((SV*) av)); XSRETURN(1); } break; #endif case FFI_PL_TYPE_RECORD: if(result.pointer == NULL) { XSRETURN_EMPTY; } else { SV *value = newSV(0); sv_setpvn(value, result.pointer, self->return_type->extra[0].record.size); if(self->return_type->extra[0].record.stash) { SV *ref = ST(0) = sv_2mortal(newRV_noinc(value)); sv_bless(ref, self->return_type->extra[0].record.stash); } else { ST(0) = sv_2mortal(value); } XSRETURN(1); } break; case FFI_PL_SHAPE_OBJECT | FFI_PL_TYPE_OPAQUE: if(result.pointer == NULL) { XSRETURN_EMPTY; } else { SV *ref; SV *value = newSV(0); sv_setiv(value, PTR2IV(((void*)result.pointer))); ref = ST(0) = sv_2mortal(newRV_noinc(value)); sv_bless(ref, gv_stashpv(self->return_type->extra[0].object.class, GV_ADD)); XSRETURN(1); } break; default: switch(type_code & FFI_PL_SHAPE_MASK) { /* * RETURN VALUE - TYPE POINTER */ case FFI_PL_SHAPE_POINTER: if(result.pointer == NULL) { XSRETURN_EMPTY; } else { SV *value; switch(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setuv(value, *((uint8_t*) result.pointer)); break; case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setiv(value, *((int8_t*) result.pointer)); break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setuv(value, *((uint16_t*) result.pointer)); break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setiv(value, *((int16_t*) result.pointer)); break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setuv(value, *((uint32_t*) result.pointer)); break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setiv(value, *((int32_t*) result.pointer)); break; case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_POINTER: value = newSV(0); #ifdef HAVE_IV_IS_64 sv_setuv(value, *((uint64_t*) result.pointer)); #else sv_seti64(value, *((int64_t*) result.pointer)); #endif break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_POINTER: value = newSV(0); #ifdef HAVE_IV_IS_64 sv_setiv(value, *((int64_t*) result.pointer)); #else sv_seti64(value, *((int64_t*) result.pointer)); #endif break; case FFI_PL_TYPE_FLOAT | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setnv(value, *((float*) result.pointer)); break; case FFI_PL_TYPE_DOUBLE | FFI_PL_SHAPE_POINTER: value = newSV(0); sv_setnv(value, *((double*) result.pointer)); break; case FFI_PL_TYPE_OPAQUE | FFI_PL_SHAPE_POINTER: if( *((void**)result.pointer) == NULL ) value = &PL_sv_undef; else { value = newSV(0); sv_setiv(value, PTR2IV(*((void**)result.pointer))); } break; #ifdef FFI_PL_PROBE_LONGDOUBLE case FFI_PL_TYPE_LONG_DOUBLE | FFI_PL_SHAPE_POINTER: value = newSV(0); ffi_pl_long_double_to_perl(value, (long double*)result.pointer); break; #endif #ifdef FFI_PL_PROBE_COMPLEX case FFI_PL_TYPE_COMPLEX_FLOAT | FFI_PL_SHAPE_POINTER: { SV *c[2]; AV *av; c[0] = sv_2mortal(newSVnv( ((float*)result.pointer)[0] )); c[1] = sv_2mortal(newSVnv( ((float*)result.pointer)[1] )); av = av_make(2, c); value = newRV_noinc((SV*)av); } break; case FFI_PL_TYPE_COMPLEX_DOUBLE | FFI_PL_SHAPE_POINTER: { SV *c[2]; AV *av; c[0] = sv_2mortal(newSVnv( ((double*)result.pointer)[0] )); c[1] = sv_2mortal(newSVnv( ((double*)result.pointer)[1] )); av = av_make(2, c); value = newRV_noinc((SV*)av); } break; #endif case FFI_PL_TYPE_STRING | FFI_PL_SHAPE_POINTER: value = newSV(0); if( *((void**)result.pointer) == NULL ) value = &PL_sv_undef; else sv_setpv(value, (char*) result.pointer); break; default: warn("return type not supported"); XSRETURN_EMPTY; } ST(0) = sv_2mortal(newRV_noinc(value)); XSRETURN(1); } break; /* * RETURN VALUE - TYPE ARRAY */ case FFI_PL_SHAPE_ARRAY: if(result.pointer == NULL) { XSRETURN_EMPTY; } else { int count = self->return_type->extra[0].array.element_count; if(count == 0 && type_code & FFI_PL_TYPE_OPAQUE) { while(((void**)result.pointer)[count] != NULL) count++; } AV *av; SV **sv; Newx(sv, count, SV*); switch(type_code) { case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_ARRAY: for(i=0; ireturn_type->extra[0].custom_perl.native_to_perl, ret_in != NULL ? ret_in : &PL_sv_undef, -1 ); MY_CXT.current_argv = NULL; ffi_pl_heap_free(); if(ret_in != NULL) { SvREFCNT_dec(ret_in); } if(ret_out == NULL) { XSRETURN_EMPTY; } else { ST(0) = sv_2mortal(ret_out); XSRETURN(1); } } break; case FFI_PL_SHAPE_OBJECT: { SV *ref; SV *value = newSV(0); switch(type_code) { case FFI_PL_TYPE_SINT8 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN sv_setiv(value, result.sint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 sv_setiv(value, result.sint8_array[7]); #else sv_setiv(value, result.sint8); #endif break; case FFI_PL_TYPE_UINT8 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN sv_setuv(value, result.uint8_array[3]); #elif defined FFI_PL_PROBE_BIGENDIAN64 sv_setuv(value, result.uint8_array[7]); #else sv_setuv(value, result.uint8); #endif break; case FFI_PL_TYPE_SINT16 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN sv_setiv(value, result.sint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 sv_setiv(value, result.sint16_array[3]); #else sv_setiv(value, result.sint16); #endif break; case FFI_PL_TYPE_UINT16 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN sv_setiv(value, result.uint16_array[1]); #elif defined FFI_PL_PROBE_BIGENDIAN64 sv_setuv(value, result.uint16_array[3]); #else sv_setuv(value, result.uint16); #endif break; case FFI_PL_TYPE_SINT32 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN64 sv_setiv(value, result.sint32_array[1]); #else sv_setiv(value, result.sint32); #endif break; case FFI_PL_TYPE_UINT32 | FFI_PL_SHAPE_OBJECT: #if defined FFI_PL_PROBE_BIGENDIAN64 sv_setuv(value, result.uint32_array[1]); #else sv_setuv(value, result.uint32); #endif break; case FFI_PL_TYPE_SINT64 | FFI_PL_SHAPE_OBJECT: #ifdef HAVE_IV_IS_64 sv_setiv(value, result.sint64); #else sv_seti64(value, result.sint64); #endif break; case FFI_PL_TYPE_UINT64 | FFI_PL_SHAPE_OBJECT: #ifdef HAVE_IV_IS_64 sv_setuv(value, result.uint64); #else sv_setu64(value, result.uint64); #endif break; default: break; } ref = ST(0) = sv_2mortal(newRV_noinc(value)); sv_bless(ref, gv_stashpv(self->return_type->extra[0].object.class, GV_ADD)); XSRETURN(1); } break; default: warn("return type not supported"); XSRETURN_EMPTY; break; } #endif } } warn("return type not supported"); XSRETURN_EMPTY; #undef EXTRA_ARGS #undef FFI_PL_CALL_NO_RECORD_VALUE #undef FFI_PL_CALL_RET_NO_NORMAL #undef RESULT FFI-Platypus-1.10/include/ffi_platypus_guts.h000644 000765 000024 00000005761 13616651126 021675 0ustar00ollisgstaff000000 000000 #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_to_complex_float(SV *sv, float *ptr); void ffi_pl_complex_float_to_perl(SV *sv, float *ptr); void ffi_pl_perl_to_complex_double(SV *sv, double *ptr); void ffi_pl_complex_double_to_perl(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.loaded_math_longdouble == 1) \ { \ 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-1.10/include/libtest.h000644 000765 000024 00000000326 13616651126 017564 0ustar00ollisgstaff000000 000000 #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 FFI-Platypus-1.10/include/perl_math_int64.h000644 000765 000024 00000004144 13616651126 021117 0ustar00ollisgstaff000000 000000 /* * 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 #endifFFI-Platypus-1.10/include/ppport.h000644 000765 000024 00001163457 13616651126 017462 0ustar00ollisgstaff000000 000000 #if 0 <<'SKIP'; #endif /* ---------------------------------------------------------------------- include/ppport.h -- Perl/Pollution/Portability Version 3.56 Automatically created by Devel::PPPort running under perl 5.030000. Do NOT edit this file directly! -- Edit PPPort_pm.PL and the includes in parts/inc/ instead. Use 'perldoc include/ppport.h' to view the documentation below. ---------------------------------------------------------------------- SKIP =pod =head1 NAME include/ppport.h - Perl/Pollution/Portability version 3.56 =head1 SYNOPSIS perl include/ppport.h [options] [source files] Searches current directory for files if no [source files] are given --help show short help --version show version --patch=file write one patch file with changes --copy=suffix write changed copies with suffix --diff=program use diff program and options --compat-version=version provide compatibility with Perl version --cplusplus accept C++ comments --quiet don't output anything except fatal errors --nodiag don't show diagnostics --nohints don't show hints --nochanges don't suggest changes --nofilter don't filter input files --strip strip all script and doc functionality from include/ppport.h --list-provided list provided API --list-unsupported list unsupported API --api-info=name show Perl API portability information =head1 COMPATIBILITY This version of F is designed to support operation with Perl installations back to 5.003_07, and has been tested up to 5.31.6. =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_07. 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 ----------------------------------------------------------------------------------------- caller_cx() NEED_caller_cx NEED_caller_cx_GLOBAL croak_xs_usage() NEED_croak_xs_usage NEED_croak_xs_usage_GLOBAL die_sv() NEED_die_sv NEED_die_sv_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 load_module() NEED_load_module NEED_load_module_GLOBAL mess() NEED_mess NEED_mess_GLOBAL mess_nocontext() NEED_mess_nocontext NEED_mess_nocontext_GLOBAL mess_sv() NEED_mess_sv NEED_mess_sv_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 my_strnlen() NEED_my_strnlen NEED_my_strnlen_GLOBAL newCONSTSUB() NEED_newCONSTSUB NEED_newCONSTSUB_GLOBAL newSVpvn_share() NEED_newSVpvn_share NEED_newSVpvn_share_GLOBAL PL_parser NEED_PL_parser NEED_PL_parser_GLOBAL PL_signals NEED_PL_signals NEED_PL_signals_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_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_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 utf8_to_uvchr_buf() NEED_utf8_to_uvchr_buf NEED_utf8_to_uvchr_buf_GLOBAL vload_module() NEED_vload_module NEED_vload_module_GLOBAL vmess() NEED_vmess NEED_vmess_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 Some of the suggested edits and/or generated patches may not compile as-is without tweaking manually. This is generally due to the need for an extra parameter to be added to the call to prevent buffer overflow. 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 send a bug report to 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 # These are tools that must be included in include/ppport.h. It doesn't work if given # a .pl suffix sub format_version { # Given an input version that is acceptable to parse_version(), return a # string of the standard representation of it. my($r,$v,$s) = parse_version(shift); if ($r < 5 || ($r == 5 && $v < 6)) { my $ver = sprintf "%d.%03d", $r, $v; $s > 0 and $ver .= sprintf "_%02d", $s; return $ver; } return sprintf "%d.%d.%d", $r, $v, $s; } sub parse_version { # Returns a triplet, (5, major, minor) from the input, treated as a string, # which can be in any of several typical formats. my $ver = shift; $ver = "" unless defined $ver; my($r,$v,$s); if ( ($r, $v, $s) = $ver =~ /^(5)(\d{3})(\d{3})$/ # 5029010, from the file # names in our # parts/base/ and # parts/todo directories or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d+)\.(\d+)$/ # 5.25.7 or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{3})(\d{3})$/ # 5.025008, from the # output of $] or ($r, $v, $s) = $ver =~ /^(\d+)\.(\d{1,3})()$/ # 5.24, 5.004 or ($r, $v, $s) = $ver =~ /^(\d+)\.(00[1-5])_?(\d{2})$/ # 5.003_07 ) { $s = 0 unless $s; die "Only Perl 5 is supported '$ver'\n" if $r != 5; die "Invalid version number: $ver\n" if $v >= 1000 || $s >= 1000; return (5, 0 + $v, 0 + $s); } # For some safety, don't assume something is a version number if it has a # literal dot as one of the three characters. This will have to be fixed # when we reach 5.46 if ($ver !~ /\./ && (($r, $v, $s) = $ver =~ /^(.)(.)(.)$/)) # vstring 5.25.7 { $r = ord $r; $v = ord $v; $s = ord $s; die "Only Perl 5 is supported '$ver'\n" if $r != 5; return (5, $v, $s); } my $mesg = ""; $mesg = ". (In 5.00x_yz, x must be 1-5.)" if $ver =~ /_/; die "Invalid version number format: '$ver'$mesg\n"; } sub int_parse_version { # Returns integer 7 digit human-readable version, suitable for use in file # names in parts/todo parts/base. return 0 + join "", map { sprintf("%03d", $_) } parse_version(shift); } sub ivers # Shorter name for int_parse_version { return int_parse_version(shift); } sub format_version_line { # Returns a floating point representation of the input version my $version = int_parse_version(shift); $version =~ s/^5\B/5./; return $version; } sub dictionary_order($$) # Sort caselessly, ignoring punct { my ($lc_a, $lc_b); my ($squeezed_a, $squeezed_b); my ($valid_a, $valid_b); # Meaning valid for all releases # On early perls, the implicit pass by reference doesn't work, so we have # to use the globals to initialize. if ("$]" < "5.006" ) { $valid_a = $a; $valid_b = $b; } else { ($valid_a, $valid_b) = @_; } $lc_a = lc $valid_a; $lc_b = lc $valid_b; $squeezed_a = $lc_a; $squeezed_a =~ s/[\W_]//g; # No punct, including no underscore $squeezed_b = $lc_b; $squeezed_b =~ s/[\W_]//g; return( $squeezed_a cmp $squeezed_b or $lc_a cmp $lc_b or $valid_a cmp $valid_b); } sub sort_api_lines # Sort lines of the form flags|return|name|args... # by 'name' { $a =~ / ^ [^|]* \| [^|]* \| (\w+) /x; # 3rd field '|' is sep my $a_name = $1; $b =~ / ^ [^|]* \| [^|]* \| (\w+) /x; my $b_name = $1; return dictionary_order($a_name, $b_name); } 1; use strict; # Disable broken TRIE-optimization BEGIN { eval '${^RE_TRIE_MAXBUF} = -1' if "$]" >= 5.009004 && "$]" <= 5.009005 } my $VERSION = 3.56; 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}; $opt{'compat-version'} = 5.003_07 unless exists $opt{'compat-version'}; $opt{'compat-version'} = int_parse_version($opt{'compat-version'}); my $int_min_perl = int_parse_version(5.003_07); # Each element of this hash looks something like: # 'Poison' => { # 'base' => '5.008000', # 'provided' => 1, # 'todo' => '5.003007' # }, 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 ) : ()), (index($4, 'c') >= 0 ? ( core_only => 1 ) : ()), (index($4, 'd') >= 0 ? ( deprecated => 1 ) : ()), (index($4, 'i') >= 0 ? ( inaccessible => 1 ) : ()), (index($4, 'x') >= 0 ? ( experimental => 1 ) : ()), (index($4, 'u') >= 0 ? ( undocumented => 1 ) : ()), (index($4, 'o') >= 0 ? ( ppport_fnc => 1 ) : ()), (index($4, 'V') >= 0 ? ( unverified => 1 ) : ()), } ) : die "invalid spec: $_" } qw( abort_execution|5.025010||Viu add_above_Latin1_folds|5.021001||Viu add_cp_to_invlist|5.013011||Viu add_data|5.005000||nViu add_multi_match|5.021004||Viu _add_range_to_invlist|5.016000||cViu add_utf16_textfilter|5.011001||Viu adjust_size_and_find_bucket|5.019003||nViu advance_one_LB|5.023007||Viu advance_one_SB|5.021009||Viu advance_one_WB|5.021009||Viu alloccopstash|5.017001|5.017001|x alloc_LOGOP|5.025004||xViu allocmy|5.008001||Viu amagic_call|5.003007|5.003007|u amagic_cmp|5.009003||Viu amagic_cmp_locale|5.009003||Viu amagic_deref_call|5.013007|5.013007|u amagic_i_ncmp|5.009003||Viu amagic_is_enabled|5.015008||Viu amagic_ncmp|5.009003||Viu _aMY_CXT|5.009000|5.009000|p aMY_CXT_|5.009000|5.009000|p aMY_CXT|5.009000|5.009000|p anonymise_cv_maybe|5.013003||Viu any_dup|5.006000||Vu ao|5.005000||Viu _append_range_to_invlist|5.013010||Viu append_utf8_from_native_byte|5.019004||ncViu apply|5.003007||Viu apply_attrs|5.006000||Viu apply_attrs_my|5.007003||Viu apply_attrs_string|5.006001|5.006001|xu ARCHNAME|5.004000|5.004000| argvout_final|5.029006||Viu ASCII_TO_NEED|5.019004||ndcVu __ASSERT_|5.019007|5.008008|p assert_uft8_cache_coherent|5.013003||Viu assignment_type|5.021005||Viu atfork_lock|5.007002|5.007002|nu atfork_unlock|5.007002|5.007002|nu aTHX_|5.006000|5.003007|p aTHX|5.006000|5.003007|p aTHXR_||5.003007|pou aTHXR||5.003007|pou av_arylen_p|5.009003|5.009003|u av_clear|5.003007|5.003007| av_create_and_push|5.009005|5.009005|x av_create_and_unshift_one|5.009005|5.009005|x av_delete|5.006000|5.006000| av_exists|5.006000|5.006000| av_extend|5.003007|5.003007| av_extend_guts|5.017004||Viu av_fetch|5.003007|5.003007| av_fill|5.003007|5.003007| AvFILL|5.003007|5.003007| AvFILLp|5.004005|5.003007|poV av_iter_p|5.011000|5.011000|u av_len|5.003007|5.003007| av_make|5.003007|5.003007| av_nonelem|5.027009||Viu av_pop|5.003007|5.003007| av_push|5.003007|5.003007| av_reify|5.004004||cViu av_shift|5.003007|5.003007| av_store|5.003007|5.003007| av_tindex|5.017009|5.003007|p av_top_index|5.017009|5.003007|p av_undef|5.003007|5.003007| av_unshift|5.003007|5.003007| ax|5.003007|5.003007| backup_one_GCB|5.025003||Viu backup_one_LB|5.023007||Viu backup_one_SB|5.021009||Viu backup_one_WB|5.021009||Viu bad_type_gv|5.019002||Viu bad_type_pv|5.016000||Viu BhkDISABLE|||x BhkENABLE|||x BhkENTRY_set|||x BhkENTRY|||xi BhkFLAGS|||xi BIN|5.003007|5.003007| bind_match|5.003007||Viu block_end|5.004000|5.004000| block_gimme|5.004000|5.004000|u blockhook_register|5.013003|5.013003|x block_start|5.004000|5.004000| BOM_UTF8|5.025005|5.003007|p boolSV|5.004000|5.003007|p boot_core_mro|5.009005||Viu boot_core_PerlIO|5.007002||Viu boot_core_UNIVERSAL|5.003007||Viu _byte_dump_string|5.025006||cViu BYTEORDER|5.003007|5.003007| bytes_cmp_utf8|5.013007|5.013007| bytes_from_utf8|5.007001|5.007001|x bytes_from_utf8_loc|5.027001|5.027001|nxu bytes_to_utf8|5.006001|5.006001|x call_argv|5.006000|5.003007|p call_atexit|5.006000|5.006000|u CALL_BLOCK_HOOKS|||xi caller_cx|5.013005|5.006000|p call_list|5.004000|5.004000|u call_method|5.006000|5.003007|p calloc|5.007002|5.007002|n call_pv|5.006000|5.003007|p call_sv|5.006000|5.003007|p cando|5.003007||Viu C_ARRAY_END|5.013002|5.003007|p C_ARRAY_LENGTH|5.008001|5.003007|p CASTFLAGS|5.003007|5.003007| cast_i32|5.006000|5.006000|nu cast_iv|5.006000|5.006000|nu cast_ulong|5.006000|5.006000|nu cast_uv|5.006000|5.006000|nu category_name|5.027008||nViu cBOOL|5.013000|5.003007|p change_engine_size|5.029004||Viu CHARBITS|5.011002|5.011002| checkcomma|5.003007||Viu check_locale_boundary_crossing|5.015006||Viu check_type_and_open|5.009003||Viu check_uni|5.003007||Viu check_utf8_print|5.013009||Viu ck_entersub_args_core|||iu ck_entersub_args_list|5.013006|5.013006| ck_entersub_args_proto|5.013006|5.013006| ck_entersub_args_proto_or_list|5.013006|5.013006| ckWARN2|5.006000|5.006000| ckWARN2_d|5.006000|5.006000| ckWARN3|5.007003|5.007003| ckWARN3_d|5.007003|5.007003| ckWARN4|5.007003|5.007003| ckWARN4_d|5.007003|5.007003| ckWARN|5.006000|5.003007|p ckwarn|5.009003|5.009003|u ckwarn_common|5.011001||Viu ckWARN_d|5.006000|5.006000| ckwarn_d|5.009003|5.009003|u ck_warner|5.011001|5.011001|vu ck_warner_d|5.011001|5.011001|vu CLASS||5.003007| clear_defarray|5.023008|5.023008|u CLEAR_ERRSV|5.025007|5.025007| clear_placeholders|5.009004||xViu clear_special_blocks|5.021003||Viu clone_params_del|5.013002|5.013002|nu clone_params_new|5.013002|5.013002|nu closest_cop|5.007002||Viu cntrl_to_mnemonic|5.021004||nViu compute_EXACTish|5.017003||nViu construct_ahocorasick_from_trie|5.021001||Viu cop_fetch_label|5.015001|5.015001|x CopFILE|5.006000||pVu CopFILEAV|5.006000||pVu CopFILEGV|5.006000||pVu CopFILEGV_set|5.006000||pVu CopFILE_set|5.006000||pVu CopFILESV|5.006000||pVu cop_free|5.006000||Viu cophh_2hv|5.013007|5.013007|x cophh_copy|5.013007|5.013007|x cophh_delete_pv|5.013007|5.013007|x cophh_delete_pvn|5.013007|5.013007|x cophh_delete_pvs|5.013007|5.013007|x cophh_delete_sv|5.013007|5.013007|x cophh_fetch_pv|5.013007|5.013007|x cophh_fetch_pvn|5.013007|5.013007|x cophh_fetch_pvs|5.013007|5.013007|x cophh_fetch_sv|5.013007|5.013007|x cophh_free|5.013007|5.013007|x cophh_new_empty|5.013007|5.013007|x cophh_store_pv|5.013007|5.013007|x cophh_store_pvn|5.013007|5.013007|x cophh_store_pvs|5.013007|5.013007|x cophh_store_sv|5.013007|5.013007|x cop_hints_2hv|5.013007|5.013007| cop_hints_fetch_pv|5.013007|5.013007| cop_hints_fetch_pvn|5.013007|5.013007| cop_hints_fetch_pvs|5.013007|5.013007| cop_hints_fetch_sv|5.013007|5.013007| CopLABEL|5.009005|5.009005| CopLABEL_len|5.016000|5.016000| CopLABEL_len_flags|5.016000|5.016000| CopSTASH|5.006000||pVu CopSTASH_eq|5.006000||pVu CopSTASHPV|5.006000||pVu CopSTASHPV_set|5.006000||pVu CopSTASH_set|5.006000||pVu cop_store_label|5.015001|5.015001|x Copy|5.003007|5.003007| CopyD|5.009002|5.003007|p core_prototype|5.015002||Vi coresub_op|5.015003||Viu CPERLscope|5.005000||pVu CPPLAST|5.006000|5.006000| CPPMINUS|5.003007|5.003007| CPPRUN|5.006000|5.006000| CPPSTDIN|5.003007|5.003007| create_eval_scope|5.009004||xViu croak|5.006000|5.003007|v croak_caller|5.025004||vnViu croak_memory_wrap|5.017006|5.003007|pnu croak_nocontext|5.006000||pvnVu croak_no_mem|5.017006||nViu croak_no_modify|5.013003|5.003007|pn croak_popstack|5.017008||ncViu croak_sv|5.013001|5.003007|p croak_xs_usage|5.010001|5.003007|pn cr_textfilter|5.006000||Viu csighandler1|||nu csighandler3|||nu csighandler|||nu current_re_engine|5.017001||cViu curse|5.013009||Viu custom_op_desc|5.007003|5.007003|d custom_op_get_field|5.019006||cViu custom_op_name|5.007003|5.007003|d custom_op_register|5.013007|5.013007| cv_ckproto_len_flags|5.015004||xcViu cv_clone|5.003007|5.003007| cv_clone_into|5.017004||Viu cv_const_sv|5.003007|5.003007|n cv_const_sv_or_av|5.019003||nViu CvDEPTH|5.003007|5.003007|nu cv_dump|5.006000||Vi cv_forget_slab|5.017002||Vi cv_get_call_checker|5.013006|5.013006| cv_get_call_checker_flags|5.027003|5.027003| CvGV|5.003007|5.003007|u cvgv_from_hek|||ciu cvgv_set|5.013003||cViu cv_name|5.021005|5.021005| CvPADLIST|5.008001|5.008001|x cv_set_call_checker|5.013006|5.013006| cv_set_call_checker_flags|5.021004|5.021004| CvSTASH|5.003007|5.003007| cvstash_set|5.013007||cViu cv_undef|5.003007|5.003007| cv_undef_flags|5.021004||Viu CvWEAKOUTSIDE|||i CX_CURPAD_SAVE|||i CX_CURPAD_SV|||i cx_dump|5.005000|5.005000|u cx_dup|5.007003|5.007003|u cxinc|5.003007|5.003007|u cx_popblock|5.023008|5.023008|xu cx_popeval|5.023008|5.023008|xu cx_popformat|5.023008|5.023008|xu cx_popgiven|5.027008|5.027008|xu cx_poploop|5.023008|5.023008|xu cx_popsub|5.023008|5.023008|xu cx_popsub_args|5.023008|5.023008|xu cx_popsub_common|5.023008|5.023008|xu cx_popwhen|5.027008|5.027008|xu cx_pushblock|5.023008|5.023008|xu cx_pusheval|5.023008|5.023008|xu cx_pushformat|5.023008|5.023008|xu cx_pushgiven|5.027008|5.027008|xu cx_pushloop_for|5.023008|5.023008|xu cx_pushloop_plain|5.023008|5.023008|xu cx_pushsub|5.023008|5.023008|xu cx_pushwhen|5.027008|5.027008|xu cx_topblock|5.023008|5.023008|xu dAX|5.007002|5.003007|p dAXMARK|5.009003|5.003007|p deb|5.007003|5.007003|vu deb_curcv|5.007002||Viu deb_nocontext|5.007003|5.007003|vnu debop|5.005000|5.005000|u debprof|5.005000||Viu debprofdump|5.005000|5.005000|u debstack|5.007003|5.007003|u deb_stack_all|5.008001||Viu deb_stack_n|5.008001||Viu debstackptrs|5.007003|5.007003|u debug_start_match|5.009004||Viu DECLARATION_FOR_LC_NUMERIC_MANIPULATION|5.021010|5.021010| defelem_target|5.019002||Viu DEFSV|5.004005|5.003007|poVu DEFSV_set|5.010001||pVu delete_eval_scope|5.009004||xViu delimcpy|5.004000|5.004000|nu delimcpy_no_escape|5.025005||nViu del_sv|5.005000||Viu despatch_signals|5.007001|5.007001|u destroy_matcher|5.027008||Viu die|5.006000|5.003007|v die_nocontext|5.006000||vnVu die_sv|5.013001|5.003007|p die_unwind|5.013001||Viu dirp_dup|5.013007|5.013007|u dITEMS|5.007002|5.003007|p div128|5.005000||Viu djSP|||i dMARK|5.003007|5.003007| dMULTICALL|5.009003|5.009003| dMY_CXT|5.009000|5.009000|p dMY_CXT_SV|5.007003||poVu dNOOP|5.006000|5.003007|poVu do_aexec5|5.006000||Viu do_aexec|||iu do_aspawn|5.008000||Vu do_binmode|5.004005|5.004005|du docatch|5.005000||Vi do_chomp|5.003007||Viu do_close|5.003007|5.003007|u do_delete_local|5.011000||Viu do_dump_pad|5.008001||Vi do_eof|5.003007||Viu does_utf8_overflow|5.025006||nViu doeval_compile|5.023008||Viu do_exec3|5.006000||Viu do_exec|5.003007||Viu dofile|5.005003||Viu dofindlabel|5.003007||Viu doform|5.005000||Viu do_gv_dump|5.006000|5.006000|u do_gvgv_dump|5.006000|5.006000|u do_hv_dump|5.006000|5.006000|u doing_taint|5.008001|5.008001|nu do_ipcctl|5.003007||Viu do_ipcget|5.003007||Viu do_join|5.003007|5.003007|u do_magic_dump|5.006000|5.006000|u do_msgrcv|5.003007||Viu do_msgsnd|5.003007||Viu do_ncmp|5.015001||Viu do_oddball|5.006000||Viu dooneliner|5.006000||Viu do_op_dump|5.006000|5.006000|u do_open|5.003007|5.003007|u do_open6|5.019010||xViu do_open9|5.006000|5.006000|du do_openn|5.007001|5.007001|u doopen_pm|5.008001||Viu do_open_raw|5.019010||xViu doparseform|5.005000||Viu do_pmop_dump|5.006000|5.006000|u dopoptoeval|5.003007||Viu dopoptogivenfor|5.027008||Viu dopoptolabel|5.005000||Viu dopoptoloop|5.005000||Viu dopoptosub_at|5.005000||Viu dopoptowhen|5.027008||Viu do_print|5.003007||Viu do_readline|5.003007||Viu doref|5.009003|5.009003|u dORIGMARK|5.003007|5.003007| do_seek|5.003007||Viu do_semop|5.003007||Viu do_shmio|5.003007||Viu do_smartmatch|5.027008||Viu do_spawn|5.008000||Vu do_spawn_nowait|5.008000||Vu do_sprintf|5.003007|5.003007|u do_sv_dump|5.006000|5.006000|u do_sysseek|5.004000||Viu do_tell|5.003007||Viu do_trans|5.003007||Viu do_trans_complex|5.006001||Viu do_trans_count|5.006001||Viu do_trans_count_invmap|5.031006||Viu do_trans_invmap|5.031006||Viu do_trans_simple|5.006001||Viu DOUBLEINFBYTES|5.023000|5.023000| DOUBLEKIND|5.021006|5.021006| DOUBLEMANTBITS|5.023000|5.023000| DOUBLENANBYTES|5.023000|5.023000| DOUBLESIZE|5.005000|5.005000| dounwind|5.003007|5.003007|u DO_UTF8|5.006000|5.006000| do_vecget|5.006000||Viu do_vecset|5.003007||Viu do_vop|5.003007||Viu dowantarray|5.003007|5.003007|u drand48_init_r|||nciu drand48_r|||nciu dSAVEDERRNO|||i dSAVE_ERRNO|||i dSP|5.003007|5.003007| dTHR|5.004005|5.003007|p dTHX|5.003007|5.003007|p dTHXa|5.006000||pVu dTHXoa|5.006000||pVu dTHXR||5.003007|pou dtrace_probe_call|||ciu dtrace_probe_load|||ciu dtrace_probe_op|||ciu dtrace_probe_phase|||ciu dump_all|5.006000|5.006000| dump_all_perl|5.011000||Viu dump_c_backtrace|5.021001||V dump_eval|5.006000|5.006000|u dump_exec_pos|5.009004||Viu dump_form|5.006000|5.006000|u dump_indent|5.006000|5.006000|vu dump_mstats|5.003007||Vu dump_packsubs|5.006000|5.006000| dump_packsubs_perl|5.011000||Viu dump_regex_sets_structures|5.025006||Viu dump_sub|5.006000|5.006000|u dump_sub_perl|5.011000||Viu dump_sv_child|5.009003||Viu dump_trie|5.009004||Viu dump_trie_interim_list|5.009004||Viu dump_trie_interim_table|5.009004||Viu dumpuntil|5.005000||Viu dump_vindent|5.006000|5.006000|u dUNDERBAR|5.009002|5.003007|p dup_attrlist|5.006000||Viu dup_warnings|||ciu dVAR|5.009003|5.003007|p dXCPT|5.009002|5.003007|p dXSARGS|5.003007|5.003007| dXSI32|5.003007|5.003007|V dXSTARG|5.006000|5.003007|poVu edit_distance|5.023008||nViu emulate_cop_io|||xciu emulate_setlocale|5.027009||nViu END_EXTERN_C|5.005000|5.003007|poVu ENTER|5.003007|5.003007| ENTER_with_name|5.011002|5.011002| ERRSV|5.004005|5.003007|p eval_pv|5.006000|5.003007|p eval_sv|5.006000|5.003007|p exec_failed|5.009004||Viu expect_number|5.007001||Viu EXTEND|5.003007|5.003007| EXTERN_C|5.005000|5.003007|poVu F0convert|5.009003||nViu fbm_compile|5.005000|5.005000| fbm_instr|5.005000|5.005000| filter_add|5.003007|5.003007| filter_del|5.003007|5.003007|u filter_gets|5.005000||Viu filter_read|5.003007|5.003007| finalize_op|5.015002||Viu finalize_optree|5.015002||Vi find_and_forget_pmops|5.009005||Viu find_array_subscript|5.009004||Viu find_beginning|5.005000||Viu find_byclass|5.006000||Viu find_default_stash|5.019004||Viu find_first_differing_byte_pos|||nViu find_hash_subscript|5.009004||Viu find_in_my_stash|5.006001||Viu find_lexical_cv|5.019001||Viu find_next_masked|5.027009||nViu find_runcv|5.008001|5.008001| find_runcv_where|5.017002||Viu find_rundefsv|5.013002|5.013002| find_rundefsvoffset|5.009002|5.009002|d find_script|5.004005||Viu find_span_end|5.027009||nViu find_span_end_mask|5.027009||nViu find_uninit_var|5.009002||xVi first_symbol|5.009003||nViu fixup_errno_string|5.019007||Viu fold_constants|5.003007||Viu foldEQ|5.013002|5.013002|n foldEQ_latin1|5.013008|5.013008|nu foldEQ_latin1_s2_folded|5.029007||nViu foldEQ_locale|5.013002|5.013002|n foldEQ_utf8|5.013002|5.007003|p foldEQ_utf8_flags|5.013010||cVu forbid_setid|5.005000||Viu force_ident|5.003007||Viu force_ident_maybe_lex|5.017004||Viu force_list|5.003007||Viu force_next|5.003007||Viu _force_out_malformed_utf8_message|5.025009||cVu force_strict_version|5.011004||Viu force_version|5.005000||Viu force_word|5.003007||Viu forget_pmop|5.017007||Viu form|5.006000|5.004000|v form_nocontext|5.006000||vnVu form_short_octal_warning|5.017008||Viu fp_dup|5.007003|5.007003|u fprintf_nocontext|5.006000||vndVu free_c_backtrace|5.021001||Vi free_global_struct|5.009003||Vu free_tied_hv_pool|5.008001||Viu FREETMPS|5.003007|5.003007| free_tmps|5.003007|5.003007|u G_ARRAY|5.003007|5.003007| G_DISCARD|5.003007|5.003007| gen_constant_list|5.003007||Viu get_and_check_backslash_N_name|5.017006||cViu get_and_check_backslash_N_name_wrapper|5.029009||Viu get_ANYOF_cp_list_for_ssc|5.019005||Viu get_ANYOFM_contents|5.027009||Viu get_aux_mg|5.011000||Viu get_av|5.006000|5.003007|p get_c_backtrace|5.021001||Vi get_c_backtrace_dump|5.021001||V get_context|5.006000|5.006000|nu get_cv|5.006000|5.003007|p get_cvn_flags|5.009005|5.003007|p get_cvs|5.011000||pVu getcwd_sv|5.007002|5.007002| get_db_sub|||iu get_debug_opts|5.008001||Viu getenv_len|5.006000||Viu get_hash_seed|5.008001||Viu get_hv|5.006000|5.003007|p get_invlist_iter_addr|5.015001||nViu get_invlist_offset_addr|5.019002||nViu get_invlist_previous_index_addr|5.017004||nViu get_mstats|5.006000||Vu get_no_modify|5.005000||Viu get_num|5.008001||Viu get_opargs|5.005000||Viu get_op_descs|5.005000|5.005000|u get_op_names|5.005000|5.005000|u get_ppaddr|5.006000|5.006000|u get_re_arg|||xciu _get_regclass_nonbitmap_data|5.019009||cViu get_regex_charset_name|5.031004||nViu get_sv|5.006000|5.003007|p GetVars|5.006000||Vu get_vtbl|5.005003|5.005003|u G_EVAL|5.003007|5.003007| GIMME|5.003007|5.003007| GIMME_V|5.004000|5.004000| gimme_V|5.031005|5.031005|xu glob_2number|5.009004||Viu glob_assign_glob|5.009004||Viu G_METHOD|5.006001|5.003007|p G_METHOD_NAMED|5.019002|5.019002| G_NOARGS|5.003007|5.003007| gp_dup|5.007003|5.007003|u gp_free|5.003007|5.003007|u gp_ref|5.003007|5.003007|u G_RETHROW||5.003007|p grok_atoUV|5.021010||ncVi grok_bin|5.007003|5.003007|p grok_bslash_c|5.013001||cViu grok_bslash_N|5.017003||Viu grok_bslash_o|5.013003||cViu grok_bslash_x|5.017002||cViu grok_hex|5.007003|5.003007|p grok_infnan|5.021004|5.021004| grok_number|5.007002|5.003007|p grok_number_flags|5.021002|5.021002| GROK_NUMERIC_RADIX|5.007002|5.003007|p grok_numeric_radix|5.007002|5.003007|p grok_oct|5.007003|5.003007|p group_end|5.007003||Viu G_SCALAR|5.003007|5.003007| GV_ADD|5.003007|5.003007| gv_add_by_type|5.011000|5.011000|u Gv_AMupdate|5.011000|5.011000|u gv_autoload4|5.004000|5.004000|u gv_autoload_pv|5.015004|5.015004|u gv_autoload_pvn|5.015004|5.015004|u gv_autoload_sv|5.015004|5.015004|u GvAV|5.003007|5.003007| gv_AVadd|5.003007|5.003007|u gv_check|5.003007|5.003007|u gv_const_sv|5.009003|5.009003| GvCV|5.003007|5.003007| gv_dump|5.006000|5.006000|u gv_efullname3|5.003007|5.003007|u gv_efullname4|5.006001|5.006001|u gv_efullname|5.003007|5.003007|du gv_fetchfile|5.003007|5.003007|u gv_fetchfile_flags|5.009005|5.009005|u gv_fetchmeth|5.003007|5.003007| gv_fetchmeth_autoload|5.007003|5.007003| gv_fetchmeth_internal|5.021007||Viu gv_fetchmethod|5.003007|5.003007| gv_fetchmethod_autoload|5.004000|5.004000| gv_fetchmethod_pv_flags|5.015004|5.015004|xu gv_fetchmethod_pvn_flags|5.015004|5.015004|xu gv_fetchmethod_sv_flags|5.015004|5.015004|xu gv_fetchmeth_pv|5.015004|5.015004| gv_fetchmeth_pv_autoload|5.015004|5.015004| gv_fetchmeth_pvn|5.015004|5.015004| gv_fetchmeth_pvn_autoload|5.015004|5.015004| gv_fetchmeth_sv|5.015004|5.015004| gv_fetchmeth_sv_autoload|5.015004|5.015004| gv_fetchpv|5.003007|5.003007|u gv_fetchpvn_flags|5.009002|5.003007|pu gv_fetchpvs|5.009004||pVu gv_fetchsv|5.009002|5.003007|pu gv_fullname3|5.003007|5.003007|u gv_fullname4|5.006001|5.006001|u gv_fullname|5.003007|5.003007|du gv_handler|5.007001|5.007001|u GvHV|5.003007|5.003007| gv_HVadd|5.003007|5.003007|u gv_init|5.003007|5.003007| gv_init_pv|5.015004|5.015004| gv_init_pvn|5.015004|5.003007|p gv_init_sv|5.015004|5.015004| gv_init_svtype|5.015004||Viu gv_IOadd|5.003007|5.003007|u gv_is_in_main|5.019004||Viu gv_magicalize|5.019004||Viu gv_magicalize_isa|5.013005||Viu gv_name_set|5.009004|5.009004|u GV_NOADD_MASK|5.009005|5.003007|poVu G_VOID|5.004000|5.004000| gv_override|5.019006||Viu gv_setref|5.021005||Viu gv_stashpv|5.003007|5.003007| gv_stashpvn|5.003007|5.003007|p gv_stashpvn_internal|5.021004||Viu gv_stashpvs|5.009003|5.003007|p gv_stashsv|5.003007|5.003007| gv_stashsvpvn_cached|5.021004||Viu GV_SUPER|5.017004|5.017004| GvSV|5.003007|5.003007| gv_SVadd|||u GvSVn|5.009003||pVu gv_try_downgrade|5.011002||xcVi handle_named_backref|5.023008||Viu handle_possible_posix|5.023008||Viu handle_regex_sets|5.017009||Viu handle_user_defined_property|5.029008||cViu he_dup|5.007003|5.007003|u HEf_SVKEY|5.003007|5.003007|p HeHASH|5.003007|5.003007| hek_dup|5.009000|5.009000|u HeKEY|5.003007|5.003007| HeKLEN|5.003007|5.003007| HePV|5.004000|5.004000| HeSVKEY|5.003007|5.003007| HeSVKEY_force|5.003007|5.003007| HeSVKEY_set|5.004000|5.004000| HeUTF8|5.010001|5.008000|p HeVAL|5.003007|5.003007| hfree_next_entry|||iu hsplit|5.005000||Viu hv_assert|5.008009|5.008009| hv_auxinit|5.009003||Viu hv_auxinit_internal|5.019010||nViu hv_backreferences_p|||xiu hv_bucket_ratio|5.025003|5.025003|x hv_clear|5.003007|5.003007| hv_clear_placeholders|5.009001|5.009001| hv_common|5.010000|5.010000|u hv_common_key_len|5.010000|5.010000|u hv_copy_hints_hv|5.009004|5.009004| hv_delayfree_ent|5.004000|5.004000|u hv_delete|5.003007|5.003007| hv_delete_common|5.009001||xViu hv_delete_ent|5.003007|5.003007| hv_eiter_p|5.009003|5.009003|u hv_eiter_set|5.009003|5.009003|u HvENAME|5.013007|5.013007| hv_ename_add|5.013007||Vi hv_ename_delete|5.013007||Vi HvENAMELEN|5.015004|5.015004| HvENAMEUTF8|5.015004|5.015004| hv_exists|5.003007|5.003007| hv_exists_ent|5.003007|5.003007| hv_fetch|5.003007|5.003007| hv_fetch_ent|5.003007|5.003007| hv_fetchs|5.009003|5.003007|p HvFILL|5.003007|5.003007| hv_fill|5.013002|5.013002| hv_free_ent|5.004000|5.004000|u hv_free_ent_ret|5.015000||Viu hv_free_entries|5.027002||Viu hv_iterinit|5.003007|5.003007| hv_iterkey|5.003007|5.003007| hv_iterkeysv|5.003007|5.003007| hv_iternext|5.003007|5.003007| hv_iternext_flags|5.008000|5.008000|x hv_iternextsv|5.003007|5.003007| hv_iterval|5.003007|5.003007| hv_kill_backrefs|||xiu hv_ksplit|5.003007|5.003007|u hv_magic|5.003007|5.003007| hv_magic_check|5.006000||nViu HvNAME|5.003007|5.003007| HvNAME_get|5.009003||pVu HvNAMELEN|5.015004|5.015004| HvNAMELEN_get|5.009003||pVu hv_name_set|5.009003|5.009003|u HvNAMEUTF8|5.015004|5.015004| hv_notallowed|5.008000||Viu hv_placeholders_get|5.009003|5.009003|u hv_placeholders_p|||ciu hv_placeholders_set|5.009003|5.009003|u hv_pushkv|5.027003||Viu hv_rand_set|5.018000|5.018000|u hv_riter_p|5.009003|5.009003|u hv_riter_set|5.009003|5.009003|u hv_scalar|5.009001|5.009001| hv_store|5.003007|5.003007| hv_store_ent|5.003007|5.003007| hv_store_flags|5.008000|5.008000|xu hv_stores|5.009004|5.003007|p hv_undef|5.003007|5.003007| hv_undef_flags|||ciu I16SIZE|5.006000|5.006000| I16TYPE|5.006000|5.006000| I32SIZE|5.006000|5.006000| I32TYPE|5.006000|5.006000| I8SIZE|5.006000|5.006000| I8TYPE|5.006000|5.006000| ibcmp|5.003007|5.003007| ibcmp_locale|5.004000|5.004000| ibcmp_utf8|5.007003|5.007003|u incline|5.005000||Viu incpush|5.005000||Viu incpush_if_exists|5.009003||Viu incpush_use_sep|5.011000||Viu ingroup|5.003007||Viu init_argv_symbols|5.007003||Viu init_constants|5.017003||Viu init_dbargs|||iu init_debugger|5.005000||Viu init_global_struct|5.009003||Vu init_i18nl10n|5.006000||cVu init_i18nl14n|5.006000||dcVu initialize_invlist_guts|5.029002||Viu init_ids|5.005000||Viu init_interp|5.005000||Viu init_main_stash|5.005000||Viu init_named_cv|5.027010||cViu init_perllib|5.005000||Viu init_postdump_symbols|5.005000||Viu init_predump_symbols|5.005000||Viu init_stacks|5.005000|5.005000|u init_tm|5.007002|5.007002|u init_uniprops|5.027011||Viu IN_LOCALE|5.007002|5.004000|p IN_LOCALE_COMPILETIME|5.007002|5.004000|p IN_LOCALE_RUNTIME|5.007002|5.004000|p IN_PERL_COMPILETIME|5.008001|5.003007|poVu inplace_aassign|5.015003||Viu instr|5.003007|5.003007|n INT2PTR|5.006000|5.003007|p intro_my|5.004000|5.004000| INTSIZE|5.003007|5.003007| intuit_method|5.005000||Viu intuit_more|5.003007||Viu _inverse_folds|5.027011||cViu invert|5.003007||Viu invlist_array|5.013010||nViu _invlist_array_init|5.015001||nViu invlist_clear|5.023009||Viu invlist_clone|5.015001||cViu _invlist_contains_cp|5.017003||nViu invlist_contents|5.023008||Viu _invlist_dump|5.019003||cViu _invlistEQ|5.023006||cViu invlist_extend|5.013010||Viu invlist_highest|5.017002||nViu _invlist_intersection|5.015001||Viu _invlist_intersection_maybe_complement_2nd|5.015008||cViu _invlist_invert|5.015001||cViu invlist_is_iterating|5.017008||nViu invlist_iterfinish|5.017008||nViu invlist_iterinit|5.015001||nViu invlist_iternext|5.015001||nViu _invlist_len|5.017004||nViu invlist_lowest|||nxViu invlist_max|5.013010||nViu invlist_previous_index|5.017004||nViu invlist_replace_list_destroys_src|5.023009||Viu _invlist_search|5.017003||ncViu invlist_set_len|5.013010||Viu invlist_set_previous_index|5.017004||nViu _invlist_subtract|5.015001||Viu invlist_trim|5.013010||nViu _invlist_union|5.015001||cVu _invlist_union_maybe_complement_2nd|5.015008||cViu invmap_dump|5.031006||Viu invoke_exception_hook|5.013001||Viu io_close|5.003007||Viu isALNUM|5.003007|5.003007|p isALNUM_A|5.031003|5.003007|p isALNUMC|5.006000|5.003007|p isALNUMC_A|5.013006|5.003007|p isALNUMC_L1|5.013006|5.003007|p isALNUMC_LC|5.006000|5.006000| isALNUMC_LC_uvchr|5.017007|5.017007| isALNUM_LC|5.004000|5.004000| isALNUM_LC_uvchr|5.007001|5.007001| isa_lookup|5.005000||Viu isALPHA|5.003007|5.003007|p isALPHA_A|5.013006|5.003007|p isALPHA_L1|5.013006|5.003007|p isALPHA_LC|5.004000|5.004000| isALPHA_LC_utf8_safe|5.025009|5.006000|p isALPHA_LC_uvchr|5.007001|5.007001| isALPHANUMERIC|5.017008|5.003007|p isALPHANUMERIC_A|5.017008|5.003007|p isALPHANUMERIC_L1|5.017008|5.003007|p isALPHANUMERIC_LC|5.017008|5.004000|p isALPHANUMERIC_LC_utf8_safe|5.025009|5.006000|p isALPHANUMERIC_LC_uvchr|5.017008|5.017008| isALPHANUMERIC_utf8|5.031005|5.031005| isALPHANUMERIC_utf8_safe|5.025009|5.006000|p isALPHANUMERIC_uvchr|5.023009|5.006000|p isALPHA_utf8|5.031005|5.031005| isALPHA_utf8_safe|5.025009|5.006000|p isALPHA_uvchr|5.023009|5.006000|p is_an_int|5.005000||Viu isASCII|5.006000|5.003007|p isASCII_A|5.013006|5.003007|p isASCII_L1|5.015004|5.003007|p isASCII_LC|5.015008|5.003007|p isASCII_LC_utf8_safe|5.025009|5.025009| isASCII_LC_uvchr|5.017007|5.017007| is_ascii_string|5.011000|5.011000|n isASCII_utf8|5.031005|5.031005| isASCII_utf8_safe|5.025009|5.003007|p isASCII_uvchr|5.023009|5.003007|p isBLANK|5.006001|5.003007|p isBLANK_A|5.013006|5.003007|p isBLANK_L1|5.013006|5.003007|p isBLANK_LC|5.006001|5.003007|p isBLANK_LC_utf8_safe|5.025009|5.006000|p isBLANK_LC_uvchr|5.017007|5.017007| isBLANK_utf8|5.031005|5.031005| isBLANK_utf8_safe|5.025009|5.006000|p isBLANK_uvchr|5.023009|5.006000|p isC9_STRICT_UTF8_CHAR|5.025005|5.025005|n is_c9strict_utf8_string|5.025006|5.025006|n is_c9strict_utf8_string_loc|5.025006|5.025006|n is_c9strict_utf8_string_loclen|5.025006|5.025006|n isCNTRL|5.006000|5.003007|p isCNTRL_A|5.013006|5.003007|p isCNTRL_L1|5.013006|5.003007|p isCNTRL_LC|5.006000|5.006000| isCNTRL_LC_utf8_safe|5.025009|5.006000|p isCNTRL_LC_uvchr|5.007001|5.007001| isCNTRL_utf8|5.031005|5.031005| isCNTRL_utf8_safe|5.025009|5.006000|p isCNTRL_uvchr|5.023009|5.006000|p _is_cur_LC_category_utf8|5.021001||cVu isDIGIT|5.003007|5.003007|p isDIGIT_A|5.013006|5.003007|p isDIGIT_L1|5.013006|5.003007|p isDIGIT_LC|5.004000|5.004000| isDIGIT_LC_utf8_safe|5.025009|5.006000|p isDIGIT_LC_uvchr|5.007001|5.007001| isDIGIT_utf8|5.031005|5.031005| isDIGIT_utf8_safe|5.025009|5.006000|p isDIGIT_uvchr|5.023009|5.006000|p isFF_OVERLONG|5.025007||nViu isFOO_lc|5.017007||cViu isFOO_utf8_lc|5.017008||Viu isGCB|5.021009||Viu isGRAPH|5.006000|5.003007|p isGRAPH_A|5.013006|5.003007|p _is_grapheme|5.025009||Viu isGRAPH_L1|5.013006|5.003007|p isGRAPH_LC|5.006000|5.006000| isGRAPH_LC_utf8_safe|5.025009|5.006000|p isGRAPH_LC_uvchr|5.007001|5.007001| isGRAPH_utf8|5.031005|5.031005| isGRAPH_utf8_safe|5.025009|5.006000|p isGRAPH_uvchr|5.023009|5.006000|p isGV_with_GP|5.009004||pVu is_handle_constructor|5.006000||nViu isIDCONT|5.017008|5.003007|p isIDCONT_A|5.017008|5.003007|p isIDCONT_L1|5.017008|5.003007|p isIDCONT_LC|5.017008|5.004000|p isIDCONT_LC_utf8_safe|5.025009|5.006000|p isIDCONT_LC_uvchr|5.017008|5.017008| isIDCONT_utf8|5.031005|5.031005| isIDCONT_utf8_safe|5.025009|5.006000|p isIDCONT_uvchr|5.023009|5.006000|p isIDFIRST|5.003007|5.003007|p isIDFIRST_A|5.013006|5.003007|p isIDFIRST_L1|5.013006|5.003007|p isIDFIRST_LC|5.004000|5.004000|p isIDFIRST_LC_utf8_safe|5.025009|5.006000|p isIDFIRST_LC_uvchr|5.007001|5.007001| isIDFIRST_utf8|5.031005|5.031005| isIDFIRST_utf8_safe|5.025009|5.006000|p isIDFIRST_uvchr|5.023009|5.006000|p isinfnan|5.021004|5.021004|n isinfnansv|5.021005||Viu _is_in_locale_category|5.021001||cViu is_invariant_string|5.021007|5.011000|pn is_invlist|5.029002||nViu isLB|5.023007||Viu isLOWER|5.003007|5.003007|p isLOWER_A|5.013006|5.003007|p isLOWER_L1|5.013006|5.003007|p isLOWER_LC|5.004000|5.004000| isLOWER_LC_utf8_safe|5.025009|5.006000|p isLOWER_LC_uvchr|5.007001|5.007001| isLOWER_utf8|5.031005|5.031005| isLOWER_utf8_safe|5.025009|5.006000|p isLOWER_uvchr|5.023009|5.006000|p is_lvalue_sub|5.007001|5.007001|u IS_NUMBER_GREATER_THAN_UV_MAX|5.007002|5.003007|p IS_NUMBER_INFINITY|5.007002|5.003007|p IS_NUMBER_IN_UV|5.007002|5.003007|p IS_NUMBER_NAN|5.007003|5.003007|p IS_NUMBER_NEG|5.007002|5.003007|p IS_NUMBER_NOT_INT|5.007002|5.003007|p isOCTAL|5.013005|5.003007|p isOCTAL_A|5.013006|5.003007|p isOCTAL_L1|5.013006|5.003007|p isPRINT|5.004000|5.003007|p isPRINT_A|5.013006|5.003007|p isPRINT_L1|5.013006|5.003007|p isPRINT_LC|5.004000|5.004000| isPRINT_LC_utf8_safe|5.025009|5.006000|p isPRINT_LC_uvchr|5.007001|5.007001| isPRINT_utf8|5.031005|5.031005| isPRINT_utf8_safe|5.025009|5.006000|p isPRINT_uvchr|5.023009|5.006000|p isPSXSPC|5.006001|5.003007|p isPSXSPC_A|5.013006|5.003007|p isPSXSPC_L1|5.013006|5.003007|p isPSXSPC_LC|5.006001|5.006001| isPSXSPC_LC_utf8_safe|5.025009|5.006000|p isPSXSPC_LC_uvchr|5.017007|5.017007| isPSXSPC_utf8|5.031005|5.031005| isPSXSPC_utf8_safe|5.025009|5.006000|p isPSXSPC_uvchr|5.023009|5.006000|p isPUNCT|5.006000|5.003007|p isPUNCT_A|5.013006|5.003007|p isPUNCT_L1|5.013006|5.003007|p isPUNCT_LC|5.006000|5.006000| isPUNCT_LC_utf8_safe|5.025009|5.006000|p isPUNCT_LC_uvchr|5.007001|5.007001| isPUNCT_utf8|5.031005|5.031005| isPUNCT_utf8_safe|5.025009|5.006000|p isPUNCT_uvchr|5.023009|5.006000|p IS_SAFE_SYSCALL|5.019004|5.019004| is_safe_syscall|5.019004|5.019004| isSB|5.021009||Viu isSCRIPT_RUN|5.027008||cVi isSPACE|5.003007|5.003007|p isSPACE_A|5.013006|5.003007|p isSPACE_L1|5.013006|5.003007|p isSPACE_LC|5.004000|5.004000| isSPACE_LC_utf8_safe|5.025009|5.006000|p isSPACE_LC_uvchr|5.007001|5.007001| isSPACE_utf8|5.031005|5.031005| isSPACE_utf8_safe|5.025009|5.006000|p isSPACE_uvchr|5.023009|5.006000|p is_ssc_worth_it|5.021005||nViu isSTRICT_UTF8_CHAR|5.025005|5.025005|n is_strict_utf8_string|5.025006|5.025006|n is_strict_utf8_string_loc|5.025006|5.025006|n is_strict_utf8_string_loclen|5.025006|5.025006|n _is_uni_FOO|5.017008||cVu _is_uni_perl_idcont|5.017008||cVu _is_uni_perl_idstart|5.017007||cVu isUPPER|5.003007|5.003007|p isUPPER_A|5.013006|5.003007|p isUPPER_L1|5.013006|5.003007|p isUPPER_LC|5.004000|5.004000| isUPPER_LC_utf8_safe|5.025009|5.006000|p isUPPER_LC_uvchr|5.007001|5.007001| isUPPER_utf8|5.031005|5.031005| isUPPER_utf8_safe|5.025009|5.006000|p isUPPER_uvchr|5.023009|5.006000|p is_utf8_char|5.006000|5.006000|nd isUTF8_CHAR|5.021001|5.006001|pn is_utf8_char_buf|5.015008|5.015008|n isUTF8_CHAR_flags|5.025005|5.025005| is_utf8_char_helper|5.031004||ncVu is_utf8_common|5.009003||Viu is_utf8_cp_above_31_bits|5.025005||nViu is_utf8_fixed_width_buf_flags|5.025006|5.025006|n is_utf8_fixed_width_buf_loc_flags|5.025006|5.025006|n is_utf8_fixed_width_buf_loclen_flags|5.025006|5.025006|n _is_utf8_FOO|5.031006||cVu is_utf8_invariant_string|5.025005|5.011000|pn is_utf8_invariant_string_loc|5.027001|5.027001|n is_utf8_non_invariant_string|5.027007||ncVi is_utf8_overlong_given_start_byte_ok|5.025006||nViu _is_utf8_perl_idcont|5.031006||cVu _is_utf8_perl_idstart|5.031006||cVu is_utf8_string|5.006001|5.006001|n is_utf8_string_flags|5.025006|5.025006|n is_utf8_string_loc|5.008001|5.008001|n is_utf8_string_loc_flags|5.025006|5.025006|n is_utf8_string_loclen|5.009003|5.009003|n is_utf8_string_loclen_flags|5.025006|5.025006|n is_utf8_valid_partial_char|5.025005|5.025005|n is_utf8_valid_partial_char_flags|5.025005|5.025005|n isWB|5.021009||Viu isWORDCHAR|5.013006|5.003007|p isWORDCHAR_A|5.013006|5.003007|p isWORDCHAR_L1|5.013006|5.003007|p isWORDCHAR_LC|5.017007|5.004000|p isWORDCHAR_LC_utf8_safe|5.025009|5.006000|p isWORDCHAR_LC_uvchr|5.017007|5.017007| isWORDCHAR_utf8|5.031005|5.031005| isWORDCHAR_utf8_safe|5.025009|5.006000|p isWORDCHAR_uvchr|5.023009|5.006000|p isXDIGIT|5.006000|5.003007|p isXDIGIT_A|5.013006|5.003007|p isXDIGIT_L1|5.013006|5.003007|p isXDIGIT_LC|5.017007|5.003007|p isXDIGIT_LC_utf8_safe|5.025009|5.006000|p isXDIGIT_LC_uvchr|5.017007|5.017007| isXDIGIT_utf8|5.031005|5.031005| isXDIGIT_utf8_safe|5.025009|5.006000|p isXDIGIT_uvchr|5.023009|5.006000|p items|5.003007|5.003007|V IVdf|5.006000|5.003007|p IVSIZE|5.006000|5.003007|p IVTYPE|5.006000|5.003007|p ix|5.003007|5.003007|V jmaybe|5.003007||Viu join_exact|5.009004||Viu keyword|5.003007||Viu keyword_plugin_standard|||iu LATIN1_TO_NATIVE|5.019004|5.003007|p LEAVE|5.003007|5.003007| leave_adjust_stacks|5.023008|5.023008|xu leave_scope|5.003007|5.003007|u LEAVE_with_name|5.011002|5.011002| lex_bufutf8|5.011002|5.011002|x lex_discard_to|5.011002|5.011002|x lex_grow_linestr|5.011002|5.011002|x lex_next_chunk|5.011002|5.011002|x lex_peek_unichar|5.011002|5.011002|x lex_read_space|5.011002|5.011002|x lex_read_to|5.011002|5.011002|x lex_read_unichar|5.011002|5.011002|x lex_start|5.009005|5.009005|x lex_stuff_pv|5.013006|5.013006|x lex_stuff_pvn|5.011002|5.011002|x lex_stuff_pvs|5.013005|5.013005|x lex_stuff_sv|5.011002|5.011002|x lex_unstuff|5.011002|5.011002|x LIKELY|5.009004|5.003007|p LINKLIST|5.013006|5.013006| list|5.003007||Viu listkids|5.003007||Viu load_module|5.006000|5.003007|pv load_module_nocontext|5.006000||vnVu localize|5.003007||Viu LONGDBLINFBYTES|5.023000|5.023000| LONGDBLMANTBITS|5.023000|5.023000| LONGDBLNANBYTES|5.023000|5.023000| LONGSIZE|5.004000|5.003007| looks_like_bool|5.027008||Viu looks_like_number|5.003007|5.003007| lop|5.005000||Viu lossless_NV_to_IV|5.031001||nViu LSEEKSIZE|5.006000|5.006000| LVRET|||i magic_clear_all_env|5.004001||Viu magic_cleararylen_p|5.017002||Viu magic_clearenv|5.003007||Viu magic_clearhint|5.009004||Vi magic_clearhints|5.011000||Vi magic_clearisa|5.010001||Viu magic_clearpack|5.003007||Viu magic_clearsig|5.003007||Viu magic_copycallchecker|5.017000||Viu magic_dump|5.006000|5.006000|u magic_existspack|5.003007||Viu magic_freearylen_p|5.009003||Viu magic_freeovrld|5.007001||Viu magic_get|5.003007||Viu magic_getarylen|5.003007||Viu magic_getdebugvar|5.021005||Viu magic_getdefelem|5.004000||Viu magic_getnkeys|5.004005||Viu magic_getpack|5.003007||Viu magic_getpos|5.003007||Viu magic_getsig|5.003007||Viu magic_getsubstr|5.004005||Viu magic_gettaint|5.003007||Viu magic_getuvar|5.003007||Viu magic_getvec|5.004005||Viu magic_killbackrefs|5.006000||Viu magic_methcall1|5.013001||Viu magic_methcall|||vi magic_methpack|5.005000||Viu magic_nextpack|5.003007||Viu magic_regdata_cnt|5.006000||Viu magic_regdatum_get|5.006000||Viu magic_regdatum_set|5.006001||Viu magic_scalarpack|5.009001||Viu magic_set|5.003007||Viu magic_set_all_env|5.004004||Viu magic_setarylen|5.003007||Viu magic_setcollxfrm|5.004000||Viu magic_setdbline|5.003007||Viu magic_setdebugvar|5.021005||Viu magic_setdefelem|5.004000||Viu magic_setenv|5.003007||Viu magic_sethint|5.009004||Vi magic_setisa|5.003007||Viu magic_setlvref|5.021005||Viu magic_setmglob|5.003007||Viu magic_setnkeys|5.003007||Viu magic_setnonelem|5.027009||Viu magic_setpack|5.003007||Viu magic_setpos|5.003007||Viu magic_setregexp|5.008001||Viu magic_setsig|5.003007||Viu magic_setsubstr|5.003007||Viu magic_settaint|5.003007||Viu magic_setutf8|5.008001||Viu magic_setuvar|5.003007||Viu magic_setvec|5.003007||Viu magic_sizepack|5.005000||Viu magic_wipepack|5.003007||Viu make_exactf_invlist|5.031006||Viu make_matcher|5.027008||Viu make_trie|5.009002||Viu malloc|5.007002|5.007002|n malloced_size|5.005000||nViu malloc_good_size|5.010001||nViu MARK|5.003007|5.003007| markstack_grow|5.021001|5.021001|u matcher_matches_sv|5.027008||Viu maybe_multimagic_gv|5.019004||Viu mayberelocate|5.015006||Viu measure_struct|5.007003||Viu mem_collxfrm|5.003007||dViu _mem_collxfrm|5.025002||Viu memEQ|5.004000|5.003007|p memEQs|5.009005|5.003007|p mem_log_alloc|5.024000||nViu mem_log_common|5.010001||nViu mem_log_free|5.024000||nViu mem_log_realloc|5.024000||nViu memNE|5.004000|5.003007|p memNEs|5.009005|5.003007|p mess|5.006000|5.004000|pv mess_alloc|5.005000||Viu mess_nocontext|5.006000||pvnVu mess_sv|5.013001|5.004000|p mfree|5.007002|5.007002|nu mg_clear|5.003007|5.003007| mg_copy|5.003007|5.003007| mg_dup|5.007003|5.007003|u mg_find|5.003007|5.003007|n mg_findext|5.013008|5.003007|pn mg_find_mglob|5.019002||cViu mg_free|5.003007|5.003007| mg_freeext|5.027004|5.027004| mg_free_type|5.013006|5.013006| mg_get|5.003007|5.003007| mg_length|5.005000|5.005000|d mg_localize|5.009003||Vi mg_magical|5.003007|5.003007|n mg_set|5.003007|5.003007| mg_size|5.005000|5.005000|u mini_mktime|5.007002|5.007002|nu minus_v|5.015006||Viu missingterm|5.005000||Viu mode_from_discipline|5.006000||Viu modkids|5.003007||Viu more_bodies|||iu more_sv|5.009004||Viu moreswitches|5.003007|5.003007|u Move|5.003007|5.003007| MoveD|5.009002|5.003007|p move_proto_attr|5.019005||Viu mPUSHi|5.009002|5.003007|p mPUSHn|5.009002|5.003007|p mPUSHp|5.009002|5.003007|p mPUSHs|5.010001|5.003007|p mPUSHu|5.009002|5.003007|p mro_clean_isarev|5.013007||Viu mro_gather_and_rename|5.013007||Viu mro_get_from_name|5.010001|5.010001|u mro_get_linear_isa|5.009005|5.009005| mro_get_linear_isa_dfs|5.009005||Vi mro_get_private_data|5.010001|5.010001| mro_isa_changed_in|5.009005||Vi mro_meta_dup|5.009005||Viu mro_meta_init|||ciu mro_method_changed_in|5.009005|5.009005| mro_package_moved|5.013006||Vi mro_register|5.010001|5.010001| mro_set_mro|5.010001|5.010001|u mro_set_private_data|5.010001|5.010001| mul128|5.005000||Viu MULTICALL|5.009003|5.009003| multiconcat_stringify|5.027006||cViu multideref_stringify|5.021009||cViu MUTABLE_PTR|5.010001||pVu MUTABLE_SV|5.010001||pVu mXPUSHi|5.009002|5.003007|p mXPUSHn|5.009002|5.003007|p mXPUSHp|5.009002|5.003007|p mXPUSHs|5.010001|5.003007|p mXPUSHu|5.009002|5.003007|p my_atof2|||cu my_atof3|5.029000||cVu my_atof|5.006000|5.006000|u my_attrs|5.006000||Viu my_bytes_to_utf8|5.021009||nViu my_chsize|5.003007||Vu my_clearenv|5.009003||Viu MY_CXT|5.009000|5.009000|p MY_CXT_CLONE|5.009002|5.009000|p my_cxt_index|||u MY_CXT_INIT|5.009000|5.009000|p my_cxt_init|5.009000|5.009000|u my_dirfd|5.009005|5.009005|nu my_exit|5.003007|5.003007| my_exit_jump|5.005000||Viu my_failure_exit|5.004000|5.004000|u my_fflush_all|5.006000|5.006000|u my_fork|5.007003|5.007003|nu my_kid|5.006000||Viu my_lstat_flags|5.013003||cViu my_lstat|||u my_memrchr|5.027006||nViu my_mkostemp_cloexec|||niu my_mkostemp|||niu my_mkstemp_cloexec|||niu my_mkstemp|||niu my_nl_langinfo|5.027006||nViu my_pclose|5.003007|5.003007|u my_popen|5.003007|5.003007|u my_popen_list|5.007001|5.007001|u my_setenv|5.003007|5.003007| my_snprintf|5.009004|5.003007|pvn my_socketpair|5.007003|5.007003|nu my_sprintf|5.009003|5.003007|pnd my_stat_flags|5.013003||cViu my_stat|||u my_strerror|5.021001||Viu my_strftime|5.007002|5.007002|u my_strlcat|5.009004|5.003007|pn my_strlcpy|5.009004|5.003007|pn my_strnlen|5.027006|5.003007|pn my_strtod|5.029010|5.029010|n my_unexec|5.003007||Viu my_vsnprintf|5.009004|5.009004|n NATIVE_TO_LATIN1|5.019004|5.003007|p NATIVE_TO_NEED|5.019004||ndcVu NATIVE_TO_UNI|5.007001|5.003007|p need_utf8|5.009003||nViu newANONATTRSUB|5.006000|5.006000|u newANONHASH|5.003007|5.003007|u newANONLIST|5.003007|5.003007|u newANONSUB|5.003007|5.003007|u newASSIGNOP|5.003007|5.003007| newATTRSUB|5.006000|5.006000|u newATTRSUB_x|5.019008||cVi newAV|5.003007|5.003007| newAVREF|5.003007|5.003007|u newBINOP|5.003007|5.003007| new_collate|5.006000||Viu newCONDOP|5.003007|5.003007| new_constant|||iu newCONSTSUB|5.004005|5.003007|p newCONSTSUB_flags|5.015006|5.015006| new_ctype|5.006000||Viu newCVREF|5.003007|5.003007|u newDEFSVOP|5.021006|5.021006| newFORM|5.003007|5.003007|u newFOROP|5.013007|5.013007| newGIVENOP|5.009003|5.009003| newGIVWHENOP|5.027008||Viu newGP|||xiu newGVgen|5.003007|5.003007|u newGVgen_flags|5.015004|5.015004|u newGVOP|5.003007|5.003007| newGVREF|5.003007|5.003007|u new_he|5.005000||Viu newHV|5.003007|5.003007| newHVhv|5.005000|5.005000|u newHVREF|5.003007|5.003007|u _new_invlist|5.013010||cViu _new_invlist_C_array|5.015008||cViu newIO|5.003007|5.003007|u newLISTOP|5.003007|5.003007| newLOGOP|5.003007|5.003007| new_logop|5.005000||Viu newLOOPEX|5.003007|5.003007| newLOOPOP|5.003007|5.003007| newMETHOP|5.021005|5.021005| newMETHOP_internal|5.021005||Viu newMETHOP_named|5.021005|5.021005| new_msg_hv|5.027009||Viu newMYSUB|5.017004|5.017004|u newNULLLIST|5.003007|5.003007| new_numeric|5.006000||Viu newOP|5.003007|5.003007| newPADNAMELIST|5.021007|5.021007|nx newPADNAMEouter|5.021007|5.021007|nx newPADNAMEpvn|5.021007|5.021007|nx newPADOP|5.006000||V newPMOP|5.003007|5.003007| newPROG|5.003007|5.003007|u newPVOP|5.003007|5.003007| newRANGE|5.003007|5.003007| new_regcurly|5.027001||nViu newRV|5.003007|5.003007|u newRV_inc|5.004000|5.003007|p newRV_noinc|5.004000|5.003007|p newSLICEOP|5.003007|5.003007| new_stackinfo|5.005000|5.005000|u newSTATEOP|5.003007|5.003007| newSTUB|5.017001||Viu newSUB|5.003007|5.003007|u newSV|5.003007|5.003007| newSVavdefelem|5.019004||Viu newSVhek|5.009003|5.009003| newSViv|5.003007|5.003007| newSVnv|5.006000|5.003007| newSVOP|5.003007|5.003007| newSVpadname|5.017004|5.017004|x newSVpv|5.003007|5.003007| newSVpvf|5.006000|5.004000|v newSVpvf_nocontext|5.006000||vnVu newSVpvn|5.004005|5.003007|p newSVpvn_flags|5.010001|5.003007|p newSVpvn_share|5.007001|5.003007|p newSVpvn_utf8|5.010001|5.003007|p newSVpvs|5.009003|5.003007|p newSVpvs_flags|5.010001|5.003007|p newSVpv_share|5.013006|5.013006| newSVpvs_share|5.009003|5.003007|p newSVREF|5.003007|5.003007|u newSVrv|5.003007|5.003007| newSVsv|5.003007|5.003007| newSVsv_flags|5.029009|5.007002|pu newSVsv_nomg|5.029009|5.007003|p newSV_type|5.009005|5.003007|p newSVuv|5.006000|5.003007|p newUNOP|5.003007|5.003007| newUNOP_AUX|5.021007|5.021007| new_version|5.009000|5.009000| new_warnings_bitfield|||xciu newWHENOP|5.027008|5.027008| newWHILEOP|5.013007|5.013007| Newx|5.009003|5.003007|p Newxc|5.009003|5.003007|p newXS|5.006000|5.006000| newXS_deffile|5.021006||cViu newXS_flags|5.009004|5.009004|xu newXS_len_flags|5.015006||Vi newXSproto|5.006000|5.006000| Newxz|5.009003|5.003007|p nextargv|5.003007||Viu nextchar|5.005000||Viu next_symbol|5.007003||Viu ninstr|5.003007|5.003007|n no_bareword_allowed|5.005004||Viu no_fh_allowed|5.003007||Viu no_op|5.003007||Viu NOOP|5.005000|5.003007|poVu noperl_die|5.021006||vnViu not_a_number|5.005000||Viu nothreadhook|5.008000|5.008000| notify_parser_that_changed_to_utf8|5.025010||Viu not_incrementable|5.021002||Viu nuke_stacks|5.005000||Viu Nullav|5.003007|5.003007|d Nullch|5.003007|5.003007| Nullcv|5.003007|5.003007|d Nullhv|5.003007|5.003007|d Nullsv|5.003007|5.003007| NUM2PTR|5.006000||pVu num_overflow|5.009001||nViu NVef|5.006001|5.003007|p NVff|5.006001|5.003007|p NVgf|5.006001|5.003007|p NVMANTBITS|5.023000|5.023000| NVSIZE|5.006001|5.006001| NVTYPE|5.006000|5.003007|p oopsAV|5.003007||Viu oopsHV|5.003007||Viu op_append_elem|5.013006|5.013006| op_append_list|5.013006|5.013006| OP_CLASS|5.013007|5.013007| op_class|5.025010|5.025010| op_clear|5.006000||cViu op_contextualize|5.013006|5.013006| op_convert_list|5.021006|5.021006| OP_DESC|5.007003|5.007003| op_dump|5.006000|5.006000| openn_cleanup|5.019010||Viu openn_setup|5.019010||Viu open_script|5.005000||Viu op_free|5.003007|5.003007| OpHAS_SIBLING|5.021007|5.003007|p op_integerize|5.015003||Viu OpLASTSIB_set|5.021011|5.003007|p op_linklist|5.013006|5.013006| op_lvalue|5.013007|5.013007|x op_lvalue_flags|||ciu OpMAYBESIB_set|5.021011|5.003007|p opmethod_stash|5.021007||Viu OpMORESIB_set|5.021011|5.003007|p OP_NAME|5.007003|5.007003| op_null|5.007002|5.007002| op_parent|5.025001|5.025001|n op_prepend_elem|5.013006|5.013006| op_refcnt_dec|||xiu op_refcnt_inc|||xiu op_refcnt_lock|5.009002|5.009002|u op_refcnt_unlock|5.009002|5.009002|u op_relocate_sv|5.021005||Viu op_scope|5.013007|5.013007|x OpSIBLING|5.021007|5.003007|p op_sibling_splice|5.021002|5.021002|n opslab_force_free|5.017002||Viu opslab_free|5.017002||Viu opslab_free_nopad|5.017002||Viu op_std_init|5.015003||Viu optimize_op|5.027006||Viu optimize_optree|5.027006||Vi OP_TYPE_IS|5.019007|5.019007| OP_TYPE_IS_OR_WAS|5.019010|5.019010| op_unscope|5.017003||xViu ORIGMARK|5.003007|5.003007| OSNAME|5.003007|5.003007| OSVERS|5.007002|5.007002| output_posix_warnings|5.029005||Viu package|5.003007||Viu package_version|5.011001||Viu pack_cat||| packlist|5.008001|5.008001| pack_rec|5.008001||Viu packWARN|5.007003||pVu pad_add_anon|5.008001|5.008001| pad_add_name_pv|5.015001|5.015001| pad_add_name_pvn|5.015001|5.015001| pad_add_name_pvs|5.015001|5.015001| pad_add_name_sv|5.015001|5.015001| pad_add_weakref|5.021007||Viu pad_alloc|5.003007|5.003007|x pad_alloc_name|5.015001||Vi PadARRAY|5.017004|5.017004|x PAD_BASE_SV|||i pad_block_start|5.008001||Vi pad_check_dup|5.008001||Vi PAD_CLONE_VARS|||i PAD_COMPNAME_FLAGS|||i PAD_COMPNAME_GEN|||i PAD_COMPNAME_GEN_set|||i PAD_COMPNAME_OURSTASH|||i PAD_COMPNAME_PV|||i pad_compname_type||| PAD_COMPNAME_TYPE|||i pad_findlex|5.005000||Vi pad_findmy_pv|5.015001|5.015001| pad_findmy_pvn|5.015001|5.015001| pad_findmy_pvs|5.015001|5.015001| pad_findmy_sv|5.015001|5.015001| pad_fixup_inner_anons|5.008001||Vi pad_free|5.003007||Vi pad_leavemy|5.003007||Vi PadlistARRAY|5.017004|5.017004|x padlist_dup|5.013002||Vi PadlistMAX|5.017004|5.017004|x PadlistNAMES|5.017004|5.017004|x PadlistNAMESARRAY|5.017004|5.017004|x PadlistNAMESMAX|5.017004|5.017004|x PadlistREFCNT|5.017004|5.017004|x padlist_store|5.017004||Viu PadMAX|5.017004|5.017004|x padname_dup|5.021007||Vi padname_free|||ciu PadnameIN_SCOPE|5.031004||nViu PadnameIsOUR|||i PadnameIsSTATE|||i PadnameLEN|5.017004|5.017004|x PadnamelistARRAY|5.017004|5.017004|x padnamelist_dup|5.021007||Vi padnamelist_fetch|5.021007|5.021007|nx padnamelist_free|||ciu PadnamelistMAX|5.017004|5.017004|x PadnamelistREFCNT|5.021007|5.021007|x PadnamelistREFCNT_dec|5.021007|5.021007|x padnamelist_store|5.021007|5.021007|x PadnameOURSTASH|||i PadnameOUTER|||i PadnamePV|5.017004|5.017004|x PadnameREFCNT|5.021007|5.021007|x PadnameREFCNT_dec|5.021007|5.021007|x PadnameSV|5.017004|5.017004|x PadnameTYPE|||i PadnameUTF8|5.017004|5.017004|x pad_new|5.008001|5.008001| pad_push|5.008001||cVi pad_reset|5.003007||Vi PAD_RESTORE_LOCAL|||i PAD_SAVE_LOCAL|||i PAD_SAVE_SETNULLPAD|||i PAD_SET_CUR|||i PAD_SET_CUR_NOSAVE|||i pad_setsv|5.008001|5.008001| PAD_SETSV|||i pad_sv|5.003007||V PAD_SV|||i PAD_SVl|||i pad_swipe|5.003007||Vi pad_tidy|5.008001|5.008001|x parse_arithexpr|5.013008|5.013008|x parse_barestmt|5.013007|5.013007|x parse_block|5.013007|5.013007|x parse_body|5.006000||Viu parse_fullexpr|5.013008|5.013008|x parse_fullstmt|5.013005|5.013005|x parse_gv_stash_name|5.019004||Viu parse_ident|5.017010||Viu parse_label|5.013007|5.013007|x parse_listexpr|5.013008|5.013008|x parse_lparen_question_flags|5.017009||Viu parser_dup|5.009000|5.009000|u parser_free|5.009005||Viu parser_free_nexttoke_ops|5.017006||Viu parse_stmtseq|5.013006|5.013006|x parse_subsignature|5.031003|5.031003|x parse_termexpr|5.013008|5.013008|x parse_unicode_opts|5.008001||Viu parse_uniprop_string|5.027011||cViu path_is_searchable|5.019001||nViu peep|5.003007||Viu pending_ident|5.017004||Viu PERL_ABS|5.008001|5.003007|p perl_alloc|5.003007|5.003007|n perl_alloc_using|5.006000||nVu PERL_BCDVERSION||5.003007|pou perl_clone|5.006000||nV perl_clone_using|5.006000||nVu perl_construct|5.003007|5.003007|n Perl_custom_op_xop|5.013007||V perl_destruct|5.007003|5.007003|n perl_free|5.003007|5.003007|n PERL_HASH|5.003007|5.003007|p PERL_INT_MAX|5.003007|5.003007|p PERL_INT_MIN|5.003007|5.003007|p PerlIO_apply_layers|5.007001|5.007001| PerlIO_binmode|5.007001|5.007001| PerlIO_canset_cnt|5.003007|5.003007|n PerlIO_clearerr|5.007003|5.007003| PerlIO_close|5.007003|5.007003| PerlIO_context_layers|5.009004|5.009004|u PerlIO_debug|5.007001|5.007001| PerlIO_eof|5.007003|5.007003| PerlIO_error|5.007003|5.007003| PerlIO_exportFILE|5.003007|5.003007|n PerlIO_fast_gets|5.003007|5.003007|n PerlIO_fdopen|5.003007|5.003007|n PerlIO_fileno|5.007003|5.007003| PerlIO_fill|5.007003|5.007003|u PerlIO_findFILE|5.003007|5.003007|n PerlIO_flush|5.007003|5.007003| PERLIO_FUNCS_CAST|5.009003||pVu PERLIO_FUNCS_DECL|5.009003||pVu PerlIO_get_base|5.007003|5.007003| PerlIO_get_bufsiz|5.007003|5.007003| PerlIO_getc|5.003007|5.003007|n PerlIO_get_cnt|5.007003|5.007003| PerlIO_getpos|5.003007|5.003007|n PerlIO_get_ptr|5.007003|5.007003| PerlIO_has_base|5.003007|5.003007|n PerlIO_has_cntptr|5.003007|5.003007|n PerlIO_importFILE|5.003007|5.003007|n PerlIO_open|5.003007|5.003007|n PerlIO_printf|5.006000|5.003007| PerlIO_putc|5.003007|5.003007|n PerlIO_puts|5.003007|5.003007|n PerlIO_read|5.007003|5.007003| PerlIO_releaseFILE|5.003007|5.003007|n PerlIO_reopen|5.003007|5.003007| PerlIO_restore_errno|5.021006||cViu PerlIO_rewind|5.003007|5.003007|n PerlIO_save_errno|5.021006||cViu PerlIO_seek|5.007003|5.007003| PerlIO_set_cnt|5.007003|5.007003| PerlIO_setlinebuf|5.007003|5.007003| PerlIO_setpos|5.003007|5.003007|n PerlIO_set_ptrcnt|5.007003|5.007003| PerlIO_stderr|5.007003|5.007003| PerlIO_stdin|5.007003|5.007003| PerlIO_stdout|5.007003|5.007003| PerlIO_stdoutf|5.006000|5.003007| PerlIO_tell|5.007003|5.007003| PerlIO_ungetc|5.003007|5.003007|n PerlIO_unread|5.007003|5.007003|u PerlIO_vprintf|5.003007|5.003007|n PerlIO_write|5.007003|5.007003| Perl_langinfo|5.027004|5.027004|n PerlLIO_dup2_cloexec|5.027008||Viu PerlLIO_dup_cloexec|5.027008||Viu PerlLIO_open3_cloexec|5.027008||Viu PerlLIO_open_cloexec|5.027008||Viu PERL_LOADMOD_DENY||5.003007|ou PERL_LOADMOD_IMPORT_OPS||5.003007|ou PERL_LOADMOD_NOIMPORT||5.003007|ou PERL_LONG_MAX|5.003007|5.003007|p PERL_LONG_MIN|5.003007|5.003007|p PERL_MAGIC_arylen|5.007002|5.003007|p PERL_MAGIC_arylen_p|5.009003|5.009003| PERL_MAGIC_backref|5.007002|5.003007|p PERL_MAGIC_bm|5.007002|5.003007|p PERL_MAGIC_checkcall|5.013006|5.013006| PERL_MAGIC_collxfrm|5.007002|5.003007|p PERL_MAGIC_dbfile|5.007002|5.003007|p PERL_MAGIC_dbline|5.007002|5.003007|p PERL_MAGIC_debugvar|5.021005|5.021005| PERL_MAGIC_defelem|5.007002|5.003007|p PERL_MAGIC_env|5.007002|5.003007|p PERL_MAGIC_envelem|5.007002|5.003007|p PERL_MAGIC_ext|5.007002|5.003007|p PERL_MAGIC_fm|5.007002|5.003007|p PERL_MAGIC_glob||5.003007|pou PERL_MAGIC_hints|5.009004|5.009004| PERL_MAGIC_hintselem|5.009004|5.009004| PERL_MAGIC_isa|5.007002|5.003007|p PERL_MAGIC_isaelem|5.007002|5.003007|p PERL_MAGIC_lvref|5.021005|5.021005| PERL_MAGIC_mutex||5.003007|pou PERL_MAGIC_nkeys|5.007002|5.003007|p PERL_MAGIC_nonelem|5.027009|5.027009| PERL_MAGIC_overload||5.003007|pou PERL_MAGIC_overload_elem||5.003007|pou PERL_MAGIC_overload_table|5.007002|5.003007|p PERL_MAGIC_pos|5.007002|5.003007|p PERL_MAGIC_qr|5.007002|5.003007|p PERL_MAGIC_regdata|5.007002|5.003007|p PERL_MAGIC_regdatum|5.007002|5.003007|p PERL_MAGIC_regex_global|5.007002|5.003007|p PERL_MAGIC_rhash|5.009003|5.009003| PERL_MAGIC_shared|5.007003|5.003007|p PERL_MAGIC_shared_scalar|5.007003|5.003007|p PERL_MAGIC_sig|5.007002|5.003007|p PERL_MAGIC_sigelem|5.007002|5.003007|p PERL_MAGIC_substr|5.007002|5.003007|p PERL_MAGIC_sv|5.007002|5.003007|p PERL_MAGIC_symtab|5.009003|5.009003| PERL_MAGIC_taint|5.007002|5.003007|p PERL_MAGIC_tied|5.007002|5.003007|p PERL_MAGIC_tiedelem|5.007002|5.003007|p PERL_MAGIC_tiedscalar|5.007002|5.003007|p PERL_MAGIC_utf8|5.008001|5.003007|p PERL_MAGIC_uvar|5.007002|5.003007|p PERL_MAGIC_uvar_elem|5.007003|5.003007|p PERL_MAGIC_vec|5.007002|5.003007|p PERL_MAGIC_vstring|5.008001|5.003007|p perl_parse|5.006000|5.006000|n PerlProc_pipe_cloexec|5.027008||Viu PERL_PV_ESCAPE_ALL|5.009004|5.003007|p PERL_PV_ESCAPE_FIRSTCHAR|5.009004|5.003007|p PERL_PV_ESCAPE_NOBACKSLASH|5.009004|5.003007|p PERL_PV_ESCAPE_NOCLEAR|5.009004|5.003007|p PERL_PV_ESCAPE_NONASCII|5.013009|5.013009| PERL_PV_ESCAPE_QUOTE|5.009004|5.003007|p PERL_PV_ESCAPE_RE|5.009005|5.003007|p PERL_PV_ESCAPE_UNI|5.009004|5.003007|p PERL_PV_ESCAPE_UNI_DETECT|5.009004|5.003007|p PERL_PV_PRETTY_DUMP|5.009004|5.003007|poVu PERL_PV_PRETTY_ELLIPSES|5.010000|5.003007|p PERL_PV_PRETTY_LTGT|5.009004|5.003007|p PERL_PV_PRETTY_NOCLEAR|5.010000|5.003007|poVu PERL_PV_PRETTY_QUOTE|5.009004|5.003007|p PERL_PV_PRETTY_REGPROP|5.009004|5.003007|poVu PERL_QUAD_MAX|5.003007|5.003007|p PERL_QUAD_MIN|5.003007|5.003007|p PERL_REVISION|5.006000|5.003007|p perl_run|5.003007|5.003007|n PERL_SCAN_ALLOW_UNDERSCORES|5.007003|5.003007|p PERL_SCAN_DISALLOW_PREFIX|5.007003|5.003007|p PERL_SCAN_GREATER_THAN_UV_MAX|5.007003|5.003007|p PERL_SCAN_SILENT_ILLDIGIT|5.008001|5.003007|p PERL_SCAN_TRAILING|5.021002|5.021002| Perl_setlocale|5.027002|5.027002|n PERL_SHORT_MAX|5.003007|5.003007|p PERL_SHORT_MIN|5.003007|5.003007|p PERL_SIGNALS_UNSAFE_FLAG|5.008001|5.003007|poVu Perl_signbit|5.009005|5.009005|nx PerlSock_accept_cloexec|5.027008||Viu PerlSock_socket_cloexec|5.027008||Viu PerlSock_socketpair_cloexec|5.027008||Viu PERL_SUBVERSION|5.006000|5.003007|p PERL_SYS_INIT3|5.006000|5.006000| PERL_SYS_INIT|5.003007|5.003007| PERL_SYS_TERM|5.003007|5.003007| PERL_UCHAR_MAX|5.003007|5.003007|p PERL_UCHAR_MIN|5.003007|5.003007|p PERL_UINT_MAX|5.003007|5.003007|p PERL_UINT_MIN|5.003007|5.003007|poVu PERL_ULONG_MAX|5.003007|5.003007|p PERL_ULONG_MIN|5.003007|5.003007|p PERL_UNUSED_ARG|5.009003||pVu PERL_UNUSED_CONTEXT|5.009004|5.003007|poVu PERL_UNUSED_DECL|5.007002|5.003007|poVu PERL_UNUSED_RESULT|5.021001||pVu PERL_UNUSED_VAR|5.007002||pVu PERL_UQUAD_MAX|5.003007|5.003007|p PERL_UQUAD_MIN|5.003007|5.003007|p PERL_USE_GCC_BRACE_GROUPS|5.009004|5.004000|poVu PERL_USHORT_MAX|5.003007|5.003007|p PERL_USHORT_MIN|5.003007|5.003007|p PERL_VERSION|5.006000|5.003007|p perly_sighandler|||nu pidgone|5.003007||Viu PL_bufend||5.003007|pou PL_bufptr||5.003007|pou PL_check|5.009003|5.006000| PL_compiling|5.004005|5.003007|poVu PL_comppad|5.008001|5.008001|x PL_comppad_name|5.017004|5.017004|x PL_copline||5.003007|pou PL_curcop|5.004005|5.003007|p PL_curpad|5.005000|5.005000|x PL_curstash|5.004005|5.003007|p PL_DBsignal|5.005000|5.003007|poVu PL_DBsingle|5.004005|5.003007|poV PL_DBsub|5.004005|5.003007|poV PL_DBtrace|5.005000|5.003007|poV PL_debstash|5.004005|5.003007|poVu PL_defgv|5.004005|5.003007|p PL_diehook|5.004005|5.003007|poVu PL_dirty|5.004005|5.003007|poVu PL_dowarn|5.004005|5.003007|poV PL_errgv|5.004005|5.003007|p PL_error_count||5.003007|pou PL_exit_flags|5.006000|5.006000| PL_expect||5.003007|pou PL_hexdigit|5.005000|5.003007|poVu PL_hints|5.005000|5.003007|poVu PL_in_my||5.003007|pou PL_in_my_stash||5.005000|pou PL_keyword_plugin|5.011002|5.011002|x PL_last_in_gv|||i PL_laststatval|5.005000|5.003007|poVu PL_lex_state||5.003007|pou PL_lex_stuff||5.003007|pou PL_linestr||5.003007|pou PL_mess_sv|5.005000|5.004000|poVu PL_modglobal|5.005000|5.005000| PL_na|5.004005|5.003007|p PL_no_modify|5.006000|5.003007|poVu PL_ofsgv|||i PL_opfreehook|5.011000|5.011000| PL_parser|5.009005|5.003007|p PL_peepp|5.007003|5.007003| PL_perldb|5.004005|5.003007|poVu PL_perl_destruct_level|5.004005|5.003007|p PL_ppaddr|5.006000|5.003007|poVu PL_rpeepp|5.013005|5.013005| PL_rsfp||5.003007|pou PL_rsfp_filters||5.003007|pou PL_rs|||i PL_runops|5.006000|5.006000| PL_signals|5.008001||pVu PL_stack_base|5.004005|5.003007|poVu PL_stack_sp|5.004005|5.003007|poVu PL_statcache|5.005000|5.003007|poVu PL_stdingv|5.004005|5.003007|poVu PL_Sv|5.005000|5.003007|poVu PL_sv_arenaroot|5.004005|5.003007|poVu PL_sv_no|5.004005|5.003007|p PL_sv_undef|5.004005|5.003007|p PL_sv_yes|5.004005|5.003007|p PL_sv_zero|5.027003|5.027003| PL_tainted|5.004005|5.003007|poVu PL_tainting|5.004005|5.003007|poVu PL_tokenbuf||5.003007|pou pm_description|5.009004||Viu pmop_dump|5.006000|5.006000|u pmruntime|5.003007||Viu pmtrans|5.003007||Viu _pMY_CXT|5.007003|5.009000|pV pMY_CXT_|5.007003|5.009000|pV pMY_CXT|5.009000|5.009000|p Poison|5.008000|5.003007|p PoisonFree|5.009004|5.003007|p PoisonNew|5.009004|5.003007|p PoisonWith|5.009004|5.003007|p POPi|5.003007|5.003007| POPl|5.003007|5.003007| POPMARK|||ciu POP_MULTICALL|5.009003|5.009003| POPn|5.006000|5.003007| POPp|5.003007|5.003007| POPpbytex|5.007001|5.007001| POPpx|5.005003|5.005003| POPs|5.003007|5.003007| pop_scope|5.003007|5.003007|u POPu|5.004000|5.004000| POPul|5.006000|5.006000| populate_ANYOF_from_invlist|5.019005||Viu populate_isa|||viu pregcomp|5.009005|5.009005|u pregexec|5.003007|5.003007|u pregfree2|5.011000|5.011000|u pregfree|5.003007|5.003007|u prescan_version|5.011004|5.011004| printbuf|5.009004||Viu print_bytes_for_locale|5.027002||Viu print_collxfrm_input_and_return|5.025004||Viu printf_nocontext|5.007001|5.007001|vndu PRIVLIB|5.003007|5.003007| process_special_blocks|5.009005||Viu pTHX|5.006000|5.003007|p pTHX_|5.006000|5.003007|pV PTR2IV|5.006000|5.003007|p PTR2nat|5.009003||pVu PTR2NV|5.006000|5.003007|p PTR2ul|5.007001||pVu PTR2UV|5.006000|5.003007|p ptr_hash|5.017010||nViu PTRSIZE|5.005000|5.005000| ptr_table_clear|5.009005|5.009005|du ptr_table_fetch|5.009005|5.009005|u ptr_table_find|5.009004||nViu ptr_table_free|5.009005|5.009005|u ptr_table_new|5.009005|5.009005|u ptr_table_split|5.009005|5.009005|u ptr_table_store|5.009005|5.009005|u PTRV|5.006000|5.003007|poVu PUSHi|5.003007|5.003007| PUSHMARK|5.003007|5.003007| PUSHmortal|5.009002|5.003007|p PUSH_MULTICALL|5.011000|5.011000| PUSHn|5.006000|5.003007| PUSHp|5.003007|5.003007| PUSHs|5.003007|5.003007| push_scope|5.003007|5.003007|u PUSHu|5.004000|5.003007|p PUTBACK|5.003007|5.003007| put_charclass_bitmap_innards|5.021004||Viu put_charclass_bitmap_innards_common|5.023008||Viu put_charclass_bitmap_innards_invlist|5.023008||Viu put_code_point|5.021004||Viu put_range|5.019009||Viu pv_display|5.006000|5.003007|p pv_escape|5.009004|5.003007|p pv_pretty|5.009004|5.003007|p pv_uni_display|5.007003|5.007003| qerror|5.006000||cViu quadmath_format_needed|5.021004||nVi quadmath_format_valid|||nVi RANDBITS|5.003007|5.003007| READ_XDIGIT|5.017006|5.017006| realloc|5.007002|5.007002|n ReANY|||ncu re_compile|5.009005|5.009005|u re_croak2|||iu re_dup_guts|5.011000|5.011000|u reentrant_free|5.010000|5.010000|u reentrant_init|5.010000|5.010000|u reentrant_retry|5.010000|5.010000|vnu reentrant_size|5.010000|5.010000|u re_exec_indentf|5.023009||vViu ref|5.003007||Vu ref_array_or_hash|5.027008||Viu refcounted_he_chain_2hv|5.013007||cVi refcounted_he_fetch_pv|5.013007||cVi refcounted_he_fetch_pvn|5.013007||cVi refcounted_he_fetch_pvs|||i refcounted_he_fetch_sv|5.013007||cVi refcounted_he_free|5.013007||cVi refcounted_he_inc|5.013007||cVi refcounted_he_new_pv|5.013007||cVi refcounted_he_new_pvn|5.013007||cVi refcounted_he_new_pvs|||i refcounted_he_new_sv|5.013007||cVi refcounted_he_value|5.009004||Viu refkids|5.003007||Viu refto|5.005000||Viu reg2Lanode|5.021005||Viu reg|5.005000||Viu reganode|5.005000||Viu regatom|5.005000||Viu regbranch|5.005000||Viu reg_check_named_buff_matched|5.009005||nViu regclass|5.005000||Viu regcppop|5.005000||Viu regcppush|5.005000||Viu regcp_restore|5.025006||Viu regcurly|5.013010||nViu regdump|5.005000|5.005000|u regdump_extflags|5.009005||Viu regdump_intflags|5.019002||Viu regdupe_internal|5.009000|5.009000|u regexec_flags|5.005000|5.005000|u regex_set_precedence|5.021010||nViu regfree_internal|5.009005|5.009005|u reghop3|5.007001||nViu reghop4|5.009005||nViu reghopmaybe3|5.007001||nViu reginclass|5.005000||Viu reginitcolors|5.006000|5.006000|u reginsert|5.005000||Viu regmatch|5.005000||Viu reg_named_buff|5.009005||cViu reg_named_buff_all|5.009005|5.009005|u reg_named_buff_exists|5.009005|5.009005|u reg_named_buff_fetch|5.009005|5.009005|u reg_named_buff_firstkey|5.009005|5.009005|u reg_named_buff_iter|5.009005||cViu reg_named_buff_nextkey|5.009005|5.009005|u reg_named_buff_scalar|5.009005|5.009005|u regnext|5.005000|5.005000|u reg_node|5.005000||Viu regnode_guts|5.021005||Viu reg_numbered_buff_fetch|5.009005||cViu reg_numbered_buff_length|5.009005||cViu reg_numbered_buff_store|5.009005||cViu regpiece|5.005000||Viu regprop|5.003007||Viu reg_qr_package|5.009005||cViu regrepeat|5.005000||Viu reg_scan_name|5.009005||Viu reg_skipcomment|5.009005||nViu regtail|5.005000||Viu regtail_study|5.009004||Viu reg_temp_copy|5.009005||cViu regtry|5.005000||Viu re_indentf|5.023009||vViu re_intuit_start|5.006000||cVu re_intuit_string|5.006000||cVu Renew|5.003007|5.003007| Renewc|5.003007|5.003007| re_op_compile|5.017001||Viu repeatcpy|5.003007|5.003007|nu REPLACEMENT_CHARACTER_UTF8|5.025005|5.003007|p report_evil_fh|5.006001||Viu report_redefined_cv|5.015006||Viu report_uninit|5.006000||cVi report_wrongway_fh|5.013009||Viu re_printf|5.023009||vViu require_pv|5.006000|5.006000| require_tie_mod|5.009005||Viu RESTORE_ERRNO|||i RESTORE_LC_NUMERIC|5.021010|5.021010| restore_magic|5.009003||Viu restore_switched_locale|5.027009||Viu RETVAL|5.003007|5.003007|V rninstr|5.003007|5.003007|n rpeep|5.013005||Viu rsignal|5.004000|5.004000| rsignal_restore|5.004000||Viu rsignal_save|5.004000||Viu rsignal_state|5.004000|5.004000|u run_body|5.006000||Viu runops_debug|5.005000|5.005000|u runops_standard|5.005000|5.005000|u run_user_filter|5.009003||Viu rv2cv_op_cv|5.013006|5.013006| rvpv_dup|5.007003|5.007003|u rxres_free|5.004000||Viu rxres_restore|5.004000||Viu rxres_save|5.004000||Viu Safefree|5.003007|5.003007| safesyscalloc|5.006000|5.006000|nu safesysfree|5.006000|5.006000|nu safesysmalloc|5.006000|5.006000|nu safesysrealloc|5.006000|5.006000|nu same_dirent|5.003007||Viu SANE_ERRSV|5.031003|5.031003| save_adelete|5.011000|5.011000|u save_aelem|5.004005|5.004005|u save_aelem_flags|5.011000|5.011000|u save_alloc|5.006000|5.006000|u save_aptr|5.003007|5.003007| save_ary|5.003007|5.003007| save_bool|5.008001|5.008001|u save_clearsv|5.003007|5.003007|u SAVECLEARSV|||i SAVECOMPPAD|||i SAVE_DEFSV|5.004005|5.003007|poVu save_delete|5.003007|5.003007|u save_destructor|5.006000|5.006000|u save_destructor_x|5.006000|5.006000|u SAVE_ERRNO|||i save_freeop|5.010001|5.010001|u save_freepv|5.003007|5.003007|u save_freesv|5.003007|5.003007|u save_generic_pvref|5.006001|5.006001|u save_generic_svref|5.005003|5.005003|u save_gp|5.004000|5.004000| save_hash|5.003007|5.003007| save_hdelete|5.011000|5.011000|u save_hek_flags|5.008000||nViu save_helem|5.004005|5.004005|u save_helem_flags|5.011000|5.011000|u save_hints|5.010001|5.010001|u save_hptr|5.003007|5.003007| save_I16|5.004000|5.004000|u save_I32|5.003007|5.003007|u save_I8|5.006000|5.006000|u save_int|5.003007|5.003007|u save_item|5.003007|5.003007| save_iv|5.005000|5.005000|u save_lines|5.005000||Viu save_list|5.003007|5.003007|d save_long|5.003007|5.003007|du save_magic_flags|5.019002||Viu save_mortalizesv|5.007001|5.007001|u save_nogv|5.003007|5.003007|du save_op|5.010001|5.010001|u save_padsv_and_mortalize|5.010001|5.010001|u SAVEPADSV|||i save_pptr|5.003007|5.003007|u save_pushi32ptr|5.010001|5.010001|u save_pushptr|5.010001|5.010001|u save_pushptri32ptr|5.010001||Viu save_pushptrptr|5.010001|5.010001|u savepv|5.003007|5.003007| savepvn|5.003007|5.003007| savepvs|5.009003|5.009003| save_re_context|5.006000|5.006000|u save_scalar|5.003007|5.003007| save_scalar_at|5.005000||Viu save_set_svflags|5.009000|5.009000|u savesharedpv|5.007003|5.007003| savesharedpvn|5.009005|5.009005| save_shared_pvref|5.007003|5.007003|u savesharedpvs|5.013006|5.013006| savesharedsvpv|5.013006|5.013006| save_sptr|5.003007|5.003007|u savestack_grow|5.003007|5.003007|u savestack_grow_cnt|5.008001|5.008001|u save_strlen|5.019004||cViu savesvpv|5.009002|5.009002| save_svref|5.003007|5.003007| SAVETMPS|5.003007|5.003007| savetmps|5.023008|5.023008|xu save_to_buffer|5.027004||nViu save_vptr|5.006000|5.006000|u sawparens|5.003007||Viu scalar|5.003007||Viu scalarboolean|5.005000||Viu scalarkids|5.003007||Viu scalar_mod_type|5.006000||nViu scalarseq|5.003007||Viu scalarvoid|5.003007||Viu scan_bin|5.006000|5.006000| scan_commit|5.005000||Viu scan_const|5.003007||Viu scan_formline|5.003007||Viu scan_heredoc|5.003007||Viu scan_hex|5.006000|5.003007| scan_ident|5.003007||Viu scan_inputsymbol|5.003007||Viu scan_num|5.007001|5.007001|u scan_oct|5.006000|5.003007| scan_pat|5.003007||Viu scan_str|5.003007||xcViu scan_subst|5.003007||Viu scan_trans|5.003007||Viu scan_version|5.009001|5.009001| scan_vstring|5.009005|5.009005|u scan_word|5.003007||xcViu search_const|5.010001||Viu seed|5.008001|5.008001|u sequence_num|5.009003||Viu set_ANYOF_arg|5.019005||Viu set_caret_X|5.019006||Viu set_context|5.006000|5.006000|nu setdefout|5.003007|5.003007| SETERRNO|||i setfd_cloexec|5.027008||nViu setfd_cloexec_for_nonsysfd|5.027008||Viu setfd_cloexec_or_inhexec_by_sysfdness|5.027008||Viu setfd_inhexec|5.027008||nViu setfd_inhexec_for_sysfd|5.027008||Viu setlocale_debug_string|5.027002||nViu set_numeric_radix|5.006000||Viu set_numeric_standard|5.006000||cViu set_numeric_underlying|5.027006||cViu set_padlist|5.021006||ncViu set_regex_pv|5.029004||Viu _setup_canned_invlist|5.019008||cViu share_hek|5.004000|5.004000|u share_hek_flags|5.008000||Viu SHORTSIZE|5.004000|5.004000| should_warn_nl|5.021001||nViu si_dup|5.007003|5.007003|u sighandler1|||nViu sighandler3|||nViu sighandler|5.003007||nViu simplify_sort|5.006000||Viu SITELIB|5.003007|5.003007| skipspace_flags|5.019002||xcViu skip_to_be_ignored_text|5.023004||Viu Slab_Alloc|5.006000||cViu Slab_Free|5.007003||cViu Slab_to_ro|5.017002||Viu Slab_to_rw|5.009005||Viu softref2xv|||iu sortcv|5.009003||Viu sortcv_stacked|5.009003||Viu sortcv_xsub|5.009003||Viu sortsv|5.007003|5.007003| sortsv_flags|5.009003|5.009003| SP|5.003007|5.003007| space_join_names_mortal|5.009004||Viu SPAGAIN|5.003007|5.003007| ssc_add_range|5.019005||Viu ssc_and|5.019005||Viu ssc_anything|5.019005||Viu ssc_clear_locale|5.019005||nViu ssc_cp_and|5.019005||Viu ssc_finalize|5.019005||Viu ssc_init|5.019005||Viu ssc_intersection|5.019005||Viu ssc_is_anything|5.019005||nViu ssc_is_cp_posixl_init|5.019005||nViu ssc_or|5.019005||Viu ssc_union|5.019005||Viu ss_dup|5.007003|5.007003|u ST|5.003007|5.003007| stack_grow|5.003007|5.003007|u START_EXTERN_C|5.005000|5.003007|poVu start_glob|||xi START_MY_CXT|5.010000|5.010000|p STARTPERL|5.003007|5.003007| start_subparse|5.004000|5.003007|pu STDCHAR|5.003007|5.003007| stdize_locale|5.007001||Viu STMT_END|5.003007|5.003007|pV STMT_START|5.003007|5.003007|pV STORE_LC_NUMERIC_FORCE_TO_UNDERLYING|5.021010|5.021010| STORE_LC_NUMERIC_SET_TO_NEEDED|5.021010|5.021010| STORE_LC_NUMERIC_SET_TO_NEEDED_IN|5.031003|5.031003| strEQ|5.003007|5.003007| strGE|5.003007|5.003007| strGT|5.003007|5.003007| strip_return|5.009003||Viu strLE|5.003007|5.003007| strLT|5.003007|5.003007| strNE|5.003007|5.003007| strnEQ|5.003007|5.003007| strnNE|5.003007|5.003007| Strtod|5.029010|5.029010|n Strtol|5.006000|5.006000|n Strtoul|5.006000|5.006000|n str_to_version|5.006000|5.006000|u StructCopy|5.003007|5.003007|V STR_WITH_LEN|5.009003|5.003007|pV study_chunk|5.005000||Viu sub_crush_depth|5.004000||Viu sublex_done|5.005000||Viu sublex_push|5.005000||Viu sublex_start|5.005000||Viu sv_2bool|5.003007|5.003007| sv_2bool_flags|5.013006|5.013006| sv_2cv|5.003007|5.003007| sv_2io|5.003007|5.003007| sv_2iuv_common|5.009004||Viu sv_2iuv_non_preserve|5.007001||Viu sv_2iv|5.003007|5.003007|u sv_2iv_flags|5.009001|5.009001| sv_2mortal|5.003007|5.003007| sv_2num|5.010000||xVi sv_2nv_flags|5.013001|5.013001| sv_2pv|5.003007|5.003007|u sv_2pvbyte|5.006000|5.003007|p sv_2pvbyte_flags|5.031004|5.031004|u sv_2pvbyte_nolen|5.006000|5.003007|p sv_2pv_flags|5.007002|5.003007|p sv_2pv_nolen|5.006000|5.003007|p sv_2pvutf8|5.006000|5.006000| sv_2pvutf8_flags|5.031004|5.031004|u sv_2pvutf8_nolen|5.006000|5.006000| sv_2uv|5.004000|5.003007|pu sv_2uv_flags|5.009001|5.009001| sv_add_arena|5.003007||Vi sv_add_backref|||iu SvAMAGIC_off|5.031004|5.031004|nu SvAMAGIC_on|5.031004|5.031004|nu sv_backoff|5.003007|5.003007|n sv_bless|5.003007|5.003007| sv_buf_to_ro|5.019008||Viu sv_buf_to_rw|5.019008||Viu sv_cat_decode|5.008001|5.008001| sv_catpv|5.003007|5.003007| sv_catpvf|5.006000|5.004000|v sv_catpv_flags|5.013006|5.013006| sv_catpvf_mg|5.006000|5.004000|pv sv_catpvf_mg_nocontext|5.006000||pvnVu sv_catpvf_nocontext|5.006000||vnVu sv_catpv_mg|5.004005|5.003007|p sv_catpvn|5.003007|5.003007| sv_catpvn_flags|5.007002|5.007002| sv_catpvn_mg|5.004005|5.003007|p sv_catpvn_nomg|5.007002|5.003007|p sv_catpv_nomg|5.013006|5.013006| sv_catpvs|5.009003|5.003007|p sv_catpvs_flags|5.013006|5.013006| sv_catpvs_mg|5.013006|5.013006| sv_catpvs_nomg|5.013006|5.013006| sv_catsv|5.003007|5.003007| sv_catsv_flags|5.007002|5.007002| sv_catsv_mg|5.004005|5.003007|p sv_catsv_nomg|5.007002|5.003007|p sv_chop|5.003007|5.003007| sv_clean_all|5.003007||Vi sv_clean_objs|5.003007||Vi sv_clear|5.003007|5.003007| sv_cmp|5.003007|5.003007| sv_cmp_flags|5.013006|5.013006| sv_cmp_locale|5.004000|5.004000| sv_cmp_locale_flags|5.013006|5.013006| sv_collxfrm||| sv_collxfrm_flags|5.013006|5.013006| SV_CONST_RETURN|5.009003|5.003007|poVu sv_copypv|5.007003|5.007003| sv_copypv_flags|5.017002|5.017002| sv_copypv_nomg|5.017002|5.017002| SV_COW_DROP_PV|5.008001|5.003007|p SV_COW_SHARED_HASH_KEYS|5.009005|5.003007|poVu SvCUR|5.003007|5.003007| SvCUR_set|5.003007|5.003007| sv_dec|5.003007|5.003007| sv_dec_nomg|5.013002|5.013002| sv_del_backref|5.006000||cViu sv_derived_from|5.004000|5.004000| sv_derived_from_pv|5.015004|5.015004| sv_derived_from_pvn|5.015004|5.015004| sv_derived_from_sv|5.015004|5.015004| sv_derived_from_svpvn|5.031006||Viu sv_destroyable|5.010000|5.010000| sv_display|5.021002||Viu sv_does|5.009004|5.009004| sv_does_pv|5.015004|5.015004| sv_does_pvn|5.015004|5.015004| sv_does_sv|5.015004|5.015004| sv_dump|5.003007|5.003007| sv_dup|5.007003|5.007003|u sv_dup_common|5.013002||Viu sv_dup_inc|5.013002|5.013002|u sv_dup_inc_multiple|5.011000||Viu SvEND|5.003007|5.003007| sv_eq|5.003007|5.003007| sv_eq_flags|5.013006|5.013006| sv_exp_grow|5.009003||Viu SVf|5.006000|5.003007|poVu SVfARG|5.009005|5.003007|pV sv_force_normal|5.006000|5.006000| sv_force_normal_flags|5.007001|5.007001| sv_free2|||xciu sv_free|5.003007|5.003007| sv_free_arenas|5.003007||Vi SVf_UTF8|5.006000|5.003007|p SvGAMAGIC|5.006001|5.006001| sv_get_backrefs|5.021008|5.021008|nx SvGETMAGIC|5.004005|5.003007|p sv_gets|5.003007|5.003007| SV_GMAGIC|5.007002|5.003007|p sv_grow|5.003007|5.003007| SvGROW|5.003007|5.003007| SV_HAS_TRAILING_NUL|5.009004|5.003007|p SV_IMMEDIATE_UNREF|5.007001|5.003007|p sv_inc|5.003007|5.003007| sv_i_ncmp|5.009003||Viu sv_inc_nomg|5.013002|5.013002| sv_insert|5.003007|5.003007| sv_insert_flags|5.010001|5.010001| SvIOK|5.003007|5.003007| SvIOK_notUV|5.006000|5.006000| SvIOK_off|5.003007|5.003007| SvIOK_on|5.003007|5.003007| SvIOK_only|5.003007|5.003007| SvIOK_only_UV|5.006000|5.006000| SvIOKp|5.003007|5.003007| SvIOK_UV|5.006000|5.006000| sv_isa|5.003007|5.003007| SvIsCOW|5.008003|5.008003| SvIsCOW_shared_hash|5.008003|5.008003| sv_isobject|5.003007|5.003007| SvIV|5.003007|5.003007| sv_iv|5.005000|5.005000|d SvIV_nomg|5.009001|5.007003|p SvIV_set|5.003007|5.003007| SvIVX|5.003007|5.003007| SvIVx|5.003007|5.003007| sv_kill_backrefs|||xiu sv_len|5.003007|5.003007| SvLEN|5.003007|5.003007| SvLEN_set|5.003007|5.003007| sv_len_utf8|5.006000|5.006000|p sv_len_utf8_nomg|5.017004||pVu SvLOCK|5.007003|5.007003| sv_magic|5.003007|5.003007| sv_magicext|5.007003|5.007003| sv_magicext_mglob|5.019002||cViu sv_magic_portable||5.004000|pou SvMAGIC_set|5.009003|5.003007|p sv_mortalcopy|5.003007|5.003007| sv_mortalcopy_flags|5.017005|5.007002|p SV_MUTABLE_RETURN|5.009003|5.003007|poVu sv_ncmp|5.009003||Viu sv_newmortal|5.003007|5.003007| sv_newref|5.003007|5.003007| SvNIOK|5.003007|5.003007| SvNIOK_off|5.003007|5.003007| SvNIOKp|5.003007|5.003007| SvNOK|5.003007|5.003007| SvNOK_off|5.003007|5.003007| SvNOK_on|5.003007|5.003007| SvNOK_only|5.003007|5.003007| SvNOKp|5.003007|5.003007| sv_nolocking|5.007003|5.007003|d sv_nosharing|5.007003|5.007003| SV_NOSTEAL|5.009002|5.007003|p sv_nounlocking|5.007003|5.007003|d SvNV|5.006000|5.003007| sv_nv|5.006000|5.005000|d SvNV_nomg|5.013002|5.007003|p SvNV_set|5.006000|5.003007| SvNVX|5.006000|5.003007| SvNVx|5.006000|5.003007| SvOK|5.003007|5.003007| sv_only_taint_gmagic|5.021010||nViu SvOOK|5.003007|5.003007| SvOOK_offset|5.011000|5.011000| sv_or_pv_pos_u2b|5.019004||Viu sv_peek|5.005000|5.005000|u SvPOK|5.003007|5.003007| SvPOK_off|5.003007|5.003007| SvPOK_on|5.003007|5.003007| SvPOK_only|5.003007|5.003007| SvPOK_only_UTF8|5.006000|5.006000| SvPOKp|5.003007|5.003007| sv_pos_b2u|5.006000|5.006000| sv_pos_b2u_flags|5.019003|5.019003| sv_pos_b2u_midway|5.009004||Viu sv_pos_u2b|5.006000|5.006000| sv_pos_u2b_cached|5.009004||Viu sv_pos_u2b_flags|5.011005|5.011005| sv_pos_u2b_forwards|5.009004||nViu sv_pos_u2b_midway|5.009004||nViu SvPV|5.003007|5.003007| sv_pv|5.006000|5.006000| SvPVbyte|5.006000|5.003007|p sv_pvbyte|5.006000|5.006000| SvPVbyte_force|5.009002|5.009002| sv_pvbyten|5.006000|5.006000|d sv_pvbyten_force|5.006000|5.006000| SvPVbyte_nolen|5.006000|5.006000| SvPVbyte_nomg|5.031004|5.031004| SvPVbyte_or_null|5.031004|5.031004| SvPVbyte_or_null_nomg|5.031004|5.031004| SvPVbytex|5.006000|5.006000| SvPVbytex_force|5.006000|5.006000| SvPVCLEAR|5.025006|5.025006| SvPV_const|5.009003||pVu SvPV_flags|5.007002||pVu SvPV_flags_const|5.009003||pVu SvPV_flags_const_nolen|5.009003||pVu SvPV_flags_mutable|5.009003||pVu SvPV_force|5.003007|5.003007|p SvPV_force_flags|5.007002||pVu SvPV_force_flags_mutable|5.009003||pVu SvPV_force_flags_nolen|5.009003||pVu SvPV_force_mutable|5.009003||pVu SvPV_force_nolen|5.009003||pVu SvPV_force_nomg|5.007002|5.003007|p SvPV_force_nomg_nolen|5.009003||pVu SvPV_mutable|5.009003||pVu sv_pvn|5.005000|5.005000|d sv_pvn_force|5.003007|5.003007| sv_pvn_force_flags|5.007002|5.003007|p sv_pvn_nomg|5.007003|5.005000|pdu SvPV_nolen|5.006000|5.003007|p SvPV_nolen_const|5.009003||pVu SvPV_nomg|5.007002|5.003007|p SvPV_nomg_const|5.009003||pVu SvPV_nomg_const_nolen|5.009003||pVu SvPV_nomg_nolen|5.013007|5.003007|p SvPV_renew|5.009003||pVu SvPV_set|5.003007|5.003007| sv_pvutf8|5.006000|5.006000| SvPVutf8|5.006000|5.006000| SvPVutf8_force|5.006000|5.006000| sv_pvutf8n|5.006000|5.006000|d sv_pvutf8n_force|5.006000|5.006000| SvPVutf8_nolen|5.006000|5.006000| SvPVutf8_nomg|5.031004|5.031004| SvPVutf8_or_null|5.031004|5.031004| SvPVutf8_or_null_nomg|5.031004|5.031004| SvPVutf8x|5.006000|5.006000| SvPVutf8x_force|5.006000|5.006000| SvPVX|5.003007|5.003007| SvPVx|5.003007|5.003007| SvPVX_const|5.009003||pVu SvPVX_mutable|5.009003||pVu SvREADONLY|5.003007|5.003007| SvREADONLY_off|5.003007|5.003007| SvREADONLY_on|5.003007|5.003007| sv_recode_to_utf8|5.007003|5.007003| sv_ref|5.015004|5.015004| SvREFCNT|5.003007|5.003007| SvREFCNT_dec|5.003007|5.003007| SvREFCNT_dec_NN|5.017007|5.017007| SvREFCNT_inc|5.003007|5.003007|pn SvREFCNT_inc_NN|5.009004|5.003007|pn SvREFCNT_inc_simple|5.009004|5.003007|p SvREFCNT_inc_simple_NN|5.009004|5.003007|p SvREFCNT_inc_simple_void|5.009004|5.003007|p SvREFCNT_inc_simple_void_NN|5.009004|5.003007|p SvREFCNT_inc_void|5.009004|5.003007|pn SvREFCNT_inc_void_NN|5.009004|5.003007|p sv_reftype|5.003007|5.003007| sv_replace|5.003007|5.003007| sv_report_used|5.003007|5.003007| sv_reset|5.003007|5.003007| sv_resetpvn|5.017005||Viu SvROK|5.003007|5.003007| SvROK_off|5.003007|5.003007| SvROK_on|5.003007|5.003007| SvRV|5.003007|5.003007| SvRV_set|5.009003|5.003007|p sv_rvunweaken|5.027004|5.027004| sv_rvweaken|5.006000|5.006000| SvRX|5.009005|5.003007|p SvRXOK|5.009005|5.003007|p sv_sethek|5.015004||cViu sv_setiv|5.003007|5.003007| sv_setiv_mg|5.004005|5.003007|p SvSETMAGIC|5.003007|5.003007| SvSetMagicSV|5.004000|5.004000| SvSetMagicSV_nosteal|5.004000|5.004000| sv_setnv|5.006000|5.003007| sv_setnv_mg|5.006000|5.003007|p sv_setpv|5.003007|5.003007| sv_setpv_bufsize|5.025006|5.025006| sv_setpvf|5.006000|5.004000|v sv_setpvf_mg|5.006000|5.004000|pv sv_setpvf_mg_nocontext|5.006000||pvnVu sv_setpvf_nocontext|5.006000||vnVu sv_setpviv|5.008001|5.008001|d sv_setpviv_mg|5.008001|5.008001|d sv_setpv_mg|5.004005|5.003007|p sv_setpvn|5.003007|5.003007| sv_setpvn_mg|5.004005|5.003007|p sv_setpvs|5.009004|5.003007|p sv_setpvs_mg|5.013006|5.013006| sv_setref_iv|5.003007|5.003007| sv_setref_nv|5.006000|5.003007| sv_setref_pv|5.003007|5.003007| sv_setref_pvn|5.003007|5.003007| sv_setref_pvs|5.013006|5.013006| sv_setref_uv|5.007001|5.007001| sv_setsv|5.003007|5.003007| SvSetSV|5.003007|5.003007| sv_setsv_cow|5.009000||xcViu sv_setsv_flags|5.007002|5.007002|p sv_setsv_mg|5.004005|5.003007|p sv_setsv_nomg|5.007002|5.003007|p SvSetSV_nosteal|5.004000|5.004000| sv_set_undef|5.025008|5.025008| sv_setuv|5.004000|5.003007|p sv_setuv_mg|5.004005|5.003007|p SvSHARE|5.007003|5.007003| SvSHARED_HASH|5.009003||pVu SV_SMAGIC|5.009003|5.003007|p SvSTASH|5.003007|5.003007| SvSTASH_set|5.009003|5.003007|p SVs_TEMP|5.003007|5.003007| sv_string_from_errnum|5.027003|5.027003| SvTAINT|5.003007|5.003007| sv_taint|5.004000|5.004000| sv_tainted|5.004000|5.004000| SvTAINTED|5.004000|5.004000| SvTAINTED_off|5.004000|5.004000| SvTAINTED_on|5.004000|5.004000| SvTHINKFIRST|||i SVt_INVLIST|||c SVt_IV|5.003007|5.003007| SVt_NULL|5.003007|5.003007| SVt_NV|5.003007|5.003007| SVt_PV|5.003007|5.003007| SVt_PVAV|5.003007|5.003007| SVt_PVCV|5.003007|5.003007| SVt_PVFM|5.003007|5.003007| SVt_PVGV|5.003007|5.003007| SVt_PVHV|5.003007|5.003007| SVt_PVIO|5.003007|5.003007| SVt_PVIV|5.003007|5.003007| SVt_PVLV|5.003007|5.003007| SVt_PVMG|5.003007|5.003007| SVt_PVNV|5.003007|5.003007| SVt_REGEXP|5.011000|5.011000| SvTRUE|5.003007|5.003007| sv_true|5.005000|5.005000| SvTRUE_nomg|5.013006|5.007003|p SvTRUEx|5.003007|5.003007| SvTYPE|5.003007|5.003007| svtype|5.003007|5.003007|V sv_unglob|5.005000||Viu sv_uni_display|5.007003|5.007003| SvUNLOCK|5.007003|5.007003| sv_unmagic|5.003007|5.003007| sv_unmagicext|5.013008|5.003007|p sv_unref|5.003007|5.003007| sv_unref_flags|5.007001|5.007001| sv_untaint|5.004000|5.004000| SvUOK|5.007001|5.006000|p sv_upgrade|5.003007|5.003007| SvUPGRADE|5.003007|5.003007| sv_usepvn|5.003007|5.003007| sv_usepvn_flags|5.009004|5.009004| sv_usepvn_mg|5.004005|5.003007|p SvUTF8|5.006000|5.006000| sv_utf8_decode|5.006000|5.006000| sv_utf8_downgrade|5.006000|5.006000| sv_utf8_downgrade_flags|5.031004|5.031004| sv_utf8_downgrade_nomg|5.031004|5.031004| sv_utf8_encode|5.006000|5.006000| SV_UTF8_NO_ENCODING|5.008001|5.003007|poVu SvUTF8_off|5.006000|5.006000| SvUTF8_on|5.006000|5.006000| sv_utf8_upgrade|5.007001|5.007001| sv_utf8_upgrade_flags|5.007002|5.007002| sv_utf8_upgrade_flags_grow|5.011000|5.011000| sv_utf8_upgrade_nomg|5.007002|5.007002| SvUV|5.004000|5.003007|p sv_uv|5.005000|5.003007|pd SvUV_nomg|5.009001|5.007003|p SvUV_set|5.009003|5.003007|p SvUVX|5.004000|5.003007|p SvUVx|5.004000|5.003007|p SvUVXx|5.004000|5.003007|pd sv_vcatpvf|5.006000|5.004000|p sv_vcatpvf_mg|5.006000|5.004000|p sv_vcatpvfn|5.004000|5.004000| sv_vcatpvfn_flags|5.017002|5.017002| SvVOK|5.008001|5.008001| sv_vsetpvf|5.006000|5.004000|p sv_vsetpvf_mg|5.006000|5.004000|p sv_vsetpvfn|5.004000|5.004000| SvVSTRING_mg|5.009004||pVu swallow_bom|5.006001||Viu switch_category_locale_to_template|5.027009||Viu switch_to_global_locale|5.027009|5.003007|pn sync_locale|5.027009|5.003007|pn sys_init3|5.010000|5.010000|nu sys_init|5.010000|5.010000|nu sys_intern_clear|5.006001||Vu sys_intern_dup|5.006000||Vu sys_intern_init|5.006001||Vu sys_term|5.010000|5.010000|nu taint_env|5.003007|5.003007|u taint_proper|5.003007|5.003007|u THIS|5.003007|5.003007|V thread_locale_init|5.027009|5.027009|nxu thread_locale_term|5.027009|5.027009|nxu tied_method|5.013009||vViu tmps_grow_p|5.021005||cViu to_byte_substr|5.008000||Viu toFOLD|5.019001|5.019001| _to_fold_latin1|5.015005||ncViu toFOLD_utf8|5.031005|5.031005| toFOLD_utf8_safe|5.025009|5.006000|p toFOLD_uvchr|5.023009|5.006000|p tokenize_use|5.009003||Viu tokeq|5.005000||Viu tokereport|5.007001||Viu toLOWER|5.003007|5.003007| toLOWER_L1|5.019001|5.019001| to_lower_latin1|5.015005||nViu toLOWER_LC|5.004000|5.004000| toLOWER_utf8|5.031005|5.031005| toLOWER_utf8_safe|5.025009|5.006000|p toLOWER_uvchr|5.023009|5.006000|p too_few_arguments_pv|5.016000||Viu too_many_arguments_pv|5.016000||Viu TOPMARK|||ciu toTITLE|5.019001|5.019001| toTITLE_utf8|5.031005|5.031005| toTITLE_utf8_safe|5.025009|5.006000|p toTITLE_uvchr|5.023009|5.006000|p to_uni_fold|5.031004||cVu _to_uni_fold_flags|5.014000||cVu to_uni_lower|5.006000||cVu to_uni_title|5.006000||cVu to_uni_upper|5.006000||cVu toUPPER|5.003007|5.003007| _to_upper_title_latin1|5.015005||Viu toUPPER_utf8|5.031005|5.031005| toUPPER_utf8_safe|5.025009|5.006000|p toUPPER_uvchr|5.023009|5.006000|p _to_utf8_case|5.023006||Viu _to_utf8_fold_flags|5.014000||cVu _to_utf8_lower_flags|5.015006||cVu to_utf8_substr|5.008000||Viu _to_utf8_title_flags|5.015006||cVu _to_utf8_upper_flags|5.015006||cVu translate_substr_offsets|5.015006||nViu traverse_op_tree|5.029008||Vi try_amagic_bin|||ciu try_amagic_un|||ciu turkic_fc|5.029008||Viu turkic_lc|5.029008||Viu turkic_uc|5.029008||Viu U16SIZE|5.006000|5.006000| U16TYPE|5.006000|5.006000| U32SIZE|5.006000|5.006000| U32TYPE|5.006000|5.006000| U8SIZE|5.006000|5.006000| U8TYPE|5.006000|5.006000| uiv_2buf|5.009003||nViu UNDERBAR|5.009002|5.003007|p unexpected_non_continuation_text|5.025006||Viu UNICODE_REPLACEMENT|5.007001|5.003007|p UNI_TO_NATIVE|5.007001|5.003007|p UNLIKELY|5.009004|5.003007|p unlnk|5.003007||Vu unpack_rec|5.008001||Viu unpack_str|5.007003|5.007003|d unpackstring|5.008001|5.008001| unreferenced_to_tmp_stack|5.013002||Viu unshare_hek|5.004000||Viu unshare_hek_or_pvn|5.008000||Viu unsharepvn|5.003007|5.003007|u unwind_handler_stack|5.009003||Viu update_debugger_info|5.009005||Viu upg_version|5.009005|5.009005| usage|5.005000||Viu utf16_textfilter|5.011001||Viu utf16_to_utf8|5.006000||cViu utf16_to_utf8_reversed|5.006000||cViu UTF8_CHK_SKIP|5.031006|5.006000|p utf8_distance|5.006000|5.006000| UTF8f|5.019001|5.019001| UTF8fARG|5.019002|5.019002| utf8_hop|5.006000|5.006000|n utf8_hop_back|5.025007|5.025007|n utf8_hop_forward|5.025007|5.025007|n utf8_hop_safe|5.025007|5.025007|n UTF8_IS_INVARIANT|5.007001|5.003007|p UTF8_IS_NONCHAR|5.023002|5.023002| UTF8_IS_SUPER|5.023002|5.023002| UTF8_IS_SURROGATE|5.023002|5.023002| utf8_length|5.007001|5.007001| UTF8_MAXBYTES|5.009002|5.006000|p UTF8_MAXBYTES_CASE|5.009002|5.003007|p utf8_mg_len_cache_update|5.013003||Viu utf8_mg_pos_cache_update|5.009004||Viu utf8n_to_uvchr|5.007001|5.007001|n utf8n_to_uvchr_error|5.025006|5.025006|n utf8n_to_uvchr_msgs|5.027009|5.027009|nx _utf8n_to_uvchr_msgs_helper|5.029001||ncVu utf8n_to_uvuni|5.007001||cV UTF8_SAFE_SKIP|5.029009|5.006000|p UTF8SKIP|5.006000|5.006000| UTF8_SKIP|5.023002|5.006000|p utf8_to_bytes|5.006001|5.006001|x utf8_to_uvchr|5.007001|5.006001|pd utf8_to_uvchr_buf|5.015009|5.006001|p utf8_to_uvchr_buf_helper|5.031004||cVu utf8_to_uvuni|5.007001||dcV utf8_to_uvuni_buf|5.015009||dcV utilize|5.003007||Viu UVCHR_IS_INVARIANT|5.019004|5.003007|p UVCHR_SKIP|5.022000|5.003007|p uvchr_to_utf8|5.007001|5.007001| uvchr_to_utf8_flags|5.007003|5.007003| uvchr_to_utf8_flags_msgs|5.027009|5.027009|x UVof|5.006000|5.003007|p uvoffuni_to_utf8_flags|||c uvoffuni_to_utf8_flags_msgs|5.027009||cVu UVSIZE|5.006000|5.003007|p UVTYPE|5.006000|5.003007|p UVuf|5.006000|5.003007|p uvuni_to_utf8|5.019004||cVu uvuni_to_utf8_flags|5.007003||cV UVxf|5.006000|5.003007|p UVXf|5.007001|5.007001|p validate_proto|5.019002||xcVi validate_suid|||iu valid_utf8_to_uvchr|5.015009||ncV valid_utf8_to_uvuni|5.015009||dcVu variant_byte_number|5.031004||ncVu variant_under_utf8_count|5.027007||nVi varname|5.009003||Viu vcmp|5.009000|5.009000| vcroak|5.006000|5.006000| vdeb|5.007003|5.007003|u vform|5.006000|5.006000|u visit|5.005000||Viu vivify_defelem|5.004000||cViu vivify_ref|5.004000||Viu vload_module|5.006000|5.003007|pu vmess|5.006000|5.004000|p vnewSVpvf|5.006000|5.004000|pu vnormal|5.009002|5.009002| vnumify|5.009000|5.009000| vstringify|5.009000|5.009000| vverify|5.009003|5.009003| vwarn|5.006000|5.006000| vwarner|5.006000|5.006000|u wait4pid|5.003007||Viu warn|5.006000|5.003007|v WARN_ALL|5.006000|5.003007|p WARN_AMBIGUOUS|5.006000|5.003007|p WARN_ASSERTIONS||5.003007|pou WARN_BAREWORD|5.006000|5.003007|p WARN_CLOSED|5.006000|5.003007|p WARN_CLOSURE|5.006000|5.003007|p WARN_DEBUGGING|5.006000|5.003007|p WARN_DEPRECATED|5.006000|5.003007|p WARN_DIGIT|5.006000|5.003007|p warner|5.006000|5.004000|pvu warner_nocontext|5.006000||vnVu WARN_EXEC|5.006000|5.003007|p WARN_EXITING|5.006000|5.003007|p WARN_EXPERIMENTAL|5.017004|5.017004| WARN_EXPERIMENTAL__ALPHA_ASSERTIONS|5.027009|5.027009| WARN_EXPERIMENTAL__BITWISE|5.021009|5.021009| WARN_EXPERIMENTAL__CONST_ATTR|5.021008|5.021008| WARN_EXPERIMENTAL__DECLARED_REFS|5.025003|5.025003| WARN_EXPERIMENTAL__LEXICAL_SUBS|5.017005|5.017005| WARN_EXPERIMENTAL__POSTDEREF|5.019005|5.019005| WARN_EXPERIMENTAL__PRIVATE_USE|5.029009|5.029009| WARN_EXPERIMENTAL__REFALIASING|5.021005|5.021005| WARN_EXPERIMENTAL__REGEX_SETS|5.017008|5.017008| WARN_EXPERIMENTAL__RE_STRICT|5.021008|5.021008| WARN_EXPERIMENTAL__SCRIPT_RUN|5.027008|5.027008| WARN_EXPERIMENTAL__SIGNATURES|5.019009|5.019009| WARN_EXPERIMENTAL__SMARTMATCH|5.017011|5.017011| WARN_EXPERIMENTAL__UNIPROP_WILDCARDS|5.029009|5.029009| WARN_EXPERIMENTAL__VLB|5.029009|5.029009| WARN_EXPERIMENTAL__WIN32_PERLIO|5.021001|5.021001| WARN_GLOB|5.006000|5.003007|p WARN_ILLEGALPROTO|5.011004|5.011004| WARN_IMPRECISION|5.011000|5.011000| WARN_INPLACE|5.006000|5.003007|p WARN_INTERNAL|5.006000|5.003007|p WARN_IO|5.006000|5.003007|p WARN_LAYER|5.008000|5.003007|p WARN_LOCALE|5.021006|5.021006| WARN_MALLOC|5.006000|5.003007|p WARN_MISC|5.006000|5.003007|p WARN_MISSING|5.021002|5.021002| WARN_NEWLINE|5.006000|5.003007|p warn_nocontext|5.006000||pvnVu WARN_NONCHAR|5.013010|5.013010| WARN_NON_UNICODE|5.013010|5.013010| WARN_NUMERIC|5.006000|5.003007|p WARN_ONCE|5.006000|5.003007|p warn_on_first_deprecated_use|5.025009||Viu WARN_OVERFLOW|5.006000|5.003007|p WARN_PACK|5.006000|5.003007|p WARN_PARENTHESIS|5.006000|5.003007|p WARN_PIPE|5.006000|5.003007|p WARN_PORTABLE|5.006000|5.003007|p WARN_PRECEDENCE|5.006000|5.003007|p WARN_PRINTF|5.006000|5.003007|p _warn_problematic_locale|5.021008||ncViu WARN_PROTOTYPE|5.006000|5.003007|p WARN_QW|5.006000|5.003007|p WARN_RECURSION|5.006000|5.003007|p WARN_REDEFINE|5.006000|5.003007|p WARN_REDUNDANT|5.021002|5.021002| WARN_REGEXP|5.006000|5.003007|p WARN_RESERVED|5.006000|5.003007|p WARN_SEMICOLON|5.006000|5.003007|p WARN_SEVERE|5.006000|5.003007|p WARN_SHADOW|5.027007|5.027007| WARN_SIGNAL|5.006000|5.003007|p WARN_SUBSTR|5.006000|5.003007|p WARN_SURROGATE|5.013010|5.013010| warn_sv|5.013001|5.003007|p WARN_SYNTAX|5.006000|5.003007|p WARN_SYSCALLS|5.019004|5.019004| WARN_TAINT|5.006000|5.003007|p WARN_THREADS|5.008000|5.003007|p WARN_UNINITIALIZED|5.006000|5.003007|p WARN_UNOPENED|5.006000|5.003007|p WARN_UNPACK|5.006000|5.003007|p WARN_UNTIE|5.006000|5.003007|p WARN_UTF8|5.006000|5.003007|p WARN_VOID|5.006000|5.003007|p was_lvalue_sub|||ciu watch|5.003007||Viu whichsig|5.003007|5.003007|u whichsig_pv|5.015004|5.015004|u whichsig_pvn|5.015004|5.015004|u whichsig_sv|5.015004|5.015004|u WIDEST_UTYPE|5.015004|5.003007|p win32_croak_not_implemented|5.017006||nViu win32_setlocale|5.027006||Viu WITH_LC_NUMERIC_SET_TO_NEEDED|5.031003|5.031003| WITH_LC_NUMERIC_SET_TO_NEEDED_IN|5.031003|5.031003| with_queued_errors|5.013001||Viu wrap_keyword_plugin|5.027006|5.027006|x wrap_op_checker|5.015008|5.015008| write_to_stderr|5.008001||Viu XCPT_CATCH|5.009002|5.003007|p XCPT_RETHROW|5.009002|5.003007|p XCPT_TRY_END|5.009002|5.003007|p XCPT_TRY_START|5.009002|5.003007|p XopDISABLE|5.013007|5.013007|V XopENABLE|5.013007|5.013007|V XopENTRY|5.013007|5.013007|V XopENTRYCUSTOM|5.019006|5.013007|V XopENTRY_set|5.013007|5.013007|V XopFLAGS|5.013007|5.013007| XPUSHi|5.003007|5.003007| XPUSHmortal|5.009002|5.003007|p XPUSHn|5.006000|5.003007| XPUSHp|5.003007|5.003007| XPUSHs|5.003007|5.003007| XPUSHu|5.004000|5.003007|p XS|5.003007|5.003007|V XS_APIVERSION_BOOTCHECK|5.013004|5.013004| xs_boot_epilog|5.021006||cViu XS_EXTERNAL|5.015002|5.015002|V xs_handshake|||vnciu XS_INTERNAL|5.015002|5.015002|V XSprePUSH|5.006000|5.003007|poVu XSPROTO|5.010000||pVu XSRETURN|5.003007|5.003007|p XSRETURN_EMPTY|5.003007|5.003007| XSRETURN_IV|5.003007|5.003007| XSRETURN_NO|5.003007|5.003007| XSRETURN_NV|5.006000|5.003007| XSRETURN_PV|5.003007|5.003007| XSRETURN_UNDEF|5.003007|5.003007| XSRETURN_UV|5.008001|5.003007|p XSRETURN_YES|5.003007|5.003007| XST_mIV|5.003007|5.003007| XST_mNO|5.003007|5.003007| XST_mNV|5.006000|5.003007| XST_mPV|5.003007|5.003007| XST_mUNDEF|5.003007|5.003007| XST_mUV|5.008001|5.003007|p XST_mYES|5.003007|5.003007| XS_VERSION|5.003007|5.003007| XS_VERSION_BOOTCHECK|5.003007|5.003007| xs_version_bootcheck|||iu yyerror|5.003007||Viu yyerror_pv|5.016000||Viu yyerror_pvn|5.016000||Viu yylex|5.003007||cViu yyparse|5.003007||Viu yyquit|5.025010||Viu yyunlex|5.013005||Viu yywarn|5.003007||Viu Zero|5.003007|5.003007| ZeroD|5.009002|5.003007|p ); if (exists $opt{'list-unsupported'}) { my $f; for $f (sort dictionary_order keys %API) { next if $API{$f}{core_only}; next if $API{$f}{beyond_depr}; next if $API{$f}{inaccessible}; next if $API{$f}{experimental}; next unless $API{$f}{todo}; next if int_parse_version($API{$f}{todo}) <= $int_min_perl; print "$f ", '.'x(40-length($f)), " ", format_version($API{$f}{todo}), "\n"; } exit 0; } # Scan for hints, possible replacement candidates, etc. my(%replace, %need, %hints, %warnings, %depends); my $replace = 0; my($hint, $define, $function); sub find_api { my $code = shift; no warnings 'uninitialized'; $code =~ s{ / (?: \*[^*]*\*+(?:[^$ccs][^*]*\*+)* / | /[^\r\n]*) | "[^"\\]*(?:\\.[^"\\]*)*" | '[^'\\]*(?:\\.[^'\\]*)*' }{}egsx; grep { exists $API{$_} } $code =~ /(\w+)/mg; } while () { if ($hint) { # Here, we are in the middle of accumulating a hint or warning. my $end_of_hint = 0; # A line containing a comment end marker closes the hint. Remove that # marker for processing below. if (s/\s*$rcce(.*?)\s*$//) { die "Nothing can follow the end of comment in '$_'\n" if length $1 > 0; $end_of_hint = 1; } # Set $h to the hash of which type. my $h = $hint->[0] eq 'Hint' ? \%hints : \%warnings; # Ignore any leading and trailing white space, and an optional star comment # continuation marker, then place the meat of the line into $1 m/^\s*(?:\*\s*)?(.*?)\s*$/; # Add the meat of this line to the hash value of each API element it # applies to for (@{$hint->[1]}) { $h->{$_} ||= ''; # avoid the warning older perls generate $h->{$_} .= "$1\n"; } # If the line had a comment close, we are through with this hint undef $hint if $end_of_hint; next; } # Set up $hint if this is the beginning of a Hint: or Warning: # These are from a multi-line C comment in the file, with the first line # looking like (a space has been inserted because this file can't have C # comment markers in it): # / * Warning: PL_expect, PL_copline, PL_rsfp # # $hint becomes # [ # 'Warning', # [ # 'PL_expect', # 'PL_copline', # 'PL_rsfp', # ], # ] if (m{^\s*$rccs\s+(Hint|Warning):\s+(\w+(?:,?\s+\w+)*)\s*$}) { $hint = [$1, [split /,?\s+/, $2]]; next; } if ($define) { # If in the middle of a definition... # append a continuation line ending with backslash. if ($define->[1] =~ /\\$/) { $define->[1] .= $_; } else { # Otherwise this line ends the definition, make foo depend on bar # (and what bar depends on) if its not one of ppp's own constructs if (exists $API{$define->[0]} && $define->[1] !~ /^DPPP_\(/) { my @n = find_api($define->[1]); push @{$depends{$define->[0]}}, @n if @n } undef $define; } } # For '#define foo bar' or '#define foo(a,b,c) bar', $define becomes a # reference to [ foo, bar ] $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+)\)}; # Set $replace to the number given for lines that look like # / * Replace: \d+ * / # (blanks added to keep real C comments from appearing in this file) # Thus setting it to 1 starts a region where replacements are automatically # done, and setting it to 0 ends that region. $replace = $1 if m{^\s*$rccs\s+Replace:\s+(\d+)\s+$rcce\s*$}; # Add bar => foo to %replace for lines like '#define foo bar in a region # where $replace is non-zero $replace{$2} = $1 if $replace and m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+)}; # Add bar => foo to %replace for lines like '#define foo bar / * Replace * / # (blanks added to keep real C comments from appearing in this file) $replace{$2} = $1 if m{^\s*#\s*define\s+(\w+)(?:\([^)]*\))?\s+(\w+).*$rccs\s+Replace\s+$rcce}; # Add foo => bar to %replace for lines like / * Replace foo with bar * / # (blanks added to keep real C comments from appearing in this file) $replace{$1} = $2 if m{^\s*$rccs\s+Replace (\w+) with (\w+)\s+$rcce\s*$}; # For lines like / * foo, bar depends on baz, bat * / # create a list of the elements on the rhs, and make that list apply to each # element in the lhs, which becomes a key in \%depends. # (blanks added to keep real C comments from appearing in this file) 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 %seen; $_ = [sort dictionary_order grep !$seen{$_}++, @$_]; } 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 dictionary_order keys %API) { next unless $f =~ /$match/; print "\n=== $f ===\n"; my $info = 0; my $base; $base = int_parse_version($API{$f}{base}) if $API{$f}{base}; my $todo; $todo = int_parse_version($API{$f}{todo}) if $API{$f}{todo}; # Output information if it is generally publicly usable if ($base && ! $API{$f}{inaccessible} && ! $API{$f}{core_only}) { my $with_or= ""; if ( $base <= $int_min_perl || ( (! $API{$f}{provided} && ! $todo) || ($todo && $todo >= $base))) { $with_or= " with or"; } print "\nSupported at least since perl-", format_version($base), ",$with_or without $ppport."; if ($API{$f}{unverified}) { print "\nThis information is based on inspection of the source code", " and has not been\n", "verified by successful compilation."; } print "\n"; $info++; } if ($API{$f}{provided} || $todo) { print "\nThis is only supported by $ppport, and NOT by perl versions going forward.\n" unless $base; if ($todo) { if (! $base || $todo < $base) { my $additionally = ""; $additionally .= " additionally" if $base; print "$ppport$additionally provides support at least back to perl-", format_version($todo), ".\n"; } } elsif (! $base || $base > $int_min_perl) { if (exists $depends{$f}) { my $max = 0; for (@{$depends{$f}}) { $max = int_parse_version($API{$_}{todo}) if $API{$_}{todo} && $API{$_}{todo} > $max; # XXX What to assume unspecified values are? This effectively makes them MIN_PERL } $todo = $max if $max; } print "\n$ppport provides support for this, but ironically, does not", " currently know,\n", "for this report, the minimum version it supports for this"; if ($API{$f}{undocumented}) { print " and many things\n", "it provides that are implemented as macros and aren't", " documented. You can\n", "help by submitting a documentation patch"; } print ".\n"; if ($todo) { if ($todo <= $int_min_perl) { print "It may very well be supported all the way back to ", format_version(5.003_07), ".\n"; } else { print "But given the things $f depends on, it's a good", " guess that it isn't\n", "supported prior to ", format_version($todo), ".\n"; } } } } if ($API{$f}{provided}) { print "Support needs to be explicitly requested by #define NEED_$f\n", "(or #define NEED_${f}_GLOBAL).\n" if exists $need{$f}; $info++; } if ($base || ! $API{$f}{ppport_fnc}) { my $email = "Send email to perl5-porters\@perl.org if you need to have this functionality.\n"; if ($API{$f}{inaccessible}) { print "\nThis is not part of the public API, and may not even be accessible to XS code.\n"; $info++; } elsif ($API{$f}{core_only}) { print "\nThis is not part of the public API, and should not be used by XS code.\n"; $info++; } elsif ($API{$f}{deprecated}) { print "\nThis is deprecated and should not be used. Convert existing uses.\n"; $info++; } elsif ($API{$f}{experimental}) { print "\nThe API for this is unstable and should not be used by XS code.\n", $email; $info++; } elsif ($API{$f}{undocumented}) { print "\nSince this is undocumented, the API should be considered unstable.\n"; if ($API{$f}{provided}) { print "Consider bringing this up on the list: perl5-porters\@perl.org.\n"; } else { print "It may be that this is not intended for XS use, or it may just be\n", "that no one has gotten around to documenting it.\n", $email; } $info++; } unless ($info) { print "No portability information available. Check your spelling; or", " this could be\na bug in Devel::PPPort. To report an issue:\n", "https://github.com/Dual-Life/Devel-PPPort/issues/new\n"; } } print "\nDepends on: ", join(', ', @{$depends{$f}}), ".\n" if exists $depends{$f}; if (exists $hints{$f} || exists $warnings{$f}) { print "\n$hints{$f}" if exists $hints{$f}; print "\nWARNING:\n$warnings{$f}" if exists $warnings{$f}; $info++; } $count++; } $count or print "\nFound no API matching '$opt{'api-info'}'."; print "\n"; exit 0; } if (exists $opt{'list-provided'}) { my $f; for $f (sort dictionary_order 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} || int_parse_version($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} && int_parse_version($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 dictionary_order 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 dictionary_order keys %{$file{uses_replace}}) { warning("Uses $func instead of $replace{$func}"); $file{changes} += ($c =~ s/\b$func\b/$replace{$func}/g); } for $func (sort dictionary_order 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 dictionary_order keys %{$file{uses_todo}}) { next if int_parse_version($API{$func}{todo}) <= $int_min_perl; print "*** WARNING: Uses $func, which may not be portable below perl ", format_version($API{$func}{todo}), ", even with '$ppport'\n"; $warnings++; } } for $func (sort dictionary_order 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 dictionary_order 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 dictionary_order 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 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 D_PPP_DEC2BCD(dec) ((((dec)/100)<<8)|((((dec)%100)/10)<<4)|((dec)%10)) #define PERL_BCDVERSION ((D_PPP_DEC2BCD(PERL_REVISION)<<24)|(D_PPP_DEC2BCD(PERL_VERSION)<<12)|D_PPP_DEC2BCD(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 /* Hint: dTHX For pre-5.6.0 thread compatibility, instead use dTHXR, available only through include/ppport.h */ #ifndef dTHXa # define dTHXa(x) dNOOP #endif #ifndef pTHX # define pTHX void #endif #ifndef pTHX_ # define pTHX_ #endif #ifndef aTHX # define aTHX #endif /* Hint: aTHX For pre-5.6.0 thread compatibility, instead use aTHXR, available only through include/ppport.h */ #ifndef aTHX_ # define aTHX_ #endif /* Hint: aTHX_ For pre-5.6.0 thread compatibility, instead use aTHXR_, available only through include/ppport.h */ #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 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 # define PL_mess_sv mess_sv /* 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 it, 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 #if (PERL_BCDVERSION <= 0x5003022) # undef start_subparse # if (PERL_BCDVERSION < 0x5003022) #ifndef start_subparse # define start_subparse(a, b) Perl_start_subparse() #endif # else #ifndef start_subparse # define start_subparse(a, b) Perl_start_subparse(b) #endif # endif #if (PERL_BCDVERSION < 0x5003007) foo #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) /* And before that, we need to make sure this gets compiled for the functions * that rely on it */ #define NEED_newCONSTSUB #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 #if defined(NEED_newCONSTSUB) || defined(NEED_newCONSTSUB_GLOBAL) #ifdef newCONSTSUB # undef newCONSTSUB #endif #define newCONSTSUB(a,b,c) DPPP_(my_newCONSTSUB)(aTHX_ a,b,c) #define Perl_newCONSTSUB DPPP_(my_newCONSTSUB) /* 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( start_subparse(FALSE, 0), 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 #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 #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 HEf_SVKEY # define HEf_SVKEY -2 #endif #if defined(DEBUGGING) && !defined(__COVERITY__) #ifndef __ASSERT_ # define __ASSERT_(statement) assert(statement), #endif #else #ifndef __ASSERT_ # define __ASSERT_(statement) #endif #endif /* These could become provided when they become part of the public API */ #ifndef withinCOUNT # define withinCOUNT(c, l, n) \ (((WIDEST_UTYPE) (((c)) - ((l) | 0))) <= (((WIDEST_UTYPE) ((n) | 0)))) #endif #ifndef inRANGE # define inRANGE(c, l, u) \ ( (sizeof(c) == sizeof(U8)) ? withinCOUNT(((U8) (c)), (l), ((u) - (l))) \ : (sizeof(c) == sizeof(U16)) ? withinCOUNT(((U16) (c)), (l), ((u) - (l))) \ : (sizeof(c) == sizeof(U32)) ? withinCOUNT(((U32) (c)), (l), ((u) - (l))) \ : (withinCOUNT(((WIDEST_UTYPE) (c)), (l), ((u) - (l))))) #endif /* Create the macro for "is'macro'_utf8_safe(s, e)". For code points below * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code * point. That is so that it can automatically get the bug fixes done in this * file. */ #define D_PPP_IS_GENERIC_UTF8_SAFE(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _L1((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ /* The cast in the line below is only to silence warnings */ \ ? is ## macro ## _L1((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8(s)) /* Create the macro for "is'macro'_LC_utf8_safe(s, e)". For code points below * 256, it calls the equivalent _L1 macro by converting the UTF-8 to code * point. That is so that it can automatically get the bug fixes done in this * file. */ #define D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _LC((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ /* The cast in the line below is only to silence warnings */ \ ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8(s)) /* A few of the early functions are broken. For these and the non-LC case, * machine generated code is substituted. But that code doesn't work for * locales. This is just like the above macro, but at the end, we call the * macro we've generated for the above 255 case, which is correct since locale * isn't involved. This will generate extra code to handle the 0-255 inputs, * but hopefully it will be optimized out by the C compiler. But just in case * it isn't, this macro is only used on the few versions that are broken */ #define D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, macro) \ (((e) - (s)) <= 0 \ ? 0 \ : UTF8_IS_INVARIANT((s)[0]) \ ? is ## macro ## _LC((s)[0]) \ : (((e) - (s)) < UTF8SKIP(s)) \ ? 0 \ : UTF8_IS_DOWNGRADEABLE_START((s)[0]) \ /* The cast in the line below is only to silence warnings */ \ ? is ## macro ## _LC((WIDEST_UTYPE) LATIN1_TO_NATIVE( \ UTF8_ACCUMULATE(NATIVE_UTF8_TO_I8((s)[0]) \ & UTF_START_MASK(2), \ (s)[1]))) \ : is ## macro ## _utf8_safe(s, e)) #ifndef SvRX # define SvRX(rv) (SvROK((rv)) ? (SvMAGICAL(SvRV((rv))) ? (mg_find(SvRV((rv)), PERL_MAGIC_qr) ? mg_find(SvRV((rv)), PERL_MAGIC_qr)->mg_obj : NULL) : NULL) : NULL) #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 (PERL_BCDVERSION < 0x5004000) || defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN #ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN #endif # 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 av_tindex # define av_tindex AvFILL #endif #ifndef av_top_index # define av_top_index 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 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 WIDEST_UTYPE # ifdef QUADKIND # ifdef U64TYPE # define WIDEST_UTYPE U64TYPE # else # define WIDEST_UTYPE Quad_t # endif # else # define WIDEST_UTYPE U32 # endif #endif /* On versions without NATIVE_TO_ASCII, only ASCII is supported */ #if defined(EBCDIC) && defined(NATIVE_TO_ASCI) #ifndef NATIVE_TO_LATIN1 # define NATIVE_TO_LATIN1(c) NATIVE_TO_ASCII(c) #endif #ifndef LATIN1_TO_NATIVE # define LATIN1_TO_NATIVE(c) ASCII_TO_NATIVE(c) #endif #ifndef NATIVE_TO_UNI # define NATIVE_TO_UNI(c) ((c) > 255 ? (c) : NATIVE_TO_LATIN1(c)) #endif #ifndef UNI_TO_NATIVE # define UNI_TO_NATIVE(c) ((c) > 255 ? (c) : LATIN1_TO_NATIVE(c)) #endif #else #ifndef NATIVE_TO_LATIN1 # define NATIVE_TO_LATIN1(c) (c) #endif #ifndef LATIN1_TO_NATIVE # define LATIN1_TO_NATIVE(c) (c) #endif #ifndef NATIVE_TO_UNI # define NATIVE_TO_UNI(c) (c) #endif #ifndef UNI_TO_NATIVE # define UNI_TO_NATIVE(c) (c) #endif #endif /* Warning: LATIN1_TO_NATIVE, NATIVE_TO_LATIN1 NATIVE_TO_UNI UNI_TO_NATIVE EBCDIC is not supported on versions earlier than 5.7.1 */ /* The meaning of this changed; use the modern version */ #undef isPSXSPC #undef isPSXSPC_A #undef isPSXSPC_L1 /* Hint: isPSXSPC, isPSXSPC_A, isPSXSPC_L1, isPSXSPC_utf8_safe This is equivalent to the corresponding isSPACE-type macro. On perls before 5.18, this matched a vertical tab and SPACE didn't. But the include/ppport.h SPACE version does match VT in all perl releases. Since VT's are extremely rarely found in real-life files, this difference effectively doesn't matter */ /* Hint: isSPACE, isSPACE_A, isSPACE_L1, isSPACE_utf8_safe Until Perl 5.18, this did not match the vertical tab (VT). The include/ppport.h version does match it in all perl releases. Since VT's are extremely rarely found in real-life files, this difference effectively doesn't matter */ #ifdef EBCDIC /* This is the first version where these macros are fully correct on EBCDIC * platforms. Relying on * the C library functions, as earlier releases did, * causes problems with * locales */ # if (PERL_BCDVERSION < 0x5022000) # undef isALNUM # undef isALNUM_A # undef isALNUM_L1 # undef isALNUMC # undef isALNUMC_A # undef isALNUMC_L1 # undef isALPHA # undef isALPHA_A # undef isALPHA_L1 # undef isALPHANUMERIC # undef isALPHANUMERIC_A # undef isALPHANUMERIC_L1 # undef isASCII # undef isASCII_A # undef isASCII_L1 # undef isBLANK # undef isBLANK_A # undef isBLANK_L1 # undef isCNTRL # undef isCNTRL_A # undef isCNTRL_L1 # undef isDIGIT # undef isDIGIT_A # undef isDIGIT_L1 # undef isGRAPH # undef isGRAPH_A # undef isGRAPH_L1 # undef isIDCONT # undef isIDCONT_A # undef isIDCONT_L1 # undef isIDFIRST # undef isIDFIRST_A # undef isIDFIRST_L1 # undef isLOWER # undef isLOWER_A # undef isLOWER_L1 # undef isOCTAL # undef isOCTAL_A # undef isOCTAL_L1 # undef isPRINT # undef isPRINT_A # undef isPRINT_L1 # undef isPUNCT # undef isPUNCT_A # undef isPUNCT_L1 # undef isSPACE # undef isSPACE_A # undef isSPACE_L1 # undef isUPPER # undef isUPPER_A # undef isUPPER_L1 # undef isWORDCHAR # undef isWORDCHAR_A # undef isWORDCHAR_L1 # undef isXDIGIT # undef isXDIGIT_A # undef isXDIGIT_L1 # endif #ifndef isASCII # define isASCII(c) (isCNTRL(c) || isPRINT(c)) #endif /* The below is accurate for all EBCDIC code pages supported by * all the versions of Perl overridden by this */ #ifndef isCNTRL # define isCNTRL(c) ( (c) == '\0' || (c) == '\a' || (c) == '\b' \ || (c) == '\f' || (c) == '\n' || (c) == '\r' \ || (c) == '\t' || (c) == '\v' \ || ((c) <= 3 && (c) >= 1) /* SOH, STX, ETX */ \ || (c) == 7 /* U+7F DEL */ \ || ((c) <= 0x13 && (c) >= 0x0E) /* SO, SI */ \ /* DLE, DC[1-3] */ \ || (c) == 0x18 /* U+18 CAN */ \ || (c) == 0x19 /* U+19 EOM */ \ || ((c) <= 0x1F && (c) >= 0x1C) /* [FGRU]S */ \ || (c) == 0x26 /* U+17 ETB */ \ || (c) == 0x27 /* U+1B ESC */ \ || (c) == 0x2D /* U+05 ENQ */ \ || (c) == 0x2E /* U+06 ACK */ \ || (c) == 0x32 /* U+16 SYN */ \ || (c) == 0x37 /* U+04 EOT */ \ || (c) == 0x3C /* U+14 DC4 */ \ || (c) == 0x3D /* U+15 NAK */ \ || (c) == 0x3F /* U+1A SUB */ \ ) #endif #if '^' == 106 /* EBCDIC POSIX-BC */ # define D_PPP_OUTLIER_CONTROL 0x5F #else /* EBCDIC 1047 037 */ # define D_PPP_OUTLIER_CONTROL 0xFF #endif /* The controls are everything below blank, plus one outlier */ #ifndef isCNTRL_L1 # define isCNTRL_L1(c) ((WIDEST_UTYPE) (c) < ' ' \ || (WIDEST_UTYPE) (c) == D_PPP_OUTLIER_CONTROL) #endif /* The ordering of the tests in this and isUPPER are to exclude most characters * early */ #ifndef isLOWER # define isLOWER(c) ( (c) >= 'a' && (c) <= 'z' \ && ( (c) <= 'i' \ || ((c) >= 'j' && (c) <= 'r') \ || (c) >= 's')) #endif #ifndef isUPPER # define isUPPER(c) ( (c) >= 'A' && (c) <= 'Z' \ && ( (c) <= 'I' \ || ((c) >= 'J' && (c) <= 'R') \ || (c) >= 'S')) #endif #else /* Above is EBCDIC; below is ASCII */ # if (PERL_BCDVERSION < 0x5004000) /* The implementation of these in older perl versions can give wrong results if * the C program locale is set to other than the C locale */ # undef isALNUM # undef isALNUM_A # undef isALPHA # undef isALPHA_A # undef isDIGIT # undef isDIGIT_A # undef isIDFIRST # undef isIDFIRST_A # undef isLOWER # undef isLOWER_A # undef isUPPER # undef isUPPER_A # endif # if (PERL_BCDVERSION == 0x5007000) /* this perl made space GRAPH */ # undef isGRAPH # endif # if (PERL_BCDVERSION < 0x5008000) /* earlier perls omitted DEL */ # undef isCNTRL # endif # if (PERL_BCDVERSION < 0x5010000) /* earlier perls included all of the isSPACE() characters, which is wrong. The * version provided by Devel::PPPort always overrides an existing buggy * version. */ # undef isPRINT # undef isPRINT_A # endif # if (PERL_BCDVERSION < 0x5014000) /* earlier perls always returned true if the parameter was a signed char */ # undef isASCII # undef isASCII_A # endif # if (PERL_BCDVERSION < 0x5017008) /* earlier perls didn't include PILCROW, SECTION SIGN */ # undef isPUNCT_L1 # endif # if (PERL_BCDVERSION < 0x5013007) /* khw didn't investigate why this failed */ # undef isALNUMC_L1 #endif # if (PERL_BCDVERSION < 0x5020000) /* earlier perls didn't include \v */ # undef isSPACE # undef isSPACE_A # undef isSPACE_L1 # endif #ifndef isASCII # define isASCII(c) ((WIDEST_UTYPE) (c) <= 127) #endif #ifndef isCNTRL # define isCNTRL(c) ((WIDEST_UTYPE) (c) < ' ' || (c) == 127) #endif #ifndef isCNTRL_L1 # define isCNTRL_L1(c) (isCNTRL(c) || ( (WIDEST_UTYPE) (c) <= 0x9F \ && (WIDEST_UTYPE) (c) >= 0x80)) #endif #ifndef isLOWER # define isLOWER(c) ((c) >= 'a' && (c) <= 'z') #endif #ifndef isUPPER # define isUPPER(c) ((c) <= 'Z' && (c) >= 'A') #endif #endif /* Below are definitions common to EBCDIC and ASCII */ #ifndef isASCII_L1 # define isASCII_L1(c) isASCII(c) #endif #ifndef isASCII_LC # define isASCII_LC(c) isASCII(c) #endif #ifndef isALNUM # define isALNUM(c) isWORDCHAR(c) #endif #ifndef isALNUMC # define isALNUMC(c) isALPHANUMERIC(c) #endif #ifndef isALNUMC_L1 # define isALNUMC_L1(c) isALPHANUMERIC_L1(c) #endif #ifndef isALPHA # define isALPHA(c) (isUPPER(c) || isLOWER(c)) #endif #ifndef isALPHA_L1 # define isALPHA_L1(c) (isUPPER_L1(c) || isLOWER_L1(c)) #endif #ifndef isALPHANUMERIC # define isALPHANUMERIC(c) (isALPHA(c) || isDIGIT(c)) #endif #ifndef isALPHANUMERIC_L1 # define isALPHANUMERIC_L1(c) (isALPHA_L1(c) || isDIGIT(c)) #endif #ifndef isALPHANUMERIC_LC # define isALPHANUMERIC_LC(c) (isALPHA_LC(c) || isDIGIT_LC(c)) #endif #ifndef isBLANK # define isBLANK(c) ((c) == ' ' || (c) == '\t') #endif #ifndef isBLANK_L1 # define isBLANK_L1(c) ( isBLANK(c) \ || ( (WIDEST_UTYPE) (c) < 256 \ && NATIVE_TO_LATIN1((U8) c) == 0xA0)) #endif #ifndef isBLANK_LC # define isBLANK_LC(c) isBLANK(c) #endif #ifndef isDIGIT # define isDIGIT(c) ((c) <= '9' && (c) >= '0') #endif #ifndef isDIGIT_L1 # define isDIGIT_L1(c) isDIGIT(c) #endif #ifndef isGRAPH # define isGRAPH(c) (isWORDCHAR(c) || isPUNCT(c)) #endif #ifndef isGRAPH_L1 # define isGRAPH_L1(c) ( isPRINT_L1(c) \ && (c) != ' ' \ && NATIVE_TO_LATIN1((U8) c) != 0xA0) #endif #ifndef isIDCONT # define isIDCONT(c) isWORDCHAR(c) #endif #ifndef isIDCONT_L1 # define isIDCONT_L1(c) isWORDCHAR_L1(c) #endif #ifndef isIDCONT_LC # define isIDCONT_LC(c) isWORDCHAR_LC(c) #endif #ifndef isIDFIRST # define isIDFIRST(c) (isALPHA(c) || (c) == '_') #endif #ifndef isIDFIRST_L1 # define isIDFIRST_L1(c) (isALPHA_L1(c) || (U8) (c) == '_') #endif #ifndef isIDFIRST_LC # define isIDFIRST_LC(c) (isALPHA_LC(c) || (U8) (c) == '_') #endif #ifndef isLOWER_L1 # define isLOWER_L1(c) ( isLOWER(c) \ || ( (WIDEST_UTYPE) (c) < 256 \ && ( ( NATIVE_TO_LATIN1((U8) c) >= 0xDF \ && NATIVE_TO_LATIN1((U8) c) != 0xF7) \ || NATIVE_TO_LATIN1((U8) c) == 0xAA \ || NATIVE_TO_LATIN1((U8) c) == 0xBA \ || NATIVE_TO_LATIN1((U8) c) == 0xB5))) #endif #ifndef isOCTAL # define isOCTAL(c) (((WIDEST_UTYPE)((c)) & ~7) == '0') #endif #ifndef isOCTAL_L1 # define isOCTAL_L1(c) isOCTAL(c) #endif #ifndef isPRINT # define isPRINT(c) (isGRAPH(c) || (c) == ' ') #endif #ifndef isPRINT_L1 # define isPRINT_L1(c) ((WIDEST_UTYPE) (c) < 256 && ! isCNTRL_L1(c)) #endif #ifndef isPSXSPC # define isPSXSPC(c) isSPACE(c) #endif #ifndef isPSXSPC_L1 # define isPSXSPC_L1(c) isSPACE_L1(c) #endif #ifndef isPUNCT # define isPUNCT(c) ( (c) == '-' || (c) == '!' || (c) == '"' \ || (c) == '#' || (c) == '$' || (c) == '%' \ || (c) == '&' || (c) == '\'' || (c) == '(' \ || (c) == ')' || (c) == '*' || (c) == '+' \ || (c) == ',' || (c) == '.' || (c) == '/' \ || (c) == ':' || (c) == ';' || (c) == '<' \ || (c) == '=' || (c) == '>' || (c) == '?' \ || (c) == '@' || (c) == '[' || (c) == '\\' \ || (c) == ']' || (c) == '^' || (c) == '_' \ || (c) == '`' || (c) == '{' || (c) == '|' \ || (c) == '}' || (c) == '~') #endif #ifndef isPUNCT_L1 # define isPUNCT_L1(c) ( isPUNCT(c) \ || ( (WIDEST_UTYPE) (c) < 256 \ && ( NATIVE_TO_LATIN1((U8) c) == 0xA1 \ || NATIVE_TO_LATIN1((U8) c) == 0xA7 \ || NATIVE_TO_LATIN1((U8) c) == 0xAB \ || NATIVE_TO_LATIN1((U8) c) == 0xB6 \ || NATIVE_TO_LATIN1((U8) c) == 0xB7 \ || NATIVE_TO_LATIN1((U8) c) == 0xBB \ || NATIVE_TO_LATIN1((U8) c) == 0xBF))) #endif #ifndef isSPACE # define isSPACE(c) ( isBLANK(c) || (c) == '\n' || (c) == '\r' \ || (c) == '\v' || (c) == '\f') #endif #ifndef isSPACE_L1 # define isSPACE_L1(c) ( isSPACE(c) \ || ( (WIDEST_UTYPE) (c) < 256 \ && ( NATIVE_TO_LATIN1((U8) c) == 0x85 \ || NATIVE_TO_LATIN1((U8) c) == 0xA0))) #endif #ifndef isUPPER_L1 # define isUPPER_L1(c) ( isUPPER(c) \ || ( (WIDEST_UTYPE) (c) < 256 \ && ( NATIVE_TO_LATIN1((U8) c) >= 0xC0 \ && NATIVE_TO_LATIN1((U8) c) <= 0xDE \ && NATIVE_TO_LATIN1((U8) c) != 0xD7))) #endif #ifndef isWORDCHAR # define isWORDCHAR(c) (isALPHANUMERIC(c) || (c) == '_') #endif #ifndef isWORDCHAR_L1 # define isWORDCHAR_L1(c) (isIDFIRST_L1(c) || isDIGIT(c)) #endif #ifndef isWORDCHAR_LC # define isWORDCHAR_LC(c) (isIDFIRST_LC(c) || isDIGIT_LC(c)) #endif #ifndef isXDIGIT # define isXDIGIT(c) ( isDIGIT(c) \ || ((c) >= 'a' && (c) <= 'f') \ || ((c) >= 'A' && (c) <= 'F')) #endif #ifndef isXDIGIT_L1 # define isXDIGIT_L1(c) isXDIGIT(c) #endif #ifndef isXDIGIT_LC # define isXDIGIT_LC(c) isxdigit(c) #endif #ifndef isALNUM_A # define isALNUM_A(c) isALNUM(c) #endif #ifndef isALNUMC_A # define isALNUMC_A(c) isALNUMC(c) #endif #ifndef isALPHA_A # define isALPHA_A(c) isALPHA(c) #endif #ifndef isALPHANUMERIC_A # define isALPHANUMERIC_A(c) isALPHANUMERIC(c) #endif #ifndef isASCII_A # define isASCII_A(c) isASCII(c) #endif #ifndef isBLANK_A # define isBLANK_A(c) isBLANK(c) #endif #ifndef isCNTRL_A # define isCNTRL_A(c) isCNTRL(c) #endif #ifndef isDIGIT_A # define isDIGIT_A(c) isDIGIT(c) #endif #ifndef isGRAPH_A # define isGRAPH_A(c) isGRAPH(c) #endif #ifndef isIDCONT_A # define isIDCONT_A(c) isIDCONT(c) #endif #ifndef isIDFIRST_A # define isIDFIRST_A(c) isIDFIRST(c) #endif #ifndef isLOWER_A # define isLOWER_A(c) isLOWER(c) #endif #ifndef isOCTAL_A # define isOCTAL_A(c) isOCTAL(c) #endif #ifndef isPRINT_A # define isPRINT_A(c) isPRINT(c) #endif #ifndef isPSXSPC_A # define isPSXSPC_A(c) isPSXSPC(c) #endif #ifndef isPUNCT_A # define isPUNCT_A(c) isPUNCT(c) #endif #ifndef isSPACE_A # define isSPACE_A(c) isSPACE(c) #endif #ifndef isUPPER_A # define isUPPER_A(c) isUPPER(c) #endif #ifndef isWORDCHAR_A # define isWORDCHAR_A(c) isWORDCHAR(c) #endif #ifndef isXDIGIT_A # define isXDIGIT_A(c) isXDIGIT(c) #endif #ifndef isASCII_utf8_safe # define isASCII_utf8_safe(s,e) (((e) - (s)) <= 0 ? 0 : isASCII(*(s))) #endif #ifndef isASCII_uvchr # define isASCII_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isASCII_L1(c) : 0) #endif #if (PERL_BCDVERSION >= 0x5006000) #ifndef isALPHA_uvchr # define isALPHA_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isALPHA_L1(c) : is_uni_alpha((UV) (c))) #endif #ifndef isALPHANUMERIC_uvchr # define isALPHANUMERIC_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isALPHANUMERIC_L1(c) : (is_uni_alpha((UV) (c)) || is_uni_digit((UV) (c)))) #endif # ifdef is_uni_blank #ifndef isBLANK_uvchr # define isBLANK_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isBLANK_L1(c) : is_uni_blank((UV) (c))) #endif # else #ifndef isBLANK_uvchr # define isBLANK_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isBLANK_L1(c) \ : ( (UV) (c) == 0x1680 /* Unicode 3.0 */ \ || inRANGE((UV) (c), 0x2000, 0x200A) \ || (UV) (c) == 0x202F /* Unicode 3.0 */\ || (UV) (c) == 0x205F /* Unicode 3.2 */\ || (UV) (c) == 0x3000)) #endif # endif #ifndef isCNTRL_uvchr # define isCNTRL_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isCNTRL_L1(c) : is_uni_cntrl((UV) (c))) #endif #ifndef isDIGIT_uvchr # define isDIGIT_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isDIGIT_L1(c) : is_uni_digit((UV) (c))) #endif #ifndef isGRAPH_uvchr # define isGRAPH_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isGRAPH_L1(c) : is_uni_graph((UV) (c))) #endif #ifndef isIDCONT_uvchr # define isIDCONT_uvchr(c) isWORDCHAR_uvchr(c) #endif #ifndef isIDFIRST_uvchr # define isIDFIRST_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isIDFIRST_L1(c) : is_uni_idfirst((UV) (c))) #endif #ifndef isLOWER_uvchr # define isLOWER_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isLOWER_L1(c) : is_uni_lower((UV) (c))) #endif #ifndef isPRINT_uvchr # define isPRINT_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isPRINT_L1(c) : is_uni_print((UV) (c))) #endif #ifndef isPSXSPC_uvchr # define isPSXSPC_uvchr(c) isSPACE_uvchr(c) #endif #ifndef isPUNCT_uvchr # define isPUNCT_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isPUNCT_L1(c) : is_uni_punct((UV) (c))) #endif #ifndef isSPACE_uvchr # define isSPACE_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isSPACE_L1(c) : is_uni_space((UV) (c))) #endif #ifndef isUPPER_uvchr # define isUPPER_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isUPPER_L1(c) : is_uni_upper((UV) (c))) #endif #ifndef isXDIGIT_uvchr # define isXDIGIT_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isXDIGIT_L1(c) : is_uni_xdigit((UV) (c))) #endif #ifndef isWORDCHAR_uvchr # define isWORDCHAR_uvchr(c) ((WIDEST_UTYPE) (c) < 256 \ ? isWORDCHAR_L1(c) : is_uni_alnum((UV) (c))) #endif #ifndef isALPHA_utf8_safe # define isALPHA_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHA) #endif # ifdef isALPHANUMERIC_utf8 #ifndef isALPHANUMERIC_utf8_safe # define isALPHANUMERIC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_UTF8_SAFE(s, e, ALPHANUMERIC) #endif # else #ifndef isALPHANUMERIC_utf8_safe # define isALPHANUMERIC_utf8_safe(s,e) \ (isALPHA_utf8_safe(s,e) || isDIGIT_utf8_safe(s,e)) #endif # endif /* This was broken before 5.18, and just use this instead of worrying about * which releases the official works on */ # if 'A' == 65 #ifndef isBLANK_utf8_safe # define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? /* Machine generated */ \ ( ( 0x09 == ((const U8*)s)[0] || 0x20 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0xC2 == ((const U8*)s)[0] ) ? \ ( ( 0xA0 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xE1 == ((const U8*)s)[0] ) ? \ ( ( ( 0x9A == ((const U8*)s)[1] ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xE2 == ((const U8*)s)[0] ) ? \ ( ( 0x80 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x80, 0x8A ) || 0xAF == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( ( 0x81 == ((const U8*)s)[1] ) && ( 0x9F == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xE3 == ((const U8*)s)[0] ) && ( 0x80 == ((const U8*)s)[1] ) ) && ( 0x80 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif # elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ #ifndef isBLANK_utf8_safe # define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0x80 == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xBC == ((const U8*)s)[0] ) ? \ ( ( ( 0x63 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xCA == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x73 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif # elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ #ifndef isBLANK_utf8_safe # define isBLANK_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( 0x05 == ((const U8*)s)[0] || 0x40 == ((const U8*)s)[0] ) ? 1 \ : ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) ? \ ( ( 0x78 == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? 2 : 0 ) \ : ( 0xBD == ((const U8*)s)[0] ) ? \ ( ( ( 0x62 == ((const U8*)s)[1] ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( 0xCA == ((const U8*)s)[0] ) ? \ ( ( 0x41 == ((const U8*)s)[1] ) ? \ ( ( inRANGE(((const U8*)s)[2], 0x41, 0x4A ) || 0x51 == ((const U8*)s)[2] ) ? 3 : 0 )\ : ( 0x42 == ((const U8*)s)[1] ) ? \ ( ( 0x56 == ((const U8*)s)[2] ) ? 3 : 0 ) \ : ( ( 0x43 == ((const U8*)s)[1] ) && ( 0x72 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : ( ( ( 0xCE == ((const U8*)s)[0] ) && ( 0x41 == ((const U8*)s)[1] ) ) && ( 0x41 == ((const U8*)s)[2] ) ) ? 3 : 0 )\ : 0 ) \ : 0 ) #endif # else # error Unknown character set # endif #ifndef isCNTRL_utf8_safe # define isCNTRL_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, CNTRL) #endif #ifndef isDIGIT_utf8_safe # define isDIGIT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, DIGIT) #endif #ifndef isGRAPH_utf8_safe # define isGRAPH_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, GRAPH) #endif # ifdef isIDCONT_utf8 #ifndef isIDCONT_utf8_safe # define isIDCONT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDCONT) #endif # else #ifndef isIDCONT_utf8_safe # define isIDCONT_utf8_safe(s,e) isWORDCHAR_utf8_safe(s,e) #endif # endif #ifndef isIDFIRST_utf8_safe # define isIDFIRST_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, IDFIRST) #endif #ifndef isLOWER_utf8_safe # define isLOWER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, LOWER) #endif #ifndef isPRINT_utf8_safe # define isPRINT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PRINT) #endif # undef isPSXSPC_utf8_safe /* Use the modern definition */ #ifndef isPSXSPC_utf8_safe # define isPSXSPC_utf8_safe(s,e) isSPACE_utf8_safe(s,e) #endif #ifndef isPUNCT_utf8_safe # define isPUNCT_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, PUNCT) #endif #ifndef isSPACE_utf8_safe # define isSPACE_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, SPACE) #endif #ifndef isUPPER_utf8_safe # define isUPPER_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, UPPER) #endif # ifdef isWORDCHAR_utf8 #ifndef isWORDCHAR_utf8_safe # define isWORDCHAR_utf8_safe(s,e) D_PPP_IS_GENERIC_UTF8_SAFE(s, e, WORDCHAR) #endif # else #ifndef isWORDCHAR_utf8_safe # define isWORDCHAR_utf8_safe(s,e) \ (isALPHANUMERIC_utf8_safe(s,e) || (*(s)) == '_') #endif # endif /* This was broken before 5.12, and just use this instead of worrying about * which releases the official works on */ # if 'A' == 65 #ifndef isXDIGIT_utf8_safe # define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x30, 0x39 ) || inRANGE(((const U8*)s)[0], 0x41, 0x46 ) || inRANGE(((const U8*)s)[0], 0x61, 0x66 ) ) ? 1\ : ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xEF == ((const U8*)s)[0] ) ) ? ( ( 0xBC == ((const U8*)s)[1] ) ?\ ( ( inRANGE(((const U8*)s)[2], 0x90, 0x99 ) || inRANGE(((const U8*)s)[2], 0xA1, 0xA6 ) ) ? 3 : 0 )\ : ( ( 0xBD == ((const U8*)s)[1] ) && ( inRANGE(((const U8*)s)[2], 0x81, 0x86 ) ) ) ? 3 : 0 ) : 0 )\ : 0 ) #endif # elif 'A' == 193 && '^' == 95 /* EBCDIC 1047 */ #ifndef isXDIGIT_utf8_safe # define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x73 == ((const U8*)s)[1] ) ) ? ( ( 0x67 == ((const U8*)s)[2] ) ?\ ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || inRANGE(((const U8*)s)[3], 0x62, 0x68 ) ) ? 4 : 0 )\ : ( ( inRANGE(((const U8*)s)[2], 0x68, 0x69 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ : 0 ) #endif # elif 'A' == 193 && '^' == 176 /* EBCDIC 037 */ #ifndef isXDIGIT_utf8_safe # define isXDIGIT_utf8_safe(s,e) \ ( ( LIKELY((e) > (s)) ) ? \ ( ( inRANGE(((const U8*)s)[0], 0x81, 0x86 ) || inRANGE(((const U8*)s)[0], 0xC1, 0xC6 ) || inRANGE(((const U8*)s)[0], 0xF0, 0xF9 ) ) ? 1\ : ( ( ( LIKELY(((e) - (s)) >= UTF8SKIP(s)) ) && ( 0xDD == ((const U8*)s)[0] ) ) && ( 0x72 == ((const U8*)s)[1] ) ) ? ( ( 0x66 == ((const U8*)s)[2] ) ?\ ( ( inRANGE(((const U8*)s)[3], 0x57, 0x59 ) || 0x5F == ((const U8*)s)[3] || inRANGE(((const U8*)s)[3], 0x62, 0x67 ) ) ? 4 : 0 )\ : ( ( inRANGE(((const U8*)s)[2], 0x67, 0x68 ) ) && ( inRANGE(((const U8*)s)[3], 0x42, 0x47 ) ) ) ? 4 : 0 ) : 0 )\ : 0 ) #endif # else # error Unknown character set # endif #ifndef isALPHA_LC_utf8_safe # define isALPHA_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHA) #endif # ifdef isALPHANUMERIC_utf8 #ifndef isALPHANUMERIC_LC_utf8_safe # define isALPHANUMERIC_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, ALPHANUMERIC) #endif # else #ifndef isALPHANUMERIC_LC_utf8_safe # define isALPHANUMERIC_LC_utf8_safe(s,e) \ (isALPHA_LC_utf8_safe(s,e) || isDIGIT_LC_utf8_safe(s,e)) #endif # endif #ifndef isBLANK_LC_utf8_safe # define isBLANK_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, BLANK) #endif #ifndef isCNTRL_LC_utf8_safe # define isCNTRL_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, CNTRL) #endif #ifndef isDIGIT_LC_utf8_safe # define isDIGIT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, DIGIT) #endif #ifndef isGRAPH_LC_utf8_safe # define isGRAPH_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, GRAPH) #endif # ifdef isIDCONT_utf8 #ifndef isIDCONT_LC_utf8_safe # define isIDCONT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDCONT) #endif # else #ifndef isIDCONT_LC_utf8_safe # define isIDCONT_LC_utf8_safe(s,e) isWORDCHAR_LC_utf8_safe(s,e) #endif # endif #ifndef isIDFIRST_LC_utf8_safe # define isIDFIRST_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, IDFIRST) #endif #ifndef isLOWER_LC_utf8_safe # define isLOWER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, LOWER) #endif #ifndef isPRINT_LC_utf8_safe # define isPRINT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PRINT) #endif # undef isPSXSPC_LC_utf8_safe /* Use the modern definition */ #ifndef isPSXSPC_LC_utf8_safe # define isPSXSPC_LC_utf8_safe(s,e) isSPACE_LC_utf8_safe(s,e) #endif #ifndef isPUNCT_LC_utf8_safe # define isPUNCT_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, PUNCT) #endif #ifndef isSPACE_LC_utf8_safe # define isSPACE_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, SPACE) #endif #ifndef isUPPER_LC_utf8_safe # define isUPPER_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, UPPER) #endif # ifdef isWORDCHAR_utf8 #ifndef isWORDCHAR_LC_utf8_safe # define isWORDCHAR_LC_utf8_safe(s,e) D_PPP_IS_GENERIC_LC_UTF8_SAFE(s, e, WORDCHAR) #endif # else #ifndef isWORDCHAR_LC_utf8_safe # define isWORDCHAR_LC_utf8_safe(s,e) \ (isALPHANUMERIC_LC_utf8_safe(s,e) || (*(s)) == '_') #endif # endif #ifndef isXDIGIT_LC_utf8_safe # define isXDIGIT_LC_utf8_safe(s,e) \ D_PPP_IS_GENERIC_LC_UTF8_SAFE_BROKEN(s, e, XDIGIT) #endif /* Warning: isALPHANUMERIC_utf8_safe, isALPHA_utf8_safe, isASCII_utf8_safe, * isBLANK_utf8_safe, isCNTRL_utf8_safe, isDIGIT_utf8_safe, isGRAPH_utf8_safe, * isIDCONT_utf8_safe, isIDFIRST_utf8_safe, isLOWER_utf8_safe, * isPRINT_utf8_safe, isPSXSPC_utf8_safe, isPUNCT_utf8_safe, isSPACE_utf8_safe, * isUPPER_utf8_safe, isWORDCHAR_utf8_safe, isWORDCHAR_utf8_safe, * isXDIGIT_utf8_safe, * isALPHANUMERIC_LC_utf8_safe, isALPHA_LC_utf8_safe, isASCII_LC_utf8_safe, * isBLANK_LC_utf8_safe, isCNTRL_LC_utf8_safe, isDIGIT_LC_utf8_safe, * isGRAPH_LC_utf8_safe, isIDCONT_LC_utf8_safe, isIDFIRST_LC_utf8_safe, * isLOWER_LC_utf8_safe, isPRINT_LC_utf8_safe, isPSXSPC_LC_utf8_safe, * isPUNCT_LC_utf8_safe, isSPACE_LC_utf8_safe, isUPPER_LC_utf8_safe, * isWORDCHAR_LC_utf8_safe, isWORDCHAR_LC_utf8_safe, isXDIGIT_LC_utf8_safe, * isALPHANUMERIC_uvchr, isALPHA_uvchr, isASCII_uvchr, isBLANK_uvchr, * isCNTRL_uvchr, isDIGIT_uvchr, isGRAPH_uvchr, isIDCONT_uvchr, * isIDFIRST_uvchr, isLOWER_uvchr, isPRINT_uvchr, isPSXSPC_uvchr, * isPUNCT_uvchr, isSPACE_uvchr, isUPPER_uvchr, isWORDCHAR_uvchr, * isWORDCHAR_uvchr, isXDIGIT_uvchr * * The UTF-8 handling is buggy in early Perls, and this can give inaccurate * results for code points above 0xFF, until the implementation started * settling down in 5.12 and 5.14 */ #endif #define D_PPP_TOO_SHORT_MSG "Malformed UTF-8 character starting with:" \ " \\x%02x (too short; %d bytes available, need" \ " %d)\n" /* Perls starting here had a new API which handled multi-character results */ #if (PERL_BCDVERSION >= 0x5007003) #ifndef toLOWER_uvchr # define toLOWER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_lower(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toUPPER_uvchr # define toUPPER_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_upper(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toTITLE_uvchr # define toTITLE_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_title(NATIVE_TO_UNI(c), s, l)) #endif #ifndef toFOLD_uvchr # define toFOLD_uvchr(c, s, l) UNI_TO_NATIVE(to_uni_fold( NATIVE_TO_UNI(c), s, l)) #endif # if (PERL_BCDVERSION != 0x5015006) /* Just this version is broken */ /* Prefer the macro to the function */ # if defined toLOWER_utf8 # define D_PPP_TO_LOWER_CALLEE(s,r,l) toLOWER_utf8(s,r,l) # else # define D_PPP_TO_LOWER_CALLEE(s,r,l) to_utf8_lower(s,r,l) # endif # if defined toTITLE_utf8 # define D_PPP_TO_TITLE_CALLEE(s,r,l) toTITLE_utf8(s,r,l) # else # define D_PPP_TO_TITLE_CALLEE(s,r,l) to_utf8_title(s,r,l) # endif # if defined toUPPER_utf8 # define D_PPP_TO_UPPER_CALLEE(s,r,l) toUPPER_utf8(s,r,l) # else # define D_PPP_TO_UPPER_CALLEE(s,r,l) to_utf8_upper(s,r,l) # endif # if defined toFOLD_utf8 # define D_PPP_TO_FOLD_CALLEE(s,r,l) toFOLD_utf8(s,r,l) # else # define D_PPP_TO_FOLD_CALLEE(s,r,l) to_utf8_fold(s,r,l) # endif # else /* Below is 5.15.6, which failed to make the macros available # outside of core, so we have to use the 'Perl_' form. khw # decided it was easier to just handle this case than have to # document the exception, and make an exception in the tests below # */ # define D_PPP_TO_LOWER_CALLEE(s,r,l) \ Perl__to_utf8_lower_flags(aTHX_ s, r, l, 0, NULL) # define D_PPP_TO_TITLE_CALLEE(s,r,l) \ Perl__to_utf8_title_flags(aTHX_ s, r, l, 0, NULL) # define D_PPP_TO_UPPER_CALLEE(s,r,l) \ Perl__to_utf8_upper_flags(aTHX_ s, r, l, 0, NULL) # define D_PPP_TO_FOLD_CALLEE(s,r,l) \ Perl__to_utf8_fold_flags(aTHX_ s, r, l, FOLD_FLAGS_FULL, NULL) # endif /* The actual implementation of the backported macros. If too short, croak, * otherwise call the original that doesn't have an upper limit parameter */ # define D_PPP_GENERIC_MULTI_ARG_TO(name, s, e,r,l) \ (((((e) - (s)) <= 0) \ /* We could just do nothing, but modern perls croak */ \ ? (croak("Attempting case change on zero length string"), \ 0) /* So looks like it returns something, and will compile */ \ : ((e) - (s)) < UTF8SKIP(s)) \ ? (croak(D_PPP_TOO_SHORT_MSG, \ s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 0) \ : D_PPP_TO_ ## name ## _CALLEE(s,r,l)) #ifndef toUPPER_utf8_safe # define toUPPER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(UPPER,s,e,r,l) #endif #ifndef toLOWER_utf8_safe # define toLOWER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(LOWER,s,e,r,l) #endif #ifndef toTITLE_utf8_safe # define toTITLE_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(TITLE,s,e,r,l) #endif #ifndef toFOLD_utf8_safe # define toFOLD_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_MULTI_ARG_TO(FOLD,s,e,r,l) #endif #elif (PERL_BCDVERSION >= 0x5006000) /* Here we have UTF-8 support, but using the original API where the case * changing functions merely returned the changed code point; hence they * couldn't handle multi-character results. */ # ifdef uvchr_to_utf8 # define D_PPP_UV_TO_UTF8 uvchr_to_utf8 # else # define D_PPP_UV_TO_UTF8 uv_to_utf8 # endif /* Get the utf8 of the case changed value, and store its length; then have * to re-calculate the changed case value in order to return it */ # define D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(name, c, s, l) \ (*(l) = (D_PPP_UV_TO_UTF8(s, \ UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) - (s)), \ UNI_TO_NATIVE(to_uni_ ## name(NATIVE_TO_UNI(c)))) #ifndef toLOWER_uvchr # define toLOWER_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(lower, c, s, l) #endif #ifndef toUPPER_uvchr # define toUPPER_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(upper, c, s, l) #endif #ifndef toTITLE_uvchr # define toTITLE_uvchr(c, s, l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UVCHR(title, c, s, l) #endif #ifndef toFOLD_uvchr # define toFOLD_uvchr(c, s, l) toLOWER_uvchr(c, s, l) #endif # define D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(name, s, e, r, l) \ (((((e) - (s)) <= 0) \ ? (croak("Attempting case change on zero length string"), \ 0) /* So looks like it returns something, and will compile */ \ : ((e) - (s)) < UTF8SKIP(s)) \ ? (croak(D_PPP_TOO_SHORT_MSG, \ s[0], (int) ((e) - (s)), (int) UTF8SKIP(s)), \ 0) \ /* Get the changed code point and store its UTF-8 */ \ : D_PPP_UV_TO_UTF8(r, to_utf8_ ## name(s)), \ /* Then store its length, and re-get code point for return */ \ *(l) = UTF8SKIP(r), to_utf8_ ## name(r)) /* Warning: toUPPER_utf8_safe, toLOWER_utf8_safe, toTITLE_utf8_safe, * toUPPER_uvchr, toLOWER_uvchr, toTITLE_uvchr The UTF-8 case changing operations had bugs before around 5.12 or 5.14; this backport does not correct them. In perls before 7.3, multi-character case changing is not implemented; this backport uses the simple case changes available in those perls. */ #ifndef toUPPER_utf8_safe # define toUPPER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(upper, s, e, r, l) #endif #ifndef toLOWER_utf8_safe # define toLOWER_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(lower, s, e, r, l) #endif #ifndef toTITLE_utf8_safe # define toTITLE_utf8_safe(s,e,r,l) \ D_PPP_GENERIC_SINGLE_ARG_TO_UTF8(title, s, e, r, l) #endif /* Warning: toFOLD_utf8_safe, toFOLD_uvchr The UTF-8 case changing operations had bugs before around 5.12 or 5.14; this backport does not correct them. In perls before 7.3, case folding is not implemented; instead, this backport substitutes simple (not multi-character, which isn't available) lowercasing. This gives the correct result in most, but not all, instances */ #ifndef toFOLD_utf8_safe # define toFOLD_utf8_safe(s,e,r,l) toLOWER_utf8_safe(s,e,r,l) #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 LIKELY # define LIKELY(x) (x) #endif #ifndef UNLIKELY # define UNLIKELY(x) (x) #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 #if (PERL_BCDVERSION >= 0x5004000) && !defined(vnewSVpvf) #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define vnewSVpvf(pat, args) ({ SV *_sv = newSV(0); sv_vsetpvfn(_sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)); _sv; }) #else # define vnewSVpvf(pat, args) ((PL_Sv = newSV(0)), sv_vsetpvfn(PL_Sv, (pat), strlen((pat)), (args), Null(SV**), 0, Null(bool*)), PL_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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_catpvf_mg) || defined(NEED_sv_catpvf_mg_GLOBAL) #define Perl_sv_catpvf_mg DPPP_(my_sv_catpvf_mg) void DPPP_(my_sv_catpvf_mg)(pTHX_ SV * const sv, const char * const 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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_catpvf_mg_nocontext) || defined(NEED_sv_catpvf_mg_nocontext_GLOBAL) #define sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) #define Perl_sv_catpvf_mg_nocontext DPPP_(my_sv_catpvf_mg_nocontext) void DPPP_(my_sv_catpvf_mg_nocontext)(SV * const sv, const char * const 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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_setpvf_mg) || defined(NEED_sv_setpvf_mg_GLOBAL) #define Perl_sv_setpvf_mg DPPP_(my_sv_setpvf_mg) void DPPP_(my_sv_setpvf_mg)(pTHX_ SV * const sv, const char * const 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 * const sv, const char * const pat, ...); static #else extern void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const pat, ...); #endif #if defined(NEED_sv_setpvf_mg_nocontext) || defined(NEED_sv_setpvf_mg_nocontext_GLOBAL) #define sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) #define Perl_sv_setpvf_mg_nocontext DPPP_(my_sv_setpvf_mg_nocontext) void DPPP_(my_sv_setpvf_mg_nocontext)(SV * const sv, const char * const 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: 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) #ifndef sv_2pvbyte # define sv_2pvbyte(sv, lp) (sv_utf8_downgrade((sv), 0), SvPV((sv), *(lp))) #endif /* Hint: sv_2pvbyte * Use the SvPVbyte() macro instead of sv_2pvbyte(). */ /* Replace sv_2pvbyte with SvPVbyte */ #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(). */ /* Replace sv_pvn with SvPV */ /* Hint: sv_pvn_force * Always use the SvPV_force() macro instead of sv_pvn_force(). */ /* Replace sv_pvn_force with SvPV_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_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) #ifndef sv_2pv_flags # define sv_2pv_flags(sv, lp, flags) sv_2pv((sv), (lp) ? (lp) : &PL_na) #endif #ifndef sv_pvn_force_flags # define sv_pvn_force_flags(sv, lp, flags) sv_pvn_force((sv), (lp) ? (lp) : &PL_na) #endif #endif #if (PERL_BCDVERSION < 0x5008008) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009003) ) # define D_PPP_SVPV_NOLEN_LP_ARG &PL_na #else # define D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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, D_PPP_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 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 #if defined(NEED_warner) || defined(NEED_warner_GLOBAL) #define Perl_warner DPPP_(my_warner) 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 #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 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 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) #ifndef sv_2uv # define sv_2uv(sv) ({ SV *_sv = (sv); (UV) (SvNOK(_sv) ? SvNV(_sv) : sv_2nv(_sv)); }) #endif #else #ifndef sv_2uv # define sv_2uv(sv) ((PL_Sv = (sv)), (UV) (SvNOK(PL_Sv) ? SvNV(PL_Sv) : sv_2nv(PL_Sv))) #endif #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 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) #ifndef SvUVx # define SvUVx(sv) ({ SV *_sv = (sv)); SvUV(_sv); }) #endif #else #ifndef SvUVx # define SvUVx(sv) ((PL_Sv = (sv)), SvUV(PL_Sv)) #endif #endif /* Hint: sv_uv * Always use the SvUVx() macro instead of sv_uv(). */ /* Replace sv_uv with SvUVx */ #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 #if !defined(my_strnlen) #if defined(NEED_my_strnlen) static Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen); static #else extern Size_t DPPP_(my_my_strnlen)(const char * str, Size_t maxlen); #endif #if defined(NEED_my_strnlen) || defined(NEED_my_strnlen_GLOBAL) #define my_strnlen DPPP_(my_my_strnlen) #define Perl_my_strnlen DPPP_(my_my_strnlen) Size_t DPPP_(my_my_strnlen)(const char *str, Size_t maxlen) { const char *p = str; while(maxlen-- && *p) p++; return p - str; } #endif #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 #ifdef NEED_mess_sv #define NEED_mess #endif #ifdef NEED_mess #define NEED_mess_nocontext #define NEED_vmess #endif #ifndef croak_sv #if (PERL_BCDVERSION >= 0x5007003) || ( (PERL_BCDVERSION >= 0x5006001) && (PERL_BCDVERSION < 0x5007000) ) # if ( (PERL_BCDVERSION >= 0x5008000) && (PERL_BCDVERSION < 0x5008009) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5010001) ) # define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) \ STMT_START { \ SV *_errsv = ERRSV; \ SvFLAGS(_errsv) = (SvFLAGS(_errsv) & ~SVf_UTF8) | \ (SvFLAGS(sv) & SVf_UTF8); \ } STMT_END # else # define D_PPP_FIX_UTF8_ERRSV_FOR_SV(sv) STMT_START {} STMT_END # endif # define croak_sv(sv) \ STMT_START { \ SV *_sv = (sv); \ if (SvROK(_sv)) { \ sv_setsv(ERRSV, _sv); \ croak(NULL); \ } else { \ D_PPP_FIX_UTF8_ERRSV_FOR_SV(_sv); \ croak("%" SVf, SVfARG(_sv)); \ } \ } STMT_END #elif (PERL_BCDVERSION >= 0x5004000) # define croak_sv(sv) croak("%" SVf, SVfARG(sv)) #else # define croak_sv(sv) croak("%s", SvPV_nolen(sv)) #endif #endif #ifndef die_sv #if defined(NEED_die_sv) static OP * DPPP_(my_die_sv)(pTHX_ SV * baseex); static #else extern OP * DPPP_(my_die_sv)(pTHX_ SV * baseex); #endif #if defined(NEED_die_sv) || defined(NEED_die_sv_GLOBAL) #ifdef die_sv # undef die_sv #endif #define die_sv(a) DPPP_(my_die_sv)(aTHX_ a) #define Perl_die_sv DPPP_(my_die_sv) OP * DPPP_(my_die_sv)(pTHX_ SV *baseex) { croak_sv(baseex); return (OP *)NULL; } #endif #endif #ifndef warn_sv #if (PERL_BCDVERSION >= 0x5004000) # define warn_sv(sv) warn("%" SVf, SVfARG(sv)) #else # define warn_sv(sv) warn("%s", SvPV_nolen(sv)) #endif #endif #if ! defined vmess && (PERL_BCDVERSION >= 0x5004000) # if defined(NEED_vmess) static SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); static #else extern SV * DPPP_(my_vmess)(pTHX_ const char * pat, va_list * args); #endif #if defined(NEED_vmess) || defined(NEED_vmess_GLOBAL) #ifdef vmess # undef vmess #endif #define vmess(a,b) DPPP_(my_vmess)(aTHX_ a,b) #define Perl_vmess DPPP_(my_vmess) SV* DPPP_(my_vmess)(pTHX_ const char* pat, va_list* args) { mess(pat, args); return PL_mess_sv; } # endif #endif #if (PERL_BCDVERSION < 0x5006000) && (PERL_BCDVERSION >= 0x5004000) #undef mess #endif #if !defined(mess_nocontext) && !defined(Perl_mess_nocontext) && (PERL_BCDVERSION >= 0x5004000) #if defined(NEED_mess_nocontext) static SV * DPPP_(my_mess_nocontext)(const char * pat, ...); static #else extern SV * DPPP_(my_mess_nocontext)(const char * pat, ...); #endif #if defined(NEED_mess_nocontext) || defined(NEED_mess_nocontext_GLOBAL) #define mess_nocontext DPPP_(my_mess_nocontext) #define Perl_mess_nocontext DPPP_(my_mess_nocontext) SV* DPPP_(my_mess_nocontext)(const char* pat, ...) { dTHX; SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #endif #endif #ifndef mess #if defined(NEED_mess) static SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); static #else extern SV * DPPP_(my_mess)(pTHX_ const char * pat, ...); #endif #if defined(NEED_mess) || defined(NEED_mess_GLOBAL) #define Perl_mess DPPP_(my_mess) SV* DPPP_(my_mess)(pTHX_ const char* pat, ...) { SV *sv; va_list args; va_start(args, pat); sv = vmess(pat, &args); va_end(args); return sv; } #ifdef mess_nocontext #define mess mess_nocontext #else #define mess Perl_mess_nocontext #endif #endif #endif #if ! defined mess_sv && (PERL_BCDVERSION >= 0x5004000) #if defined(NEED_mess_sv) static SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); static #else extern SV * DPPP_(my_mess_sv)(pTHX_ SV * basemsg, bool consume); #endif #if defined(NEED_mess_sv) || defined(NEED_mess_sv_GLOBAL) #ifdef mess_sv # undef mess_sv #endif #define mess_sv(a,b) DPPP_(my_mess_sv)(aTHX_ a,b) #define Perl_mess_sv DPPP_(my_mess_sv) SV * DPPP_(my_mess_sv)(pTHX_ SV *basemsg, bool consume) { SV *tmp; SV *ret; if (SvPOK(basemsg) && SvCUR(basemsg) && *(SvEND(basemsg)-1) == '\n') { if (consume) return basemsg; ret = mess(""); SvSetSV_nosteal(ret, basemsg); return ret; } if (consume) { sv_catsv(basemsg, mess("")); return basemsg; } ret = mess(""); tmp = newSVsv(ret); SvSetSV_nosteal(ret, basemsg); sv_catsv(ret, tmp); sv_dec(tmp); return ret; } #endif #endif #ifndef warn_nocontext #define warn_nocontext warn #endif #ifndef croak_nocontext #define croak_nocontext croak #endif #ifndef croak_no_modify #define croak_no_modify() croak_nocontext("%s", PL_no_modify) #define Perl_croak_no_modify() croak_no_modify() #endif #ifndef croak_memory_wrap #if (PERL_BCDVERSION >= 0x5009002) || ( (PERL_BCDVERSION >= 0x5008006) && (PERL_BCDVERSION < 0x5009000) ) # define croak_memory_wrap() croak_nocontext("%s", PL_memory_wrap) #else # define croak_memory_wrap() croak_nocontext("panic: memory wrap") #endif #endif #ifndef croak_xs_usage #if defined(NEED_croak_xs_usage) static void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); static #else extern void DPPP_(my_croak_xs_usage)(const CV * const cv, const char * const params); #endif #if defined(NEED_croak_xs_usage) || defined(NEED_croak_xs_usage_GLOBAL) #define croak_xs_usage DPPP_(my_croak_xs_usage) #define Perl_croak_xs_usage DPPP_(my_croak_xs_usage) void DPPP_(my_croak_xs_usage)(const CV *const cv, const char *const params) { dTHX; const GV *const gv = CvGV(cv); #ifdef PERL_ARGS_ASSERT_CROAK_XS_USAGE PERL_ARGS_ASSERT_CROAK_XS_USAGE; #else assert(cv); assert(params); #endif if (gv) { const char *const gvname = GvNAME(gv); const HV *const stash = GvSTASH(gv); const char *const hvname = stash ? HvNAME(stash) : NULL; if (hvname) croak("Usage: %s::%s(%s)", hvname, gvname, params); else croak("Usage: %s(%s)", gvname, params); } else { /* Pants. I don't think that it should be possible to get here. */ croak("Usage: CODE(0x%" UVxf ")(%s)", PTR2UV(cv), params); } } #endif #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 #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define D_PPP_CROAK_IF_ERROR(cond) ({ SV *_errsv; ((cond) && (_errsv = ERRSV) && (SvROK(_errsv) || SvTRUE(_errsv)) && (croak_sv(_errsv), 1)); }) #else # define D_PPP_CROAK_IF_ERROR(cond) ((cond) && (SvROK(ERRSV) || SvTRUE(ERRSV)) && (croak_sv(ERRSV), 1)) #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 #ifndef G_RETHROW # define G_RETHROW 8192 # ifdef eval_sv # undef eval_sv # endif # if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define eval_sv(sv, flags) ({ I32 _flags = (flags); I32 _ret = Perl_eval_sv(aTHX_ sv, (_flags & ~G_RETHROW)); D_PPP_CROAK_IF_ERROR(_flags & G_RETHROW); _ret; }) # else # define eval_sv(sv, flags) ((PL_na = Perl_eval_sv(aTHX_ sv, ((flags) & ~G_RETHROW))), D_PPP_CROAK_IF_ERROR((flags) & G_RETHROW), (I32)PL_na) # endif #endif /* Older Perl versions have broken croak_on_error=1 */ #if (PERL_BCDVERSION < 0x5031002) # ifdef eval_pv # undef eval_pv # if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define eval_pv(p, croak_on_error) ({ SV *_sv = Perl_eval_pv(aTHX_ p, 0); D_PPP_CROAK_IF_ERROR(croak_on_error); _sv; }) # else # define eval_pv(p, croak_on_error) ((PL_Sv = Perl_eval_pv(aTHX_ p, 0)), D_PPP_CROAK_IF_ERROR(croak_on_error), PL_Sv) # endif # endif #endif /* Replace perl_eval_pv with eval_pv */ #ifndef eval_pv #if defined(NEED_eval_pv) static SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error); static #else extern SV * DPPP_(my_eval_pv)(const char * p, I32 croak_on_error); #endif #if defined(NEED_eval_pv) || defined(NEED_eval_pv_GLOBAL) #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) SV* DPPP_(my_eval_pv)(const 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; D_PPP_CROAK_IF_ERROR(croak_on_error); return sv; } #endif #endif #if ! defined(vload_module) && defined(start_subparse) #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 #if defined(NEED_vload_module) || defined(NEED_vload_module_GLOBAL) #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) 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; utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0), #if (PERL_BCDVERSION > 0x5003000) veop, #endif modname, imop); 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 #if defined(NEED_load_module) || defined(NEED_load_module_GLOBAL) #ifdef load_module # undef load_module #endif #define load_module DPPP_(my_load_module) #define Perl_load_module DPPP_(my_load_module) 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(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define newRV_noinc(sv) ({ SV *_sv = (SV *)newRV((sv)); SvREFCNT_dec((sv)); _sv; }) #else # define newRV_noinc(sv) ((PL_Sv = (SV *)newRV((sv))), SvREFCNT_dec((sv)), PL_Sv) #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 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(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define newSV_type(t) ({ SV *_sv = newSV(0); sv_upgrade(_sv, (t)); _sv; }) #else # define newSV_type(t) ((PL_Sv = newSV(0)), sv_upgrade(PL_Sv, (t)), PL_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(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define newSVpvn_flags(s, len, flags) ({ SV *_sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len)); SvFLAGS(_sv) |= ((flags) & SVf_UTF8); ((flags) & SVs_TEMP) ? sv_2mortal(_sv) : _sv; }) #else # define newSVpvn_flags(s, len, flags) ((PL_Sv = newSVpvn(D_PPP_CONSTPV_ARG((s)), (len))), SvFLAGS(PL_Sv) |= ((flags) & SVf_UTF8), (((flags) & SVs_TEMP) ? sv_2mortal(PL_Sv) : PL_Sv)) #endif #endif #if ( (PERL_BCDVERSION >= 0x5007003) && (PERL_BCDVERSION < 0x5008007) ) || ( (PERL_BCDVERSION >= 0x5009000) && (PERL_BCDVERSION < 0x5009002) ) #undef sv_setsv_flags #define SV_NOSTEAL 16 #define sv_setsv_flags(dstr, sstr, flags) \ STMT_START { \ if (((flags) & SV_NOSTEAL) && (sstr) && (SvFLAGS((SV *)(sstr)) & SVs_TEMP)) { \ SvTEMP_off((SV *)(sstr)); \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ SvTEMP_on((SV *)(sstr)); \ } else { \ Perl_sv_setsv_flags(aTHX_ (dstr), (sstr), (flags) & ~SV_NOSTEAL); \ } \ } STMT_END #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) #ifndef newSVsv_flags # define newSVsv_flags(sv, flags) ({ SV *_sv = newSV(0); sv_setsv_flags(_sv, (sv), (flags)); _sv; }) #endif #else #ifndef newSVsv_flags # define newSVsv_flags(sv, flags) ((PL_Sv = newSV(0)), sv_setsv_flags(PL_Sv, (sv), (flags)), PL_Sv) #endif #endif #ifdef SV_NOSTEAL #ifndef newSVsv_nomg # define newSVsv_nomg(sv) newSVsv_flags((sv), SV_NOSTEAL) #endif #endif #if (PERL_BCDVERSION >= 0x5017005) #ifndef sv_mortalcopy_flags # define sv_mortalcopy_flags(sv, flags) Perl_sv_mortalcopy_flags(aTHX_ (sv), (flags)) #endif #else #ifndef sv_mortalcopy_flags # define sv_mortalcopy_flags(sv, flags) sv_2mortal(newSVsv_flags((sv), (flags))) #endif #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 /* 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 * s, I32 len, U32 hash); static #else extern SV * DPPP_(my_newSVpvn_share)(pTHX_ const char * s, I32 len, U32 hash); #endif #if defined(NEED_newSVpvn_share) || defined(NEED_newSVpvn_share_GLOBAL) #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) SV * DPPP_(my_newSVpvn_share)(pTHX_ const char *s, I32 len, U32 hash) { SV *sv; if (len < 0) len = -len; if (!hash) PERL_HASH(hash, (char*) s, len); sv = newSVpvn((char *) s, 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 #if (PERL_BCDVERSION >= 0x5009002) && (PERL_BCDVERSION <= 0x5009003) /* 5.9.2 and 5.9.3 ignore the length param */ #undef gv_fetchpvn_flags #endif #ifndef GV_NOADD_MASK # define GV_NOADD_MASK 0xE0 #endif #ifndef gv_fetchpvn_flags # define gv_fetchpvn_flags(name, len, flags, sv_type) gv_fetchpv(SvPVX(sv_2mortal(newSVpvn((name), (len)))), ((flags) & GV_NOADD_MASK) ? FALSE : TRUE, (I32)(sv_type)) #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 /* 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 /* 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 #ifdef SV_NOSTEAL #ifndef SvIV_nomg # define SvIV_nomg(sv) (!SvGMAGICAL((sv)) ? SvIV((sv)) : SvIVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #ifndef SvUV_nomg # define SvUV_nomg(sv) (!SvGMAGICAL((sv)) ? SvUV((sv)) : SvUVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #ifndef SvNV_nomg # define SvNV_nomg(sv) (!SvGMAGICAL((sv)) ? SvNV((sv)) : SvNVx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #ifndef SvTRUE_nomg # define SvTRUE_nomg(sv) (!SvGMAGICAL((sv)) ? SvTRUE((sv)) : SvTRUEx(sv_mortalcopy_flags((sv), SV_NOSTEAL))) #endif #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)(const SV * sv, int type, const MGVTBL * vtbl); static #else extern MAGIC * DPPP_(my_mg_findext)(const SV * sv, int type, const MGVTBL * vtbl); #endif #if defined(NEED_mg_findext) || defined(NEED_mg_findext_GLOBAL) #define mg_findext DPPP_(my_mg_findext) #define Perl_mg_findext DPPP_(my_mg_findext) MAGIC * DPPP_(my_mg_findext)(const 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 #if defined(NEED_sv_unmagicext) || defined(NEED_sv_unmagicext_GLOBAL) #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) 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 level, const PERL_CONTEXT * * dbcxp); static #else extern const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, const PERL_CONTEXT * * dbcxp); #endif #if defined(NEED_caller_cx) || defined(NEED_caller_cx_GLOBAL) #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) const PERL_CONTEXT * DPPP_(my_caller_cx)(pTHX_ I32 level, 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)) level++; if (!level--) 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 #if defined(NEED_grok_numeric_radix) || defined(NEED_grok_numeric_radix_GLOBAL) #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) 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 #if defined(NEED_grok_number) || defined(NEED_grok_number_GLOBAL) #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) 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 #if defined(NEED_grok_bin) || defined(NEED_grok_bin_GLOBAL) #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) 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 #if defined(NEED_grok_hex) || defined(NEED_grok_hex_GLOBAL) #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) 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 #if defined(NEED_grok_oct) || defined(NEED_grok_oct_GLOBAL) #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) 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 #if defined(NEED_my_snprintf) || defined(NEED_my_snprintf_GLOBAL) #define my_snprintf DPPP_(my_my_snprintf) #define Perl_my_snprintf DPPP_(my_my_snprintf) 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 #if defined(NEED_my_sprintf) || defined(NEED_my_sprintf_GLOBAL) #define my_sprintf DPPP_(my_my_sprintf) /* Warning: my_sprintf It's safer to use my_snprintf instead */ /* Replace my_sprintf with my_snprintf */ 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 #if defined(NEED_my_strlcat) || defined(NEED_my_strlcat_GLOBAL) #define my_strlcat DPPP_(my_my_strlcat) #define Perl_my_strlcat DPPP_(my_my_strlcat) 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 #if defined(NEED_my_strlcpy) || defined(NEED_my_strlcpy_GLOBAL) #define my_strlcpy DPPP_(my_my_strlcpy) #define Perl_my_strlcpy DPPP_(my_my_strlcpy) 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 #define D_PPP_MIN(a,b) (((a) <= (b)) ? (a) : (b)) #ifndef UNICODE_REPLACEMENT # define UNICODE_REPLACEMENT 0xFFFD #endif #ifdef UTF8_MAXLEN #ifndef UTF8_MAXBYTES # define UTF8_MAXBYTES UTF8_MAXLEN #endif #endif #ifndef UTF_START_MARK # define UTF_START_MARK(len) \ (((len) > 7) ? 0xFF : (0xFF & (0xFE << (7-(len))))) #endif #if (PERL_BCDVERSION < 0x5018000) /* On non-EBCDIC was valid before this, */ /* but easier to just do one check */ # undef UTF8_MAXBYTES_CASE #endif #if 'A' == 65 # define D_PPP_BYTE_INFO_BITS 6 /* 6 bits meaningful in continuation bytes */ #ifndef UTF8_MAXBYTES_CASE # define UTF8_MAXBYTES_CASE 13 #endif #else # define D_PPP_BYTE_INFO_BITS 5 /* 5 bits meaningful in continuation bytes */ #ifndef UTF8_MAXBYTES_CASE # define UTF8_MAXBYTES_CASE 15 #endif #endif #ifndef UTF_ACCUMULATION_SHIFT # define UTF_ACCUMULATION_SHIFT D_PPP_BYTE_INFO_BITS #endif #ifdef NATIVE_TO_UTF #ifndef NATIVE_UTF8_TO_I8 # define NATIVE_UTF8_TO_I8(c) NATIVE_TO_UTF(c) #endif #else /* System doesn't support EBCDIC */ #ifndef NATIVE_UTF8_TO_I8 # define NATIVE_UTF8_TO_I8(c) (c) #endif #endif #ifdef UTF_TO_NATIVE #ifndef I8_TO_NATIVE_UTF8 # define I8_TO_NATIVE_UTF8(c) UTF_TO_NATIVE(c) #endif #else /* System doesn't support EBCDIC */ #ifndef I8_TO_NATIVE_UTF8 # define I8_TO_NATIVE_UTF8(c) (c) #endif #endif #ifndef UTF_START_MASK # define UTF_START_MASK(len) \ (((len) >= 7) ? 0x00 : (0x1F >> ((len)-2))) #endif #ifndef UTF_IS_CONTINUATION_MASK # define UTF_IS_CONTINUATION_MASK \ ((U8) (0xFF << UTF_ACCUMULATION_SHIFT)) #endif #ifndef UTF_CONTINUATION_MARK # define UTF_CONTINUATION_MARK \ (UTF_IS_CONTINUATION_MASK & 0xB0) #endif #ifndef UTF_MIN_START_BYTE # define UTF_MIN_START_BYTE \ ((UTF_CONTINUATION_MARK >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) #endif #ifndef UTF_MIN_ABOVE_LATIN1_BYTE # define UTF_MIN_ABOVE_LATIN1_BYTE \ ((0x100 >> UTF_ACCUMULATION_SHIFT) | UTF_START_MARK(2)) #endif #if (PERL_BCDVERSION < 0x5007000) /* Was the complement of what should have been */ # undef UTF8_IS_DOWNGRADEABLE_START #endif #ifndef UTF8_IS_DOWNGRADEABLE_START # define UTF8_IS_DOWNGRADEABLE_START(c) \ inRANGE(NATIVE_UTF8_TO_I8(c), \ UTF_MIN_START_BYTE, UTF_MIN_ABOVE_LATIN1_BYTE - 1) #endif #ifndef UTF_CONTINUATION_MASK # define UTF_CONTINUATION_MASK \ ((U8) ((1U << UTF_ACCUMULATION_SHIFT) - 1)) #endif #ifndef UTF8_ACCUMULATE # define UTF8_ACCUMULATE(base, added) \ (((base) << UTF_ACCUMULATION_SHIFT) \ | ((NATIVE_UTF8_TO_I8(added)) \ & UTF_CONTINUATION_MASK)) #endif #ifndef UTF8_ALLOW_ANYUV # define UTF8_ALLOW_ANYUV 0 #endif #ifndef UTF8_ALLOW_EMPTY # define UTF8_ALLOW_EMPTY 0x0001 #endif #ifndef UTF8_ALLOW_CONTINUATION # define UTF8_ALLOW_CONTINUATION 0x0002 #endif #ifndef UTF8_ALLOW_NON_CONTINUATION # define UTF8_ALLOW_NON_CONTINUATION 0x0004 #endif #ifndef UTF8_ALLOW_SHORT # define UTF8_ALLOW_SHORT 0x0008 #endif #ifndef UTF8_ALLOW_LONG # define UTF8_ALLOW_LONG 0x0010 #endif #ifndef UTF8_ALLOW_OVERFLOW # define UTF8_ALLOW_OVERFLOW 0x0080 #endif #ifndef UTF8_ALLOW_ANY # define UTF8_ALLOW_ANY ( UTF8_ALLOW_CONTINUATION \ |UTF8_ALLOW_NON_CONTINUATION \ |UTF8_ALLOW_SHORT \ |UTF8_ALLOW_LONG \ |UTF8_ALLOW_OVERFLOW) #endif #if defined UTF8SKIP /* Don't use official versions because they use MIN, which may not be available */ #undef UTF8_SAFE_SKIP #undef UTF8_CHK_SKIP #ifndef UTF8_SAFE_SKIP # define UTF8_SAFE_SKIP(s, e) ( \ ((((e) - (s)) <= 0) \ ? 0 \ : D_PPP_MIN(((e) - (s)), UTF8SKIP(s)))) #endif #ifndef UTF8_CHK_SKIP # define UTF8_CHK_SKIP(s) \ (s[0] == '\0' ? 1 : ((U8) D_PPP_MIN(my_strnlen((char *) (s), UTF8SKIP(s)), \ UTF8SKIP(s)))) #endif #ifndef UTF8_SKIP # define UTF8_SKIP(s) UTF8SKIP(s) #endif #endif #if 'A' == 65 #ifndef UTF8_IS_INVARIANT # define UTF8_IS_INVARIANT(c) isASCII(c) #endif #else #ifndef UTF8_IS_INVARIANT # define UTF8_IS_INVARIANT(c) (isASCII(c) || isCNTRL_L1(c)) #endif #endif #ifndef UVCHR_IS_INVARIANT # define UVCHR_IS_INVARIANT(c) UTF8_IS_INVARIANT(c) #endif #ifdef UVCHR_IS_INVARIANT # if 'A' == 65 # ifdef QUADKIND # define D_PPP_UVCHR_SKIP_UPPER(c) \ (WIDEST_UTYPE) (c) < \ (((WIDEST_UTYPE) 1) << (6 * D_PPP_BYTE_INFO_BITS)) ? 7 : 13 # else # define D_PPP_UVCHR_SKIP_UPPER(c) 7 /* 32 bit platform */ # endif # else /* In the releases this is backported to, UTF-EBCDIC had a max of 2**31-1 */ # define D_PPP_UVCHR_SKIP_UPPER(c) 7 # endif #ifndef UVCHR_SKIP # define UVCHR_SKIP(c) \ UVCHR_IS_INVARIANT(c) ? 1 : \ (WIDEST_UTYPE) (c) < (32 * (1U << ( D_PPP_BYTE_INFO_BITS))) ? 2 : \ (WIDEST_UTYPE) (c) < (16 * (1U << (2 * D_PPP_BYTE_INFO_BITS))) ? 3 : \ (WIDEST_UTYPE) (c) < ( 8 * (1U << (3 * D_PPP_BYTE_INFO_BITS))) ? 4 : \ (WIDEST_UTYPE) (c) < ( 4 * (1U << (4 * D_PPP_BYTE_INFO_BITS))) ? 5 : \ (WIDEST_UTYPE) (c) < ( 2 * (1U << (5 * D_PPP_BYTE_INFO_BITS))) ? 6 : \ D_PPP_UVCHR_SKIP_UPPER(c) #endif #endif #ifdef is_ascii_string #ifndef is_invariant_string # define is_invariant_string(s,l) is_ascii_string(s,l) #endif #ifndef is_utf8_invariant_string # define is_utf8_invariant_string(s,l) is_ascii_string(s,l) #endif /* Hint: is_ascii_string, is_invariant_string is_utf8_invariant_string() does the same thing and is preferred because its name is more accurate as to what it does */ #endif #ifdef ibcmp_utf8 #ifndef foldEQ_utf8 # define foldEQ_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2) \ cBOOL(! ibcmp_utf8(s1,pe1,l1,u1,s2,pe2,l2,u2)) #endif #endif #if defined(is_utf8_string) && defined(UTF8SKIP) #ifndef isUTF8_CHAR # define isUTF8_CHAR(s, e) ( \ (e) <= (s) || ! is_utf8_string(s, UTF8_SAFE_SKIP(s, e)) \ ? 0 \ : UTF8SKIP(s)) #endif #endif #if 'A' == 65 #ifndef BOM_UTF8 # define BOM_UTF8 "\xEF\xBB\xBF" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 # define REPLACEMENT_CHARACTER_UTF8 "\xEF\xBF\xBD" #endif #elif '^' == 95 #ifndef BOM_UTF8 # define BOM_UTF8 "\xDD\x73\x66\x73" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 # define REPLACEMENT_CHARACTER_UTF8 "\xDD\x73\x73\x71" #endif #elif '^' == 176 #ifndef BOM_UTF8 # define BOM_UTF8 "\xDD\x72\x65\x72" #endif #ifndef REPLACEMENT_CHARACTER_UTF8 # define REPLACEMENT_CHARACTER_UTF8 "\xDD\x72\x72\x70" #endif #else # error Unknown character set #endif #if (PERL_BCDVERSION < 0x5031004) /* Versions prior to this accepted things that are now considered * malformations, and didn't return -1 on error with warnings enabled * */ # undef utf8_to_uvchr_buf #endif /* This implementation brings modern, generally more restricted standards to * utf8_to_uvchr_buf. Some of these are security related, and clearly must * be done. But its arguable that the others need not, and hence should not. * The reason they're here is that a module that intends to play with the * latest perls should be able to work the same in all releases. An example is * that perl no longer accepts any UV for a code point, but limits them to * IV_MAX or below. This is for future internal use of the larger code points. * If it turns out that some of these changes are breaking code that isn't * intended to work with modern perls, the tighter restrictions could be * relaxed. khw thinks this is unlikely, but has been wrong in the past. */ /* 5.6.0 is the first release with UTF-8, and we don't implement this function * there due to its likely lack of still being in use, and the underlying * implementation is very different from later ones, without the later * safeguards, so would require extra work to deal with */ #if (PERL_BCDVERSION >= 0x5006001) && ! defined(utf8_to_uvchr_buf) /* Choose which underlying implementation to use. At least one must be * present or the perl is too early to handle this function */ # if defined(utf8n_to_uvchr) || defined(utf8_to_uvchr) || defined(utf8_to_uv) # if defined(utf8n_to_uvchr) /* This is the preferred implementation */ # define D_PPP_utf8_to_uvchr_buf_callee utf8n_to_uvchr # elif /* Must be at least 5.6.1 from #if above; \ If have both regular and _simple, regular has all args */ \ defined(utf8_to_uv) && defined(utf8_to_uv_simple) # define D_PPP_utf8_to_uvchr_buf_callee utf8_to_uv # elif defined(utf8_to_uvchr) /* The below won't work well on error input */ # define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ utf8_to_uvchr((U8 *)(s), (retlen)) # else # define D_PPP_utf8_to_uvchr_buf_callee(s, curlen, retlen, flags) \ utf8_to_uv((U8 *)(s), (retlen)) # endif # endif # if defined(NEED_utf8_to_uvchr_buf) static UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); static #else extern UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 * s, const U8 * send, STRLEN * retlen); #endif #if defined(NEED_utf8_to_uvchr_buf) || defined(NEED_utf8_to_uvchr_buf_GLOBAL) #ifdef utf8_to_uvchr_buf # undef utf8_to_uvchr_buf #endif #define utf8_to_uvchr_buf(a,b,c) DPPP_(my_utf8_to_uvchr_buf)(aTHX_ a,b,c) #define Perl_utf8_to_uvchr_buf DPPP_(my_utf8_to_uvchr_buf) UV DPPP_(my_utf8_to_uvchr_buf)(pTHX_ const U8 *s, const U8 *send, STRLEN *retlen) { UV ret; STRLEN curlen; bool overflows = 0; const U8 *cur_s = s; const bool do_warnings = ckWARN_d(WARN_UTF8); # if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC) STRLEN overflow_length = 0; # endif if (send > s) { curlen = send - s; } else { assert(0); /* Modern perls die under this circumstance */ curlen = 0; if (! do_warnings) { /* Handle empty here if no warnings needed */ if (retlen) *retlen = 0; return UNICODE_REPLACEMENT; } } # if (PERL_BCDVERSION < 0x5026000) && ! defined(EBCDIC) /* Perl did not properly detect overflow for much of its history on * non-EBCDIC platforms, often returning an overlong value which may or may * not have been tolerated in the call. Also, earlier versions, when they * did detect overflow, may have disallowed it completely. Modern ones can * replace it with the REPLACEMENT CHARACTER, depending on calling * parameters. Therefore detect it ourselves in releases it was * problematic in. */ if (curlen > 0 && UNLIKELY(*s >= 0xFE)) { /* First, on a 32-bit machine the first byte being at least \xFE * automatically is overflow, as it indicates something requiring more * than 31 bits */ if (sizeof(ret) < 8) { overflows = 1; overflow_length = (*s == 0xFE) ? 7 : 13; } else { const U8 highest[] = /* 2*63-1 */ "\xFF\x80\x87\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF\xBF"; const U8 *cur_h = highest; for (cur_s = s; cur_s < send; cur_s++, cur_h++) { if (UNLIKELY(*cur_s == *cur_h)) { continue; } /* If this byte is larger than the corresponding highest UTF-8 * byte, the sequence overflows; otherwise the byte is less * than (as we handled the equality case above), and so the * sequence doesn't overflow */ overflows = *cur_s > *cur_h; break; } /* Here, either we set the bool and broke out of the loop, or got * to the end and all bytes are the same which indicates it doesn't * overflow. If it did overflow, it would be this number of bytes * */ overflow_length = 13; } } if (UNLIKELY(overflows)) { ret = 0; if (! do_warnings && retlen) { *retlen = overflow_length; } } else # endif /* < 5.26 */ /* Here, we are either in a release that properly detects overflow, or * we have checked for overflow and the next statement is executing as * part of the above conditional where we know we don't have overflow. * * The modern versions allow anything that evaluates to a legal UV, but * not overlongs nor an empty input */ ret = D_PPP_utf8_to_uvchr_buf_callee( s, curlen, retlen, (UTF8_ALLOW_ANYUV & ~(UTF8_ALLOW_LONG|UTF8_ALLOW_EMPTY))); # if (PERL_BCDVERSION >= 0x5026000) && (PERL_BCDVERSION < 0x5028000) /* But actually, more modern versions restrict the UV to being no more than * what an IV can hold, so it could still have gotten it wrong about * overflowing. */ if (UNLIKELY(ret > IV_MAX)) { overflows = 1; } # endif if (UNLIKELY(overflows)) { if (! do_warnings) { if (retlen) { *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); *retlen = D_PPP_MIN(*retlen, curlen); } return UNICODE_REPLACEMENT; } else { /* We use the error message in use from 5.8-5.26 */ Perl_warner(aTHX_ packWARN(WARN_UTF8), "Malformed UTF-8 character (overflow at 0x%" UVxf ", byte 0x%02x, after start byte 0x%02x)", ret, *cur_s, *s); if (retlen) { *retlen = (STRLEN) -1; } return 0; } } /* Here, did not overflow, but if it failed for some other reason, and * warnings are off, to emulate the behavior of the real utf8_to_uvchr(), * try again, allowing anything. (Note a return of 0 is ok if the input * was '\0') */ if (UNLIKELY(ret == 0 && (curlen == 0 || *s != '\0'))) { /* If curlen is 0, we already handled the case where warnings are * disabled, so this 'if' will be true, and so later on, we know that * 's' is dereferencible */ if (do_warnings) { *retlen = (STRLEN) -1; } else { ret = D_PPP_utf8_to_uvchr_buf_callee( s, curlen, retlen, UTF8_ALLOW_ANY); /* Override with the REPLACEMENT character, as that is what the * modern version of this function returns */ ret = UNICODE_REPLACEMENT; # if (PERL_BCDVERSION < 0x5016000) /* Versions earlier than this don't necessarily return the proper * length. It should not extend past the end of string, nor past * what the first byte indicates the length is, nor past the * continuation characters */ if (retlen && *retlen >= 0) { unsigned int i = 1; *retlen = D_PPP_MIN(*retlen, curlen); *retlen = D_PPP_MIN(*retlen, UTF8SKIP(s)); do { # ifdef UTF8_IS_CONTINUATION if (! UTF8_IS_CONTINUATION(s[i])) # else /* Versions without the above don't support EBCDIC anyway */ if (s[i] < 0x80 || s[i] > 0xBF) # endif { *retlen = i; break; } } while (++i < *retlen); } # endif } } return ret; } # endif #endif #if defined(UTF8SKIP) && defined(utf8_to_uvchr_buf) #undef utf8_to_uvchr /* Always redefine this unsafe function so that it refuses to read past a NUL, making it much less likely to read off the end of the buffer. A NUL indicates the start of the next character anyway. If the input isn't NUL-terminated, the function remains unsafe, as it always has been. */ #ifndef utf8_to_uvchr # define utf8_to_uvchr(s, lp) \ ((*(s) == '\0') \ ? utf8_to_uvchr_buf(s,((s)+1), lp) /* Handle single NUL specially */ \ : utf8_to_uvchr_buf(s, (s) + UTF8_CHK_SKIP(s), (lp))) #endif #endif /* Hint: utf8_to_uvchr Use utf8_to_uvchr_buf() instead. But ONLY if you KNOW the upper bound of the input string (not resorting to using UTF8SKIP, etc., to infer it). The backported utf8_to_uvchr() will do a better job to prevent most cases of trying to read beyond the end of the buffer */ /* Replace utf8_to_uvchr with utf8_to_uvchr_buf */ #ifdef SV_NOSTEAL /* Older Perl versions have broken sv_len_utf8() when passed sv does not have SVf_UTF8 flag set */ /* Also note that SvGETMAGIC() may change presence of SVf_UTF8 flag */ # if (PERL_BCDVERSION < 0x5017005) # undef sv_len_utf8 # if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) # define sv_len_utf8_nomg(sv) ({ SV *_sv2 = (sv); (SvUTF8(_sv2) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(_sv2) ? _sv2 : sv_mortalcopy_flags(_sv2, SV_NOSTEAL))) : ({ STRLEN _len; SvPV_nomg(_sv2, _len); _len; })); }) # define sv_len_utf8(sv) ({ SV *_sv1 = (sv); SvGETMAGIC(_sv1); sv_len_utf8_nomg(_sv1); }) # else # define sv_len_utf8_nomg(sv) (PL_Sv = (sv), (SvUTF8(PL_Sv) ? Perl_sv_len_utf8(aTHX_ (!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) : (SvPV_nomg(PL_Sv, PL_na), PL_na))) # define sv_len_utf8(sv) (PL_Sv = (sv), SvGETMAGIC(PL_Sv), sv_len_utf8_nomg(PL_Sv)) # endif # endif # if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) #ifndef sv_len_utf8_nomg # define sv_len_utf8_nomg(sv) ({ SV *_sv = (sv); sv_len_utf8(!SvGMAGICAL(_sv) ? _sv : sv_mortalcopy_flags(_sv, SV_NOSTEAL)); }) #endif # else #ifndef sv_len_utf8_nomg # define sv_len_utf8_nomg(sv) ((PL_Sv = (sv)), sv_len_utf8(!SvGMAGICAL(PL_Sv) ? PL_Sv : sv_mortalcopy_flags(PL_Sv, SV_NOSTEAL))) #endif # 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 #if defined(NEED_pv_escape) || defined(NEED_pv_escape_GLOBAL) #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) 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_buf) 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_buf) 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_buf) isuni ? utf8_to_uvchr_buf((U8*)pv, end, &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 #if defined(NEED_pv_pretty) || defined(NEED_pv_pretty_GLOBAL) #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) 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 #if defined(NEED_pv_display) || defined(NEED_pv_display_GLOBAL) #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) 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 /* If this doesn't exist, it's not needed, so noop */ #ifndef switch_to_global_locale # define switch_to_global_locale() #endif /* Originally, this didn't return a value, but in perls like that, the value * should always be TRUE. Add a return to Perl_sync_locale() when it's * available. And actually do a sync when its not, if locales are available on * this system. */ #ifdef sync_locale # if (PERL_BCDVERSION < 0x5027009) # if (PERL_BCDVERSION >= 0x5021003) # undef sync_locale # define sync_locale() (Perl_sync_locale(aTHX), 1) # elif defined(sync_locale) /* These should be the 5.20 maints*/ # undef sync_locale /* Just copy their defn and return 1 */ # define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), \ new_collate(setlocale(LC_COLLATE, NULL)), \ set_numeric_local(), \ new_numeric(setlocale(LC_NUMERIC, NULL)), \ 1) # elif defined(new_ctype) && defined(LC_CTYPE) # define sync_locale() (new_ctype(setlocale(LC_CTYPE, NULL)), 1) # endif # endif #endif #ifndef sync_locale # define sync_locale() 1 #endif #endif /* _P_P_PORTABILITY_H_ */ /* End of File include/ppport.h */ FFI-Platypus-1.10/inc/Alien/000755 000765 000024 00000000000 13616651126 016122 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/bad-forks.pl000644 000765 000024 00000001374 13616651126 017304 0ustar00ollisgstaff000000 000000 use strict; use warnings; use File::Spec; my $path; foreach my $inc (@INC) { $path = File::Spec->catfile($inc, 'forks.pm'); last if -f $path; } if(-f $path) { eval q{ use forks }; print "There seems to be something wrong with your forks.pm module.\n"; print "This exception was raised when trying to use forks:\n\n"; print " $@\n\n"; print "Although forks.pm is not required by FFI-Platypus, it does test\n"; print "against forks.pm if it is installed, so please fix your forks.pm\n"; print "before trying to install FFI-Platypus.\n\n"; print "If you believe this to be an error in FFI-Platypus, please feel\n"; print "free to open a ticket here:\n\n"; print "https://github.com/Perl5-FFI/FFI-Platypus/issues\n\n"; exit 2 if $@; } FFI-Platypus-1.10/inc/mm-build.pl000644 000765 000024 00000002644 13616651126 017143 0ustar00ollisgstaff000000 000000 use strict; use warnings; use File::Basename qw( basename ); use File::Path qw( mkpath ); use File::Copy qw( copy ); use lib 'inc'; use My::Config; use lib 'lib'; use FFI::Build; use Config (); my $config = My::Config->new; my $include = "blib/lib/auto/share/dist/FFI-Platypus/include"; mkpath $include, 0, 0755; foreach my $h (qw( ffi_platypus_config.h ffi_platypus_bundle.h )) { my $from = "include/$h"; my $to = "$include/$h"; if(-f $to) { next if slurp($from) eq slurp($to); } copy($from => $to) || die "unable to copy $from => $to $!"; } my $lib = FFI::Build->new( 'plfill', source => ['ffi/*.c'], verbose => (!!$ENV{V} ? 2 : 1), dir => 'blib/lib/auto/share/dist/FFI-Platypus/lib', platform => $config->platform, alien => [$config->alien], cflags => '-Iblib/lib/auto/share/dist/FFI-Platypus/include', )->build; my $name = basename($lib->basename); foreach my $dir ( 'FFI/Platypus/Memory','FFI/Platypus/Record/Meta', 'FFI/Platypus/Constant' ) { my($file) = $dir =~ m{/([^/]+)$}; mkpath("blib/arch/auto/$dir", 0, 0755); my $txtfile = "blib/arch/auto/$dir/$file.txt"; my $fh; open($fh, '>', $txtfile) || die "unable to write to $txtfile $!"; print $fh "FFI::Build\@auto/share/dist/FFI-Platypus/lib/$name\n"; close $fh; } sub slurp { my($filename) = @_; my $fh; open $fh, '<', $filename; binmode $fh; my $content = do { local $/; <$fh> }; close $fh; $content; } FFI-Platypus-1.10/inc/mm-clean.pl000644 000765 000024 00000001163 13616651126 017121 0ustar00ollisgstaff000000 000000 use strict; use warnings; use File::Glob qw( bsd_glob ); unlink $_ for map { bsd_glob($_) } ( 'ffi/_build/*', 't/ffi/_build/*', 't/ffi/*.so', 't/ffi/*.dll', 't/ffi/*.bundle', 'xs/*.o', 'xs/*.obj', 'examples/*.o', 'examples/*.so', 'examples/*.dll', 'examples/*.bundle', 'corpus/ffi_build/project1/_build/*', 'config.log', 'test*.o', 'test*.c', '*.core', 'core', 'include/ffi_platypus_config.h', 'FFI-Platypus-*.tar.gz', ); rmdir 'ffi/_build' if -d 'ffi/_build'; rmdir 't/ffi/_build' if -d 't/ffi/_build'; rmdir 'corpus/ffi_build/project1/_build' if -d 'corpus/ffi_build/project1/_build'; FFI-Platypus-1.10/inc/mm-config-pb.pl000644 000765 000024 00000000165 13616651126 017704 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 'inc'; use My::Config; my $config = My::Config->new; $config->probe_runner_build; FFI-Platypus-1.10/inc/mm-config-set.pl000644 000765 000024 00000000327 13616651126 020076 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 'inc'; use My::BuildConfig; my($key, @value) = @ARGV; my $config = My::BuildConfig->new; my $eumm = $config->get('eumm'); $eumm->{$key} = [@value]; $config->set('eumm' => $eumm); FFI-Platypus-1.10/inc/mm-config.pl000644 000765 000024 00000000305 13616651126 017301 0ustar00ollisgstaff000000 000000 use strict; use warnings; use ExtUtils::CBuilder; use lib 'inc'; use My::Config; exit if -f '_mm/config'; my $config = My::Config->new; $config->generate_dev; $config->configure; $config->alien; FFI-Platypus-1.10/inc/mm-test.pl000644 000765 000024 00000000606 13616651126 017017 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 'lib'; use FFI::Build; use lib 'inc'; use My::Config; use My::ShareConfig; my $config = My::Config->new; FFI::Build->new( 'test', source => ['t/ffi/*.c'], verbose => (!!$ENV{V} ? 2 : 1), alien => [$config->build_config->get('alien')->{class}], cflags => ['-Iinclude'], dir => 't/ffi', platform => $config->platform, )->build; FFI-Platypus-1.10/inc/My/000755 000765 000024 00000000000 13616651126 015457 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/mymm.pl000644 000765 000024 00000021126 13616651126 016410 0ustar00ollisgstaff000000 000000 package mymm; use strict; use warnings; use Config; use File::Glob qw( bsd_glob ); use ExtUtils::MakeMaker (); use IPC::Cmd (); use lib 'inc'; use File::Spec; use My::BuildConfig; use My::ShareConfig; use Capture::Tiny qw( capture_merged ); { my $dh; opendir $dh, 'inc'; my @files = map { File::Spec->catfile('inc', $_) } grep /^bad-.*\.pl$/, readdir $dh; close $dh; foreach my $badcheck (@files) { my($out, $ret) = capture_merged { system $^X, $badcheck; $?; }; if($ret) { if($out ne '') { print $out; exit; } else { print "bad check $badcheck failed\n"; exit; } } } } sub myWriteMakefile { my %args = @_; my $build_config = My::BuildConfig->new; my $share_config = My::ShareConfig->new; my %diag; my %alien; ExtUtils::MakeMaker->VERSION('7.12'); $build_config->set(version => [ $args{VERSION} =~ /^([0-9]+)\.([0-9]{2})/ ]); if(eval { require Alien::FFI; Alien::FFI->VERSION('0.20'); 1 }) { print "using already installed Alien::FFI (version @{[ Alien::FFI->VERSION ]})\n"; $build_config->set(alien => { class => 'Alien::FFI', mode => 'already-installed' }); require Alien::Base::Wrapper; Alien::Base::Wrapper->import( 'Alien::FFI', 'Alien::psapi', '!export' ); %alien = Alien::Base::Wrapper->mm_args; } else { require Alien::FFI::pkgconfig if $^O ne 'MSWin32'; require Alien::FFI::PkgConfigPP if $^O eq 'MSWin32'; my $alien_install_type_unset = !defined $ENV{ALIEN_INSTALL_TYPE}; if($alien_install_type_unset && $^O eq 'MSWin32' && Alien::FFI::PkgConfigPP->exists) { print "using system libffia via PkgConfigPP\n"; $build_config->set(alien => { class => 'Alien::FFI::PkgConfigPP', mode => 'system' }); require Alien::Base::Wrapper; Alien::Base::Wrapper->import( 'Alien::FFI::PkgConfigPP', 'Alien::psapi', '!export' ); %alien = Alien::Base::Wrapper->mm_args; } elsif($alien_install_type_unset && $^O ne 'MSWin32' && Alien::FFI::pkgconfig->exists) { print "using system libffi via @{[ Alien::FFI::pkgconfig->pkg_config_exe ]}\n"; $build_config->set(alien => { class => 'Alien::FFI::pkgconfig', mode => 'system' }); require Alien::Base::Wrapper; Alien::Base::Wrapper->import( 'Alien::FFI::pkgconfig', 'Alien::psapi', '!export' ); %alien = Alien::Base::Wrapper->mm_args; } else { print "requiring Alien::FFI in fallback mode.\n"; $build_config->set(alien => { class => 'Alien::FFI', mode => 'fallback' }); %alien = ( CC => '$(FULLPERL) -Iinc -MAlien::Base::Wrapper=Alien::FFI,Alien::psapi -e cc --', LD => '$(FULLPERL) -Iinc -MAlien::Base::Wrapper=Alien::FFI,Alien::psapi -e ld --', ); $args{BUILD_REQUIRES}->{'Alien::FFI'} = '0.20'; } } $alien{INC} = defined $alien{INC} ? "-Iinclude $alien{INC}" : "-Iinclude"; %args = (%args, %alien); if($ENV{FFI_PLATYPUS_DEBUG_FAKE32} || $Config{uvsize} < 8) { $args{BUILD_REQUIRES}->{'Math::Int64'} = '0.34'; } if($ENV{FFI_PLATYPUS_DEBUG_FAKE32} && $Config{uvsize} == 8) { print "DEBUG_FAKE32:\n"; print " + making Math::Int64 a prereq\n"; print " + Using Math::Int64's C API to manipulate 64 bit values\n"; $build_config->set(config_debug_fake32 => 1); $diag{config}->{config_debug_fake32} = 1; } if($ENV{FFI_PLATYPUS_NO_ALLOCA}) { print "NO_ALLOCA:\n"; print " + alloca() will not be used, even if your platform supports it.\n"; $build_config->set(config_no_alloca => 1); $diag{config}->{config_no_alloca} = 1; } delete $args{PM}; $args{XSMULTI} = 1; $args{XSBUILD} = { xs => { 'lib/FFI/Platypus' => { OBJECT => 'lib/FFI/Platypus$(OBJ_EXT) ' . join(' ', map { s/\.c$/\$(OBJ_EXT)/; $_ } bsd_glob "xs/*.c"), %alien, }, }, }; $args{PREREQ_PM}->{'Math::Int64'} = '0.34' if $ENV{FFI_PLATYPUS_DEBUG_FAKE32} || $Config{uvsize} < 8; # 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 }; $build_config->set(diag => \%diag); $share_config->set(config_dlext => \@dlext); ExtUtils::MakeMaker::WriteMakefile(%args); } #package MM; # #sub init_tools #{ # my $self = shift; # $self->SUPER::init_tools(@_); # # return if !!$ENV{V}; # # my $noecho = $^O eq 'MSWin32' ? 'REM ' : '@'; # # foreach my $tool (qw( RM_F RM_RF CP MV )) # { # $self->{$tool} = $noecho . $self->{$tool}; # } # # return; #} package MY; use Config; sub dynamic_lib { my($self, @therest) = @_; my $dynamic_lib = $self->SUPER::dynamic_lib(@therest); my %h = map { m!include/(.*?)$! && $1 => [$_] } File::Glob::bsd_glob('include/*.h'); push @{ $h{"ffi_platypus.h"} }, map { "include/ffi_platypus_$_.h" } qw( config ); my %targets = ( 'include/ffi_platypus_config.h' => ['_mm/config'], 'lib/FFI/Platypus.c' => [File::Glob::bsd_glob('xs/*.xs'), 'lib/FFI/Platypus.xs', 'lib/FFI/typemap'], ); foreach my $cfile (File::Glob::bsd_glob('xs/*.c'), 'lib/FFI/Platypus.c') { my $ofile = $cfile; $ofile =~ s/\.c$/\$(OBJ_EXT)/; my @deps = ($cfile, '_mm/config'); if(-d ".git") { # for a development build, lets go ahead and compute the .h # dependencies to make it easier to do a partial rebuild. my $source_file = $cfile; $source_file = 'lib/FFI/Platypus.xs' if $source_file =~ /^lib\/FFI/; my $fh; open $fh, '<', $source_file; while(<$fh>) { if(/^#include [<"](.*?)[>"]/ && $h{$1}) { push @deps, @{$h{$1}}; } } close $fh; } $targets{$ofile} = \@deps; } $dynamic_lib .= "\n"; foreach my $target (sort keys %targets) { $dynamic_lib .= "$target : @{$targets{$target}}\n"; } $dynamic_lib; } sub postamble { my $postamble = ''; my $noecho = !!$ENV{V} ? '' : '$(NOECHO) '; my $sep = $^O eq 'MSWin32' && $Config{make} eq 'nmake' ? '\\' : '/'; $postamble .= "flags: _mm${sep}flags\n" . "_mm${sep}flags:\n"; foreach my $key (qw( cc inc ccflags cccdlflags optimize ld ldflags lddlflags )) { $postamble .= sprintf "\t$noecho\$(FULLPERL) inc${sep}mm-config-set.pl %-20s \$(%s)\n", $key, uc $key; } $postamble .= "\t$noecho\$(MKPATH) _mm\n" . "\t$noecho\$(TOUCH) _mm${sep}flags\n\n"; $postamble .= "probe-runner-builder prb: _mm${sep}probe-builder\n" . "_mm${sep}probe-builder: _mm${sep}flags\n" . "\t$noecho\$(FULLPERL) inc${sep}mm-config-pb.pl\n" . "\t$noecho\$(MKPATH) _mm\n" . "\t$noecho\$(TOUCH) _mm${sep}probe-builder\n\n"; $postamble .= "config :: _mm${sep}config\n" . "_mm${sep}config: _mm${sep}flags _mm${sep}probe-builder\n" . "\t$noecho\$(FULLPERL) inc${sep}mm-config.pl\n" . "\t$noecho\$(MKPATH) _mm\n" . "\t$noecho\$(TOUCH) _mm${sep}config\n\n"; $postamble .= "pure_all :: ffi\n" . "ffi: _mm${sep}config\n" . "\t$noecho\$(FULLPERL) inc${sep}mm-build.pl\n\n"; $postamble .= "subdirs-test_dynamic subdirs-test_static subdirs-test :: ffi-test\n" . "ffi-test : _mm${sep}config\n" . "\t$noecho\$(FULLPERL) inc${sep}mm-test.pl\n\n"; $postamble .= "clean :: mm-clean\n" . "mm-clean :\n" . "\t$noecho\$(FULLPERL) inc${sep}mm-clean.pl\n" . "\t$noecho\$(RM_RF) _mm ffi-probe-*\n" . "\t$noecho\$(RM_RF) .tmp\n" . "\t$noecho\$(RM_RF) corpus${sep}*${sep}*${sep}tmpbuild*\n\n"; # Workaround for the tireless testers out there # who want to make -jX a thing. For some reason. # # When bsd make is passed -jX it turns off compat # mode, even if the Makefile itself turns off # parallel build. Unfortunately the Makefile # generated by EUMM does not work without compat # mode. So we: $postamble .= # 1. turn off parallel build using the bsd-only # faux rule `.NO_PARALLEL` rather than the # more portable `.NOTPARALLEL`, because this # will allow parallel build with gmake, which # does work. ".NO_PARALLEL:\n\n"; if($^O eq 'MSWin32' && $Config{ccname} eq 'cl') { # nothing. } else { $postamble .= # 2. turn compat mode back on. ".MAKE.MODE=compat\n\n"; } $postamble; } sub special_targets { my($self, @therest) = @_; my $st = $self->SUPER::special_targets(@therest); $st .= "\n.PHONY: flags probe-runner-builder prb ffi ffi-test\n"; $st; } 1; FFI-Platypus-1.10/inc/pdb000755 000765 000024 00000001776 13616651126 015600 0ustar00ollisgstaff000000 000000 #!/usr/bin/env perl use strict; use warnings; use lib 'inc'; use lib 'lib'; use FFI::Probe; use FFI::Probe::Runner; use FFI::Probe::Runner::Builder; use My::BuildConfig; use File::Temp; use Path::Tiny qw( path ); my $dir = FFI::Temp->newdir; my $data_filename = path( $dir, 'probe.pl' ); my $log_filename = path( $dir, 'config.log' ); my $probe = FFI::Probe->new( runner => do { my $builder = FFI::Probe::Runner::Builder->new; my $exe = $builder->exe; FFI::Probe::Runner->new( exe => $exe ); }, log => "$log_filename", data_filename => "$data_filename", alien => [My::BuildConfig->new->get('alien')->{class}], cflags => ['-Iinclude'], ); my $name = shift @ARGV; $name ||= 'recordvalue'; # this is what I am strugling with right this minute. my $fn = "inc/probe/$name.c"; my $code = do { my $fh; open $fh, '<', $fn; local $/; <$fh>; }; my $value = $probe->check($name, $code); $probe->save; print "[log]\n"; print $log_filename->slurp; print "[data]\n"; print $data_filename->slurp; FFI-Platypus-1.10/inc/probe/000755 000765 000024 00000000000 13616651126 016201 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/probe/abi.c000644 000765 000024 00000000364 13616651126 017103 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" int dlmain(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; } FFI-Platypus-1.10/inc/probe/alloca.c000644 000765 000024 00000000213 13616651126 017574 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" int dlmain(int argc, char *argv[]) { void *ptr = alloca(100); if(ptr == NULL) return 2; return 0; } FFI-Platypus-1.10/inc/probe/bigendian.c000644 000765 000024 00000000654 13616651126 020272 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" unsigned char my_foo(void) { return 0xaa; } int dlmain(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; } FFI-Platypus-1.10/inc/probe/bigendian64.c000644 000765 000024 00000000704 13616651126 020440 0ustar00ollisgstaff000000 000000 #include "ffi_platypus.h" unsigned char my_foo(void) { return 0xaa; } int dlmain(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; } FFI-Platypus-1.10/inc/probe/complex.c000644 000765 000024 00000004506 13616651126 020021 0ustar00ollisgstaff000000 000000 #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); } float complex my_float_complex_ret(float r, float i) { return r + i*I; } double complex my_double_complex_ret(double r, double i) { return r + i*I; } int dlmain(int argc, char *argv[]) { ffi_cif cif; ffi_type *args[2]; void *values[2]; 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; } args[0] = &ffi_type_float; args[1] = &ffi_type_float; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_complex_float, args) == FFI_OK) { float complex answer; float r=1.0, i=2.0; values[0] = &r; values[1] = &i; ffi_call(&cif, (void*) my_float_complex_ret, &answer, values); if(creal(answer) != 1.0 || cimag(answer) != 2.0) return 2; } args[0] = &ffi_type_double; args[1] = &ffi_type_double; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_complex_double, args) == FFI_OK) { double complex answer; double r=1.0, i=2.0; values[0] = &r; values[1] = &i; ffi_call(&cif, (void*) my_double_complex_ret, &answer, values); if(creal(answer) != 1.0 || cimag(answer) != 2.0) return 2; } return 0; } FFI-Platypus-1.10/inc/probe/longdouble.c000644 000765 000024 00000001263 13616651126 020501 0ustar00ollisgstaff000000 000000 #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 dlmain(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-1.10/inc/probe/recordvalue.c000644 000765 000024 00000002056 13616651126 020663 0ustar00ollisgstaff000000 000000 #include #include #include #define is_signed(type) ((((type)-1) < 0) ? 1 : 0) typedef struct { char name[13]; int value; } foo_t; foo_t get_foo(void) { foo_t self; strcpy(self.name, "hello"); self.value = 42; return self; } int dlmain(int argc, char *argv[]) { ffi_cif cif; ffi_type ffi_type_foo_t; int i; foo_t foo; ffi_type *arg_types[1] = { &ffi_type_void }; void *args[1] = { NULL }; ffi_type_foo_t.size = ffi_type_foo_t.alignment = 0; ffi_type_foo_t.type = FFI_TYPE_STRUCT; ffi_type_foo_t.elements = calloc(15, sizeof(ffi_type*)); for(i=0; i<13; i++) ffi_type_foo_t.elements[i] = is_signed(char) ? &ffi_type_sint8 : &ffi_type_uint8; ffi_type_foo_t.elements[13] = &ffi_type_sint32; ffi_type_foo_t.elements[14] = NULL; if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_foo_t, arg_types) == FFI_OK) { ffi_call(&cif, (void*) get_foo, &foo, args); if(strcmp(foo.name, "hello")) return 2; if(foo.value != 42) return 2; } else return 2; return 0; } FFI-Platypus-1.10/inc/probe/variadic.c000644 000765 000024 00000002407 13616651126 020132 0ustar00ollisgstaff000000 000000 #include #include #include int return_arg(int which, ...) { va_list args; va_start(args, which); int i, val; for(i=0; icatdir( qw( _mm )) } sub file { File::Spec->catfile( shift->dir, qw( config.pl )) } 1; FFI-Platypus-1.10/inc/My/Config.pm000644 000765 000024 00000022554 13616651126 017232 0ustar00ollisgstaff000000 000000 package My::Config; use strict; use warnings; use Config; use File::Spec; use FindBin; use Text::ParseWords qw( shellwords ); use My::BuildConfig; use My::ShareConfig; use My::ConfigH; use My::ShareConfig; use lib 'lib'; use FFI::Probe; use FFI::Probe::Runner; use FFI::Probe::Runner::Builder; use File::Glob qw( bsd_glob ); use File::Basename qw( basename ); my @probe_types = split /\n/, <catfile(qw( include ppport.h )); sub generate_dev { if(!-r $ppport_h || -d '.git') { my $ppport_version = 3.28; 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 "XX generating new $ppport_h\n"; open my $fh, '>', $ppport_h; print $fh $content; close $fh; } } } sub clean { unlink $ppport_h; } sub share_config { my($self) = @_; $self->{share_config} ||= My::ShareConfig->new; } sub build_config { my($self) = @_; $self->{build_config} ||= My::BuildConfig->new; } sub probe { my($self) = @_; $self->{probe} ||= FFI::Probe->new( runner => $self->probe_runner, log => "config.log", data_filename => "./blib/lib/auto/share/dist/FFI-Platypus/probe/probe.pl", alien => [$self->build_config->get('alien')->{class}], cflags => ['-Iinclude'], ); } sub probe_runner { my($self) = @_; my $builder = FFI::Probe::Runner::Builder->new; my $exe = $builder->exe; if(-e $exe) { return FFI::Probe::Runner->new( exe => $exe ); } else { return undef; } } sub probe_runner_build { my($self) = @_; my $probe = $self->probe; my $builder = FFI::Probe::Runner::Builder->new; foreach my $key (qw( cc ccflags optimize ld ldflags )) { @{ $builder->$key } = @{ $self->build_config->get('eumm')->{$key} } } $builder->build unless -e $builder->exe; } sub configure { my($self) = @_; my $probe = $self->probe; my $config_h = File::Spec->rel2abs( File::Spec->catfile( 'include', 'ffi_platypus_config.h' ) ); return if -r $config_h && ref($self->share_config->get( 'type_map' )) eq 'HASH'; my $ch = My::ConfigH->new; $ch->define_var( do { my $os = uc $^O; $os =~ s/-/_/; $os =~ s/[^A-Z0-9_]//g; "PERL_OS_$os"; } => 1 ); $ch->define_var( PERL_OS_WINDOWS => 1 ) if $^O =~ /^(MSWin32|cygwin|msys)$/; { my($major, $minor, $patch) = $] =~ /^(5)\.([0-9]{3})([0-9]{3})/; $ch->define_var( FFI_PL_PERL_VERSION_MAJOR => int $major ); $ch->define_var( FFI_PL_PERL_VERSION_MINOR => int $minor ); $ch->define_var( FFI_PL_PERL_VERSION_PATCH => int $patch ); } { my($major, $minor, $patch) = (@{ $self->build_config->get('version') }, 0); $ch->define_var( FFI_PL_VERSION_MAJOR => int $major ); $ch->define_var( FFI_PL_VERSION_MINOR => int $minor ); $ch->define_var( FFI_PL_VERSION_PATCH => int $patch ); } 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 )) { if($probe->check_header("$header.h")) { my $var = uc $header; $var =~ s{/}{_}g; $var = "HAVE_${var}_H"; $ch->define_var( $var => 1 ); } } if(!$self->build_config->get('config_debug_fake32') && $Config{ivsize} >= 8) { $ch->define_var( HAVE_IV_IS_64 => 1 ); } my %type_map; my %align; foreach my $type (@probe_types) { if($type =~ /^(float|double|long double)/) { if(my $basic = $probe->check_type_float($type)) { $type_map{$type} = $basic; $align{$type} = $probe->data->{type}->{$type}->{align}; } } elsif($type eq 'pointer') { $probe->check_type_pointer; $align{pointer} = $probe->data->{type}->{pointer}->{align}; } elsif($type eq 'enum') { if(my $basic = $probe->check_type_enum) { $type_map{enum} = $basic; $align{$basic} ||= $probe->data->{type}->{enum}->{align}; } } elsif($type eq 'senum') { if(my $basic = $probe->check_type_signed_enum) { $type_map{senum} = $basic; $align{$basic} ||= $probe->data->{type}->{senum}->{align}; } } else { if(my $basic = $probe->check_type_int($type)) { $type_map{$type} = $basic; $align{$basic} ||= $probe->data->{type}->{$type}->{align}; } elsif($type =~ /^(unsigned |signed )?(char|short|int|long)$/) { print "Unable to perform basic type check for: \"$type\"\n"; print "Please check config.log for detailed diagnostics.\n"; die "unable to configure Platypus"; } } } # Visual C++ uses SSIZE_T instead of ssize_t if($^O eq 'MSWin32' && $Config{ccname} eq 'cl' && defined $type_map{SSIZE_T}) { $type_map{ssize_t} = delete $type_map{SSIZE_T}; } elsif(defined $type_map{SSIZE_T}) { delete $type_map{SSIZE_T}; } $ch->define_var( SIZEOF_VOIDP => $probe->data->{type}->{pointer}->{size} ); if(my $size = $probe->data->{type}->{'float complex'}->{size}) { $ch->define_var( SIZEOF_FLOAT_COMPLEX => $size ) } if(my $size = $probe->data->{type}->{'double complex'}->{size}) { $ch->define_var( SIZEOF_DOUBLE_COMPLEX => $size ) } if(my $size = $probe->data->{type}->{'long double complex'}->{size}) { $ch->define_var( SIZEOF_LONG_DOUBLE_COMPLEX => $size ) } # short aliases $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}; $ch->write_config_h; my %probe; if(defined $ENV{FFI_PLATYPUS_PROBE_OVERRIDE}) { foreach my $kv (split /:/, $ENV{FFI_PLATYPUS_PROBE_OVERRIDE}) { my($k,$v) = split /=/, $kv, 2; $probe{$k} = $v; } } if($Config{byteorder} =~ /^(1234|12345678)$/) { $probe{bigendian} = 0; $probe{bigendian64} = 0; } if($self->build_config->get('config_no_alloca')) { $probe{alloca} = 0; } foreach my $cfile (bsd_glob 'inc/probe/*.c') { my $name = basename $cfile; $name =~ s/\.c$//; unless(defined $probe{$name}) { my $code = do { my $fh; open $fh, '<', $cfile; local $/; <$fh>; }; my $value = $probe->check($name, $code); $probe{$name} = $value if defined $value; } if($probe{$name}) { $ch->define_var( "FFI_PL_PROBE_" . uc($name) => 1 ); } } my %abi; if(my $cpp_output = $probe->check_cpp("#include \n")) { if($cpp_output =~ m/typedef\s+enum\s+ffi_abi\s+{(.*?)}/s) { my $enum = $1; while($enum =~ s/FFI_([A-Z_0-9]+)//) { my $abi = $1; next if $abi =~ /^(FIRST|LAST)_ABI$/; $probe->check_eval( decl => [ "#include \"ffi_platypus.h\"", ], stmt => [ "ffi_cif cif;", "ffi_type *args[1];", "ffi_abi abi;", "if(ffi_prep_cif(&cif, FFI_$abi, 0, &ffi_type_void, args) != FFI_OK) { return 2; }", ], eval => { "abi.@{[ lc $abi ]}" => [ '%d' => "FFI_$abi" ], }, ); } if(defined $probe->data->{abi}) { %abi = %{ $probe->data->{abi} || {} }; } else { print "Unable to verify any ffi_abis.\n"; print "only default ABI will be available\n"; } } else { print "Unable to find ffi_abi enum.\n"; print "only default ABI will be available\n"; } } else { print "C pre-processor failed...\n"; print "only default ABI will be available\n"; } $ch->write_config_h; $self->share_config->set( type_map => \%type_map ); $self->share_config->set( align => \%align ); $self->share_config->set( probe => \%probe ); $self->share_config->set( abi => \%abi ); } sub platform { my($self) = @_; my %Config = %Config; my $eumm = $self->build_config->get('eumm'); foreach my $key (keys %$eumm) { $Config{$key} = $eumm->{$key}; } require FFI::Build::Platform; FFI::Build::Platform->new(\%Config); } sub alien { my($self) = @_; my $class = $self->build_config->get('alien')->{class}; my $pm = "$class.pm"; $pm =~ s/::/\//g; require $pm; $self->build_config->get('alien')->{class}; } 1; FFI-Platypus-1.10/inc/My/ConfigH.pm000644 000765 000024 00000001445 13616651126 017336 0ustar00ollisgstaff000000 000000 package My::ConfigH; use strict; use warnings; use Carp qw( croak ); use File::Basename qw( basename ); sub new { my($class, $filename) = @_; $filename ||= "include/ffi_platypus_config.h"; my $self = bless { content => '', filename => $filename, }, $class; $self; } sub define_var { my($self, $key, $value) = @_; croak "value for $key is not defined" unless defined $value; $self->{content} .= "#define $key $value\n"; } sub write_config_h { my($self) = @_; my $once = uc basename($self->{filename}); $once =~ s/\./_/g; my $fh; my $fn = $self->{filename}; open $fh, '>', $fn or die "unable to write to $fn $!"; print $fh "#ifndef $once\n"; print $fh "#define $once\n\n"; print $fh "@{[ $self->{content} ]}\n"; print $fh "#endif\n"; close $fh; } 1; FFI-Platypus-1.10/inc/My/ConfigPl.pm000644 000765 000024 00000001637 13616651126 017525 0ustar00ollisgstaff000000 000000 package My::ConfigPl; use strict; use warnings; use Data::Dumper (); use Carp qw( croak ); use File::Path qw( mkpath ); sub dir { croak "subclasss requires dir method" } sub file { croak "subclasss requires file method" } sub new { my $class = shift; my $data; if(-e $class->file) { $data = do "./@{[ $class->file ]}"; } else { $data = { 'test-key' => 'test-value' }; } bless { data => $data }, $class; } sub get { my($self, $name) = @_; $self->{data}->{$name}; } sub set { my($self, $name, $value) = @_; $self->{data}->{$name} = $value; my $dd = Data::Dumper->new([$self->{data}],['x']) ->Indent(1) ->Terse(0) ->Purity(1) ->Sortkeys(1) ->Dump; mkpath( $self->dir, 0, 0755 ) unless -d $self->dir; my $fh; open($fh, '>', $self->file) || die "error writing @{[ $self->file ]}"; print $fh 'do { my '; print $fh $dd; print $fh '$x;}'; close $fh; } 1; FFI-Platypus-1.10/inc/My/ShareConfig.pm000644 000765 000024 00000000405 13616651126 020204 0ustar00ollisgstaff000000 000000 package My::ShareConfig; use strict; use warnings; use File::Spec (); use base qw( My::ConfigPl ); sub dir { File::Spec->catdir( qw( blib lib auto share dist FFI-Platypus )) } sub file { File::Spec->catfile( shift->dir, qw( config.pl )) } 1; FFI-Platypus-1.10/inc/Alien/Base/000755 000765 000024 00000000000 13616651126 016774 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/Alien/FFI/000755 000765 000024 00000000000 13616651126 016526 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/inc/Alien/psapi.pm000644 000765 000024 00000000562 13616651126 017577 0ustar00ollisgstaff000000 000000 package Alien::psapi; use strict; use warnings; use Config; sub cflags {''} sub libs { if($^O eq 'MSWin32') { if($Config{ccname} eq 'cl') { return "psapi.lib "; } else { return "-lpsapi"; } } elsif($^O eq 'cygwin' || $^O eq 'msys') { return "-L/usr/lib/w32api -lpsapi "; } ''; } sub install_type {'system'} 1; FFI-Platypus-1.10/inc/Alien/FFI/pkgconfig.pm000644 000765 000024 00000003473 13616651126 021042 0ustar00ollisgstaff000000 000000 package Alien::FFI::pkgconfig; use strict; use warnings; use Config; use IPC::Cmd (); use Capture::Tiny qw( capture ); use Env qw( @PKG_CONFIG_PATH ); use File::Glob qw( bsd_glob ); our $VERBOSE = !!$ENV{V}; sub pkg_config_exe { foreach my $cmd ($ENV{PKG_CONFIG}, qw( pkgconf pkg-config )) { next unless defined $cmd; return $cmd if IPC::Cmd::can_run($cmd); } return; } sub _pkg_config { my(@args) = @_; local $ENV{PKG_CONFIG_PATH} = $ENV{PKG_CONFIG_PATH}; if($^O eq 'darwin' && -d '/usr/local/Cellar/libffi') { my($dir) = bsd_glob '/usr/local/Cellar/libffi/*/lib/pkgconfig'; push @PKG_CONFIG_PATH, $dir if $dir && -d $dir; } my $cmd = pkg_config_exe; if(defined $cmd) { my @cmd = ($cmd, @args); print "+@cmd\n" if $VERBOSE; my($out, $err, $ret) = capture { system @cmd; $?; }; chomp $out; chomp $err; print "[out]\n$out\n" if $out ne '' && $VERBOSE; print "[err]\n$err\n" if $err ne '' && $VERBOSE; die "command failed" if $ret; my $value = $out; $value; } else { print "no pkg-config.\n" if $VERBOSE; return; } } my $version; my $exists; my $cflags; my $libs; sub exists { return $exists if defined $exists; return $exists = '' unless pkg_config_exe; $exists = !!eval { _pkg_config('--exists', 'libffi'); 1 }; } sub version { unless(defined $version) { $version = _pkg_config('--modversion', 'libffi'); } $version; } sub config { my($class, $key) = @_; die "unimplemented for $key" unless $key eq 'version'; $class->version; } sub cflags { unless(defined $cflags) { $cflags = _pkg_config('--cflags', 'libffi'); } $cflags; } sub libs { unless(defined $libs) { $libs = _pkg_config('--libs', 'libffi'); } $libs; } sub install_type {'system'} sub runtime_prop { return {} } 1; FFI-Platypus-1.10/inc/Alien/FFI/PkgConfigPP.pm000644 000765 000024 00000001202 13616651126 021166 0ustar00ollisgstaff000000 000000 package Alien::FFI::PkgConfigPP; use strict; use warnings; our $VERBOSE = !!$ENV{V}; my $pkg; sub _pkg { $pkg ||= eval { require PkgConfig; my $pkg = PkgConfig->find('libffi'); die $pkg->errmsg if $pkg->errmsg; $pkg; }; die "libffi not found" unless $pkg; $pkg; } sub exists { !!eval { _pkg }; } sub version { _pkg->pkg_version; } sub config { my($class, $key) = @_; die "unimplemented for $key" unless $key eq 'version'; $class->version; } sub cflags { scalar _pkg->get_cflags; } sub libs { scalar _pkg->get_ldflags; } sub install_type { return 'system' } sub runtime_prop { return {} } 1; FFI-Platypus-1.10/inc/Alien/Base/Wrapper.pm000644 000765 000024 00000032116 13616651126 020755 0ustar00ollisgstaff000000 000000 package Alien::Base::Wrapper; use strict; use warnings; use 5.006; use Config; use Text::ParseWords qw( shellwords ); # NOTE: Although this module is now distributed with Alien-Build, # it should have NO non-perl-core dependencies for all Perls # 5.6.0-5.30.1 (as of this writing, and any Perl more recent). # You should be able to extract this module from the rest of # Alien-Build and use it by itself. (There is a dzil plugin # for this [AlienBase::Wrapper::Bundle] # ABSTRACT: Compiler and linker wrapper for Alien our $VERSION = '2.02'; # VERSION sub _join { join ' ', map { s/(\s)/\\$1/g; $_ } map { "$_" } @_; ## no critic (ControlStructures::ProhibitMutatingListFunctions) } sub new { my($class, @aliens) = @_; my $export = 1; my $writemakefile = 0; my @cflags_I; my @cflags_other; my @ldflags_L; my @ldflags_l; my @ldflags_other; my %requires = ( 'ExtUtils::MakeMaker' => '6.52', 'Alien::Base::Wrapper' => '1.97', ); foreach my $alien (@aliens) { if($alien eq '!export') { $export = 0; next; } if($alien eq 'WriteMakefile') { $writemakefile = 1; next; } my $version = 0; if($alien =~ s/=(.*)$//) { $version = $1; } $alien = "Alien::$alien" unless $alien =~ /::/; $requires{$alien} = $version; my $alien_pm = $alien . '.pm'; $alien_pm =~ s/::/\//g; require $alien_pm unless eval { $alien->can('cflags') } && eval { $alien->can('libs') }; my $cflags; my $libs; if($alien->install_type eq 'share' && $alien->can('cflags_static')) { $cflags = $alien->cflags_static; $libs = $alien->libs_static; } else { $cflags = $alien->cflags; $libs = $alien->libs; } push @cflags_I, grep /^-I/, shellwords $cflags; push @cflags_other, grep !/^-I/, shellwords $cflags; push @ldflags_L, grep /^-L/, shellwords $libs; push @ldflags_l, grep /^-l/, shellwords $libs; push @ldflags_other, grep !/^-[Ll]/, shellwords $libs; } my @cflags_define = grep /^-D/, @cflags_other; my @cflags_other2 = grep !/^-D/, @cflags_other; my @mm; push @mm, INC => _join @cflags_I if @cflags_I; push @mm, CCFLAGS => _join(@cflags_other2) . " $Config{ccflags}" if @cflags_other2; push @mm, DEFINE => _join(@cflags_define) if @cflags_define; # TODO: handle spaces in -L paths push @mm, LIBS => ["@ldflags_L @ldflags_l"]; my @ldflags = (@ldflags_L, @ldflags_other); push @mm, LDDLFLAGS => _join(@ldflags) . " $Config{lddlflags}" if @ldflags; push @mm, LDFLAGS => _join(@ldflags) . " $Config{ldflags}" if @ldflags; my @mb; push @mb, extra_compiler_flags => _join(@cflags_I, @cflags_other); push @mb, extra_linker_flags => _join(@ldflags_l); if(@ldflags) { push @mb, config => { lddlflags => _join(@ldflags) . " $Config{lddlflags}", ldflags => _join(@ldflags) . " $Config{ldflags}", }, } bless { cflags_I => \@cflags_I, cflags_other => \@cflags_other, ldflags_L => \@ldflags_L, ldflags_l => \@ldflags_l, ldflags_other => \@ldflags_other, mm => \@mm, mb => \@mb, _export => $export, _writemakefile => $writemakefile, requires => \%requires, }, $class; } my $default_abw = __PACKAGE__->new; # for testing only sub _reset { __PACKAGE__->new } sub _myexec { my @command = @_; if($^O eq 'MSWin32') { # To handle weird quoting on MSWin32 # this logic needs to be improved. my $command = "@command"; $command =~ s{"}{\\"}g; system $command; if($? == -1 ) { die "failed to execute: $!\n"; } elsif($? & 127) { die "child died with signal @{[ $? & 128 ]}"; } else { exit($? >> 8); } } else { exec @command; } } sub cc { my @command = ( shellwords($Config{cc}), @{ $default_abw->{cflags_I} }, @{ $default_abw->{cflags_other} }, @ARGV, ); print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET}; _myexec @command; } sub ld { my @command = ( shellwords($Config{ld}), @{ $default_abw->{ldflags_L} }, @{ $default_abw->{ldflags_other} }, @ARGV, @{ $default_abw->{ldflags_l} }, ); print "@command\n" unless $ENV{ALIEN_BASE_WRAPPER_QUIET}; _myexec @command; } sub mm_args { my $self = ref $_[0] ? shift : $default_abw; @{ $self->{mm} }; } sub mm_args2 { my $self = shift; $self = $default_abw unless ref $self; my %args = @_; my @mm = @{ $self->{mm} }; while(@mm) { my $key = shift @mm; my $value = shift @mm; if(defined $args{$key}) { if($args{$key} eq 'LIBS') { require Carp; # Todo: support this maybe? Carp::croak("please do not specify your own LIBS key with mm_args2"); } else { $args{$key} = join ' ', $value, $args{$key}; } } else { $args{$key} = $value; } } foreach my $module (keys %{ $self->{requires} }) { $args{CONFIGURE_REQUIRES}->{$module} = $self->{requires}->{$module}; } %args; } sub mb_args { my $self = ref $_[0] ? shift : $default_abw; @{ $self->{mb} }; } sub import { shift; my $abw = $default_abw = __PACKAGE__->new(@_); if($abw->_export) { my $caller = caller; no strict 'refs'; *{"${caller}::cc"} = \&cc; *{"${caller}::ld"} = \&ld; } if($abw->_writemakefile) { my $caller = caller; no strict 'refs'; *{"${caller}::WriteMakefile"} = \&WriteMakefile; } } sub WriteMakefile { my %args = @_; require ExtUtils::MakeMaker; ExtUtils::MakeMaker->VERSION('6.52'); my @aliens; if(my $reqs = delete $args{alien_requires}) { if(ref $reqs eq 'HASH') { @aliens = map { my $module = $_; my $version = $reqs->{$module}; $version ? "$module=$version" : "$module"; } sort keys %$reqs; } elsif(ref $reqs eq 'ARRAY') { @aliens = @$reqs; } else { require Carp; Carp::croak("aliens_require must be either a hash or array reference"); } } else { require Carp; Carp::croak("You are using Alien::Base::Wrapper::WriteMakefile, but didn't specify any alien requirements"); } ExtUtils::MakeMaker::WriteMakefile( Alien::Base::Wrapper->new(@aliens)->mm_args2(%args), ); } sub _export { shift->{_export} } sub _writemakefile { shift->{_writemakefile} } 1; __END__ =pod =encoding UTF-8 =head1 NAME Alien::Base::Wrapper - Compiler and linker wrapper for Alien =head1 VERSION version 2.02 =head1 SYNOPSIS From the command line: % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e cc -- -o foo.o -c foo.c % perl -MAlien::Base::Wrapper=Alien::Foo,Alien::Bar -e ld -- -o foo foo.o From Makefile.PL (static): use ExtUtils::MakeMaker; use Alien::Base::Wrapper (); WriteMakefile( Alien::Base::Wrapper->new( 'Alien::Foo', 'Alien::Bar')->mm_args2( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', ), ); From Makefile.PL (static with wrapper) use Alien::Base::Wrapper qw( WriteMakefile); WriteMakefile( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', 'alien_requires' => { 'Alien::Foo' => 0, 'Alien::Bar' => 0, }, ); From Makefile.PL (dynamic): use Devel::CheckLib qw( check_lib ); use ExtUtils::MakeMaker 6.52; my @mm_args; my @libs; if(check_lib( lib => [ 'foo' ] ) { push @mm_args, LIBS => [ '-lfoo' ]; } else { push @mm_args, CC => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e cc --', LD => '$(FULLPERL) -MAlien::Base::Wrapper=Alien::Foo -e ld --', BUILD_REQUIRES => { 'Alien::Foo' => 0, 'Alien::Base::Wrapper' => 0, } ; } WriteMakefile( 'NAME' => 'Foo::XS', 'VERSION_FROM' => 'lib/Foo/XS.pm', 'CONFIGURE_REQUIRES => { 'ExtUtils::MakeMaker' => 6.52, }, @mm_args, ); =head1 DESCRIPTION This module acts as a wrapper around one or more L modules. It is designed to work with L based aliens, but it should work with any L which uses the same essential API. In the first example (from the command line), this class acts as a wrapper around the compiler and linker that Perl is configured to use. It takes the normal compiler and linker flags and adds the flags provided by the Aliens specified, and then executes the command. It will print the command to the console so that you can see exactly what is happening. In the second example (from Makefile.PL non-dynamic), this class is used to generate the appropriate L (EUMM) arguments needed to C. In the third example (from Makefile.PL dynamic), we do a quick check to see if the simple linker flag C<-lfoo> will work, if so we use that. If not, we use a wrapper around the compiler and linker that will use the alien flags that are known at build time. The problem that this form attempts to solve is that compiler and linker flags typically need to be determined at I time, when a distribution is installed, meaning if you are going to use an L module then it needs to be a configure prerequisite, even if the library is already installed and easily detected on the operating system. The author of this module believes that the third (from Makefile.PL dynamic) form is somewhat unnecessary. L modules based on L have a few prerequisites, but they are well maintained and reliable, so while there is a small cost in terms of extra dependencies, the overall reliability thanks to reduced overall complexity. =head1 CONSTRUCTOR =head2 new my $abw = Alien::Base::Wrapper->new(@aliens); Instead of passing the aliens you want to use into this modules import you can create a non-global instance of C using the OO interface. =head1 FUNCTIONS =head2 cc % perl -MAlien::Base::Wrapper=Alien::Foo -e cc -- cflags Invoke the C compiler with the appropriate flags from C and what is provided on the command line. =head2 ld % perl -MAlien::Base::Wrapper=Alien::Foo -e ld -- ldflags Invoke the linker with the appropriate flags from C and what is provided on the command line. =head2 mm_args my %args = $abw->mm_args; my %args = Alien::Base::Wrapper->mm_args; Returns arguments that you can pass into C to compile/link against the specified Aliens. Note that this does not set C. You probably want to use C below instead for that reason. =head2 mm_args2 my %args = $abw->mm_args2(%args); my %args = Alien::Base::Wrapper->mm_args2(%args); Returns arguments that you can pass into C to compile/link against. It works a little differently from C above in that you can pass in arguments. It also adds the appropriate C for you so you do not have to do that explicitly. =head2 mb_args my %args = $abw->mb_args; my %args = Alien::Base::Wrapper->mb_args; Returns arguments that you can pass into the constructor to L. =head2 WriteMakefile use Alien::Base::Wrapper qw( WriteMakefile ); WriteMakefile(%args, alien_requires => %aliens); WriteMakefile(%args, alien_requires => @aliens); This is a thin wrapper around C from L, which adds the given aliens to the configure requirements and sets the appropriate compiler and linker flags. If the aliens are specified as a hash reference, then the keys are the module names and the values are the versions. For a list it is just the name of the aliens. For the list form you can specify a version by appending C<=version> to the name of the Aliens, that is: WriteMakefile( alien_requires => [ 'Alien::libfoo=1.23', 'Alien::libbar=4.56' ], ); The list form is recommended if the ordering of the aliens matter. The aliens are sorted in the hash form to make it consistent, but it may not be the order that you want. =head1 ENVIRONMENT Alien::Base::Wrapper responds to these environment variables: =over 4 =item ALIEN_BASE_WRAPPER_QUIET If set to true, do not print the command before executing =back =head1 SEE ALSO L, L =head1 AUTHOR Author: Graham Ollis Eplicease@cpan.orgE Contributors: Diab Jerius (DJERIUS) Roy Storey (KIWIROY) Ilya Pavlov David Mertens (run4flat) Mark Nunberg (mordy, mnunberg) Christian Walde (Mithaldu) Brian Wightman (MidLifeXis) Zaki Mughal (zmughal) mohawk (mohawk2, ETJ) Vikas N Kumar (vikasnkumar) Flavio Poletti (polettix) Salvador Fandiño (salva) Gianni Ceccarelli (dakkar) Pavel Shaydo (zwon, trinitum) Kang-min Liu (劉康民, gugod) Nicholas Shipp (nshp) Juan Julián Merelo Guervós (JJ) Joel Berger (JBERGER) Petr Pisar (ppisar) Lance Wicks (LANCEW) Ahmad Fatoum (a3f, ATHREEF) José Joaquín Atria (JJATRIA) Duke Leto (LETO) Shoichi Kaji (SKAJI) Shawn Laffan (SLAFFAN) Paul Evans (leonerd, PEVANS) =head1 COPYRIGHT AND LICENSE This software is copyright (c) 2011-2020 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-1.10/ffi/constant.c000644 000765 000024 00000001172 13616651126 017063 0ustar00ollisgstaff000000 000000 #include #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif EXPORT ffi_platypus_constant_t * ffi_platypus_constant__new(void* set_str, void* set_sint, void* set_uint, void* set_double) { ffi_platypus_constant_t *self = malloc(sizeof(ffi_platypus_constant_t)); self->set_str = set_str; self->set_sint = set_sint; self->set_uint = set_uint; self->set_double = set_double; return self; } EXPORT void ffi_platypus_constant__DESTROY(ffi_platypus_constant_t *self) { free(self); } FFI-Platypus-1.10/ffi/memory.c000644 000765 000024 00000001517 13616651126 016545 0ustar00ollisgstaff000000 000000 #include #include /* * strdup and strndup are useful, but technically not part of the * C standard, and thus may be missing from some environments. * If libc provides these functions then it will use them, * otherwise it will fallback on these implementations. */ #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif EXPORT char * ffi_platypus_memory__strdup(const char *olds) { char *news; size_t size; size = strlen(olds)+1; news = malloc(size); if(news != NULL) { memcpy(news, olds, size); } return news; } EXPORT char * ffi_platypus_memory__strndup(const char *olds, size_t max) { char *news; size_t size; size = strnlen(olds, max); news = malloc(size+1); if(news != NULL) { news[size] = '\0'; memcpy(news, olds, size); } return news; } FFI-Platypus-1.10/ffi/record_meta.c000644 000765 000024 00000004205 13616651126 017516 0ustar00ollisgstaff000000 000000 #include #include #include #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif typedef struct meta_t { ffi_type top; ffi_type *elements[0]; } meta_t; /* * Question: this is the documented way of creating a struct type. * we already compute the size and alignment for the Perl interface * to the members, can we use that instead? */ EXPORT meta_t * ffi_platypus_record_meta__new(ffi_type *list[]) { int size, i; meta_t *t; for(size=0; list[size] != NULL; size++) ; t = malloc(sizeof(meta_t) + sizeof(ffi_type*)*(size+1) ); if(t == NULL) return NULL; t->top.size = 0; t->top.alignment = 0; t->top.type = FFI_TYPE_STRUCT; t->top.elements = (ffi_type**) &t->elements; for(i=0; ielements[i] = list[i]; } return t; } EXPORT ffi_type * ffi_platypus_record_meta__ffi_type(meta_t *t) { return &t->top; } EXPORT size_t ffi_platypus_record_meta__size(meta_t *t) { return t->top.size; } EXPORT unsigned short ffi_platypus_record_meta__alignment(meta_t *t) { return t->top.alignment; } EXPORT ffi_type ** ffi_platypus_record_meta__element_pointers(meta_t *t) { return t->top.elements; } EXPORT void ffi_platypus_record_meta__DESTROY(meta_t *t) { free(t); } EXPORT ffi_type * ffi_platypus_record_meta___find_symbol(const char *name) { if(!strcmp(name, "sint8")) return &ffi_type_sint8; else if(!strcmp(name, "sint16")) return &ffi_type_sint16; else if(!strcmp(name, "sint32")) return &ffi_type_sint32; else if(!strcmp(name, "sint64")) return &ffi_type_sint64; else if(!strcmp(name, "uint8")) return &ffi_type_uint8; else if(!strcmp(name, "uint16")) return &ffi_type_uint16; else if(!strcmp(name, "uint32")) return &ffi_type_uint32; else if(!strcmp(name, "uint64")) return &ffi_type_uint64; else if(!strcmp(name, "pointer")) return &ffi_type_pointer; else if(!strcmp(name, "float")) return &ffi_type_float; else if(!strcmp(name, "double")) return &ffi_type_double; /* TODO: longdouble, complex_float, complex_duble, complex_longdouble */ else return NULL; } FFI-Platypus-1.10/examples/archive.pl000644 000765 000024 00000006266 13616651126 020127 0ustar00ollisgstaff000000 000000 use 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; } FFI-Platypus-1.10/examples/archive_object.pl000644 000765 000024 00000005577 13616651126 021461 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus (); use FFI::CheckLib qw( find_lib_or_exit ); # 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 = FFI::Platypus->new( api => 1 ); $ffi->lib(find_lib_or_exit lib => 'archive'); $ffi->type('object(Archive)' => 'archive_t'); $ffi->type('object(ArchiveRead)' => 'archive_read_t'); $ffi->type('object(ArchiveWrite)' => 'archive_write_t'); $ffi->type('object(ArchiveEntry)' => 'archive_entry_t'); package Archive; # base class is "abstract" having no constructor or destructor $ffi->mangler(sub { my($name) = @_; "archive_$name"; }); $ffi->attach( error_string => ['archive_t'] => 'string' ); package ArchiveRead; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_read_$name"; }); $ffi->attach( new => ['string'] => 'archive_read_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_t'] => 'void' ); $ffi->attach( support_filter_all => ['archive_t'] => 'int' ); $ffi->attach( support_format_all => ['archive_t'] => 'int' ); $ffi->attach( open_filename => ['archive_t','string','size_t'] => 'int' ); $ffi->attach( next_header2 => ['archive_t', 'archive_entry_t' ] => 'int' ); $ffi->attach( data_skip => ['archive_t'] => 'int' ); # ... define additional read methods package ArchiveWrite; our @ISA = qw( Archive ); $ffi->mangler(sub { my($name) = @_; "archive_write_$name"; }); $ffi->attach( new => ['string'] => 'archive_write_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_write_t'] => 'void' ); # ... define additional write methods package ArchiveEntry; $ffi->mangler(sub { my($name) = @_; "archive_entry_$name"; }); $ffi->attach( new => ['string'] => 'archive_entry_t' ); $ffi->attach( [ free => 'DESTROY' ] => ['archive_entry_t'] => 'void' ); $ffi->attach( pathname => ['archive_entry_t'] => '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; } FFI-Platypus-1.10/examples/attach_from_pointer.pl000644 000765 000024 00000000527 13616651126 022527 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::TinyCC; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); 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"; FFI-Platypus-1.10/examples/bundle-const/000755 000765 000024 00000000000 13616651126 020534 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-foo/000755 000765 000024 00000000000 13616651126 020171 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-init/000755 000765 000024 00000000000 13616651126 020351 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bzip2.pl000644 000765 000024 00000004020 13616651126 017516 0ustar00ollisgstaff000000 000000 use 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( api => 1 ); $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); FFI-Platypus-1.10/examples/char.pl000644 000765 000024 00000000625 13616651126 017414 0ustar00ollisgstaff000000 000000 use 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; FFI-Platypus-1.10/examples/closure-opaque.pl000644 000765 000024 00000000657 13616651126 021450 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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" FFI-Platypus-1.10/examples/closure.c000644 000765 000024 00000000556 13616651126 017765 0ustar00ollisgstaff000000 000000 /* * 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"); } FFI-Platypus-1.10/examples/closure.pl000644 000765 000024 00000000754 13616651126 020156 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $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" FFI-Platypus-1.10/examples/file_handle.pl000644 000765 000024 00000001743 13616651126 020733 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; { package FD; use constant O_RDONLY => 0; use constant O_WRONLY => 1; use constant O_RDWR => 2; use constant IN => bless \do { my $in=0 }, __PACKAGE__; use constant OUT => bless \do { my $out=1 }, __PACKAGE__; use constant ERR => bless \do { my $err=2 }, __PACKAGE__; my $ffi = FFI::Platypus->new( api => 1, lib => [undef]); $ffi->type('object(FD,int)' => 'fd'); $ffi->attach( [ 'open' => 'new' ] => [ 'string', 'int', 'mode_t' ] => 'fd' => sub { my($xsub, $class, $fn, @rest) = @_; my $fd = $xsub->($fn, @rest); die "error opening $fn $!" if $$fd == -1; $fd; }); $ffi->attach( write => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( read => ['fd', 'string', 'size_t' ] => 'ssize_t' ); $ffi->attach( close => ['fd'] => 'int' ); } my $fd = FD->new("$0", FD::O_RDONLY); my $buffer = "\0" x 10; while(my $br = $fd->read($buffer, 10)) { FD::OUT->write($buffer, $br); } $fd->close; FFI-Platypus-1.10/examples/get_uptime.pl000644 000765 000024 00000003641 13616651126 020642 0ustar00ollisgstaff000000 000000 #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'); FFI-Platypus-1.10/examples/getpid.pl000644 000765 000024 00000000314 13616651126 017746 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(getpid => [] => 'int'); puts(getpid()); FFI-Platypus-1.10/examples/integer.pl000644 000765 000024 00000000324 13616651126 020130 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib(undef); $ffi->attach(puts => ['string'] => 'int'); $ffi->attach(atoi => ['string'] => 'int'); puts(atoi('56')); FFI-Platypus-1.10/examples/list_integer_types.pl000644 000765 000024 00000000420 13616651126 022404 0ustar00ollisgstaff000000 000000 use 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}; } FFI-Platypus-1.10/examples/malloc.pl000644 000765 000024 00000000505 13616651126 017743 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free memcpy ); my $ffi = FFI::Platypus->new( api => 1 ); 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; FFI-Platypus-1.10/examples/math.pl000644 000765 000024 00000000604 13616651126 017425 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use FFI::CheckLib; my $ffi = FFI::Platypus->new( api => 1 ); $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)); FFI-Platypus-1.10/examples/notify.pl000644 000765 000024 00000002056 13616651126 020007 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::CheckLib; use FFI::Platypus; # NOTE: I ported this from anoter Perl FFI library and it seems to work most # of the time, but also seems to SIGSEGV sometimes. I saw the same behavior # in the old 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( api => 1 ); $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(); FFI-Platypus-1.10/examples/pipe.pl000644 000765 000024 00000000353 13616651126 017432 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ); $ffi->lib(undef); $ffi->attach([pipe=>'mypipe'] => ['int[2]'] => 'int'); my @fd = (0,0); mypipe(\@fd); my($fd1,$fd2) = @fd; print "$fd1 $fd2\n"; FFI-Platypus-1.10/examples/string.pl000644 000765 000024 00000000656 13616651126 020011 0ustar00ollisgstaff000000 000000 use 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)); FFI-Platypus-1.10/examples/time.pl000644 000765 000024 00000003420 13616651126 017431 0ustar00ollisgstaff000000 000000 use 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( api => 1 ); $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"; FFI-Platypus-1.10/examples/time_oo.pl000644 000765 000024 00000004331 13616651126 020130 0ustar00ollisgstaff000000 000000 use 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( api => 1 ); $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; FFI-Platypus-1.10/examples/time_record.pl000644 000765 000024 00000001557 13616651126 021000 0ustar00ollisgstaff000000 000000 use strict; use warnings; package My::UnixTime; use FFI::Platypus::Record; record_layout_1(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( api => 1 ); $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; FFI-Platypus-1.10/examples/uuid.pl000644 000765 000024 00000001137 13616651126 017444 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::CheckLib; use FFI::Platypus; use FFI::Platypus::Memory qw( malloc free ); my $ffi = FFI::Platypus->new( api => 1 ); $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"; FFI-Platypus-1.10/examples/var_array.c000644 000765 000024 00000000211 13616651126 020263 0ustar00ollisgstaff000000 000000 int sum(int *array, int size) { int total, i; for (i = 0, total = 0; i < size; i++) { total += array[i]; } return total; } FFI-Platypus-1.10/examples/var_array.pl000644 000765 000024 00000000347 13616651126 020466 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; my $ffi = FFI::Platypus->new( api => 1 ) $ffi->lib('./var_array.so'); $ffi->attach( sum => [ 'int[]', 'int' ] => 'int' ); my @list = (1..100); print sum(\@list, scalar @list), "\n"; FFI-Platypus-1.10/examples/win32_beep.pl000644 000765 000024 00000000362 13616651126 020432 0ustar00ollisgstaff000000 000000 use 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); FFI-Platypus-1.10/examples/win32_getSystemTime.pl000644 000765 000024 00000003012 13616651126 022315 0ustar00ollisgstaff000000 000000 # 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; FFI-Platypus-1.10/examples/zmq3.pl000644 000765 000024 00000004417 13616651126 017374 0ustar00ollisgstaff000000 000000 use 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( api => 1 ); $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"; }; FFI-Platypus-1.10/examples/bundle-init/ffi/000755 000765 000024 00000000000 13616651126 021115 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-init/lib/000755 000765 000024 00000000000 13616651126 021117 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-init/t/000755 000765 000024 00000000000 13616651126 020614 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-init/t/init.t000644 000765 000024 00000000130 13616651126 021736 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use Init; ok 'did not crash'; done_testing; FFI-Platypus-1.10/examples/bundle-init/lib/Init.pm000644 000765 000024 00000000574 13616651126 022366 0ustar00ollisgstaff000000 000000 package Init; use strict; use warnings; use FFI::Platypus; our $VERSION = '1.00'; { my $ffi = FFI::Platypus->new( api => 1 ); my $say = $ffi->closure(sub { my $string = shift; print "$string\n"; }); $ffi->bundle([ $ffi->cast( 'string' => 'opaque', $VERSION ), $ffi->cast( '(string)->void' => 'opaque', $say ), ]); undef $ffi; undef $say; } 1; FFI-Platypus-1.10/examples/bundle-init/ffi/init.c000644 000765 000024 00000000706 13616651126 022227 0ustar00ollisgstaff000000 000000 #include char buffer[512]; const char *version; void (*say)(const char *); void ffi_pl_bundle_init(const char *package, int argc, void *argv[]) { version = argv[0]; say = argv[1]; say("in init!"); snprintf(buffer, 512, "package = %s, version = %s", package, version); say(buffer); snprintf(buffer, 512, "args = %d", argc); say(buffer); } void ffi_pl_bundle_fini(const char *package) { say("in fini!"); } FFI-Platypus-1.10/examples/bundle-foo/ffi/000755 000765 000024 00000000000 13616651126 020735 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-foo/lib/000755 000765 000024 00000000000 13616651126 020737 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-foo/Makefile.PL000644 000765 000024 00000000363 13616651126 022145 0ustar00ollisgstaff000000 000000 use ExtUtils::MakeMaker; use FFI::Build::MM; my $fbmm = FFI::Build::MM->new; WriteMakefile( $fbmm->mm_args( NAME => 'Foo', DISTNAME => 'Foo', VERSION => '1.00', # ... ) ); sub MY::postamble { $fbmm->mm_postamble; } FFI-Platypus-1.10/examples/bundle-foo/t/000755 000765 000024 00000000000 13616651126 020434 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-foo/t/foo.t000644 000765 000024 00000000252 13616651126 021403 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use Foo; my $foo = Foo->new("platypus", 10); isa_ok $foo, 'Foo'; is $foo->name, "platypus"; is $foo->value, 10; done_testing; FFI-Platypus-1.10/examples/bundle-foo/lib/Foo.pm000644 000765 000024 00000001041 13616651126 022014 0ustar00ollisgstaff000000 000000 package Foo; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->type('object(Foo)' => 'foo_t'); $ffi->mangler(sub { my $name = shift; $name =~ s/^/foo__/; $name; }); $ffi->bundle; $ffi->attach( new => [ 'string', 'string', 'int' ] => 'foo_t' ); $ffi->attach( name => [ 'foo_t' ] => 'string' ); $ffi->attach( value => [ 'foo_t' ] => 'int' ); $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); } 1; FFI-Platypus-1.10/examples/bundle-foo/ffi/foo.c000644 000765 000024 00000000762 13616651126 021671 0ustar00ollisgstaff000000 000000 #include #include typedef struct { char *name; int value; } foo_t; foo_t* foo__new(const char *class_name, const char *name, int value) { (void)class_name; foo_t *self = malloc( sizeof( foo_t ) ); self->name = strdup(name); self->value = value; return self; } const char * foo__name(foo_t *self) { return self->name; } int foo__value(foo_t *self) { return self->value; } void foo__DESTROY(foo_t *self) { free(self->name); free(self); } FFI-Platypus-1.10/examples/bundle-const/ffi/000755 000765 000024 00000000000 13616651126 021300 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-const/lib/000755 000765 000024 00000000000 13616651126 021302 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-const/t/000755 000765 000024 00000000000 13616651126 020777 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/examples/bundle-const/t/const.t000644 000765 000024 00000000270 13616651126 022311 0ustar00ollisgstaff000000 000000 use strict; use warnings; use Test::More; use Const; foreach my $name (sort keys %Const::) { next unless $name =~ /^MY/; note "$name=@{[ Const->$name ]}"; } ok 1; done_testing; FFI-Platypus-1.10/examples/bundle-const/lib/Const.pm000644 000765 000024 00000000202 13616651126 022720 0ustar00ollisgstaff000000 000000 package Const; use strict; use warnings; use FFI::Platypus; { my $ffi = FFI::Platypus->new( api => 1 ); $ffi->bundle; } 1; FFI-Platypus-1.10/examples/bundle-const/ffi/const.c000644 000765 000024 00000000661 13616651126 022575 0ustar00ollisgstaff000000 000000 #include #include "myheader.h" void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c) { c->set_str("MYVERSION_STRING", MYVERSION_STRING); c->set_uint("MYVERSION_MAJOR", MYVERSION_MAJOR); c->set_uint("MYVERSION_MINOR", MYVERSION_MINOR); c->set_uint("MYVERSION_PATCH", MYVERSION_PATCH); c->set_sint("MYBAD", MYBAD); c->set_sint("MYOK", MYOK); c->set_double("MYPI", MYPI); } FFI-Platypus-1.10/examples/bundle-const/ffi/myheader.h000644 000765 000024 00000000326 13616651126 023250 0ustar00ollisgstaff000000 000000 #ifndef MYHEADER_H #define MYHEADER_H #define MYVERSION_STRING "1.2.3" #define MYVERSION_MAJOR 1 #define MYVERSION_MINOR 2 #define MYVERSION_PATCH 3 enum { MYBAD = -1, MYOK = 1 }; #define MYPI 3.14 #endif FFI-Platypus-1.10/corpus/ffi_build/000755 000765 000024 00000000000 13616651126 017557 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_base/000755 000765 000024 00000000000 13616651126 021550 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_c/000755 000765 000024 00000000000 13616651126 021060 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_cxx/000755 000765 000024 00000000000 13616651126 021440 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_mm/000755 000765 000024 00000000000 13616651126 020250 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_probe_runner/000755 000765 000024 00000000000 13616651126 021160 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/memory/000755 000765 000024 00000000000 13616651126 017144 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/memory/arg_array.pl000644 000765 000024 00000002775 13616651126 021463 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { "${_}[2]" } ( 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); no_leaks_ok { my @a = (1,2); $f->call(\@a) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'opaque[2]' ] => 'void' ); my @a = ($ptr, undef); no_leaks_ok { $f->call(\@a) }; $free->call($ptr); }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'string[2]' ] => 'void' ); my @a = ("hello world", undef); no_leaks_ok { $f->call(\@a) }; }; subtest 'complex' => sub { foreach my $type (qw( complex_float[2] complex_double[2] )) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); { my @c = ([1.0,2.0],[3.0,4.0]); no_leaks_ok { $f->call(\@c) }; } { my @c = (Math::Complex->make(1.0,2.0),Math::Complex->make(3.0,4.0)); no_leaks_ok { $f->call(\@c) }; } }; } }; done_testing; FFI-Platypus-1.10/corpus/memory/arg_custom.pl000644 000765 000024 00000002352 13616651126 021646 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { "$_" } ( 'float', 'double', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; $ffi->custom_type( foo_t => { native_type => $type, native_to_perl => sub { $_[0] }, perl_to_native => sub { $_[0] }, perl_to_native_post => sub { $_[0] }, }); my $f = $ffi->function(0 => [ "foo_t" ] => 'void' ); no_leaks_ok { $f->call(129) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); $ffi->custom_type( foo_t => { native_type => 'opaque', native_to_perl => sub { $_[0] }, perl_to_native => sub { $_[0] }, perl_to_native_post => sub { $_[0] }, }); my $f = $ffi->function(0 => [ 'foo_t' ] => 'void' ); no_leaks_ok { $f->call($ptr) }; $free->call($ptr); no_leaks_ok { $f->call(undef) }; }; done_testing; FFI-Platypus-1.10/corpus/memory/arg_object.pl000644 000765 000024 00000001775 13616651126 021612 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 ); { package Foo; sub new { my($class, $arg) = @_; bless \$arg, $class; } } foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new( api => 1 ); my $f = $ffi->function(0 => [ "object(Foo,$type)" ] => 'void' ); my $foo = Foo->new(129); no_leaks_ok { $f->call($foo) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( api => 1, lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'object(Foo)' ] => 'void' ); my $foo1 = Foo->new($ptr); no_leaks_ok { $f->call($foo1) }; $free->call($ptr); my $foo2 = Foo->new(undef); no_leaks_ok { $f->call($foo2) }; }; done_testing; FFI-Platypus-1.10/corpus/memory/arg_pointer.pl000644 000765 000024 00000003151 13616651126 022012 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { "$_*" } ( 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); no_leaks_ok { my $val = 129; $f->call(\$val) }; no_leaks_ok { $f->call(undef) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'opaque*' ] => 'void' ); no_leaks_ok { $f->call(\$ptr) }; $free->call($ptr); no_leaks_ok { $f->call(undef) }; }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'string*' ] => 'void' ); no_leaks_ok { $f->call(\"hello world") }; my $str = "hello world"; no_leaks_ok { $f->call(\$str) }; no_leaks_ok { $f->call(undef) }; }; subtest 'complex' => sub { foreach my $type (qw( complex_float* complex_double* )) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); { my $c = [1.0,2.0]; no_leaks_ok { $f->call(\$c) }; } { my $c = Math::Complex->make(1.0,2.0); no_leaks_ok { $f->call(\$c) }; } no_leaks_ok { $f->call(undef) }; }; } }; done_testing; FFI-Platypus-1.10/corpus/memory/arg_scalar.pl000644 000765 000024 00000005141 13616651126 021600 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 't/lib'; use Test::FauxAttach; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); use FFI::Platypus::Record::Meta; my @types = ( 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); no_leaks_ok { $f->call(129) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'opaque' ] => 'void' ); no_leaks_ok { $f->call($ptr) }; $free->call($ptr); no_leaks_ok { $f->call(undef) }; }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'string' ] => 'void' ); no_leaks_ok { $f->call("hello world") }; no_leaks_ok { $f->call(undef) }; }; subtest 'complex' => sub { foreach my $type (qw( complex_float complex_double )) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => 'void' ); { my $c = [1.0,2.0]; no_leaks_ok { $f->call($c) }; } { my $c = Math::Complex->make(1.0,2.0); no_leaks_ok { $f->call($c) }; } }; } }; subtest 'record' => sub { my $ffi = FFI::Platypus->new( api => 1 ); our $meta = FFI::Platypus::Record::Meta->new(['sint32']); { package Foo; sub new { my $value = "\0" x 4; return bless \$value, 'Foo'; } sub _ffi_record_size { 4 } sub _ffi_meta { $meta } } $ffi->type('record(Foo)' => 'foo_t'); my $foo = Foo->new; foreach my $type (qw( foo_t foo_t* )) { subtest $type => sub { my $f = $ffi->function(0 => [ $type ] => 'void' ); no_leaks_ok { $f->call($foo) }; } } subtest 'record(4)*' => sub { my $f = $ffi->function(0 => [ 'record(4)*' ] => 'void' ); my $str = "\0" x 4; no_leaks_ok { $f->call($str) }; }; undef $meta; }; subtest 'closure' => sub { my $ffi = FFI::Platypus->new; $ffi->type('()->void' => 'closure_t'); my $f = $ffi->function(0 => [ 'closure_t' ] => 'void' ); no_leaks_ok { $f->call(undef) }; no_leaks_ok { my $closure = $ffi->closure(sub {}); $f->call($closure); }; { my $closure = $ffi->closure(sub {}); $f->call($closure); no_leaks_ok { $f->call($closure); } }; }; done_testing; FFI-Platypus-1.10/corpus/memory/attach.pl000644 000765 000024 00000000626 13616651126 020751 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use FFI::CheckLib qw( find_lib ); my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; my $ffi = FFI::Platypus->new(); $ffi->lib( $libtest ); $ffi->type('()->void' => 'callback_t'); $ffi->attach( gh174_func1 => [ 'callback_t' ] => 'void' ); my $callback = $ffi->closure( sub { print "Perl callback()\n" } ); gh174_func1( $callback ); FFI-Platypus-1.10/corpus/memory/empty.pl000644 000765 000024 00000000053 13616651126 020635 0ustar00ollisgstaff000000 000000 use strict; use warnings; print "nada\n"; FFI-Platypus-1.10/corpus/memory/function.pl000644 000765 000024 00000000706 13616651126 021331 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use FFI::CheckLib qw( find_lib ); { my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; my $ffi = FFI::Platypus->new(); $ffi->lib( $libtest ); $ffi->type('()->void' => 'callback_t'); my $gh174_func1 = $ffi->function( gh174_func1 => [ 'callback_t' ] => 'void' ); my $callback = $ffi->closure( sub { print "Perl callback()\n" } ); $gh174_func1->call( $callback ); } FFI-Platypus-1.10/corpus/memory/return_array.pl000644 000765 000024 00000005404 13616651126 022221 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { $_ . '[2]' } ( 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( 'malloc' => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( 'free' => [ 'opaque' ] => 'void' ); my $memcpy = $ffi->function( 'memcpy' => [ 'opaque', $type, 'size_t' ] => 'opaque' ); my $size = $ffi->sizeof($type); my $ptr = $malloc->call($size); $memcpy->call($ptr, [1,2], $size); no_leaks_ok { $ffi->cast( 'opaque' => $type, $ptr ); }; if($type =~ /^longdouble/) { my @o = @{ $ffi->cast( 'opaque' => $type, $ptr ) }; cmp_ok $o[0], '==', 1; cmp_ok $o[1], '==', 2; } else { is_deeply $ffi->cast( 'opaque' => $type, $ptr ), [1,2]; } $free->call($ptr); } } subtest 'string/opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( 'malloc' => [ 'size_t' ] => 'opaque' ); my $strdup = $ffi->function( 'strdup' => [ 'string' ] => 'opaque' ); my $free = $ffi->function( 'free' => [ 'opaque' ] => 'void' ); my $memcpy = $ffi->function( 'memcpy' => [ 'opaque', 'opaque[2]', 'size_t' ] => 'opaque' ); my $size = $ffi->sizeof('string[2]'); my $ptr = $malloc->call($size); my $frooble = $strdup->call("frooble"); $memcpy->call($ptr, [$frooble,undef], $size); no_leaks_ok { $ffi->cast( 'opaque' => 'string[2]', $ptr ); }; is_deeply $ffi->cast( 'opaque' => 'string[2]', $ptr ), ["frooble",undef]; no_leaks_ok { $ffi->cast( 'opaque' => 'opaque[2]', $ptr ); }; is_deeply $ffi->cast( 'opaque' => 'opaque[2]', $ptr ), [$frooble,undef]; $free->call($frooble); $free->call($ptr); }; foreach my $type (qw( complex_float[2] complex_double[2] )) { subtest $type => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( 'malloc' => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( 'free' => [ 'opaque' ] => 'void' ); my $memcpy = $ffi->function( 'memcpy' => [ 'opaque', $type, 'size_t' ] => 'opaque' ); my $size = $ffi->sizeof($type); my $ptr = $malloc->call($size); $memcpy->call($ptr, [[1.0,2.0],[3.0,4.0]], $size); no_leaks_ok { $ffi->cast( 'opaque' => $type, $ptr ); }; is_deeply $ffi->cast( 'opaque' => $type, $ptr ), [[1.0,2.0],[3.0,4.0]]; $free->call($ptr); }; } done_testing; FFI-Platypus-1.10/corpus/memory/return_custom.pl000644 000765 000024 00000002354 13616651126 022416 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { "$_" } ( 'float', 'double', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; $ffi->custom_type( foo_t => { native_type => $type, native_to_perl => sub { $_[0] }, perl_to_native => sub { $_[0] }, perl_to_native_post => sub { $_[0] }, }); my $f = $ffi->function(0 => [ "foo_t" ] => 'foo_t' ); no_leaks_ok { $f->call(129) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); $ffi->custom_type( foo_t => { native_type => 'opaque', native_to_perl => sub { $_[0] }, perl_to_native => sub { $_[0] }, perl_to_native_post => sub { $_[0] }, }); my $f = $ffi->function(0 => [ 'foo_t' ] => 'foo_t' ); no_leaks_ok { $f->call($ptr) }; $free->call($ptr); no_leaks_ok { $f->call(undef) }; }; done_testing; FFI-Platypus-1.10/corpus/memory/return_object.pl000644 000765 000024 00000001731 13616651126 022350 0ustar00ollisgstaff000000 000000 use strict; use warnings; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); my @types = map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 ); { package Foo; sub new { my($class, $arg) = @_; bless \$arg, $class; } } foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new( api => 1 ); my $f = $ffi->function(0 => [] => "object(Foo,$type)" ); no_leaks_ok { $f->call }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( api => 1, lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'object(Foo)' ] => 'object(Foo)' ); my $foo1 = Foo->new($ptr); no_leaks_ok { $f->call($foo1) }; $free->call($ptr); my $foo2 = Foo->new(undef); no_leaks_ok { $f->call($foo2) }; }; done_testing; FFI-Platypus-1.10/corpus/memory/return_pointer.pl000644 000765 000024 00000002642 13616651126 022564 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 't/lib'; use Test::FauxAttach; use FFI::Platypus; use Test::More; use Test::LeakTrace qw( no_leaks_ok ); use FFI::Platypus::Memory qw( malloc free memset strdup ); my $ptr = malloc(400); memset($ptr, 0, 400); my @types = map { "$_*" } ( 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'opaque' ] => $type ); no_leaks_ok { $f->call($ptr) }; no_leaks_ok { $f->call(undef) }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'opaque' ] => 'opaque*' ); no_leaks_ok { $f->call($ptr) }; no_leaks_ok { $f->call(undef) }; my $f2 = $ffi->function(0 => [ 'opaque*' ] => 'opaque*' ); no_leaks_ok { $f2->call(\$ptr) }; }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'opaque' ] => 'string*' ); my $ptr = strdup("hello world"); no_leaks_ok { $f->call($ptr) }; no_leaks_ok { $f->call(undef) }; free $ptr; }; subtest 'complex' => sub { foreach my $type (qw( complex_float* complex_double* )) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'opaque' ] => $type ); no_leaks_ok { $f->call($ptr) }; }; } }; free $ptr; done_testing; FFI-Platypus-1.10/corpus/memory/return_scalar.pl000644 000765 000024 00000004253 13616651126 022351 0ustar00ollisgstaff000000 000000 use strict; use warnings; use lib 't/lib'; use Test::FauxAttach; use FFI::Platypus; use Test::More; use Math::Complex; use Test::LeakTrace qw( no_leaks_ok ); use FFI::Platypus::Record::Meta; my @types = ( 'void', 'float', 'double', 'longdouble', map { ( "sint$_" , "uint$_" ) } qw( 8 16 32 64 )); foreach my $type (@types) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [] => $type ); no_leaks_ok { $f->call }; } } subtest 'opaque' => sub { my $ffi = FFI::Platypus->new( lib => [undef] ); my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); my $ptr = $malloc->call(200); my $f = $ffi->function(0 => [ 'opaque' ] => 'opaque' ); no_leaks_ok { $f->call($ptr) }; $free->call($ptr); no_leaks_ok { $f->call(undef) }; }; subtest 'string' => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ 'string' ] => 'string' ); no_leaks_ok { $f->call("hello world") }; no_leaks_ok { $f->call(undef) }; }; subtest 'complex' => sub { foreach my $type (qw( complex_float complex_double )) { subtest $type => sub { my $ffi = FFI::Platypus->new; my $f = $ffi->function(0 => [ $type ] => $type ); { my $c = [1.0,2.0]; no_leaks_ok { $f->call($c) }; } { my $c = Math::Complex->make(1.0,2.0); no_leaks_ok { $f->call($c) }; } }; } }; subtest 'record' => sub { my $ffi = FFI::Platypus->new( api => 1 ); our $meta = FFI::Platypus::Record::Meta->new(['sint32']); { package Foo; sub new { my $value = "\0" x 4; return bless \$value, 'Foo'; } sub _ffi_record_size { 4 } sub _ffi_meta { $meta } } $ffi->type('record(Foo)' => 'foo_t'); my $foo = Foo->new; foreach my $type (qw( foo_t foo_t* )) { subtest $type => sub { my $f = $ffi->function(0 => [ $type ] => $type ); no_leaks_ok { $f->call($foo) }; } } subtest 'record(4)*' => sub { my $f = $ffi->function(0 => [ 'foo_t' ] => 'record(4)*' ); no_leaks_ok { $f->call($foo) }; }; undef $meta; }; done_testing; FFI-Platypus-1.10/corpus/memory/supp/000755 000765 000024 00000000000 13616651126 020133 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/memory/supp/basic_type_cache.supp000644 000765 000024 00000000331 13616651126 024306 0ustar00ollisgstaff000000 000000 { Memcheck:Leak match-leak-kinds: definite fun:malloc fun:Perl_safesysmalloc fun:ffi_pl_type_new fun:XS_FFI__Platypus__TypeParser_create_type_* fun:Perl_pp_entersub ... } FFI-Platypus-1.10/corpus/ffi_probe_runner/bar.c000644 000765 000024 00000000333 13616651126 022067 0ustar00ollisgstaff000000 000000 #include int dlmain(int argc, char *argv[]) { int i; printf("argc=%d\n", argc); for(i=0;i int dlmain(int argc, char *argv[]) { int i; printf("argc=%d\n", argc); for(i=0;iisa('FFI::Build::Platform'); { source => [ "$DIR/*.c" ] }; FFI-Platypus-1.10/corpus/ffi_build_mm/lb1bad/hello1.c000644 000765 000024 00000000000 13616651126 022713 0ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_mm/lb1bad/hello2.c000644 000765 000024 00000000000 13616651126 022714 0ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_mm/lb1/hello.fbx000644 000765 000024 00000000206 13616651126 022530 0ustar00ollisgstaff000000 000000 use strict; use warnings; our $DIR; our $PLATFORM; die unless $PLATFORM->isa('FFI::Build::Platform'); { source => [ "$DIR/*.c" ] }; FFI-Platypus-1.10/corpus/ffi_build_mm/lb1/hello1.c000644 000765 000024 00000000000 13616651126 022244 0ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_mm/lb1/hello2.c000644 000765 000024 00000000000 13616651126 022245 0ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_cxx/basic.cxx000644 000765 000024 00000000151 13616651126 023242 0ustar00ollisgstaff000000 000000 #include int main(int argc, char *argv[]) { cout << "hello world" << endl; return 0; } FFI-Platypus-1.10/corpus/ffi_build_file_cxx/foo1.cxx000644 000765 000024 00000000171 13616651126 023027 0ustar00ollisgstaff000000 000000 class Foo { public: int answer() { return 42; }; }; int foo1() { // comment Foo foo; return foo.answer(); } FFI-Platypus-1.10/corpus/ffi_build_file_cxx/foo2.cpp000644 000765 000024 00000000170 13616651126 023007 0ustar00ollisgstaff000000 000000 #include class Foo { public: int answer() { return 42; }; }; int foo1() { // comment return 42; } FFI-Platypus-1.10/corpus/ffi_build_file_cxx/include/000755 000765 000024 00000000000 13616651126 023063 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_cxx/include/myfoo.h000644 000765 000024 00000000123 13616651126 024361 0ustar00ollisgstaff000000 000000 #ifndef MYFOO_H #define MYFOO_H /* this doesn't do anything apparently */ #endif FFI-Platypus-1.10/corpus/ffi_build_file_c/basic.c000644 000765 000024 00000000105 13616651126 022301 0ustar00ollisgstaff000000 000000 #include int main(int argc, char *argv[]) { return 0; } FFI-Platypus-1.10/corpus/ffi_build_file_c/foo1.c000644 000765 000024 00000000034 13616651126 022065 0ustar00ollisgstaff000000 000000 int foo1() { return 42; } FFI-Platypus-1.10/corpus/ffi_build_file_c/foo2.c000644 000765 000024 00000000057 13616651126 022073 0ustar00ollisgstaff000000 000000 #include int foo1() { return 42; } FFI-Platypus-1.10/corpus/ffi_build_file_c/include/000755 000765 000024 00000000000 13616651126 022503 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build_file_c/include/myfoo.h000644 000765 000024 00000000123 13616651126 024001 0ustar00ollisgstaff000000 000000 #ifndef MYFOO_H #define MYFOO_H /* this doesn't do anything apparently */ #endif FFI-Platypus-1.10/corpus/ffi_build_file_base/basic.foo000644 000765 000024 00000000025 13616651126 023333 0ustar00ollisgstaff000000 000000 This is a basic foo. FFI-Platypus-1.10/corpus/ffi_build/project-cxx/000755 000765 000024 00000000000 13616651126 022025 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build/project1/000755 000765 000024 00000000000 13616651126 021306 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build/project2/000755 000765 000024 00000000000 13616651126 021307 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build/source/000755 000765 000024 00000000000 13616651126 021057 5ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build/source/foo.c000644 000765 000024 00000000000 13616651126 021774 0ustar00ollisgstaff000000 000000 FFI-Platypus-1.10/corpus/ffi_build/project2/bar.c000644 000765 000024 00000000101 13616651126 022207 0ustar00ollisgstaff000000 000000 #include int myanswer() { return answer(); } FFI-Platypus-1.10/corpus/ffi_build/project1/foo1.c000644 000765 000024 00000000165 13616651126 022320 0ustar00ollisgstaff000000 000000 #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif EXPORT int foo1() { return 42; } FFI-Platypus-1.10/corpus/ffi_build/project1/foo2.c000644 000765 000024 00000000200 13616651126 022307 0ustar00ollisgstaff000000 000000 #ifdef _MSC_VER #define EXPORT __declspec(dllexport) #else #define EXPORT #endif EXPORT const char * foo2() { return "42"; } FFI-Platypus-1.10/corpus/ffi_build/project-cxx/foo1.cxx000644 000765 000024 00000000167 13616651126 023421 0ustar00ollisgstaff000000 000000 class Foo { public: int answer() { return 42; }; }; extern "C" int foo1() { Foo foo; return foo.answer(); } FFI-Platypus-1.10/corpus/ffi_build/project-cxx/foo2.cpp000644 000765 000024 00000000523 13616651126 023376 0ustar00ollisgstaff000000 000000 // This requires C++11 (I believe) // TODO: support older c++ compilers. #include class Foo2 { public: const char *answer() { return "42"; }; }; extern "C" const char * foo2() { Foo2 foo; return foo.answer(); } extern "C" void not_to_call_just_to_pull_in_the_stdcpp() { std::cout << "Hello There" << std::endl; }