├── .cirrus.yml ├── .gitattributes ├── .github └── workflows │ ├── linux.yml │ ├── macos.yml │ ├── msys2-mingw.yml │ ├── static.yml │ └── windows.yml ├── .gitignore ├── .gitmodules ├── .yath.rc ├── CONTRIBUTING ├── Changes ├── Changes.FFI-Build ├── Changes.FFI-Platypus-Type-StringArray ├── Makefile.PL ├── README.md ├── SUPPORT ├── author.yml ├── corpus ├── ffi_build │ ├── project-cxx │ │ ├── foo1.cxx │ │ └── foo2.cpp │ ├── project1 │ │ ├── foo1.c │ │ └── foo2.c │ ├── project2 │ │ └── bar.c │ └── source │ │ └── foo.c ├── ffi_build_file_base │ └── basic.foo ├── ffi_build_file_c │ ├── basic.c │ ├── foo1.c │ ├── foo2.c │ └── include │ │ └── myfoo.h ├── ffi_build_file_cxx │ ├── basic.cxx │ ├── foo1.cxx │ ├── foo2.cpp │ └── include │ │ └── myfoo.h ├── ffi_build_mm │ ├── lb1 │ │ ├── hello.fbx │ │ ├── hello1.c │ │ └── hello2.c │ ├── lb1bad │ │ ├── hello.fbx │ │ ├── hello1.c │ │ └── hello2.c │ ├── lb2 │ │ ├── hello1.c │ │ └── hello2.c │ └── project1 │ │ ├── ffi │ │ ├── x.c │ │ ├── y.c │ │ └── z.c │ │ └── t │ │ └── ffi │ │ ├── a.c │ │ ├── b.c │ │ └── c.c ├── ffi_build_plugin │ ├── lib1 │ │ └── FFI │ │ │ └── Build │ │ │ └── Plugin │ │ │ └── blank.txt │ └── lib2 │ │ └── FFI │ │ └── Build │ │ └── Plugin │ │ ├── Foo1.pm │ │ └── Foo2.pm ├── ffi_probe_runner │ ├── bar.c │ └── foo.c └── memory │ ├── arg_array.pl │ ├── arg_custom.pl │ ├── arg_object.pl │ ├── arg_pointer.pl │ ├── arg_scalar.pl │ ├── attach.pl │ ├── empty.pl │ ├── function.pl │ ├── return_array.pl │ ├── return_custom.pl │ ├── return_object.pl │ ├── return_pointer.pl │ ├── return_scalar.pl │ └── supp │ └── basic_type_cache.supp ├── dist.ini ├── examples ├── add.c ├── add.pl ├── archive.pl ├── archive.tar ├── archive_object.pl ├── array_reverse.c ├── array_reverse.pl ├── array_sum.c ├── array_sum.pl ├── bundle-answer │ ├── .gitignore │ ├── ffi │ │ ├── answer.c │ │ └── answer.fbx │ ├── include │ │ └── answer.h │ ├── lib │ │ └── Answer.pm │ └── t │ │ └── answer.t ├── bundle-bzip2 │ ├── .gitignore │ ├── ffi │ │ ├── bz2.fbx │ │ └── compress.c │ ├── lib │ │ └── Bzip2.pm │ └── t │ │ └── bzip2.t ├── bundle-const │ ├── ffi │ │ ├── const.c │ │ └── myheader.h │ ├── lib │ │ └── Const.pm │ └── t │ │ └── const.t ├── bundle-foo │ ├── Makefile.PL │ ├── ffi │ │ └── foo.c │ ├── lib │ │ └── Foo.pm │ └── t │ │ └── foo.t ├── bundle-init │ ├── ffi │ │ └── init.c │ ├── lib │ │ └── Init.pm │ └── t │ │ └── init.t ├── char.pl ├── closure-opaque.pl ├── closure.c ├── closure.pl ├── color.c ├── color.pl ├── curl.pl ├── curl_callback.pl ├── file_handle.pl ├── file_handle.txt ├── list_integer_types.pl ├── malloc.pl ├── math.pl ├── notify.pl ├── notify.png ├── person.c ├── person.pl ├── pipe.pl ├── puts.pl ├── string_reverse.c ├── string_reverse.pl ├── swap.c ├── swap.pl ├── tcod.pl ├── time.pl ├── time_record.pl ├── time_struct.pl ├── var_array.c ├── var_array.pl ├── win32_beep.pl ├── win32_getSystemTime.pl ├── win32_messagebox.pl ├── win32_messagebox.png ├── xor_cipher.c ├── xor_cipher.pl └── zmq3.pl ├── ffi ├── constant.c ├── memory.c └── record_meta.c ├── inc ├── Alien │ ├── Base │ │ └── Wrapper.pm │ ├── FFI │ │ ├── PkgConfigPP.pm │ │ ├── Vcpkg.pm │ │ └── pkgconfig.pm │ └── psapi.pm ├── My │ ├── BuildConfig.pm │ ├── Config.pm │ ├── ConfigH.pm │ ├── ConfigPl.pm │ └── ShareConfig.pm ├── abi │ ├── abis-all.json │ └── compute-all.pl ├── bad-5100t.pl ├── bad-forks.pl ├── bad-oldperl.pl ├── mm-build.pl ├── mm-clean.pl ├── mm-config-pb.pl ├── mm-config-set.pl ├── mm-config.pl ├── mm-test.pl ├── mymm.pl ├── pdb └── probe │ ├── abi.c │ ├── alloca.c │ ├── bigendian.c │ ├── bigendian64.c │ ├── complex.c │ ├── longdouble.c │ ├── recordvalue.c │ ├── strnlen.c │ └── variadic.c ├── include ├── ffi_platypus.h ├── ffi_platypus_bundle.h ├── ffi_platypus_call.h ├── ffi_platypus_guts.h ├── libtest.h └── perl_math_int64.h ├── lib └── FFI │ ├── Build.pm │ ├── Build │ ├── File │ │ ├── Base.pm │ │ ├── C.pm │ │ ├── CXX.pm │ │ ├── Library.pm │ │ └── Object.pm │ ├── MM.pm │ ├── Platform.pm │ ├── Plugin.pm │ └── PluginData.pm │ ├── Platypus.pm │ ├── Platypus.xs │ ├── Platypus │ ├── API.pm │ ├── Buffer.pm │ ├── Bundle.pm │ ├── Closure.pm │ ├── Constant.pm │ ├── DL.pm │ ├── Function.pm │ ├── Internal.pm │ ├── Lang.pm │ ├── Lang │ │ ├── ASM.pm │ │ ├── C.pm │ │ └── Win32.pm │ ├── Legacy.pm │ ├── Memory.pm │ ├── Record.pm │ ├── Record │ │ ├── Meta.pm │ │ └── TieArray.pm │ ├── ShareConfig.pm │ ├── Type.pm │ ├── Type │ │ ├── PointerSizeBuffer.pm │ │ ├── StringArray.pm │ │ ├── StringPointer.pm │ │ └── WideString.pm │ ├── TypeParser.pm │ └── TypeParser │ │ ├── Version0.pm │ │ ├── Version1.pm │ │ └── Version2.pm │ ├── Probe.pm │ ├── Probe │ ├── Runner.pm │ └── Runner │ │ ├── Builder.pm │ │ └── Result.pm │ ├── Temp.pm │ └── typemap ├── maint ├── cip-before-install ├── cip-test-examples ├── generate-abw ├── generate-readme ├── generate-record-accessor ├── run-after_build.pl ├── run-before_build.pl └── tt │ ├── accessor.tt │ └── accessor_wrapper.tt ├── perlcriticrc ├── t ├── 00_diag.t ├── ffi │ ├── align.c │ ├── align_array.c │ ├── align_fixed.c │ ├── align_string.c │ ├── basic.c │ ├── closure.c │ ├── color.c │ ├── complex_double.c │ ├── complex_float.c │ ├── double.c │ ├── float.c │ ├── gh117.c │ ├── gh174.c │ ├── longdouble.c │ ├── memcmp4.c │ ├── meta.c │ ├── pointer.c │ ├── record.c │ ├── sint16.c │ ├── sint32.c │ ├── sint64.c │ ├── sint8.c │ ├── string.c │ ├── string_array.c │ ├── uint16.c │ ├── uint32.c │ ├── uint64.c │ ├── uint8.c │ └── variadic.c ├── ffi_build.t ├── ffi_build_file_base.t ├── ffi_build_file_c.t ├── ffi_build_file_cxx.t ├── ffi_build_file_library.t ├── ffi_build_file_object.t ├── ffi_build_mm.t ├── ffi_build_platform.t ├── ffi_build_plugin.t ├── ffi_build_plugindata.t ├── ffi_platypus.t ├── ffi_platypus_api.t ├── ffi_platypus_buffer.t ├── ffi_platypus_bundle.t ├── ffi_platypus_closure.t ├── ffi_platypus_constant.t ├── ffi_platypus_dl.t ├── ffi_platypus_function.t ├── ffi_platypus_function_wrapper.t ├── ffi_platypus_internal.t ├── ffi_platypus_lang.t ├── ffi_platypus_lang_asm.t ├── ffi_platypus_lang_c.t ├── ffi_platypus_lang_win32.t ├── ffi_platypus_legacy.t ├── ffi_platypus_memory.t ├── ffi_platypus_record.t ├── ffi_platypus_record_meta.t ├── ffi_platypus_record_tiearray.t ├── ffi_platypus_shareconfig.t ├── ffi_platypus_type.t ├── ffi_platypus_type_pointersizebuffer.t ├── ffi_platypus_type_stringarray.t ├── ffi_platypus_type_stringpointer.t ├── ffi_platypus_type_widestring.t ├── ffi_platypus_typeparser.t ├── ffi_platypus_typeparser_version0.t ├── ffi_platypus_typeparser_version1.t ├── ffi_platypus_typeparser_version2.t ├── ffi_probe.t ├── ffi_probe_runner.t ├── ffi_probe_runner_builder.t ├── ffi_probe_runner_result.t ├── ffi_temp.t ├── forks.t ├── gh117.t ├── gh129.t ├── gh323.t ├── lib │ └── Test │ │ ├── Cleanup.pm │ │ ├── FauxAttach.pm │ │ └── Platypus.pm ├── memory.t ├── threads.t ├── type_complex_double.t ├── type_complex_float.t ├── type_custom.t ├── type_double.t ├── type_float.t ├── type_longdouble.t ├── type_longdouble__array.t ├── type_longdouble__hide.t ├── type_longdouble__ptr.t ├── type_opaque.t ├── type_record.t ├── type_record_value.t ├── type_sint16.t ├── type_sint32.t ├── type_sint64.t ├── type_sint8.t ├── type_string.t ├── type_uint16.t ├── type_uint32.t ├── type_uint64.t └── type_uint8.t ├── xs ├── ABI.xs ├── API.xs ├── Buffer.xs ├── Closure.xs ├── ClosureData.xs ├── DL.xs ├── Function.xs ├── Internal.xs ├── Record.xs ├── Type.xs ├── TypeParser.xs ├── cast.c ├── closure.c ├── complex.c ├── custom.c ├── meta.c ├── names.c ├── perl_math_int64.c ├── record_opaque.c ├── record_simple.c ├── record_string.c └── windl.c └── xt └── author ├── critic.t ├── example.t └── pod_link.t /.cirrus.yml: -------------------------------------------------------------------------------- 1 | freebsd_instance: 2 | image: freebsd-13-0-release-amd64 3 | 4 | task: 5 | auto_cancellation: $CI != "true" 6 | install_script: 7 | - sudo tzsetup America/New_York 8 | - sudo pkg install -y p5-Dist-Zilla p5-App-cpanminus git libffi p5-Capture-Tiny p5-ExtUtils-MakeMaker p5-IPC-Cmd p5-ExtUtils-ParseXS pkgconf 9 | - sudo dzil authordeps --missing | cpanm -n 10 | - sudo dzil listdeps --missing | cpanm -n 11 | script: 12 | - dzil test -v 13 | 14 | -------------------------------------------------------------------------------- /.gitattributes: -------------------------------------------------------------------------------- 1 | *.pm linguist-language=Perl 2 | *.t linguist-language=Perl 3 | *.h linguist-language=C 4 | -------------------------------------------------------------------------------- /.github/workflows/macos.yml: -------------------------------------------------------------------------------- 1 | name: macos 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | env: 12 | PERL5LIB: /Users/runner/perl5/lib/perl5 13 | PERL_LOCAL_LIB_ROOT: /Users/runner/perl5 14 | PERL_MB_OPT: --install_base /Users/runner/perl5 15 | PERL_MM_OPT: INSTALL_BASE=/Users/runner/perl5 16 | 17 | jobs: 18 | perl: 19 | 20 | runs-on: macOS-latest 21 | 22 | steps: 23 | - uses: actions/checkout@v2 24 | 25 | - name: Set up Perl 26 | run: | 27 | brew install perl libffi libarchive jq 28 | curl https://cpanmin.us | perl - App::cpanminus -n 29 | echo "/Users/runner/perl5/bin" >> $GITHUB_PATH 30 | 31 | - name: perl -V 32 | run: perl -V 33 | 34 | - name: Prepare for cache 35 | run: | 36 | perl -V > perlversion.txt 37 | brew info --installed --json libffi | jq '.[] | select(.name=="libffi") | .versions' >> perlversion.txt 38 | ls -l perlversion.txt 39 | 40 | - name: Cache CPAN modules 41 | uses: actions/cache@v1 42 | with: 43 | path: ~/perl5 44 | key: ${{ runner.os }}-build-${{ hashFiles('perlversion.txt') }} 45 | restore-keys: | 46 | ${{ runner.os }}-build-${{ hashFiles('perlversion.txt') }} 47 | 48 | - name: Install Static Dependencies 49 | run: | 50 | cpanm -n Dist::Zilla 51 | dzil authordeps --missing | cpanm -n 52 | dzil listdeps --missing | cpanm -n 53 | 54 | - name: Install Dynamic Dependencies 55 | run: dzil run --no-build 'cpanm --installdeps .' 56 | 57 | - name: Run Tests 58 | run: dzil test -v 59 | 60 | - name: CPAN log 61 | if: ${{ failure() }} 62 | run: | 63 | cat ~/.cpanm/latest-build/build.log 64 | -------------------------------------------------------------------------------- /.github/workflows/msys2-mingw.yml: -------------------------------------------------------------------------------- 1 | name: msys2-mingw 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | env: 12 | PERL5LIB: /c/cx/lib/perl5:/c/cx/lib/perl5/MSWin32-x64-multi-thread 13 | PERL_LOCAL_LIB_ROOT: c:/cx 14 | PERL_MB_OPT: --install_base C:/cx 15 | PERL_MM_OPT: INSTALL_BASE=C:/cx 16 | ALIEN_BUILD_PLUGIN_PKGCONFIG_COMMANDLINE_TEST: 1 # Test Alien::Build::Plugin::PkgConfig::CommandLine 17 | 18 | jobs: 19 | perl: 20 | 21 | runs-on: windows-latest 22 | 23 | defaults: 24 | run: 25 | shell: msys2 {0} 26 | 27 | steps: 28 | - name: Set git to use LF 29 | run: | 30 | git config --global core.autocrlf false 31 | git config --global core.eol lf 32 | shell: powershell 33 | 34 | - uses: actions/checkout@v2 35 | 36 | - name: Set up Perl 37 | uses: msys2/setup-msys2@v2 38 | with: 39 | update: true 40 | install: >- 41 | base-devel 42 | mingw-w64-x86_64-toolchain 43 | mingw-w64-x86_64-perl 44 | mingw-w64-x86_64-libffi 45 | mingw-w64-x86_64-libarchive 46 | 47 | - name: perl -V 48 | run: | 49 | perl -V 50 | 51 | - name: Prepare for cache 52 | run: | 53 | perl -V > perlversion.txt 54 | ls perlversion.txt 55 | 56 | - name: Cache CPAN modules 57 | uses: actions/cache@v1 58 | with: 59 | path: c:\cx 60 | key: ${{ runner.os }}-build-msys2-${{ hashFiles('perlversion.txt') }} 61 | restore-keys: | 62 | ${{ runner.os }}-build-msys2-${{ hashFiles('perlversion.txt') }} 63 | 64 | - name: Install Static Dependencies 65 | run: | 66 | export PATH="/c/cx/bin:$PATH" 67 | yes | cpan App::cpanminus || true 68 | cpanm -n Dist::Zilla 69 | perl -S dzil authordeps --missing | perl -S cpanm -n 70 | perl -S dzil listdeps --missing | perl -S cpanm -n 71 | 72 | - name: Install Dynamic Dependencies 73 | run: | 74 | export PATH="/c/cx/bin:$PATH" 75 | perl -S dzil run --no-build 'perl -S cpanm --installdeps .' 76 | 77 | - name: Run Tests 78 | run: | 79 | export PATH="/c/cx/bin:$PATH" 80 | perl -S dzil test -v 81 | -------------------------------------------------------------------------------- /.github/workflows/static.yml: -------------------------------------------------------------------------------- 1 | name: static 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | jobs: 12 | perl: 13 | 14 | runs-on: ubuntu-latest 15 | 16 | env: 17 | CIP_TAG: static 18 | 19 | steps: 20 | - uses: actions/checkout@v2 21 | 22 | - name: Bootstrap CIP 23 | run: | 24 | curl -L https://raw.githubusercontent.com/uperl/cip/main/bin/github-bootstrap | bash 25 | 26 | - name: Build + Test 27 | run: | 28 | cip script 29 | -------------------------------------------------------------------------------- /.github/workflows/windows.yml: -------------------------------------------------------------------------------- 1 | name: windows 2 | 3 | on: 4 | push: 5 | branches: 6 | - '*' 7 | tags-ignore: 8 | - '*' 9 | pull_request: 10 | 11 | env: 12 | PERL5LIB: c:\cx\lib\perl5 13 | PERL_LOCAL_LIB_ROOT: c:/cx 14 | PERL_MB_OPT: --install_base C:/cx 15 | PERL_MM_OPT: INSTALL_BASE=C:/cx 16 | 17 | jobs: 18 | perl: 19 | 20 | runs-on: windows-latest 21 | 22 | steps: 23 | - name: Set git to use LF 24 | run: | 25 | git config --global core.autocrlf false 26 | git config --global core.eol lf 27 | 28 | - uses: actions/checkout@v2 29 | 30 | - name: Set up Perl 31 | run: | 32 | choco install strawberryperl 33 | echo "C:\cx\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 34 | echo "C:\strawberry\c\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 35 | echo "C:\strawberry\perl\site\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 36 | echo "C:\strawberry\perl\bin" | Out-File -FilePath $env:GITHUB_PATH -Encoding utf8 -Append 37 | 38 | - name: perl -V 39 | run: | 40 | perl -V 41 | 42 | - name: Prepare for cache 43 | run: | 44 | perl -V > perlversion.txt 45 | dir perlversion.txt 46 | 47 | - name: Cache CPAN modules 48 | uses: actions/cache@v1 49 | with: 50 | path: c:\cx 51 | key: ${{ runner.os }}-build-${{ hashFiles('perlversion.txt') }} 52 | restore-keys: | 53 | ${{ runner.os }}-build-${{ hashFiles('perlversion.txt') }} 54 | 55 | - name: Install Static Dependencies 56 | run: | 57 | cpanm -n Dist::Zilla 58 | dzil authordeps --missing | cpanm -n 59 | dzil listdeps --missing | cpanm -n 60 | - name: Install Dynamic Dependencies 61 | run: | 62 | dzil run --no-build 'cpanm --installdeps .' 63 | - name: Run Tests 64 | run: dzil test -v 65 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /META.yml 2 | /META.json 3 | /MYMETA.* 4 | /blib 5 | /FFI-Platypus-* 6 | /.build 7 | /config.log 8 | /lib/FFI/Platypus.c 9 | /include/ffi_platypus_config.h 10 | /include/ppport.h 11 | /test*.c 12 | *.o 13 | *.obj 14 | *.dll 15 | *.dylib 16 | *.so 17 | *.bundle 18 | *.tmp 19 | *.core 20 | *.old 21 | core 22 | /inc/probe/bigendian 23 | /inc/probe/bigendian64 24 | /inc/probe/complex 25 | /inc/probe/longdouble 26 | /inc/probe/abi 27 | /inc/probe/*.exe 28 | *.exp 29 | *.lib 30 | *.pdb 31 | *.swp 32 | /_mm 33 | /pm_to_blib 34 | /Makefile 35 | *.bs 36 | *.def 37 | /test-* 38 | tmpbuild.* 39 | /ffi-probe-* 40 | /.tmp 41 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/.gitmodules -------------------------------------------------------------------------------- /.yath.rc: -------------------------------------------------------------------------------- 1 | [test] 2 | -j 5 3 | --no-unsafe-inc 4 | --qvf 5 | 6 | -------------------------------------------------------------------------------- /Changes.FFI-Build: -------------------------------------------------------------------------------- 1 | Revision history for {{$dist->name}} 2 | 3 | After 0.12 FFI-Build was merged with FFI-Platypus 4 | 5 | 0.12 2019-01-06 10:23:17 -0500 6 | - Make FFI::Platypus an optional testing dependency 7 | (previously it was a required dependency for testing 8 | only). 9 | 10 | 0.11 2018-12-20 21:55:50 -0700 11 | - Require EUMM 7.24 for fixes in testing 12 | 13 | 0.10 2018-12-20 17:51:17 -0700 14 | - Fix bug where build aliens were used 15 | for test only build 16 | 17 | 0.09 2018-08-28 10:50:27 -0400 18 | - Additional test diagnostics 19 | 20 | 0.08 2018-08-28 09:58:19 -0400 21 | - Same workaroudn for linkers with space 22 | 23 | 0.07 2018-08-20 10:52:27 -0400 24 | - Workaround for compilers with space 25 | 26 | 0.06 2018-08-20 08:57:30 -0400 27 | - Fix test 28 | 29 | 0.05 2018-08-20 05:17:36 -0400 30 | - Removed FFI::Build::File::Fortran, which is now part of the 31 | FFI-Platypus-Lang-Fortran dist 32 | 33 | 0.04 2018-08-19 12:56:54 -0400 34 | - When `cc -MM` or `c++ -MM` fails for computing dependencies, fall back 35 | on just the .c file being the dependency. 36 | 37 | 0.03 2018-08-16 04:03:09 -0400 38 | - Fix for test failure on cygwin + MSWin32 39 | - Additional diagnostics for Fortran build test 40 | 41 | 0.02 2018-08-09 04:54:30 -0400 42 | - initial version 43 | -------------------------------------------------------------------------------- /Changes.FFI-Platypus-Type-StringArray: -------------------------------------------------------------------------------- 1 | Revision history for FFI-Platypus-Type-StringArray 2 | 3 | After 0.02 FFI-Platypus-Type-StringArray was merged with FFI-Platypus 4 | 5 | 0.02 2018-07-28 21:34:16 -0400 6 | - Add support as a return type. 7 | 8 | 0.01 2015-01-23 16:50:47 -0500 9 | - initial version 10 | -------------------------------------------------------------------------------- /SUPPORT: -------------------------------------------------------------------------------- 1 | SUPPORT 2 | 3 | The intent of the FFI-Platypus team is to support the same versions of 4 | Perl that are supported by the Perl toolchain. As of this writing that 5 | means 5.16 and better. 6 | 7 | IRC: #native on irc.perl.org 8 | 9 | (click for instant chat room login) 10 | 11 | 12 | If something does not work the way you think it should, or if you have 13 | a feature request, please open an issue on this project's GitHub Issue 14 | tracker: 15 | 16 | https://github.com/perlFFI/FFI-Platypus/issues 17 | 18 | -------------------------------------------------------------------------------- /corpus/ffi_build/project-cxx/foo1.cxx: -------------------------------------------------------------------------------- 1 | class Foo { 2 | public: 3 | int answer() { return 42; }; 4 | }; 5 | 6 | extern "C" int 7 | foo1() 8 | { 9 | Foo foo; 10 | return foo.answer(); 11 | } 12 | -------------------------------------------------------------------------------- /corpus/ffi_build/project-cxx/foo2.cpp: -------------------------------------------------------------------------------- 1 | // This requires C++11 (I believe) 2 | // TODO: support older c++ compilers. 3 | #include 4 | 5 | class Foo2 { 6 | public: 7 | const char *answer() { return "42"; }; 8 | }; 9 | 10 | extern "C" const char * 11 | foo2() 12 | { 13 | Foo2 foo; 14 | return foo.answer(); 15 | } 16 | 17 | extern "C" void 18 | not_to_call_just_to_pull_in_the_stdcpp() 19 | { 20 | std::cout << "Hello There" << std::endl; 21 | } 22 | -------------------------------------------------------------------------------- /corpus/ffi_build/project1/foo1.c: -------------------------------------------------------------------------------- 1 | #ifdef _MSC_VER 2 | #define EXPORT __declspec(dllexport) 3 | #else 4 | #define EXPORT 5 | #endif 6 | 7 | EXPORT 8 | int 9 | foo1() 10 | { 11 | return 42; 12 | } 13 | -------------------------------------------------------------------------------- /corpus/ffi_build/project1/foo2.c: -------------------------------------------------------------------------------- 1 | #ifdef _MSC_VER 2 | #define EXPORT __declspec(dllexport) 3 | #else 4 | #define EXPORT 5 | #endif 6 | 7 | EXPORT 8 | const char * 9 | foo2() 10 | { 11 | return "42"; 12 | } 13 | -------------------------------------------------------------------------------- /corpus/ffi_build/project2/bar.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int myanswer() 4 | { 5 | return answer(); 6 | } 7 | -------------------------------------------------------------------------------- /corpus/ffi_build/source/foo.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build/source/foo.c -------------------------------------------------------------------------------- /corpus/ffi_build_file_base/basic.foo: -------------------------------------------------------------------------------- 1 | This is a basic foo. 2 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_c/basic.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int 4 | main(int argc, char *argv[]) 5 | { 6 | return 0; 7 | } 8 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_c/foo1.c: -------------------------------------------------------------------------------- 1 | int 2 | foo1() 3 | { 4 | return 42; 5 | } 6 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_c/foo2.c: -------------------------------------------------------------------------------- 1 | #include 2 | int 3 | foo1() 4 | { 5 | return 42; 6 | } 7 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_c/include/myfoo.h: -------------------------------------------------------------------------------- 1 | #ifndef MYFOO_H 2 | #define MYFOO_H 3 | 4 | /* this doesn't do anything apparently */ 5 | 6 | #endif 7 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_cxx/basic.cxx: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int 4 | main(int argc, char *argv[]) 5 | { 6 | cout << "hello world" << endl; 7 | return 0; 8 | } 9 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_cxx/foo1.cxx: -------------------------------------------------------------------------------- 1 | class Foo { 2 | public: 3 | int answer() { return 42; }; 4 | }; 5 | 6 | int 7 | foo1() 8 | { 9 | // comment 10 | Foo foo; 11 | return foo.answer(); 12 | } 13 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_cxx/foo2.cpp: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | class Foo { 4 | public: 5 | int answer() { return 42; }; 6 | }; 7 | 8 | int 9 | foo1() 10 | { 11 | // comment 12 | return 42; 13 | } 14 | -------------------------------------------------------------------------------- /corpus/ffi_build_file_cxx/include/myfoo.h: -------------------------------------------------------------------------------- 1 | #ifndef MYFOO_H 2 | #define MYFOO_H 3 | 4 | /* this doesn't do anything apparently */ 5 | 6 | #endif 7 | -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1/hello.fbx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | our $DIR; 5 | our $PLATFORM; 6 | die unless $PLATFORM->isa('FFI::Build::Platform'); 7 | 8 | { source => [ "$DIR/*.c" ] }; 9 | -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1/hello1.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb1/hello1.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1/hello2.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb1/hello2.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1bad/hello.fbx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | skootch skootch; 4 | our $DIR; 5 | our $PLATFORM; 6 | die unless $PLATFORM->isa('FFI::Build::Platform'); 7 | 8 | { source => [ "$DIR/*.c" ] }; 9 | -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1bad/hello1.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb1bad/hello1.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb1bad/hello2.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb1bad/hello2.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb2/hello1.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb2/hello1.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/lb2/hello2.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/lb2/hello2.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/ffi/x.c: -------------------------------------------------------------------------------- 1 | #ifdef _MSC_VER 2 | #define EXPORT __declspec(dllexport) 3 | #else 4 | #define EXPORT 5 | #endif 6 | 7 | EXPORT 8 | int 9 | frooble_runtime() 10 | { 11 | return 47; 12 | } 13 | -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/ffi/y.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/project1/ffi/y.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/ffi/z.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/project1/ffi/z.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/t/ffi/a.c: -------------------------------------------------------------------------------- 1 | #ifdef _MSC_VER 2 | #define EXPORT __declspec(dllexport) 3 | #else 4 | #define EXPORT 5 | #endif 6 | 7 | EXPORT 8 | int 9 | frooble_test() 10 | { 11 | return 50; 12 | } 13 | -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/t/ffi/b.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/project1/t/ffi/b.c -------------------------------------------------------------------------------- /corpus/ffi_build_mm/project1/t/ffi/c.c: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/corpus/ffi_build_mm/project1/t/ffi/c.c -------------------------------------------------------------------------------- /corpus/ffi_build_plugin/lib1/FFI/Build/Plugin/blank.txt: -------------------------------------------------------------------------------- 1 | 2 | -------------------------------------------------------------------------------- /corpus/ffi_build_plugin/lib2/FFI/Build/Plugin/Foo1.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::Plugin::Foo1; 2 | 3 | use strict; 4 | use warnings; 5 | use constant api_version => 0; 6 | 7 | sub new 8 | { 9 | my($class) = @_; 10 | bless {}, $class; 11 | } 12 | 13 | sub bar 14 | { 15 | my($self, @args) = @_; 16 | $self->{bar} = \@args; 17 | } 18 | 19 | 1; 20 | -------------------------------------------------------------------------------- /corpus/ffi_build_plugin/lib2/FFI/Build/Plugin/Foo2.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::Plugin::Foo2; 2 | 3 | use strict; 4 | use warnings; 5 | use constant api_version => 0; 6 | 7 | sub new 8 | { 9 | my($class) = @_; 10 | bless {}, $class; 11 | } 12 | 13 | 1; 14 | -------------------------------------------------------------------------------- /corpus/ffi_probe_runner/bar.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int 4 | dlmain(int argc, char *argv[]) 5 | { 6 | int i; 7 | printf("argc=%d\n", argc); 8 | for(i=0;i 2 | 3 | int 4 | dlmain(int argc, char *argv[]) 5 | { 6 | int i; 7 | printf("argc=%d\n", argc); 8 | for(i=0;i 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { "${_}[2]" } ( 'float', 'double', 'longdouble', 7 | map { ( "sint$_" , "uint$_" ) } 8 | qw( 8 16 32 64 )); 9 | 10 | foreach my $type (@types) 11 | { 12 | subtest $type => sub { 13 | my $ffi = FFI::Platypus->new; 14 | my $f = $ffi->function(0 => [ $type ] => 'void' ); 15 | no_leaks_ok { 16 | my @a = (1,2); 17 | $f->call(\@a) 18 | }; 19 | } 20 | } 21 | 22 | subtest 'opaque' => sub { 23 | my $ffi = FFI::Platypus->new( lib => [undef] ); 24 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 25 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 26 | my $ptr = $malloc->call(200); 27 | my $f = $ffi->function(0 => [ 'opaque[2]' ] => 'void' ); 28 | 29 | my @a = ($ptr, undef); 30 | no_leaks_ok { $f->call(\@a) }; 31 | $free->call($ptr); 32 | }; 33 | 34 | subtest 'string' => sub { 35 | my $ffi = FFI::Platypus->new; 36 | my $f = $ffi->function(0 => [ 'string[2]' ] => 'void' ); 37 | 38 | my @a = ("hello world", undef); 39 | no_leaks_ok { $f->call(\@a) }; 40 | }; 41 | 42 | subtest 'complex' => sub { 43 | 44 | foreach my $type (qw( complex_float[2] complex_double[2] )) 45 | { 46 | subtest $type => sub { 47 | my $ffi = FFI::Platypus->new; 48 | my $f = $ffi->function(0 => [ $type ] => 'void' ); 49 | 50 | { 51 | my @c = ([1.0,2.0],[3.0,4.0]); 52 | no_leaks_ok { $f->call(\@c) }; 53 | } 54 | 55 | { 56 | my @c = (Math::Complex->make(1.0,2.0),Math::Complex->make(3.0,4.0)); 57 | no_leaks_ok { $f->call(\@c) }; 58 | } 59 | }; 60 | } 61 | 62 | }; 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /corpus/memory/arg_custom.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { "$_" } ( 'float', 'double', 7 | map { ( "sint$_" , "uint$_" ) } 8 | qw( 8 16 32 64 )); 9 | 10 | foreach my $type (@types) 11 | { 12 | subtest $type => sub { 13 | my $ffi = FFI::Platypus->new; 14 | $ffi->custom_type( foo_t => { 15 | native_type => $type, 16 | native_to_perl => sub { $_[0] }, 17 | perl_to_native => sub { $_[0] }, 18 | perl_to_native_post => sub { $_[0] }, 19 | }); 20 | my $f = $ffi->function(0 => [ "foo_t" ] => 'void' ); 21 | no_leaks_ok { $f->call(129) }; 22 | } 23 | } 24 | 25 | subtest 'opaque' => sub { 26 | my $ffi = FFI::Platypus->new( lib => [undef] ); 27 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 28 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 29 | my $ptr = $malloc->call(200); 30 | 31 | $ffi->custom_type( foo_t => { 32 | native_type => 'opaque', 33 | native_to_perl => sub { $_[0] }, 34 | perl_to_native => sub { $_[0] }, 35 | perl_to_native_post => sub { $_[0] }, 36 | }); 37 | 38 | my $f = $ffi->function(0 => [ 'foo_t' ] => 'void' ); 39 | 40 | no_leaks_ok { $f->call($ptr) }; 41 | $free->call($ptr); 42 | no_leaks_ok { $f->call(undef) }; 43 | }; 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /corpus/memory/arg_object.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { ( "sint$_" , "uint$_" ) } 7 | qw( 8 16 32 64 ); 8 | 9 | { 10 | package Foo; 11 | 12 | sub new 13 | { 14 | my($class, $arg) = @_; 15 | bless \$arg, $class; 16 | } 17 | } 18 | 19 | foreach my $type (@types) 20 | { 21 | subtest $type => sub { 22 | my $ffi = FFI::Platypus->new( api => 1 ); 23 | my $f = $ffi->function(0 => [ "object(Foo,$type)" ] => 'void' ); 24 | my $foo = Foo->new(129); 25 | no_leaks_ok { $f->call($foo) }; 26 | } 27 | } 28 | 29 | subtest 'opaque' => sub { 30 | my $ffi = FFI::Platypus->new( api => 1, lib => [undef] ); 31 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 32 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 33 | my $ptr = $malloc->call(200); 34 | my $f = $ffi->function(0 => [ 'object(Foo)' ] => 'void' ); 35 | 36 | my $foo1 = Foo->new($ptr); 37 | 38 | no_leaks_ok { $f->call($foo1) }; 39 | $free->call($ptr); 40 | 41 | my $foo2 = Foo->new(undef); 42 | no_leaks_ok { $f->call($foo2) }; 43 | }; 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /corpus/memory/arg_pointer.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { "$_*" } ( 'float', 'double', 'longdouble', 7 | map { ( "sint$_" , "uint$_" ) } 8 | qw( 8 16 32 64 )); 9 | 10 | foreach my $type (@types) 11 | { 12 | subtest $type => sub { 13 | my $ffi = FFI::Platypus->new; 14 | my $f = $ffi->function(0 => [ $type ] => 'void' ); 15 | no_leaks_ok { 16 | my $val = 129; 17 | $f->call(\$val) 18 | }; 19 | no_leaks_ok { $f->call(undef) }; 20 | } 21 | } 22 | 23 | subtest 'opaque' => sub { 24 | my $ffi = FFI::Platypus->new( lib => [undef] ); 25 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 26 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 27 | my $ptr = $malloc->call(200); 28 | my $f = $ffi->function(0 => [ 'opaque*' ] => 'void' ); 29 | 30 | no_leaks_ok { $f->call(\$ptr) }; 31 | $free->call($ptr); 32 | no_leaks_ok { $f->call(undef) }; 33 | }; 34 | 35 | subtest 'string' => sub { 36 | my $ffi = FFI::Platypus->new; 37 | my $f = $ffi->function(0 => [ 'string*' ] => 'void' ); 38 | no_leaks_ok { $f->call(\"hello world") }; 39 | my $str = "hello world"; 40 | no_leaks_ok { $f->call(\$str) }; 41 | no_leaks_ok { $f->call(undef) }; 42 | }; 43 | 44 | subtest 'complex' => sub { 45 | 46 | foreach my $type (qw( complex_float* complex_double* )) 47 | { 48 | subtest $type => sub { 49 | my $ffi = FFI::Platypus->new; 50 | my $f = $ffi->function(0 => [ $type ] => 'void' ); 51 | 52 | { 53 | my $c = [1.0,2.0]; 54 | no_leaks_ok { $f->call(\$c) }; 55 | } 56 | 57 | { 58 | my $c = Math::Complex->make(1.0,2.0); 59 | no_leaks_ok { $f->call(\$c) }; 60 | } 61 | no_leaks_ok { $f->call(undef) }; 62 | }; 63 | } 64 | 65 | }; 66 | 67 | done_testing; 68 | -------------------------------------------------------------------------------- /corpus/memory/attach.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus; 4 | use FFI::CheckLib qw( find_lib ); 5 | 6 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 7 | 8 | my $ffi = FFI::Platypus->new(); 9 | $ffi->lib( $libtest ); 10 | $ffi->type('()->void' => 'callback_t'); 11 | $ffi->attach( gh174_func1 => [ 'callback_t' ] => 'void' ); 12 | my $callback = $ffi->closure( 13 | sub { print "Perl callback()\n" } 14 | ); 15 | gh174_func1( $callback ); 16 | -------------------------------------------------------------------------------- /corpus/memory/empty.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | print "nada\n"; 5 | -------------------------------------------------------------------------------- /corpus/memory/function.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus; 4 | use FFI::CheckLib qw( find_lib ); 5 | 6 | { 7 | 8 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 9 | 10 | my $ffi = FFI::Platypus->new(); 11 | $ffi->lib( $libtest ); 12 | $ffi->type('()->void' => 'callback_t'); 13 | my $gh174_func1 = $ffi->function( gh174_func1 => [ 'callback_t' ] => 'void' ); 14 | my $callback = $ffi->closure( 15 | sub { print "Perl callback()\n" } 16 | ); 17 | $gh174_func1->call( $callback ); 18 | } 19 | -------------------------------------------------------------------------------- /corpus/memory/return_custom.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { "$_" } ( 'float', 'double', 7 | map { ( "sint$_" , "uint$_" ) } 8 | qw( 8 16 32 64 )); 9 | 10 | foreach my $type (@types) 11 | { 12 | subtest $type => sub { 13 | my $ffi = FFI::Platypus->new; 14 | $ffi->custom_type( foo_t => { 15 | native_type => $type, 16 | native_to_perl => sub { $_[0] }, 17 | perl_to_native => sub { $_[0] }, 18 | perl_to_native_post => sub { $_[0] }, 19 | }); 20 | my $f = $ffi->function(0 => [ "foo_t" ] => 'foo_t' ); 21 | no_leaks_ok { $f->call(129) }; 22 | } 23 | } 24 | 25 | subtest 'opaque' => sub { 26 | my $ffi = FFI::Platypus->new( lib => [undef] ); 27 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 28 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 29 | my $ptr = $malloc->call(200); 30 | 31 | $ffi->custom_type( foo_t => { 32 | native_type => 'opaque', 33 | native_to_perl => sub { $_[0] }, 34 | perl_to_native => sub { $_[0] }, 35 | perl_to_native_post => sub { $_[0] }, 36 | }); 37 | 38 | my $f = $ffi->function(0 => [ 'foo_t' ] => 'foo_t' ); 39 | 40 | no_leaks_ok { $f->call($ptr) }; 41 | $free->call($ptr); 42 | no_leaks_ok { $f->call(undef) }; 43 | }; 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /corpus/memory/return_object.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use Math::Complex; 4 | use Test::LeakTrace qw( no_leaks_ok ); 5 | 6 | my @types = map { ( "sint$_" , "uint$_" ) } 7 | qw( 8 16 32 64 ); 8 | 9 | { 10 | package Foo; 11 | 12 | sub new 13 | { 14 | my($class, $arg) = @_; 15 | bless \$arg, $class; 16 | } 17 | } 18 | 19 | foreach my $type (@types) 20 | { 21 | subtest $type => sub { 22 | my $ffi = FFI::Platypus->new( api => 1 ); 23 | my $f = $ffi->function(0 => [] => "object(Foo,$type)" ); 24 | no_leaks_ok { $f->call }; 25 | } 26 | } 27 | 28 | subtest 'opaque' => sub { 29 | my $ffi = FFI::Platypus->new( api => 1, lib => [undef] ); 30 | my $malloc = $ffi->function( malloc => [ 'size_t' ] => 'opaque' ); 31 | my $free = $ffi->function( free => [ 'opaque' ] => 'void' ); 32 | my $ptr = $malloc->call(200); 33 | my $f = $ffi->function(0 => [ 'object(Foo)' ] => 'object(Foo)' ); 34 | 35 | my $foo1 = Foo->new($ptr); 36 | 37 | no_leaks_ok { $f->call($foo1) }; 38 | $free->call($ptr); 39 | 40 | my $foo2 = Foo->new(undef); 41 | no_leaks_ok { $f->call($foo2) }; 42 | }; 43 | 44 | done_testing; 45 | -------------------------------------------------------------------------------- /corpus/memory/return_pointer.pl: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use lib 't/lib'; 3 | use Test::FauxAttach; 4 | use FFI::Platypus; 5 | use Test::LeakTrace qw( no_leaks_ok ); 6 | use FFI::Platypus::Memory qw( malloc free memset strdup ); 7 | 8 | my $ptr = malloc(400); 9 | memset($ptr, 0, 400); 10 | 11 | my @types = map { "$_*" } ( 'float', 'double', 'longdouble', 12 | map { ( "sint$_" , "uint$_" ) } 13 | qw( 8 16 32 64 )); 14 | 15 | foreach my $type (@types) 16 | { 17 | subtest $type => sub { 18 | my $ffi = FFI::Platypus->new; 19 | my $f = $ffi->function(0 => [ 'opaque' ] => $type ); 20 | no_leaks_ok { $f->call($ptr) }; 21 | no_leaks_ok { $f->call(undef) }; 22 | } 23 | } 24 | 25 | subtest 'opaque' => sub { 26 | my $ffi = FFI::Platypus->new; 27 | my $f = $ffi->function(0 => [ 'opaque' ] => 'opaque*' ); 28 | 29 | no_leaks_ok { $f->call($ptr) }; 30 | no_leaks_ok { $f->call(undef) }; 31 | 32 | my $f2 = $ffi->function(0 => [ 'opaque*' ] => 'opaque*' ); 33 | no_leaks_ok { $f2->call(\$ptr) }; 34 | }; 35 | 36 | subtest 'string' => sub { 37 | my $ffi = FFI::Platypus->new; 38 | my $f = $ffi->function(0 => [ 'opaque' ] => 'string*' ); 39 | 40 | my $ptr = strdup("hello world"); 41 | 42 | no_leaks_ok { $f->call($ptr) }; 43 | no_leaks_ok { $f->call(undef) }; 44 | 45 | free $ptr; 46 | }; 47 | 48 | subtest 'complex' => sub { 49 | 50 | foreach my $type (qw( complex_float* complex_double* )) 51 | { 52 | subtest $type => sub { 53 | my $ffi = FFI::Platypus->new; 54 | my $f = $ffi->function(0 => [ 'opaque' ] => $type ); 55 | 56 | no_leaks_ok { $f->call($ptr) }; 57 | }; 58 | } 59 | 60 | }; 61 | 62 | free $ptr; 63 | 64 | done_testing; 65 | -------------------------------------------------------------------------------- /corpus/memory/supp/basic_type_cache.supp: -------------------------------------------------------------------------------- 1 | { 2 | 3 | Memcheck:Leak 4 | match-leak-kinds: definite 5 | fun:malloc 6 | fun:Perl_safesysmalloc 7 | fun:ffi_pl_type_new 8 | fun:XS_FFI__Platypus__TypeParser_create_type_* 9 | fun:Perl_pp_entersub 10 | ... 11 | } 12 | -------------------------------------------------------------------------------- /examples/add.c: -------------------------------------------------------------------------------- 1 | int add(int a, int b) { 2 | return a+b; 3 | } 4 | -------------------------------------------------------------------------------- /examples/add.pl: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | use FFI::CheckLib qw( find_lib_or_die ); 7 | use File::Basename qw( dirname ); 8 | 9 | my $ffi = FFI::Platypus->new( api => 2, lib => './add.so' ); 10 | $ffi->attach( add => ['int', 'int'] => 'int' ); 11 | 12 | print add(1,2), "\n"; # prints 3 13 | -------------------------------------------------------------------------------- /examples/array_reverse.c: -------------------------------------------------------------------------------- 1 | void 2 | array_reverse(int a[], int len) { 3 | int tmp, i; 4 | 5 | for(i=0; i < len/2; i++) { 6 | tmp = a[i]; 7 | a[i] = a[len-i-1]; 8 | a[len-i-1] = tmp; 9 | } 10 | } 11 | 12 | void 13 | array_reverse10(int a[10]) { 14 | array_reverse(a, 10); 15 | } 16 | -------------------------------------------------------------------------------- /examples/array_reverse.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './array_reverse.so', 8 | ); 9 | 10 | $ffi->attach( array_reverse => ['int[]','int'] ); 11 | $ffi->attach( array_reverse10 => ['int[10]'] ); 12 | 13 | my @a = (1..10); 14 | array_reverse10( \@a ); 15 | print "$_ " for @a; 16 | print "\n"; 17 | 18 | @a = (1..20); 19 | array_reverse( \@a, 20 ); 20 | print "$_ " for @a; 21 | print "\n"; 22 | -------------------------------------------------------------------------------- /examples/array_sum.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | int 4 | array_sum(const int *a) { 5 | int i, sum; 6 | if(a == NULL) 7 | return -1; 8 | for(i=0, sum=0; a[i] != 0; i++) 9 | sum += a[i]; 10 | return sum; 11 | } 12 | -------------------------------------------------------------------------------- /examples/array_sum.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './array_sum.so', 8 | ); 9 | 10 | $ffi->attach( array_sum => ['int*'] => 'int' ); 11 | 12 | print array_sum(undef), "\n"; # -1 13 | print array_sum([0]), "\n"; # 0 14 | print array_sum([1,2,3,0]), "\n"; # 6 15 | -------------------------------------------------------------------------------- /examples/bundle-answer/.gitignore: -------------------------------------------------------------------------------- 1 | /ffi/_build 2 | -------------------------------------------------------------------------------- /examples/bundle-answer/ffi/answer.c: -------------------------------------------------------------------------------- 1 | int 2 | answer(void) 3 | { 4 | /* the answer to life the universe and everything */ 5 | return 42; 6 | } 7 | -------------------------------------------------------------------------------- /examples/bundle-answer/ffi/answer.fbx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | our $DIR; 5 | 6 | return { 7 | cflags => "-I/include", 8 | source => "$DIR/*.c", 9 | } 10 | -------------------------------------------------------------------------------- /examples/bundle-answer/include/answer.h: -------------------------------------------------------------------------------- 1 | #ifndef ANSWER_H 2 | #define ANSWER_H 3 | 4 | int answer(void); 5 | 6 | #endif 7 | -------------------------------------------------------------------------------- /examples/bundle-answer/lib/Answer.pm: -------------------------------------------------------------------------------- 1 | package Answer; 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | use Exporter qw( import ); 7 | 8 | our @EXPORT = qw( answer ); 9 | 10 | my $ffi = FFI::Platypus->new( api => 2 ); 11 | $ffi->bundle; 12 | $ffi->attach( answer => [] => 'int' ); 13 | 14 | 1; 15 | -------------------------------------------------------------------------------- /examples/bundle-answer/t/answer.t: -------------------------------------------------------------------------------- 1 | use Test2::V0; 2 | use Answer; 3 | 4 | is(answer(), 42); 5 | 6 | done_testing; 7 | -------------------------------------------------------------------------------- /examples/bundle-bzip2/.gitignore: -------------------------------------------------------------------------------- 1 | /ffi/_build 2 | -------------------------------------------------------------------------------- /examples/bundle-bzip2/ffi/bz2.fbx: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | { 5 | alien => ['Alien::Libbz2'], 6 | source => ['ffi/*.c'], 7 | }; 8 | -------------------------------------------------------------------------------- /examples/bundle-bzip2/ffi/compress.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | int 5 | bzip2__new(bz_stream **stream, int blockSize100k, int verbosity, int workFactor ) 6 | { 7 | *stream = malloc(sizeof(bz_stream)); 8 | (*stream)->bzalloc = NULL; 9 | (*stream)->bzfree = NULL; 10 | (*stream)->opaque = NULL; 11 | 12 | return BZ2_bzCompressInit(*stream, blockSize100k, verbosity, workFactor ); 13 | } 14 | -------------------------------------------------------------------------------- /examples/bundle-bzip2/lib/Bzip2.pm: -------------------------------------------------------------------------------- 1 | package Bzip2; 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | use FFI::Platypus::Memory qw( free ); 7 | 8 | my $ffi = FFI::Platypus->new( api => 2 ); 9 | $ffi->bundle; 10 | 11 | $ffi->mangler(sub { 12 | my $name = shift; 13 | $name =~ s/^/bzip2__/ unless $name =~ /^BZ2_/; 14 | $name; 15 | }); 16 | 17 | =head2 new 18 | 19 | my $bzip2 = Bzip2->new($block_size_100k, $verbosity, $work_flow); 20 | 21 | =cut 22 | 23 | $ffi->attach( new => ['opaque*', 'int', 'int', 'int'] => 'int' => sub { 24 | my $xsub = shift; 25 | my $class = shift; 26 | my $ptr; 27 | my $ret = $xsub->(\$ptr, @_); 28 | return bless \$ptr, $class; 29 | }); 30 | 31 | $ffi->attach( [ BZ2_bzCompressEnd => 'DESTROY' ] => ['opaque'] => 'int' => sub { 32 | my $xsub = shift; 33 | my $self = shift; 34 | my $ret = $xsub->($$self); 35 | free $$self; 36 | }); 37 | 38 | 1; 39 | -------------------------------------------------------------------------------- /examples/bundle-bzip2/t/bzip2.t: -------------------------------------------------------------------------------- 1 | use Test2::V0; 2 | use Bzip2; 3 | 4 | subtest 'compress' => sub { 5 | my $bzip2 = Bzip2->new; 6 | isa_ok $bzip2, 'Bzip2'; 7 | }; 8 | 9 | done_testing; 10 | -------------------------------------------------------------------------------- /examples/bundle-const/ffi/const.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include "myheader.h" 3 | 4 | void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *c) 5 | { 6 | c->set_str("MYVERSION_STRING", MYVERSION_STRING); 7 | c->set_uint("MYVERSION_MAJOR", MYVERSION_MAJOR); 8 | c->set_uint("MYVERSION_MINOR", MYVERSION_MINOR); 9 | c->set_uint("MYVERSION_PATCH", MYVERSION_PATCH); 10 | c->set_sint("MYBAD", MYBAD); 11 | c->set_sint("MYOK", MYOK); 12 | c->set_double("MYPI", MYPI); 13 | } 14 | -------------------------------------------------------------------------------- /examples/bundle-const/ffi/myheader.h: -------------------------------------------------------------------------------- 1 | #ifndef MYHEADER_H 2 | #define MYHEADER_H 3 | 4 | #define MYVERSION_STRING "1.2.3" 5 | #define MYVERSION_MAJOR 1 6 | #define MYVERSION_MINOR 2 7 | #define MYVERSION_PATCH 3 8 | 9 | enum { 10 | MYBAD = -1, 11 | MYOK = 1 12 | }; 13 | 14 | #define MYPI 3.14 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /examples/bundle-const/lib/Const.pm: -------------------------------------------------------------------------------- 1 | package Const; 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | 7 | { 8 | my $ffi = FFI::Platypus->new( api => 2 ); 9 | $ffi->bundle; 10 | } 11 | 12 | 1; 13 | -------------------------------------------------------------------------------- /examples/bundle-const/t/const.t: -------------------------------------------------------------------------------- 1 | use Test2::V0; 2 | use Const; 3 | 4 | foreach my $name (sort keys %Const::) 5 | { 6 | next unless $name =~ /^MY/; 7 | note "$name=@{[ Const->$name ]}"; 8 | } 9 | 10 | ok 1; 11 | 12 | done_testing; 13 | -------------------------------------------------------------------------------- /examples/bundle-foo/Makefile.PL: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use ExtUtils::MakeMaker; 4 | use FFI::Build::MM; 5 | my $fbmm = FFI::Build::MM->new; 6 | WriteMakefile( 7 | $fbmm->mm_args( 8 | NAME => 'Foo', 9 | DISTNAME => 'Foo', 10 | VERSION => '1.00', 11 | # ... 12 | ) 13 | ); 14 | 15 | sub MY::postamble 16 | { 17 | $fbmm->mm_postamble; 18 | } 19 | -------------------------------------------------------------------------------- /examples/bundle-foo/ffi/foo.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | typedef struct { 5 | char *name; 6 | int value; 7 | } foo_t; 8 | 9 | foo_t* 10 | foo__new(const char *class_name, const char *name, int value) { 11 | (void)class_name; 12 | foo_t *self = malloc( sizeof( foo_t ) ); 13 | self->name = strdup(name); 14 | self->value = value; 15 | return self; 16 | } 17 | 18 | const char * 19 | foo__name(foo_t *self) { 20 | return self->name; 21 | } 22 | 23 | int 24 | foo__value(foo_t *self) { 25 | return self->value; 26 | } 27 | 28 | void 29 | foo__DESTROY(foo_t *self) { 30 | free(self->name); 31 | free(self); 32 | } 33 | -------------------------------------------------------------------------------- /examples/bundle-foo/lib/Foo.pm: -------------------------------------------------------------------------------- 1 | package Foo; 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | 7 | my $ffi = FFI::Platypus->new( api => 2 ); 8 | 9 | $ffi->type('object(Foo)' => 'foo_t'); 10 | $ffi->mangler(sub { 11 | my $name = shift; 12 | $name =~ s/^/foo__/; 13 | $name; 14 | }); 15 | 16 | $ffi->bundle; 17 | 18 | $ffi->attach( new => [ 'string', 'string', 'int' ] => 'foo_t' ); 19 | $ffi->attach( name => [ 'foo_t' ] => 'string' ); 20 | $ffi->attach( value => [ 'foo_t' ] => 'int' ); 21 | $ffi->attach( DESTROY => [ 'foo_t' ] => 'void' ); 22 | 23 | 1; 24 | -------------------------------------------------------------------------------- /examples/bundle-foo/t/foo.t: -------------------------------------------------------------------------------- 1 | use Test2::V0; 2 | use Foo; 3 | 4 | my $foo = Foo->new("platypus", 10); 5 | isa_ok $foo, 'Foo'; 6 | is $foo->name, "platypus"; 7 | is $foo->value, 10; 8 | 9 | done_testing; 10 | -------------------------------------------------------------------------------- /examples/bundle-init/ffi/init.c: -------------------------------------------------------------------------------- 1 | #include 2 | 3 | char buffer[512]; 4 | const char *version; 5 | void (*say)(const char *); 6 | 7 | void 8 | ffi_pl_bundle_init(const char *package, int argc, void *argv[]) 9 | { 10 | version = argv[0]; 11 | say = argv[1]; 12 | 13 | say("in init!"); 14 | 15 | snprintf(buffer, 512, "package = %s, version = %s", package, version); 16 | say(buffer); 17 | 18 | snprintf(buffer, 512, "args = %d", argc); 19 | say(buffer); 20 | } 21 | 22 | void 23 | ffi_pl_bundle_fini(const char *package) 24 | { 25 | say("in fini!"); 26 | } 27 | -------------------------------------------------------------------------------- /examples/bundle-init/lib/Init.pm: -------------------------------------------------------------------------------- 1 | package Init; 2 | 3 | use strict; 4 | use warnings; 5 | use FFI::Platypus 2.00; 6 | 7 | our $VERSION = '1.00'; 8 | 9 | { 10 | my $ffi = FFI::Platypus->new( api => 2 ); 11 | 12 | my $say = $ffi->closure(sub { 13 | my $string = shift; 14 | print "$string\n"; 15 | }); 16 | 17 | $ffi->bundle([ 18 | $ffi->cast( 'string' => 'opaque', $VERSION ), 19 | $ffi->cast( '(string)->void' => 'opaque', $say ), 20 | ]); 21 | 22 | undef $ffi; 23 | undef $say; 24 | } 25 | 26 | 1; 27 | -------------------------------------------------------------------------------- /examples/bundle-init/t/init.t: -------------------------------------------------------------------------------- 1 | use Test2::V0; 2 | use Init; 3 | 4 | ok 'did not crash'; 5 | 6 | done_testing; 7 | -------------------------------------------------------------------------------- /examples/char.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | $ffi->lib(undef); 7 | $ffi->type('int' => 'character'); 8 | 9 | my @list = qw( 10 | alnum alpha ascii blank cntrl digit lower print punct 11 | space upper xdigit 12 | ); 13 | 14 | $ffi->attach("is$_" => ['character'] => 'int') for @list; 15 | 16 | my $char = shift(@ARGV) || 'a'; 17 | 18 | no strict 'refs'; 19 | printf "'%s' is %s %s\n", $char, $_, &{'is'.$_}(ord $char) for @list; 20 | -------------------------------------------------------------------------------- /examples/closure-opaque.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | $ffi->lib('./closure.so'); 7 | $ffi->type('(int)->int' => 'closure_t'); 8 | 9 | $ffi->attach(set_closure => ['closure_t'] => 'void'); 10 | $ffi->attach(call_closure => ['int'] => 'int'); 11 | 12 | my $closure = $ffi->closure(sub { $_[0] * 6 }); 13 | my $opaque = $ffi->cast(closure_t => 'opaque', $closure); 14 | set_closure($opaque); 15 | print call_closure(2), "\n"; # prints "12" 16 | -------------------------------------------------------------------------------- /examples/closure.c: -------------------------------------------------------------------------------- 1 | /* 2 | * closure.c - on Linux compile with: gcc closure.c -shared -o closure.so -fPIC 3 | */ 4 | 5 | #include 6 | 7 | typedef int (*closure_t)(int); 8 | closure_t my_closure = NULL; 9 | 10 | void set_closure(closure_t value) 11 | { 12 | my_closure = value; 13 | } 14 | 15 | int call_closure(int value) 16 | { 17 | if(my_closure != NULL) 18 | return my_closure(value); 19 | else 20 | fprintf(stderr, "closure is NULL\n"); 21 | } 22 | -------------------------------------------------------------------------------- /examples/closure.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | $ffi->lib('./closure.so'); 7 | $ffi->type('(int)->int' => 'closure_t'); 8 | 9 | $ffi->attach(set_closure => ['closure_t'] => 'void'); 10 | $ffi->attach(call_closure => ['int'] => 'int'); 11 | 12 | my $closure1 = $ffi->closure(sub { $_[0] * 2 }); 13 | set_closure($closure1); 14 | print call_closure(2), "\n"; # prints "4" 15 | 16 | my $closure2 = $ffi->closure(sub { $_[0] * 4 }); 17 | set_closure($closure2); 18 | print call_closure(2), "\n"; # prints "8" 19 | -------------------------------------------------------------------------------- /examples/color.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | 4 | typedef struct color_t { 5 | char name[8]; 6 | uint8_t red; 7 | uint8_t green; 8 | uint8_t blue; 9 | } color_t; 10 | 11 | color_t 12 | color_increase_red(color_t color, uint8_t amount) 13 | { 14 | strcpy(color.name, "reddish"); 15 | color.red += amount; 16 | return color; 17 | } 18 | -------------------------------------------------------------------------------- /examples/color.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './color.so' 8 | ); 9 | 10 | package Color { 11 | 12 | use FFI::Platypus::Record; 13 | use overload 14 | '""' => sub { shift->as_string }, 15 | bool => sub { 1 }, fallback => 1; 16 | 17 | record_layout_1($ffi, 18 | 'string(8)' => 'name', qw( 19 | uint8 red 20 | uint8 green 21 | uint8 blue 22 | )); 23 | 24 | sub as_string { 25 | my($self) = @_; 26 | sprintf "%s: [red:%02x green:%02x blue:%02x]", 27 | $self->name, $self->red, $self->green, $self->blue; 28 | } 29 | 30 | } 31 | 32 | $ffi->type('record(Color)' => 'color_t'); 33 | $ffi->attach( color_increase_red => ['color_t','uint8'] => 'color_t' ); 34 | 35 | my $gray = Color->new( 36 | name => 'gray', 37 | red => 0xDC, 38 | green => 0xDC, 39 | blue => 0xDC, 40 | ); 41 | 42 | my $slightly_red = color_increase_red($gray, 20); 43 | 44 | print "$gray\n"; 45 | print "$slightly_red\n"; 46 | -------------------------------------------------------------------------------- /examples/curl.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::CheckLib qw( find_lib_or_die ); 5 | use constant CURLOPT_URL => 10002; 6 | 7 | my $ffi = FFI::Platypus->new( 8 | api => 2, 9 | lib => find_lib_or_die(lib => 'curl'), 10 | ); 11 | 12 | my $curl_handle = $ffi->function( 'curl_easy_init' => [] => 'opaque' ) 13 | ->call; 14 | 15 | $ffi->function( 'curl_easy_setopt' => ['opaque', 'enum' ] => ['string'] ) 16 | ->call($curl_handle, CURLOPT_URL, "https://pl.atypus.org" ); 17 | 18 | $ffi->function( 'curl_easy_perform' => ['opaque' ] => 'enum' ) 19 | ->call($curl_handle); 20 | 21 | $ffi->function( 'curl_easy_cleanup' => ['opaque' ] ) 22 | ->call($curl_handle); 23 | -------------------------------------------------------------------------------- /examples/curl_callback.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::CheckLib qw( find_lib_or_die ); 5 | use FFI::Platypus::Buffer qw( window ); 6 | use constant CURLOPT_URL => 10002; 7 | use constant CURLOPT_WRITEFUNCTION => 20011; 8 | 9 | my $ffi = FFI::Platypus->new( 10 | api => 2, 11 | lib => find_lib_or_die(lib => 'curl'), 12 | ); 13 | 14 | my $curl_handle = $ffi->function( 'curl_easy_init' => [] => 'opaque' ) 15 | ->call; 16 | 17 | $ffi->function( 'curl_easy_setopt' => [ 'opaque', 'enum' ] => ['string'] ) 18 | ->call($curl_handle, CURLOPT_URL, "https://pl.atypus.org" ); 19 | 20 | my $html; 21 | 22 | my $closure = $ffi->closure(sub { 23 | my($ptr, $len, $num, $user) = @_; 24 | window(my $buf, $ptr, $len*$num); 25 | $html .= $buf; 26 | return $len*$num; 27 | }); 28 | 29 | $ffi->function( 'curl_easy_setopt' => [ 'opaque', 'enum' ] => ['(opaque,size_t,size_t,opaque)->size_t'] => 'enum' ) 30 | ->call($curl_handle, CURLOPT_WRITEFUNCTION, $closure); 31 | 32 | $ffi->function( 'curl_easy_perform' => [ 'opaque' ] => 'enum' ) 33 | ->call($curl_handle); 34 | 35 | $ffi->function( 'curl_easy_cleanup' => [ 'opaque' ] ) 36 | ->call($curl_handle); 37 | 38 | if($html =~ /(.*?)<\/title>/) { 39 | print "$1\n"; 40 | } 41 | -------------------------------------------------------------------------------- /examples/file_handle.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | { 6 | package FD; 7 | 8 | use constant O_RDONLY => 0; 9 | use constant O_WRONLY => 1; 10 | use constant O_RDWR => 2; 11 | 12 | use constant IN => bless \do { my $in=0 }, __PACKAGE__; 13 | use constant OUT => bless \do { my $out=1 }, __PACKAGE__; 14 | use constant ERR => bless \do { my $err=2 }, __PACKAGE__; 15 | 16 | my $ffi = FFI::Platypus->new( api => 2, lib => [undef]); 17 | 18 | $ffi->type('object(FD,int)' => 'fd'); 19 | 20 | $ffi->attach( [ 'open' => 'new' ] => [ 'string', 'int', 'mode_t' ] => 'fd' => sub { 21 | my($xsub, $class, $fn, @rest) = @_; 22 | my $fd = $xsub->($fn, @rest); 23 | die "error opening $fn $!" if $$fd == -1; 24 | $fd; 25 | }); 26 | 27 | $ffi->attach( write => ['fd', 'string', 'size_t' ] => 'ssize_t' ); 28 | $ffi->attach( read => ['fd', 'string', 'size_t' ] => 'ssize_t' ); 29 | $ffi->attach( close => ['fd'] => 'int' ); 30 | } 31 | 32 | my $fd = FD->new("file_handle.txt", FD::O_RDONLY); 33 | 34 | my $buffer = "\0" x 10; 35 | 36 | while(my $br = $fd->read($buffer, 10)) 37 | { 38 | FD::OUT->write($buffer, $br); 39 | } 40 | 41 | $fd->close; 42 | -------------------------------------------------------------------------------- /examples/file_handle.txt: -------------------------------------------------------------------------------- 1 | Hello World 2 | -------------------------------------------------------------------------------- /examples/list_integer_types.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | 7 | foreach my $type_name (sort $ffi->types) 8 | { 9 | my $meta = $ffi->type_meta($type_name); 10 | next unless defined $meta->{element_type} && $meta->{element_type} eq 'int'; 11 | printf "%20s %s\n", $type_name, $meta->{ffi_type}; 12 | } 13 | -------------------------------------------------------------------------------- /examples/malloc.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::Platypus::Memory qw( malloc free memcpy strdup ); 5 | 6 | my $ffi = FFI::Platypus->new( api => 2 ); 7 | my $buffer = malloc 14; 8 | my $ptr_string = strdup("hello there!!\n"); 9 | 10 | memcpy $buffer, $ptr_string, 15; 11 | 12 | print $ffi->cast('opaque' => 'string', $buffer); 13 | 14 | free $ptr_string; 15 | free $buffer; 16 | -------------------------------------------------------------------------------- /examples/math.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::CheckLib; 5 | 6 | my $ffi = FFI::Platypus->new( api => 2 ); 7 | $ffi->lib(undef); 8 | $ffi->attach(puts => ['string'] => 'int'); 9 | $ffi->attach(fdim => ['double','double'] => 'double'); 10 | 11 | puts(fdim(7.0, 2.0)); 12 | 13 | $ffi->attach(cos => ['double'] => 'double'); 14 | 15 | puts(cos(2.0)); 16 | 17 | $ffi->attach(fmax => ['double', 'double'] => 'double'); 18 | 19 | puts(fmax(2.0,3.0)); 20 | -------------------------------------------------------------------------------- /examples/notify.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::CheckLib; 4 | use FFI::Platypus 2.00; 5 | 6 | my $ffi = FFI::Platypus->new( 7 | api => 2, 8 | lib => find_lib_or_die(lib => 'notify'), 9 | ); 10 | 11 | $ffi->attach( notify_init => ['string'] ); 12 | $ffi->attach( notify_uninit => [] ); 13 | $ffi->attach( notify_notification_new => ['string', 'string', 'string'] => 'opaque' ); 14 | $ffi->attach( notify_notification_show => ['opaque', 'opaque'] ); 15 | 16 | my $message = join "\n", 17 | "Hello from Platypus!", 18 | "Welcome to the fun", 19 | "world of FFI"; 20 | 21 | notify_init('Platypus Hello'); 22 | my $n = notify_notification_new('Platypus Hello World', $message, 'dialog-information'); 23 | notify_notification_show($n, undef); 24 | notify_uninit(); 25 | -------------------------------------------------------------------------------- /examples/notify.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/examples/notify.png -------------------------------------------------------------------------------- /examples/person.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | #include <stdlib.h> 3 | 4 | typedef struct person_t { 5 | char *name; 6 | unsigned int age; 7 | } person_t; 8 | 9 | person_t * 10 | person_new(const char *name, unsigned int age) { 11 | person_t *self = malloc(sizeof(person_t)); 12 | self->name = strdup(name); 13 | self->age = age; 14 | } 15 | 16 | const char * 17 | person_name(person_t *self) { 18 | return self->name; 19 | } 20 | 21 | unsigned int 22 | person_age(person_t *self) { 23 | return self->age; 24 | } 25 | 26 | void 27 | person_free(person_t *self) { 28 | free(self->name); 29 | free(self); 30 | } 31 | -------------------------------------------------------------------------------- /examples/person.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './person.so', 8 | ); 9 | 10 | $ffi->type( 'opaque' => 'person_t' ); 11 | 12 | $ffi->attach( person_new => ['string','unsigned int'] => 'person_t' ); 13 | $ffi->attach( person_name => ['person_t'] => 'string' ); 14 | $ffi->attach( person_age => ['person_t'] => 'unsigned int' ); 15 | $ffi->attach( person_free => ['person_t'] ); 16 | 17 | my $person = person_new( 'Roger Frooble Bits', 35 ); 18 | 19 | print "name = ", person_name($person), "\n"; 20 | print "age = ", person_age($person), "\n"; 21 | 22 | person_free($person); 23 | -------------------------------------------------------------------------------- /examples/pipe.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | $ffi->lib(undef); 7 | $ffi->attach([pipe=>'mypipe'] => ['int[2]'] => 'int'); 8 | 9 | my @fd = (0,0); 10 | mypipe(\@fd); 11 | my($fd1,$fd2) = @fd; 12 | 13 | print "$fd1 $fd2\n"; 14 | -------------------------------------------------------------------------------- /examples/puts.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2, lib => undef ); 6 | $ffi->attach( puts => ['string'] => 'int' ); 7 | 8 | puts("hello world"); 9 | -------------------------------------------------------------------------------- /examples/string_reverse.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | #include <stdlib.h> 3 | 4 | const char * 5 | string_reverse(const char *input) 6 | { 7 | static char *output = NULL; 8 | int i, len; 9 | 10 | if(output != NULL) 11 | free(output); 12 | 13 | if(input == NULL) 14 | return NULL; 15 | 16 | len = strlen(input); 17 | output = malloc(len+1); 18 | 19 | for(i=0; input[i]; i++) 20 | output[len-i-1] = input[i]; 21 | output[len] = '\0'; 22 | 23 | return output; 24 | } 25 | -------------------------------------------------------------------------------- /examples/string_reverse.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './string_reverse.so', 8 | ); 9 | 10 | $ffi->attach( string_reverse => ['string'] => 'string' ); 11 | 12 | print string_reverse("\nHello world"); 13 | 14 | string_reverse(undef); 15 | -------------------------------------------------------------------------------- /examples/swap.c: -------------------------------------------------------------------------------- 1 | void 2 | swap(int *a, int *b) 3 | { 4 | int tmp = *b; 5 | *b = *a; 6 | *a = tmp; 7 | } 8 | -------------------------------------------------------------------------------- /examples/swap.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( 6 | api => 2, 7 | lib => './swap.so', 8 | ); 9 | 10 | $ffi->attach( swap => ['int*','int*'] ); 11 | 12 | my $a = 1; 13 | my $b = 2; 14 | 15 | print "[a,b] = [$a,$b]\n"; 16 | 17 | swap( \$a, \$b ); 18 | 19 | print "[a,b] = [$a,$b]\n"; 20 | -------------------------------------------------------------------------------- /examples/tcod.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::CheckLib qw( find_lib_or_die ); 5 | 6 | my $ffi = FFI::Platypus->new( 7 | api => 2, 8 | lib => [find_lib_or_die lib => 'tcod'], 9 | ); 10 | 11 | package TCOD::ColorRGB { 12 | 13 | use overload 14 | '""' => sub { shift->to_string }, 15 | "+" => sub { shift->add(@_) }, 16 | bool => sub { 1 }, 17 | fallback => 1; 18 | 19 | use FFI::Platypus::Record; 20 | record_layout_1( 21 | uint8 => 'r', 22 | uint8 => 'g', 23 | uint8 => 'b', 24 | ); 25 | 26 | $ffi->type('record(TCOD::ColorRGB)' => 'TCOD_color_t'); 27 | $ffi->attach( [ TCOD_color_add => 'add' ] => ['TCOD_color_t','TCOD_color_t'] => 'TCOD_color_t'); 28 | 29 | sub to_string 30 | { 31 | my($self) = @_; 32 | sprintf "[%02x %02x %02x]", 33 | $self->r, 34 | $self->g, 35 | $self->b; 36 | } 37 | 38 | } 39 | 40 | 41 | $ffi->attach( TCOD_color_RGB => [ 'uint8', 'uint8', 'uint8' ] => 'TCOD_color_t' ); 42 | 43 | my $red = TCOD_color_RGB(255,0,0); 44 | my $blue = TCOD_color_RGB(0,255,0); 45 | my $purple = $red + $blue; 46 | 47 | print "$red\n"; # [ff 00 00] 48 | print "$blue\n"; # [00 00 ff] 49 | print "$purple\n"; # [ff 00 ff] 50 | -------------------------------------------------------------------------------- /examples/time.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Convert::Binary::C; 4 | use FFI::Platypus 2.00; 5 | use Data::Dumper qw( Dumper ); 6 | 7 | my $c = Convert::Binary::C->new; 8 | 9 | # Alignment of zero (0) means use 10 | # the alignment of your CPU 11 | $c->configure( Alignment => 0 ); 12 | 13 | # parse the tm record structure so 14 | # that Convert::Binary::C knows 15 | # what to spit out and suck in 16 | $c->parse(<<ENDC); 17 | struct tm { 18 | int tm_sec; 19 | int tm_min; 20 | int tm_hour; 21 | int tm_mday; 22 | int tm_mon; 23 | int tm_year; 24 | int tm_wday; 25 | int tm_yday; 26 | int tm_isdst; 27 | long int tm_gmtoff; 28 | const char *tm_zone; 29 | }; 30 | ENDC 31 | 32 | # get the size of tm so that we can give it 33 | # to Platypus 34 | my $tm_size = $c->sizeof("tm"); 35 | 36 | # create the Platypus instance and create the appropriate 37 | # types and functions 38 | my $ffi = FFI::Platypus->new( api => 2 ); 39 | $ffi->lib(undef); 40 | $ffi->type("record($tm_size)*" => 'tm'); 41 | $ffi->attach( [ localtime => 'my_localtime' ] => ['time_t*'] => 'tm' ); 42 | $ffi->attach( [ time => 'my_time' ] => ['tm'] => 'time_t' ); 43 | 44 | # =============================================== 45 | # get the tm struct from the C localtime function 46 | # note that we pass in a reference to the value that time 47 | # returns because localtime takes a pointer to time_t 48 | # for some reason. 49 | my $time_hashref = $c->unpack( tm => my_localtime(\time) ); 50 | 51 | # tm_zone comes back from Convert::Binary::C as an opaque, 52 | # cast it into a string. We localize it to just this do 53 | # block so that it will be a pointer when we pass it back 54 | # to C land below. 55 | do { 56 | local $time_hashref->{tm_zone} = $ffi->cast(opaque => string => $time_hashref->{tm_zone}); 57 | print Dumper($time_hashref); 58 | }; 59 | 60 | # =============================================== 61 | # convert the tm struct back into an epoch value 62 | my $time = my_time( $c->pack( tm => $time_hashref ) ); 63 | 64 | print "time = $time\n"; 65 | print "perl time = ", time, "\n"; 66 | -------------------------------------------------------------------------------- /examples/time_record.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | 4 | package Unix::TimeStruct; 5 | 6 | use FFI::Platypus 2.00; 7 | use FFI::Platypus::Record; 8 | 9 | record_layout_1(qw( 10 | int tm_sec 11 | int tm_min 12 | int tm_hour 13 | int tm_mday 14 | int tm_mon 15 | int tm_year 16 | int tm_wday 17 | int tm_yday 18 | int tm_isdst 19 | long tm_gmtoff 20 | string tm_zone 21 | )); 22 | 23 | my $ffi = FFI::Platypus->new( api => 2 ); 24 | $ffi->lib(undef); 25 | # define a record class Unix::TimeStruct and alias it to "tm" 26 | $ffi->type("record(Unix::TimeStruct)*" => 'tm'); 27 | 28 | # attach the C localtime function as a constructor 29 | $ffi->attach( localtime => ['time_t*'] => 'tm', sub { 30 | my($inner, $class, $time) = @_; 31 | $time = time unless defined $time; 32 | $inner->(\$time); 33 | }); 34 | 35 | package main; 36 | 37 | # now we can actually use our Unix::TimeStruct class 38 | my $time = Unix::TimeStruct->localtime; 39 | printf "time is %d:%d:%d %s\n", 40 | $time->tm_hour, 41 | $time->tm_min, 42 | $time->tm_sec, 43 | $time->tm_zone; 44 | -------------------------------------------------------------------------------- /examples/time_struct.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::C; 5 | 6 | my $ffi = FFI::Platypus->new( 7 | api => 2, 8 | lib => [undef], 9 | ); 10 | FFI::C->ffi($ffi); 11 | 12 | package Unix::TimeStruct { 13 | 14 | FFI::C->struct(tm => [ 15 | tm_sec => 'int', 16 | tm_min => 'int', 17 | tm_hour => 'int', 18 | tm_mday => 'int', 19 | tm_mon => 'int', 20 | tm_year => 'int', 21 | tm_wday => 'int', 22 | tm_yday => 'int', 23 | tm_isdst => 'int', 24 | tm_gmtoff => 'long', 25 | _tm_zone => 'opaque', 26 | ]); 27 | 28 | # For now 'string' is unsupported by FFI::C, but we 29 | # can cast the time zone from an opaque pointer to 30 | # string. 31 | sub tm_zone { 32 | my $self = shift; 33 | $ffi->cast('opaque', 'string', $self->_tm_zone); 34 | } 35 | 36 | # attach the C localtime function 37 | $ffi->attach( localtime => ['time_t*'] => 'tm', sub { 38 | my($inner, $class, $time) = @_; 39 | $time = time unless defined $time; 40 | $inner->(\$time); 41 | }); 42 | } 43 | 44 | # now we can actually use our Unix::TimeStruct class 45 | my $time = Unix::TimeStruct->localtime; 46 | printf "time is %d:%d:%d %s\n", 47 | $time->tm_hour, 48 | $time->tm_min, 49 | $time->tm_sec, 50 | $time->tm_zone; 51 | -------------------------------------------------------------------------------- /examples/var_array.c: -------------------------------------------------------------------------------- 1 | int 2 | sum(int *array, int size) 3 | { 4 | int total, i; 5 | for (i = 0, total = 0; i < size; i++) 6 | { 7 | total += array[i]; 8 | } 9 | return total; 10 | } 11 | -------------------------------------------------------------------------------- /examples/var_array.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my $ffi = FFI::Platypus->new( api => 2 ); 6 | $ffi->lib('./var_array.so'); 7 | 8 | $ffi->attach( sum => [ 'int[]', 'int' ] => 'int' ); 9 | 10 | my @list = (1..100); 11 | 12 | print sum(\@list, scalar @list), "\n"; 13 | -------------------------------------------------------------------------------- /examples/win32_beep.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | 5 | my($freq, $duration) = @_; 6 | $freq ||= 750; 7 | $duration ||= 300; 8 | 9 | FFI::Platypus 10 | ->new( api => 2, lib=>[undef], lang => 'Win32' ) 11 | ->function( Beep => ['DWORD','DWORD']=>'BOOL') 12 | ->call($freq, $duration); 13 | -------------------------------------------------------------------------------- /examples/win32_getSystemTime.pl: -------------------------------------------------------------------------------- 1 | # Author : Bakkiaraj M 2 | # Script: Get System time from windows OS using GetLocalTime API. 3 | use strict; 4 | use warnings; 5 | use FFI::CheckLib; 6 | use FFI::Platypus; 7 | use Convert::Binary::C; 8 | 9 | #Get the system time using Kernel32.dll 10 | 11 | #find the Kernel32.dll 12 | my $libPath = find_lib(lib=>'Kernel32'); 13 | #Create FFI Object 14 | my $ffiObj = FFI::Platypus->new(); 15 | $ffiObj->lib($libPath); 16 | 17 | #Import the GetLocalTime function 18 | $ffiObj->attach('GetLocalTime',['record(16)'],'void'); 19 | 20 | #Define SYSTEMTIME Struct as per https://msdn.microsoft.com/en-us/library/windows/desktop/ms724950(v=vs.85).aspx 21 | #As per, C:\MinGW\include\windef.h, WORD id unsigned short 22 | my $c = Convert::Binary::C->new->parse(<<ENDC); 23 | 24 | struct SYSTEMTIME { 25 | unsigned short wYear; 26 | unsigned short wMonth; 27 | unsigned short wDayOfWeek; 28 | unsigned short wDay; 29 | unsigned short wHour; 30 | unsigned short wMinute; 31 | unsigned short wSecond; 32 | unsigned short wMilliseconds; 33 | }; 34 | 35 | ENDC 36 | 37 | 38 | my $dateStruct = { 39 | wYear=>0, 40 | wMonth=>0, 41 | wDayOfWeek=>0, 42 | wDay=>0, 43 | wHour=>0, 44 | wMinute=>0, 45 | wSecond=>0, 46 | wMilliseconds=>0, 47 | }; 48 | 49 | my $packed = $c->pack('SYSTEMTIME', $dateStruct); 50 | 51 | #Call the function by passing the structure reference 52 | GetLocalTime($packed); 53 | 54 | if (defined ($packed)) 55 | { 56 | #Unpack the structure 57 | my $sysDate = $c->unpack('SYSTEMTIME', $packed); 58 | print "\n WINDOWS SYSTEM TIME: ",$$sysDate{'wHour'},':',$$sysDate{'wMinute'},':',$$sysDate{'wSecond'},'.',$$sysDate{'wMilliseconds'},' ',$$sysDate{'wDay'},'/',$$sysDate{'wMonth'},'/',$$sysDate{'wYear'}, "\n"; 59 | } 60 | else 61 | { 62 | print "\n Something is wrong\n"; 63 | } 64 | 65 | exit 0; 66 | -------------------------------------------------------------------------------- /examples/win32_messagebox.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use utf8; 4 | use FFI::Platypus 2.00; 5 | 6 | my $ffi = FFI::Platypus->new( 7 | api => 2, 8 | lib => [undef], 9 | ); 10 | 11 | # see FFI::Platypus::Lang::Win32 12 | $ffi->lang('Win32'); 13 | 14 | # Send a Unicode string to the Windows API MessageBoxW function. 15 | use constant MB_OK => 0x00000000; 16 | use constant MB_DEFAULT_DESKTOP_ONLY => 0x00020000; 17 | $ffi->attach( [MessageBoxW => 'MessageBox'] => [ 'HWND', 'LPCWSTR', 'LPCWSTR', 'UINT'] => 'int' ); 18 | MessageBox(undef, "I ❤️ Platypus", "Confession", MB_OK|MB_DEFAULT_DESKTOP_ONLY); 19 | 20 | -------------------------------------------------------------------------------- /examples/win32_messagebox.png: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/PerlFFI/FFI-Platypus/8213e8416a77dc377fd338bac64542dcdc0f8661/examples/win32_messagebox.png -------------------------------------------------------------------------------- /examples/xor_cipher.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | #include <stdlib.h> 3 | 4 | char * 5 | string_crypt(const char *input, int len, const char *key) 6 | { 7 | char *output; 8 | int i, n; 9 | 10 | if(input == NULL) 11 | return NULL; 12 | 13 | output = malloc(len+1); 14 | output[len] = '\0'; 15 | 16 | for(i=0, n=0; i<len; i++, n++) { 17 | if(key[n] == '\0') 18 | n = 0; 19 | output[i] = input[i] ^ key[n]; 20 | } 21 | 22 | return output; 23 | } 24 | 25 | void 26 | string_crypt_free(char *output) 27 | { 28 | if(output != NULL) 29 | free(output); 30 | } 31 | -------------------------------------------------------------------------------- /examples/xor_cipher.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use FFI::Platypus 2.00; 4 | use FFI::Platypus::Buffer qw( buffer_to_scalar ); 5 | use YAML (); 6 | 7 | my $ffi = FFI::Platypus->new( 8 | api => 2, 9 | lib => './xor_cipher.so', 10 | ); 11 | 12 | $ffi->attach( string_crypt_free => ['opaque'] ); 13 | 14 | $ffi->attach( string_crypt => ['string','int','string'] => 'opaque' => sub{ 15 | my($xsub, $input, $key) = @_; 16 | my $ptr = $xsub->($input, length($input), $key); 17 | my $output = buffer_to_scalar $ptr, length($input); 18 | string_crypt_free($ptr); 19 | return $output; 20 | }); 21 | 22 | my $orig = "hello world"; 23 | my $key = "foobar"; 24 | 25 | print YAML::Dump($orig); 26 | my $encrypted = string_crypt($orig, $key); 27 | print YAML::Dump($encrypted); 28 | my $decrypted = string_crypt($encrypted, $key); 29 | print YAML::Dump($decrypted); 30 | -------------------------------------------------------------------------------- /ffi/constant.c: -------------------------------------------------------------------------------- 1 | #include <ffi_platypus_bundle.h> 2 | 3 | #ifdef _MSC_VER 4 | #define EXPORT __declspec(dllexport) 5 | #else 6 | #define EXPORT 7 | #endif 8 | 9 | EXPORT 10 | ffi_platypus_constant_t * 11 | ffi_platypus_constant__new(void* set_str, 12 | void* set_sint, 13 | void* set_uint, 14 | void* set_double) 15 | { 16 | ffi_platypus_constant_t *self = malloc(sizeof(ffi_platypus_constant_t)); 17 | self->set_str = set_str; 18 | self->set_sint = set_sint; 19 | self->set_uint = set_uint; 20 | self->set_double = set_double; 21 | return self; 22 | } 23 | 24 | EXPORT 25 | void 26 | ffi_platypus_constant__DESTROY(ffi_platypus_constant_t *self) 27 | { 28 | free(self); 29 | } 30 | -------------------------------------------------------------------------------- /ffi/memory.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | #include <stdlib.h> 3 | 4 | /* 5 | * strdup and strndup are useful, but technically not part of the 6 | * C standard, and thus may be missing from some environments. 7 | * If libc provides these functions then it will use them, 8 | * otherwise it will fallback on these implementations. 9 | */ 10 | 11 | #ifdef _MSC_VER 12 | #define EXPORT __declspec(dllexport) 13 | #else 14 | #define EXPORT 15 | #endif 16 | 17 | EXPORT 18 | char * 19 | ffi_platypus_memory__strdup(const char *olds) 20 | { 21 | char *news; 22 | size_t size; 23 | 24 | size = strlen(olds)+1; 25 | news = malloc(size); 26 | if(news != NULL) 27 | { 28 | memcpy(news, olds, size); 29 | } 30 | 31 | return news; 32 | } 33 | 34 | EXPORT 35 | char * 36 | ffi_platypus_memory__strndup(const char *olds, size_t max) 37 | { 38 | char *news; 39 | size_t size; 40 | 41 | #ifdef FFI_PL_PROBE_STRNLEN 42 | size = strnlen(olds, max); 43 | #else 44 | for(size=0; size <max && olds[size] != '\0'; size++) 45 | ; 46 | #endif 47 | news = malloc(size+1); 48 | if(news != NULL) 49 | { 50 | news[size] = '\0'; 51 | memcpy(news, olds, size); 52 | } 53 | return news; 54 | } 55 | -------------------------------------------------------------------------------- /inc/Alien/FFI/PkgConfigPP.pm: -------------------------------------------------------------------------------- 1 | package Alien::FFI::PkgConfigPP; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | our $VERBOSE = !!$ENV{V}; 7 | 8 | my $pkg; 9 | 10 | sub _pkg 11 | { 12 | $pkg ||= eval { 13 | require PkgConfig; 14 | my $pkg = PkgConfig->find('libffi'); 15 | die $pkg->errmsg if $pkg->errmsg; 16 | $pkg; 17 | }; 18 | die "libffi not found" unless $pkg; 19 | $pkg; 20 | } 21 | 22 | sub exists 23 | { 24 | !!eval { _pkg }; 25 | } 26 | 27 | sub version { 28 | _pkg->pkg_version; 29 | } 30 | 31 | sub config 32 | { 33 | my($class, $key) = @_; 34 | die "unimplemented for $key" unless $key eq 'version'; 35 | $class->version; 36 | } 37 | 38 | sub cflags 39 | { 40 | scalar _pkg->get_cflags; 41 | } 42 | 43 | sub libs 44 | { 45 | scalar _pkg->get_ldflags; 46 | } 47 | 48 | sub install_type { return 'system' } 49 | 50 | sub runtime_prop { return {} } 51 | 52 | 1; 53 | 54 | -------------------------------------------------------------------------------- /inc/Alien/FFI/Vcpkg.pm: -------------------------------------------------------------------------------- 1 | package Alien::FFI::Vcpkg; 2 | 3 | use strict; 4 | use warnings; 5 | 6 | my $pkg; 7 | 8 | sub vcpkg 9 | { 10 | $pkg ||= do { 11 | require Win32::Vcpkg::List; 12 | Win32::Vcpkg::List->new->search('libffi'); 13 | }; 14 | } 15 | 16 | sub exists 17 | { 18 | !!vcpkg(); 19 | } 20 | 21 | sub version 22 | { 23 | vcpkg->version; 24 | } 25 | 26 | sub config 27 | { 28 | my($class, $key) = @_; 29 | die "unimplemented for $key" unless $key eq 'version'; 30 | $class->version; 31 | } 32 | 33 | sub cflags 34 | { 35 | scalar vcpkg->cflags; 36 | } 37 | 38 | sub libs 39 | { 40 | scalar vcpkg->libs; 41 | } 42 | 43 | sub install_type { return 'system' } 44 | 45 | sub runtime_prop { return {} } 46 | 47 | 1; 48 | 49 | -------------------------------------------------------------------------------- /inc/Alien/psapi.pm: -------------------------------------------------------------------------------- 1 | package Alien::psapi; 2 | 3 | use strict; 4 | use warnings; 5 | use Config; 6 | 7 | sub cflags {''} 8 | 9 | sub libs 10 | { 11 | if($^O eq 'MSWin32') 12 | { 13 | if($Config{ccname} eq 'cl') 14 | { 15 | return "psapi.lib "; 16 | } 17 | else 18 | { 19 | return "-lpsapi"; 20 | } 21 | } 22 | elsif($^O eq 'cygwin' || $^O eq 'msys') 23 | { 24 | return "-L/usr/lib/w32api -lpsapi "; 25 | } 26 | ''; 27 | } 28 | 29 | sub install_type {'system'} 30 | 31 | 1; 32 | 33 | -------------------------------------------------------------------------------- /inc/My/BuildConfig.pm: -------------------------------------------------------------------------------- 1 | package My::BuildConfig; 2 | 3 | use strict; 4 | use warnings; 5 | use File::Spec (); 6 | use parent qw( My::ConfigPl ); 7 | 8 | sub dir { File::Spec->catdir( qw( _mm )) } 9 | sub file { File::Spec->catfile( shift->dir, qw( config.pl )) } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /inc/My/ConfigH.pm: -------------------------------------------------------------------------------- 1 | package My::ConfigH; 2 | 3 | use strict; 4 | use warnings; 5 | use Carp qw( croak ); 6 | use File::Basename qw( basename ); 7 | 8 | sub new 9 | { 10 | my($class, $filename) = @_; 11 | 12 | $filename ||= "include/ffi_platypus_config.h"; 13 | 14 | my $self = bless { 15 | content => '', 16 | filename => $filename, 17 | }, $class; 18 | 19 | $self; 20 | } 21 | 22 | sub define_var 23 | { 24 | my($self, $key, $value) = @_; 25 | croak "value for $key is not defined" unless defined $value; 26 | $self->{content} .= "#define $key $value\n"; 27 | } 28 | 29 | sub write_config_h 30 | { 31 | my($self) = @_; 32 | 33 | my $once = uc basename($self->{filename}); 34 | $once =~ s/\./_/g; 35 | 36 | my $fh; 37 | my $fn = $self->{filename}; 38 | open $fh, '>', $fn or die "unable to write to $fn $!"; 39 | print $fh "#ifndef $once\n"; 40 | print $fh "#define $once\n\n"; 41 | print $fh "@{[ $self->{content} ]}\n"; 42 | print $fh "#endif\n"; 43 | close $fh; 44 | } 45 | 46 | 1; 47 | -------------------------------------------------------------------------------- /inc/My/ConfigPl.pm: -------------------------------------------------------------------------------- 1 | package My::ConfigPl; 2 | 3 | use strict; 4 | use warnings; 5 | use Data::Dumper (); 6 | use Carp qw( croak ); 7 | use File::Path qw( mkpath ); 8 | 9 | sub dir { croak "subclasss requires dir method" } 10 | sub file { croak "subclasss requires file method" } 11 | 12 | sub new 13 | { 14 | my $class = shift; 15 | my $data; 16 | if(-e $class->file) 17 | { 18 | $data = do "./@{[ $class->file ]}"; 19 | } 20 | else 21 | { 22 | $data = { 'test-key' => 'test-value' }; 23 | } 24 | bless { data => $data }, $class; 25 | } 26 | 27 | sub get 28 | { 29 | my($self, $name) = @_; 30 | $self->{data}->{$name}; 31 | } 32 | 33 | sub set 34 | { 35 | my($self, $name, $value) = @_; 36 | $self->{data}->{$name} = $value; 37 | 38 | my $dd = Data::Dumper->new([$self->{data}],['x']) 39 | ->Indent(1) 40 | ->Terse(0) 41 | ->Purity(1) 42 | ->Sortkeys(1) 43 | ->Dump; 44 | 45 | mkpath( $self->dir, 0, 0755 ) unless -d $self->dir; 46 | 47 | my $fh; 48 | open($fh, '>', $self->file) || die "error writing @{[ $self->file ]}"; 49 | print $fh 'do { my '; 50 | print $fh $dd; 51 | print $fh '$x;}'; 52 | close $fh; 53 | } 54 | 55 | 1; 56 | -------------------------------------------------------------------------------- /inc/My/ShareConfig.pm: -------------------------------------------------------------------------------- 1 | package My::ShareConfig; 2 | 3 | use strict; 4 | use warnings; 5 | use File::Spec (); 6 | use parent qw( My::ConfigPl ); 7 | 8 | sub dir { File::Spec->catdir( qw( blib lib auto share dist FFI-Platypus )) } 9 | sub file { File::Spec->catfile( shift->dir, qw( config.pl )) } 10 | 11 | 1; 12 | -------------------------------------------------------------------------------- /inc/abi/abis-all.json: -------------------------------------------------------------------------------- 1 | [ 2 | "AIX", 3 | "ARCOMPACT", 4 | "COMPAT", 5 | "COMPAT_GCC_SYSV", 6 | "COMPAT_LINUX", 7 | "COMPAT_LINUX64", 8 | "COMPAT_LINUX_SOFT_FLOAT", 9 | "COMPAT_SYSV", 10 | "DARWIN", 11 | "EABI", 12 | "EFI64", 13 | "ELFBSD", 14 | "FASTCALL", 15 | "GNUW64", 16 | "LINUX", 17 | "LINUX_LONG_DOUBLE_128", 18 | "LINUX_LONG_DOUBLE_IEEE128", 19 | "LINUX_STRUCT_ALIGN", 20 | "MIPS_O32", 21 | "MS_CDECL", 22 | "N32", 23 | "N32_SOFT_FLOAT", 24 | "N64", 25 | "N64_SOFT_FLOAT", 26 | "O32", 27 | "O32_SOFT_FLOAT", 28 | "OBSD", 29 | "OSF", 30 | "PA32", 31 | "PA64", 32 | "PASCAL", 33 | "REGISTER", 34 | "STDCALL", 35 | "SYSV", 36 | "SYSV_IBM_LONG_DOUBLE", 37 | "SYSV_LONG_DOUBLE_128", 38 | "SYSV_SOFT_FLOAT", 39 | "SYSV_STRUCT_RET", 40 | "THISCALL", 41 | "UNIX", 42 | "UNIX64", 43 | "UNUSED_1", 44 | "UNUSED_2", 45 | "UNUSED_3", 46 | "V8", 47 | "V9", 48 | "VFP", 49 | "WIN64" 50 | ] 51 | -------------------------------------------------------------------------------- /inc/abi/compute-all.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use feature qw( say ); 4 | use Path::Tiny qw( path ); 5 | use Git::Wrapper; 6 | use File::chdir; 7 | use JSON::PP (); 8 | 9 | # Only intended for use by the Platypus maintainer! 10 | # Sometimes detecting the ABIs from the C compiler pre-processor is unreliable 11 | # so we can look in the libffi source for all possible ABIs for all possible 12 | # platforms and just try them all. This computes the list from the latest 13 | # source (or libffi directory as specified by LIBFFI_ROOT). This list will 14 | # used by the config step to detect ABIs available on your platform. 15 | 16 | my $libffi_root; 17 | 18 | if(defined $ENV{LIBFFI_ROOT}) 19 | { 20 | die "no such directory: $ENV{LIBFFI_ROOT}" unless -d $ENV{LIBFFI_ROOT}; 21 | $libffi_root = path($ENV{LIBFFI_ROOT}); 22 | } 23 | else 24 | { 25 | require Git::Wrapper; 26 | $libffi_root = Path::Tiny->tempdir; 27 | my $git = Git::Wrapper->new($libffi_root); 28 | $git->clone('--depth=2', 'https://github.com/libffi/libffi.git', $libffi_root); 29 | } 30 | 31 | say $libffi_root; 32 | 33 | my %abis; 34 | 35 | $libffi_root->visit( 36 | sub { 37 | my($path) = @_; 38 | return if $path->is_dir; 39 | return unless $path->basename eq 'ffitarget.h'; 40 | say ' ' . $path->relative($libffi_root); 41 | 42 | my $c = $path->slurp; 43 | if($c =~ m/typedef\s+enum\s+ffi_abi\s+{(.*?)}/s) 44 | { 45 | my $c = $1; 46 | while($c =~ s/FFI_([A-Z_0-9]+)//) 47 | { 48 | my $abi = $1; 49 | next if $abi =~ /^(FIRST|LAST|DEFAULT)_ABI$/; 50 | say ' ', $abi; 51 | $abis{$abi}++; 52 | } 53 | } 54 | else 55 | { 56 | say ' no abis'; 57 | } 58 | }, 59 | { recurse => 1 }, 60 | ); 61 | 62 | path(__FILE__)->parent->child("abis-all.json")->spew_raw(JSON::PP->new->pretty(1)->encode([sort keys %abis])); 63 | -------------------------------------------------------------------------------- /inc/bad-5100t.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use Config; 4 | 5 | if($] == 5.010 && $Config{useithreads}) 6 | { 7 | print "\n\n\n"; 8 | print " !! ERROR ERROR ERRORS ERROR !!\n"; 9 | print "\n"; 10 | print "The version of Perl you are using (5.10.0) when compiled\n"; 11 | print "with threads is buggy and not supported by the Platypus team.\n"; 12 | print "Please take the time to upgraded to a supported version of\n"; 13 | print "Perl. Easiest upgrade is probably to 5.10.0 unthreaded, or\n"; 14 | print "5.10.1. Better would be to upgrade to 5.32.\n"; 15 | print "\n"; 16 | print "https://github.com/PerlFFI/FFI-Platypus/issues/271\n"; 17 | print "\n"; 18 | print " !! ERROR ERROR ERRORS ERROR !!\n"; 19 | print "\n\n\n"; 20 | exit 2; 21 | } 22 | -------------------------------------------------------------------------------- /inc/bad-forks.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use File::Spec; 4 | 5 | my $path; 6 | foreach my $inc (@INC) 7 | { 8 | $path = File::Spec->catfile($inc, 'forks.pm'); 9 | last if -f $path; 10 | } 11 | 12 | if(-f $path) 13 | { 14 | eval q{ use forks }; 15 | if(my $error = $@) 16 | { 17 | print "There seems to be something wrong with your forks.pm module.\n"; 18 | print "This exception was raised when trying to use forks:\n\n"; 19 | 20 | print " $error\n\n"; 21 | 22 | print "Although forks.pm is not required by FFI-Platypus, it does test\n"; 23 | print "against forks.pm if it is installed, so please fix your forks.pm\n"; 24 | print "before trying to install FFI-Platypus.\n\n"; 25 | 26 | print "If you believe this to be an error in FFI-Platypus, please feel\n"; 27 | print "free to open a ticket here:\n\n"; 28 | 29 | print "https://github.com/PerlFFI/FFI-Platypus/issues\n\n"; 30 | exit 2; 31 | } 32 | } 33 | -------------------------------------------------------------------------------- /inc/bad-oldperl.pl: -------------------------------------------------------------------------------- 1 | if($] < 5.008004) 2 | { 3 | print "\n\n\n"; 4 | print " !! ERROR ERROR ERRORS ERROR !!\n"; 5 | print "\n"; 6 | print "The version of Perl you are using is very old (at least 15 years)\n"; 7 | print "as of this writing. The FFI-Platypus team plans on dropping support\n"; 8 | print "for Perls older than 5.8.4 on or after July 1st 2020. At that time\n"; 9 | print "FFI-Platypus will refuse to install on these old Perls. Please take\n"; 10 | print "the time to migrate to a supported version of Perl ASAP.\n"; 11 | print "\n"; 12 | print "https://github.com/PerlFFI/FFI-Platypus/issues/271\n"; 13 | print "\n"; 14 | print " !! ERROR ERROR ERRORS ERROR !!\n"; 15 | print "\n\n\n"; 16 | exit 2; 17 | } 18 | 19 | -------------------------------------------------------------------------------- /inc/mm-build.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use File::Basename qw( basename ); 4 | use File::Path qw( mkpath ); 5 | use File::Copy qw( copy ); 6 | use lib 'inc'; 7 | use My::Config; 8 | use lib 'lib'; 9 | use FFI::Build; 10 | use Config (); 11 | 12 | my $config = My::Config->new; 13 | 14 | my $include = "blib/lib/auto/share/dist/FFI-Platypus/include"; 15 | mkpath $include, 0, 0755; 16 | foreach my $h (qw( ffi_platypus_config.h ffi_platypus_bundle.h )) 17 | { 18 | my $from = "include/$h"; 19 | my $to = "$include/$h"; 20 | 21 | if(-f $to) 22 | { 23 | next if slurp($from) eq slurp($to); 24 | } 25 | 26 | copy($from => $to) || die "unable to copy $from => $to $!"; 27 | } 28 | 29 | my $lib = FFI::Build->new( 30 | 'plfill', 31 | source => ['ffi/*.c'], 32 | verbose => 1, 33 | dir => 'blib/lib/auto/share/dist/FFI-Platypus/lib', 34 | platform => $config->platform, 35 | alien => [$config->alien], 36 | cflags => '-Iblib/lib/auto/share/dist/FFI-Platypus/include -Iinclude', 37 | )->build; 38 | 39 | my $name = basename($lib->basename); 40 | 41 | foreach my $dir ( 'FFI/Platypus/Memory','FFI/Platypus/Record/Meta', 'FFI/Platypus/Constant' ) 42 | { 43 | my($file) = $dir =~ m{/([^/]+)$}; 44 | mkpath("blib/arch/auto/$dir", 0, 0755); 45 | my $txtfile = "blib/arch/auto/$dir/$file.txt"; 46 | my $fh; 47 | open($fh, '>', $txtfile) || die "unable to write to $txtfile $!"; 48 | print $fh "FFI::Build\@auto/share/dist/FFI-Platypus/lib/$name\n"; 49 | close $fh; 50 | } 51 | 52 | sub slurp 53 | { 54 | my($filename) = @_; 55 | my $fh; 56 | open $fh, '<', $filename; 57 | binmode $fh; 58 | my $content = do { local $/; <$fh> }; 59 | close $fh; 60 | $content; 61 | } 62 | -------------------------------------------------------------------------------- /inc/mm-clean.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use File::Glob qw( bsd_glob ); 4 | 5 | unlink $_ for map { bsd_glob($_) } ( 6 | 'ffi/_build/*', 7 | 't/ffi/_build/*', 8 | 't/ffi/*.so', 9 | 't/ffi/*.dll', 10 | 't/ffi/*.bundle', 11 | 'xs/*.o', 12 | 'xs/*.obj', 13 | 'examples/*.o', 14 | 'examples/*.so', 15 | 'examples/*.dll', 16 | 'examples/*.bundle', 17 | 'corpus/ffi_build/project1/_build/*', 18 | 'config.log', 19 | 'test*.o', 20 | 'test*.c', 21 | '*.core', 22 | 'core', 23 | 'include/ffi_platypus_config.h', 24 | 'FFI-Platypus-*.tar.gz', 25 | ); 26 | 27 | rmdir 'ffi/_build' if -d 'ffi/_build'; 28 | rmdir 't/ffi/_build' if -d 't/ffi/_build'; 29 | rmdir 'corpus/ffi_build/project1/_build' if -d 'corpus/ffi_build/project1/_build'; 30 | -------------------------------------------------------------------------------- /inc/mm-config-pb.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use lib 'inc'; 4 | use My::Config; 5 | 6 | my $config = My::Config->new; 7 | $config->probe_runner_build; 8 | -------------------------------------------------------------------------------- /inc/mm-config-set.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use lib 'inc'; 4 | use My::BuildConfig; 5 | 6 | my($key, @value) = @ARGV; 7 | 8 | my $config = My::BuildConfig->new; 9 | my $eumm = $config->get('eumm'); 10 | $eumm->{$key} = [@value]; 11 | $config->set('eumm' => $eumm); 12 | -------------------------------------------------------------------------------- /inc/mm-config.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use ExtUtils::CBuilder; 4 | use lib 'inc'; 5 | use My::Config; 6 | 7 | exit if -f '_mm/config'; 8 | 9 | my $config = My::Config->new; 10 | $config->generate_dev; 11 | $config->configure; 12 | $config->alien; 13 | -------------------------------------------------------------------------------- /inc/mm-test.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use lib 'lib'; 4 | use FFI::Build; 5 | use lib 'inc'; 6 | use My::Config; 7 | use My::ShareConfig; 8 | 9 | my $config = My::Config->new; 10 | 11 | FFI::Build->new( 12 | 'test', 13 | source => ['t/ffi/*.c'], 14 | verbose => 1, 15 | alien => [$config->build_config->get('alien')->{class}], 16 | cflags => ['-Iinclude'], 17 | dir => 't/ffi', 18 | platform => $config->platform, 19 | )->build; 20 | 21 | -------------------------------------------------------------------------------- /inc/pdb: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use lib 'inc'; 6 | use lib 'lib'; 7 | use FFI::Probe; 8 | use FFI::Probe::Runner; 9 | use FFI::Probe::Runner::Builder; 10 | use My::BuildConfig; 11 | use File::Temp; 12 | use Path::Tiny qw( path ); 13 | 14 | my $dir = FFI::Temp->newdir; 15 | my $data_filename = path( $dir, 'probe.pl' ); 16 | my $log_filename = path( $dir, 'config.log' ); 17 | 18 | my $probe = FFI::Probe->new( 19 | runner => do { 20 | my $builder = FFI::Probe::Runner::Builder->new; 21 | my $exe = $builder->exe; 22 | FFI::Probe::Runner->new( exe => $exe ); 23 | }, 24 | log => "$log_filename", 25 | data_filename => "$data_filename", 26 | alien => [My::BuildConfig->new->get('alien')->{class}], 27 | cflags => ['-Iinclude'], 28 | ); 29 | 30 | my $name = shift @ARGV; 31 | $name ||= 'recordvalue'; # this is what I am strugling with right this minute. 32 | my $fn = "inc/probe/$name.c"; 33 | my $code = do { 34 | my $fh; 35 | open $fh, '<', $fn; 36 | local $/; 37 | <$fh>; 38 | }; 39 | 40 | my $value = $probe->check($name, $code); 41 | 42 | $probe->save; 43 | 44 | print "[log]\n"; 45 | print $log_filename->slurp; 46 | print "[data]\n"; 47 | print $data_filename->slurp; 48 | -------------------------------------------------------------------------------- /inc/probe/abi.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | int 4 | dlmain(int argc, char *argv[]) 5 | { 6 | ffi_cif cif; 7 | ffi_type *args[1]; 8 | ffi_abi abi; 9 | 10 | abi = FFI_DEFAULT_ABI; 11 | 12 | if(ffi_prep_cif(&cif, abi, 0, &ffi_type_void, args) == FFI_OK) 13 | { 14 | return 0; 15 | } 16 | 17 | return 2; 18 | } 19 | -------------------------------------------------------------------------------- /inc/probe/alloca.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | int 4 | dlmain(int argc, char *argv[]) 5 | { 6 | void *ptr = alloca(100); 7 | 8 | if(ptr == NULL) 9 | return 2; 10 | 11 | return 0; 12 | } 13 | -------------------------------------------------------------------------------- /inc/probe/bigendian.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | unsigned char 4 | my_foo(void) 5 | { 6 | return 0xaa; 7 | } 8 | 9 | int 10 | dlmain(int argc, char *argv[]) 11 | { 12 | ffi_cif cif; 13 | ffi_type *args[1]; 14 | void *values[1]; 15 | unsigned char bytes[4] = { 0x00, 0x00, 0x00, 0x00 }; 16 | 17 | if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint8, args) ==FFI_OK) 18 | { 19 | ffi_call(&cif, (void *) my_foo, &bytes, values); 20 | if(bytes[3] == 0xaa) 21 | { 22 | return 0; 23 | } 24 | } 25 | 26 | return 2; 27 | } 28 | -------------------------------------------------------------------------------- /inc/probe/bigendian64.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | unsigned char 4 | my_foo(void) 5 | { 6 | return 0xaa; 7 | } 8 | 9 | int 10 | dlmain(int argc, char *argv[]) 11 | { 12 | ffi_cif cif; 13 | ffi_type *args[1]; 14 | void *values[1]; 15 | unsigned char bytes[8] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00 }; 16 | 17 | if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_uint8, args) ==FFI_OK) 18 | { 19 | ffi_call(&cif, (void *) my_foo, &bytes, values); 20 | if(bytes[7] == 0xaa) 21 | { 22 | return 0; 23 | } 24 | } 25 | 26 | return 2; 27 | } 28 | -------------------------------------------------------------------------------- /inc/probe/longdouble.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | long double 4 | my_long_double(long double a, long double b) 5 | { 6 | if(a != 1.0L || b != 3.0L) 7 | exit(2); 8 | return a+b; 9 | } 10 | 11 | int 12 | dlmain(int argc, char *argv[]) 13 | { 14 | ffi_cif cif; 15 | ffi_type *args[2]; 16 | void *values[2]; 17 | 18 | if(&ffi_type_longdouble == &ffi_type_double) 19 | return 2; 20 | 21 | args[0] = &ffi_type_longdouble; 22 | args[1] = &ffi_type_longdouble; 23 | 24 | if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 2, &ffi_type_longdouble, args) == FFI_OK) 25 | { 26 | long double answer; 27 | long double a = 1.0L; 28 | long double b = 3.0L; 29 | values[0] = &a; 30 | values[1] = &b; 31 | ffi_call(&cif, (void*) my_long_double, &answer, values); 32 | if(answer == 4.0L) 33 | return 0; 34 | } 35 | 36 | return 2; 37 | } 38 | -------------------------------------------------------------------------------- /inc/probe/recordvalue.c: -------------------------------------------------------------------------------- 1 | #include <ffi.h> 2 | #include <string.h> 3 | #include <stdlib.h> 4 | 5 | #define is_signed(type) ((((type)-1) < 0) ? 1 : 0) 6 | 7 | typedef struct { 8 | char name[13]; 9 | int value; 10 | } foo_t; 11 | 12 | foo_t 13 | get_foo(void) 14 | { 15 | foo_t self; 16 | strcpy(self.name, "hello"); 17 | self.value = 42; 18 | return self; 19 | } 20 | 21 | int 22 | dlmain(int argc, char *argv[]) 23 | { 24 | ffi_cif cif; 25 | ffi_type ffi_type_foo_t; 26 | int i; 27 | foo_t foo; 28 | ffi_type *arg_types[1] = { &ffi_type_void }; 29 | void *args[1] = { NULL }; 30 | 31 | ffi_type_foo_t.size = ffi_type_foo_t.alignment = 0; 32 | ffi_type_foo_t.type = FFI_TYPE_STRUCT; 33 | ffi_type_foo_t.elements = calloc(15, sizeof(ffi_type*)); 34 | 35 | for(i=0; i<13; i++) 36 | ffi_type_foo_t.elements[i] = is_signed(char) ? &ffi_type_sint8 : &ffi_type_uint8; 37 | ffi_type_foo_t.elements[13] = &ffi_type_sint32; 38 | ffi_type_foo_t.elements[14] = NULL; 39 | 40 | if(ffi_prep_cif(&cif, FFI_DEFAULT_ABI, 0, &ffi_type_foo_t, arg_types) == FFI_OK) 41 | { 42 | 43 | ffi_call(&cif, (void*) get_foo, &foo, args); 44 | 45 | if(strcmp(foo.name, "hello")) 46 | return 2; 47 | 48 | if(foo.value != 42) 49 | return 2; 50 | 51 | } 52 | else 53 | return 2; 54 | 55 | return 0; 56 | } 57 | -------------------------------------------------------------------------------- /inc/probe/strnlen.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | 3 | int 4 | dlmain(int argc, char *arg[]) 5 | { 6 | const char *test = "123456789\0"; 7 | 8 | if(strnlen(test, 100) == 9 && strnlen(test, 4) == 4) 9 | return 0; 10 | else 11 | return 2; 12 | } 13 | -------------------------------------------------------------------------------- /inc/probe/variadic.c: -------------------------------------------------------------------------------- 1 | #include <stdio.h> 2 | #include <stdarg.h> 3 | #include <ffi.h> 4 | 5 | int 6 | return_arg(int which, ...) 7 | { 8 | va_list args; 9 | va_start(args, which); 10 | int i, val; 11 | 12 | for(i=0; i<which; i++) 13 | { 14 | val = va_arg(args, int); 15 | } 16 | 17 | va_end(args); 18 | 19 | return val; 20 | } 21 | 22 | int 23 | basic_test() 24 | { 25 | int answer; 26 | 27 | answer = return_arg(4,10,20,30,40,50,60,70); 28 | 29 | if(answer != 40) 30 | { 31 | /* basic varadic function fail */ 32 | printf("basic answer = %d\n", answer); 33 | return 2; 34 | } 35 | 36 | return 0; 37 | } 38 | 39 | int 40 | ffi_test() 41 | { 42 | ffi_cif cif; 43 | ffi_type *args[8] = { &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32, &ffi_type_sint32 }; 44 | int values[8] = { 4,10,20,30,40,50,60,70 }; 45 | void *ptrvalues[8] = { &values[0], &values[1], &values[2], &values[3], &values[4], &values[5], &values[6], &values[7] }; 46 | int answer = -1; 47 | 48 | if(ffi_prep_cif_var(&cif, FFI_DEFAULT_ABI, 1, 8, &ffi_type_sint32, args) == FFI_OK) 49 | { 50 | ffi_call(&cif, (void*) return_arg, &answer, ptrvalues); 51 | if(answer != 40) 52 | { 53 | printf("ffi ansewr = %d\n", answer); 54 | return 2; 55 | } 56 | else 57 | { 58 | return 0; 59 | } 60 | } 61 | else 62 | { 63 | return 2; 64 | } 65 | } 66 | 67 | int 68 | dlmain(int argc, char *argv[]) 69 | { 70 | if(basic_test()) 71 | return 2; 72 | if(ffi_test()) 73 | return 2; 74 | return 0; 75 | } 76 | -------------------------------------------------------------------------------- /include/ffi_platypus_bundle.h: -------------------------------------------------------------------------------- 1 | #ifndef FFI_PLATYPUS_BUNDLE_H 2 | #define FFI_PLATYPUS_BUNDLE_H 3 | 4 | #include "ffi_platypus_config.h" 5 | 6 | #ifdef HAVE_STDDEF_H 7 | #include <stddef.h> 8 | #endif 9 | #ifdef HAVE_STDINT_H 10 | #include <stdint.h> 11 | #endif 12 | #ifdef HAVE_STDLIB_H 13 | #include <stdlib.h> 14 | #endif 15 | 16 | typedef struct { 17 | void (*set_str) (const char *name, const char *value); 18 | void (*set_sint) (const char *name, int64_t value ); 19 | void (*set_uint) (const char *name, uint64_t value ); 20 | void (*set_double) (const char *name, double value ); 21 | } ffi_platypus_constant_t; 22 | 23 | #ifdef _MSC_VER 24 | #define EXPORT __declspec(dllexport) 25 | #else 26 | #define EXPORT 27 | #endif 28 | 29 | EXPORT void ffi_pl_bundle_init(const char *, int, void **); 30 | EXPORT void ffi_pl_bundle_constant(const char *, ffi_platypus_constant_t *); 31 | EXPORT void ffi_pl_bundle_fini(const char *); 32 | 33 | #endif 34 | -------------------------------------------------------------------------------- /include/libtest.h: -------------------------------------------------------------------------------- 1 | #ifndef LIBTEST_H 2 | #define LIBTEST_H 3 | 4 | #include "ffi_platypus.h" 5 | 6 | #ifdef HAVE_STDIO_H 7 | #include <stdio.h> 8 | #endif 9 | 10 | #ifdef _MSC_VER 11 | #define EXTERN extern __declspec(dllexport) 12 | #else 13 | #define EXTERN extern 14 | #endif 15 | 16 | #endif 17 | -------------------------------------------------------------------------------- /lib/FFI/Build/File/CXX.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::File::CXX; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use parent qw( FFI::Build::File::C ); 7 | use constant default_suffix => '.cxx'; 8 | use constant default_encoding => ':utf8'; 9 | 10 | # ABSTRACT: Class to track C source file in FFI::Build 11 | # VERSION 12 | 13 | =head1 SYNOPSIS 14 | 15 | use FFI::Build::File::CXX; 16 | 17 | my $c = FFI::Build::File::CXX->new('src/foo.cxx'); 18 | 19 | =head1 DESCRIPTION 20 | 21 | File class for C++ source files. 22 | 23 | =cut 24 | 25 | sub accept_suffix 26 | { 27 | (qr/\.c(xx|pp)$/) 28 | } 29 | 30 | sub cc 31 | { 32 | my($self) = @_; 33 | $self->platform->cxx; 34 | } 35 | 36 | sub ld 37 | { 38 | my($self) = @_; 39 | $self->platform->cxxld; 40 | } 41 | 42 | 1; 43 | -------------------------------------------------------------------------------- /lib/FFI/Build/File/Library.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::File::Library; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use parent qw( FFI::Build::File::Base ); 7 | use constant default_encoding => ':raw'; 8 | 9 | # ABSTRACT: Class to track object file in FFI::Build 10 | # VERSION 11 | 12 | =head1 SYNOPSIS 13 | 14 | use FFI::Build; 15 | 16 | my $build = FFI::Build->new(source => 'src/*.c'); 17 | # $lib is an instance of FFI::Build::File::Library 18 | my $lib = $build->build; 19 | 20 | =head1 DESCRIPTION 21 | 22 | This is a class to track a library generated by L<FFI::Build>. 23 | This is returned by L<FFI::Build>'s build method. This class 24 | is a subclass of L<FFI::Build::File::Base>. The most important 25 | method is probably C<path>, which returns the path to the library 26 | which can be passed into L<FFI::Platypus> for immediate use. 27 | 28 | =head1 METHODS 29 | 30 | =head2 path 31 | 32 | my $path = $lib->path; 33 | 34 | Returns the path of the library. 35 | 36 | =cut 37 | 38 | sub default_suffix 39 | { 40 | shift->platform->library_suffix; 41 | } 42 | 43 | 1; 44 | -------------------------------------------------------------------------------- /lib/FFI/Build/File/Object.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::File::Object; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use parent qw( FFI::Build::File::Base ); 7 | use constant default_encoding => ':raw'; 8 | use Carp (); 9 | 10 | # ABSTRACT: Class to track object file in FFI::Build 11 | # VERSION 12 | 13 | =head1 SYNOPSIS 14 | 15 | use FFI::Build::File::Object; 16 | my $o = FFI::Build::File::Object->new('src/_build/foo.o'); 17 | 18 | =head1 DESCRIPTION 19 | 20 | This class represents an object file. You normally do not need 21 | to use it directly. 22 | 23 | =cut 24 | 25 | sub default_suffix 26 | { 27 | shift->platform->object_suffix; 28 | } 29 | 30 | sub build_item 31 | { 32 | my($self) = @_; 33 | unless(-f $self->path) 34 | { 35 | Carp::croak "File not built" 36 | } 37 | return; 38 | } 39 | 40 | 1; 41 | -------------------------------------------------------------------------------- /lib/FFI/Build/Plugin.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::Plugin; 2 | 3 | use strict; 4 | use warnings; 5 | use autodie; 6 | use File::Spec::Functions qw( catdir catfile ); 7 | 8 | # ABSTRACT: Platform and local customizations of FFI::Build 9 | # VERSION 10 | 11 | =head1 SYNOPSIS 12 | 13 | perldoc FFI::Build 14 | 15 | =head1 DESCRIPTION 16 | 17 | This class is experimental, but may do something useful in the future. 18 | 19 | =head1 SEE ALSO 20 | 21 | =over 4 22 | 23 | =item L<FFI::Platypus> 24 | 25 | =item L<FFI::Build> 26 | 27 | =back 28 | 29 | =cut 30 | 31 | sub new 32 | { 33 | my($class) = @_; 34 | 35 | my %plugins; 36 | 37 | foreach my $inc (@INC) 38 | { 39 | # CAVEAT: won't work with an @INC hook. Plugins must be in a "real" directory. 40 | my $path = catdir($inc, 'FFI', 'Build', 'Plugin'); 41 | next unless -d $path; 42 | my $dh; 43 | opendir $dh, $path; 44 | my @list = readdir $dh; 45 | closedir $dh; 46 | 47 | foreach my $name (map { my $x = $_; $x =~ s/\.pm$//; $x } grep /\.pm$/, @list) 48 | { 49 | next if defined $plugins{$name}; 50 | my $pm = catfile('FFI', 'Build', 'Plugin', "$name.pm"); 51 | require $pm; 52 | my $class = "FFI::Build::Plugin::$name"; 53 | if($class->can("api_version") && $class->api_version == 0) 54 | { 55 | $plugins{$name} = $class->new; 56 | } 57 | else 58 | { 59 | warn "$class is not the correct api version. You may need to upgrade the plugin, platypus or uninstall the plugin"; 60 | } 61 | } 62 | } 63 | 64 | bless \%plugins, $class; 65 | } 66 | 67 | sub call 68 | { 69 | my($self, $method, @args) = @_; 70 | 71 | foreach my $name (sort keys %$self) 72 | { 73 | my $plugin = $self->{$name}; 74 | $plugin->$method(@args) if $plugin->can($method); 75 | } 76 | 77 | 1; 78 | } 79 | 80 | 1; 81 | -------------------------------------------------------------------------------- /lib/FFI/Build/PluginData.pm: -------------------------------------------------------------------------------- 1 | package FFI::Build::PluginData; 2 | 3 | use strict; 4 | use warnings; 5 | use parent qw( Exporter ); 6 | 7 | our @EXPORT_OK = qw( plugin_data ); 8 | 9 | # ABSTRACT: Platform and local customizations of FFI::Build 10 | # VERSION 11 | 12 | =head1 SYNOPSIS 13 | 14 | perldoc FFI::Build 15 | 16 | =head1 DESCRIPTION 17 | 18 | This class is experimental, but may do something useful in the future. 19 | 20 | =head1 SEE ALSO 21 | 22 | =over 4 23 | 24 | =item L<FFI::Platypus> 25 | 26 | =item L<FFI::Build> 27 | 28 | =back 29 | 30 | =cut 31 | 32 | sub plugin_data 33 | { 34 | my($self) = @_; 35 | my $caller = caller; 36 | if($caller =~ /^FFI::Build::Plugin::(.*)$/) 37 | { 38 | return $self->{plugin_data}->{$1} ||= {}; 39 | } 40 | else 41 | { 42 | require Carp; 43 | Carp::croak("plugin_data must be called by a plugin"); 44 | } 45 | } 46 | 47 | 1; 48 | -------------------------------------------------------------------------------- /lib/FFI/Platypus.xs: -------------------------------------------------------------------------------- 1 | #include "EXTERN.h" 2 | #include "perl.h" 3 | #include "XSUB.h" 4 | #include "ppport.h" 5 | #include "ffi_platypus.h" 6 | #include "ffi_platypus_guts.h" 7 | #include "perl_math_int64.h" 8 | 9 | #define MY_CXT_KEY "FFI::Platypus::_guts" XS_VERSION 10 | 11 | typedef struct { 12 | ffi_pl_arguments *current_argv; 13 | /* 14 | * 0 not loaded 15 | * 1 loaded ok 16 | * 2 attempted load, but errored 17 | */ 18 | int loaded_math_longdouble; 19 | AV* custom_keepers; 20 | } my_cxt_t; 21 | 22 | START_MY_CXT 23 | 24 | XS(ffi_pl_sub_call) 25 | { 26 | ffi_pl_function *self; 27 | int i,n, perl_arg_index; 28 | SV *arg; 29 | ffi_pl_arguments *arguments; 30 | void **argument_pointers; 31 | 32 | dMY_CXT; 33 | dVAR; dXSARGS; 34 | 35 | self = (ffi_pl_function*) CvXSUBANY(cv).any_ptr; 36 | 37 | { 38 | #define EXTRA_ARGS 0 39 | #define FFI_PL_CALL_NO_RECORD_VALUE 1 40 | #include "ffi_platypus_call.h" 41 | } 42 | } 43 | 44 | XS(ffi_pl_sub_call_rv) 45 | { 46 | ffi_pl_function *self; 47 | int i,n, perl_arg_index; 48 | SV *arg; 49 | ffi_pl_arguments *arguments; 50 | void **argument_pointers; 51 | 52 | dMY_CXT; 53 | dVAR; dXSARGS; 54 | 55 | self = (ffi_pl_function*) CvXSUBANY(cv).any_ptr; 56 | 57 | { 58 | #define EXTRA_ARGS 0 59 | #define FFI_PL_CALL_RET_NO_NORMAL 1 60 | #include "ffi_platypus_call.h" 61 | } 62 | } 63 | 64 | MODULE = FFI::Platypus PACKAGE = FFI::Platypus 65 | 66 | BOOT: 67 | { 68 | HV *stash; 69 | MY_CXT_INIT; 70 | MY_CXT.current_argv = NULL; 71 | MY_CXT.loaded_math_longdouble = 0; 72 | MY_CXT.custom_keepers = get_av("FFI::Platypus::keep", GV_ADD); 73 | PERL_MATH_INT64_LOAD_OR_CROAK; 74 | 75 | stash = gv_stashpv("FFI::Platypus", TRUE); 76 | newCONSTSUB(stash, "_cast0", newSVuv(PTR2UV(cast0))); 77 | newCONSTSUB(stash, "_cast1", newSVuv(PTR2UV(cast1))); 78 | } 79 | 80 | void 81 | CLONE(...) 82 | CODE: 83 | MY_CXT_CLONE; 84 | MY_CXT.custom_keepers = get_av("FFI::Platypus::keep", GV_ADD); 85 | 86 | INCLUDE: ../../xs/DL.xs 87 | INCLUDE: ../../xs/Internal.xs 88 | INCLUDE: ../../xs/Type.xs 89 | INCLUDE: ../../xs/TypeParser.xs 90 | INCLUDE: ../../xs/Function.xs 91 | INCLUDE: ../../xs/ClosureData.xs 92 | INCLUDE: ../../xs/API.xs 93 | INCLUDE: ../../xs/ABI.xs 94 | INCLUDE: ../../xs/Record.xs 95 | INCLUDE: ../../xs/Closure.xs 96 | INCLUDE: ../../xs/Buffer.xs 97 | 98 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Internal.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Internal; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use FFI::Platypus; 7 | use Exporter qw( import ); 8 | 9 | require FFI::Platypus; 10 | _init(); 11 | 12 | our @EXPORT = grep /^FFI_PL/, keys %FFI::Platypus::Internal::; 13 | 14 | # ABSTRACT: For internal use only 15 | # VERSION 16 | 17 | =head1 SYNOPSIS 18 | 19 | perldoc FFI::Platypus 20 | 21 | =head1 DESCRIPTION 22 | 23 | This module is for internal use only. Do not rely on it having any particular behavior, or even existing in future versions. 24 | You have been warned. 25 | 26 | =cut 27 | 28 | 1; 29 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Lang.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Lang; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: Language specific customizations 8 | # VERSION 9 | 10 | =head1 SYNOPSIS 11 | 12 | perldoc FFI::Platypus::Lang; 13 | 14 | =head1 DESCRIPTION 15 | 16 | This namespace is reserved for language specific customizations of L<FFI::Platypus>. 17 | This usually involves providing native type maps. It can also involve computing 18 | mangled names. The default language is C, and is defined in L<FFI::Platypus::Lang::C>. 19 | 20 | This package itself doesn't do anything, it serves only as documentation. 21 | 22 | =head1 SEE ALSO 23 | 24 | =over 4 25 | 26 | =item L<FFI::Platypus> 27 | 28 | Platypus itself. 29 | 30 | =item L<FFI::Platypus::Lang::ASM> 31 | 32 | This language plugin provides no type aliases, and is intended 33 | for use with assembly language or for when no other language 34 | plugin is appropriate. 35 | 36 | =item L<FFI::Platypus::Lang::C> 37 | 38 | Language plugin for the C programming language. 39 | 40 | =item L<FFI::Platypus::Lang::Fortran> 41 | 42 | Non-core language plugin for the Fortran programming language. 43 | 44 | =item L<FFI::Platypus::Lang::CPP> 45 | 46 | Non-core language plugin for the C++ programming language. 47 | 48 | =item L<FFI::Platypus::Lang::Go> 49 | 50 | Non-core language plugin for the Go programming language. 51 | 52 | =item L<FFI::Platypus::Lang::Pascal> 53 | 54 | Non-core language plugin for the Pascal programming language. 55 | 56 | =item L<FFI::Platypus::Lang::Rust> 57 | 58 | Non-core language plugin for the Rust programming language. 59 | 60 | =item L<FFI::Platypus::Lang::Win32> 61 | 62 | Language plugin for use with the Win32 API. 63 | 64 | =item L<FFI::Platypus::Lang::Zig> 65 | 66 | Non-core language plugin for the Zig programming language. 67 | 68 | =back 69 | 70 | =cut 71 | 72 | 73 | 1; 74 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Lang/ASM.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Lang::ASM; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: Documentation and tools for using Platypus with the Assembly 8 | # VERSION 9 | 10 | =head1 SYNOPSIS 11 | 12 | use FFI::Platypus 2.00; 13 | my $ffi = FFI::Platypus->new( api => 2 ); 14 | $ffi->lang('ASM'); 15 | 16 | =head1 DESCRIPTION 17 | 18 | Setting your lang to C<ASM> includes no native type aliases, so types 19 | like C<int> or C<unsigned long> will not work. You need to specify 20 | instead C<sint32> or C<sint64>. Although intended for use with Assembly 21 | it could also be used for other languages if you did not want to use 22 | the normal C aliases for native types. 23 | 24 | This document will one day include information on bundling Assembly 25 | with your Perl / FFI / Platypus distribution. Pull requests welcome! 26 | 27 | =head1 METHODS 28 | 29 | =head2 native_type_map 30 | 31 | my $hashref = FFI::Platypus::Lang::ASM->native_type_map; 32 | 33 | This returns an empty hash reference. For other languages it returns 34 | a hash reference that defines the aliases for the types normally used 35 | for that language. 36 | 37 | =cut 38 | 39 | sub native_type_map 40 | { 41 | {} 42 | } 43 | 44 | 1; 45 | 46 | =head1 SEE ALSO 47 | 48 | =over 4 49 | 50 | =item L<FFI::Platypus> 51 | 52 | The Core Platypus documentation. 53 | 54 | =item L<FFI::Platypus::Lang> 55 | 56 | Includes a list of other language plugins for Platypus. 57 | 58 | =back 59 | 60 | =cut 61 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Lang/C.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Lang::C; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: Documentation and tools for using Platypus with the C programming language 8 | # VERSION 9 | 10 | =head1 SYNOPSIS 11 | 12 | use FFI::Platypus 2.00; 13 | my $ffi = FFI::Platypus->new( api => 2 ); 14 | $ffi->lang('C'); # the default 15 | 16 | =head1 DESCRIPTION 17 | 18 | This module provides some hooks for Platypus to interact with the C 19 | programming language. It is generally used by default if you do not 20 | specify another foreign programming language with the 21 | L<FFI::Platypus#lang> attribute. 22 | 23 | =head1 METHODS 24 | 25 | =head2 native_type_map 26 | 27 | my $hashref = FFI::Platypus::Lang::C->native_type_map; 28 | 29 | This returns a hash reference containing the native aliases for the 30 | C programming languages. That is the keys are native C types and the 31 | values are libffi native types. 32 | 33 | =cut 34 | 35 | sub native_type_map 36 | { 37 | require FFI::Platypus::ShareConfig; 38 | FFI::Platypus::ShareConfig->get('type_map'); 39 | } 40 | 41 | 1; 42 | 43 | =head1 SEE ALSO 44 | 45 | =over 4 46 | 47 | =item L<FFI::Platypus> 48 | 49 | The Core Platypus documentation. 50 | 51 | =item L<FFI::Platypus::Lang> 52 | 53 | Includes a list of other language plugins for Platypus. 54 | 55 | =back 56 | 57 | =cut 58 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Legacy.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Legacy; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: Legacy Platypus interfaces 8 | # VERSION 9 | 10 | =head1 DESCRIPTION 11 | 12 | This class is private to L<FFI::Platypus>. 13 | 14 | =cut 15 | 16 | package FFI::Platypus; 17 | 18 | sub _package 19 | { 20 | my($self, $module, $modlibname) = @_; 21 | 22 | ($module, $modlibname) = caller unless defined $modlibname; 23 | my @modparts = split /::/, $module; 24 | my $modfname = $modparts[-1]; 25 | my $modpname = join('/',@modparts); 26 | my $c = @modparts; 27 | $modlibname =~ s,[\\/][^\\/]+$,, while $c--; # Q&D basename 28 | 29 | { 30 | my @maybe = ( 31 | "$modlibname/auto/$modpname/$modfname.txt", 32 | "$modlibname/../arch/auto/$modpname/$modfname.txt", 33 | ); 34 | foreach my $file (@maybe) 35 | { 36 | if(-f $file) 37 | { 38 | open my $fh, '<', $file; 39 | my $line = <$fh>; 40 | close $fh; 41 | if($line =~ /^FFI::Build\@(.*)$/) 42 | { 43 | $self->lib("$modlibname/$1"); 44 | return $self; 45 | } 46 | } 47 | } 48 | } 49 | 50 | require FFI::Platypus::ShareConfig; 51 | my @dlext = @{ FFI::Platypus::ShareConfig->get("config_dlext") }; 52 | 53 | foreach my $dlext (@dlext) 54 | { 55 | my $file = "$modlibname/auto/$modpname/$modfname.$dlext"; 56 | unless(-e $file) 57 | { 58 | $modlibname =~ s,[\\/][^\\/]+$,,; 59 | $file = "$modlibname/arch/auto/$modpname/$modfname.$dlext"; 60 | } 61 | 62 | if(-e $file) 63 | { 64 | $self->lib($file); 65 | return $self; 66 | } 67 | } 68 | 69 | $self; 70 | } 71 | 72 | 1; 73 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Record/Meta.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Record::Meta; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: FFI support for structured records data 8 | # VERSION 9 | 10 | =head1 DESCRIPTION 11 | 12 | This class is private to FFI::Platypus. See L<FFI::Platypus::Record> for 13 | the public interface to Platypus records. 14 | 15 | =cut 16 | 17 | { 18 | require FFI::Platypus; 19 | my $ffi = FFI::Platypus->new( 20 | api => 2, 21 | ); 22 | $ffi->bundle; 23 | $ffi->mangler(sub { 24 | my($name) = @_; 25 | $name =~ s/^/ffi_platypus_record_meta__/; 26 | $name; 27 | }); 28 | 29 | $ffi->type('opaque' => 'ffi_type'); 30 | 31 | $ffi->custom_type('meta_t' => { 32 | native_type => 'opaque', 33 | perl_to_native => sub { 34 | ${ $_[0] }; 35 | }, 36 | }); 37 | 38 | $ffi->attach( _find_symbol => ['string'] => 'ffi_type'); 39 | 40 | $ffi->attach( new => ['ffi_type[]','int'] => 'meta_t', sub { 41 | my($xsub, $class, $elements, $closure_safe) = @_; 42 | 43 | if(ref($elements) ne 'ARRAY') 44 | { 45 | require Carp; 46 | Carp::croak("passed something other than a array ref to @{[ __PACKAGE__ ]}"); 47 | } 48 | 49 | my @element_type_pointers; 50 | foreach my $element_type (@$elements) 51 | { 52 | my $ptr = _find_symbol($element_type); 53 | if($ptr) 54 | { 55 | push @element_type_pointers, $ptr; 56 | } 57 | else 58 | { 59 | require Carp; 60 | Carp::croak("unknown type: $element_type"); 61 | } 62 | } 63 | 64 | push @element_type_pointers, undef; 65 | 66 | my $ptr = $xsub->(\@element_type_pointers, $closure_safe); 67 | bless \$ptr, $class; 68 | }); 69 | 70 | $ffi->attach( ffi_type => ['meta_t'] => 'ffi_type' ); 71 | $ffi->attach( size => ['meta_t'] => 'size_t' ); 72 | $ffi->attach( alignment => ['meta_t'] => 'ushort' ); 73 | $ffi->attach( element_pointers => ['meta_t'] => 'ffi_type[]' ); 74 | 75 | $ffi->attach( DESTROY => ['meta_t'] => 'void' ); 76 | } 77 | 78 | sub ptr { ${ shift() } } 79 | 80 | 1; 81 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/ShareConfig.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::ShareConfig; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use File::Spec; 7 | 8 | # VERSION 9 | 10 | sub dist_dir ($) 11 | { 12 | my($dist_name) = @_; 13 | 14 | my @pm = split /-/, $dist_name; 15 | $pm[-1] .= ".pm"; 16 | 17 | foreach my $inc (@INC) 18 | { 19 | if(-f File::Spec->catfile($inc, @pm)) 20 | { 21 | my $share = File::Spec->catdir($inc, qw( auto share dist ), $dist_name ); 22 | if(-d $share) 23 | { 24 | return File::Spec->rel2abs($share); 25 | } 26 | last; 27 | } 28 | } 29 | Carp::croak("unable to find dist share directory for $dist_name"); 30 | } 31 | 32 | sub get 33 | { 34 | my(undef, $name) = @_; 35 | my $config; 36 | 37 | unless($config) 38 | { 39 | my $fn = File::Spec->catfile(dist_dir('FFI-Platypus'), 'config.pl'); 40 | $fn = File::Spec->rel2abs($fn) unless File::Spec->file_name_is_absolute($fn); 41 | local $@; 42 | unless($config = do $fn) 43 | { 44 | die "couldn't parse configuration $fn $@" if $@; 45 | die "couldn't do $fn $!" if $!; 46 | die "bad or missing config file $fn"; 47 | }; 48 | } 49 | 50 | defined $name ? $config->{$name} : $config; 51 | } 52 | 53 | 1; 54 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/Type/PointerSizeBuffer.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::Type::PointerSizeBuffer; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use FFI::Platypus; 7 | use FFI::Platypus::API qw( 8 | arguments_set_pointer 9 | arguments_set_uint32 10 | arguments_set_uint64 11 | ); 12 | use FFI::Platypus::Buffer qw( scalar_to_buffer ); 13 | use FFI::Platypus::Buffer qw( buffer_to_scalar ); 14 | 15 | # ABSTRACT: Convert string scalar to a buffer as a pointer / size_t combination 16 | # VERSION 17 | 18 | =head1 SYNOPSIS 19 | 20 | In your C code: 21 | 22 | void 23 | function_with_buffer(void *pointer, size_t size) 24 | { 25 | ... 26 | } 27 | 28 | In your Platypus::FFI code: 29 | 30 | use FFI::Platypus 2.00; 31 | 32 | my $ffi = FFI::Platypus->new( api => 2 ); 33 | $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer'); 34 | 35 | $ffi->attach(function_with_buffer => ['buffer'] => 'void'); 36 | my $string = "content of buffer"; 37 | function_with_buffer($string); 38 | 39 | =head1 DESCRIPTION 40 | 41 | A common pattern in C code is to pass in a region of memory as a buffer, 42 | consisting of a pointer and a size of the memory region. In Perl, 43 | string scalars also point to a contiguous series of bytes that has a 44 | size, so when interfacing with C libraries it is handy to be able to 45 | pass in a string scalar as a pointer / size buffer pair. 46 | 47 | =cut 48 | 49 | my @stack; 50 | 51 | *arguments_set_size_t 52 | = FFI::Platypus->new( api => 2 )->sizeof('size_t') == 4 53 | ? \&arguments_set_uint32 54 | : \&arguments_set_uint64; 55 | 56 | sub perl_to_native 57 | { 58 | my($pointer, $size) = scalar_to_buffer($_[0]); 59 | push @stack, [ $pointer, $size ]; 60 | arguments_set_pointer $_[1], $pointer; 61 | arguments_set_size_t($_[1]+1, $size); 62 | } 63 | 64 | sub perl_to_native_post 65 | { 66 | my($pointer, $size) = @{ pop @stack }; 67 | $_[0] = buffer_to_scalar($pointer, $size); 68 | } 69 | 70 | sub ffi_custom_type_api_1 71 | { 72 | { 73 | native_type => 'opaque', 74 | perl_to_native => \&perl_to_native, 75 | perl_to_native_post => \&perl_to_native_post, 76 | argument_count => 2, 77 | } 78 | } 79 | 80 | 1; 81 | 82 | =head1 SEE ALSO 83 | 84 | =over 4 85 | 86 | =item L<FFI::Platypus> 87 | 88 | Main Platypus documentation. 89 | 90 | =item L<FFI::Platypus::Type> 91 | 92 | Platypus types documentation. 93 | 94 | =back 95 | 96 | =cut 97 | -------------------------------------------------------------------------------- /lib/FFI/Platypus/TypeParser/Version2.pm: -------------------------------------------------------------------------------- 1 | package FFI::Platypus::TypeParser::Version2; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use parent qw( FFI::Platypus::TypeParser::Version1 ); 7 | use constant _version => 2; 8 | 9 | # ABSTRACT: FFI Type Parser Version Two 10 | # VERSION 11 | 12 | =head1 SYNOPSIS 13 | 14 | use FFI::Platypus 2.00; 15 | my $ffi = FFI::Platypus->new( api => 2 ); 16 | $ffi->type('string(10)'); 17 | 18 | =head1 DESCRIPTION 19 | 20 | This documents the third (version 2) type parser for L<FFI::Platypus>. 21 | This type parser was included with L<FFI::Platypus> starting with version 22 | C<1.58> in an experimental capability, and C<2.00> as a stable interface. 23 | Starting with version C<1.00> the main L<FFI::Platypus> documentation 24 | describes the version 2 API and you can refer to 25 | L<FFI::Platypus::TypeParser::Version1> for details on the version1 API. 26 | 27 | =head1 SEE ALSO 28 | 29 | =over 4 30 | 31 | =item L<FFI::Platypus> 32 | 33 | The core L<FFI::Platypus> documentation. 34 | 35 | =item L<FFI::Platypus::TypeParser::Version0> 36 | 37 | The API C<0.02> type parser. 38 | 39 | =item L<FFI::Platypus::TypeParser::Version1> 40 | 41 | The API C<1.00> type parser. 42 | 43 | 44 | =back 45 | 46 | =cut 47 | 48 | 1; 49 | -------------------------------------------------------------------------------- /lib/FFI/Probe/Runner/Result.pm: -------------------------------------------------------------------------------- 1 | package FFI::Probe::Runner::Result; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | 7 | # ABSTRACT: The results from a probe run. 8 | # VERSION 9 | 10 | =head1 SYNOPSIS 11 | 12 | =head1 DESCRIPTION 13 | 14 | =head1 CONSTRUCTOR 15 | 16 | =head2 new 17 | 18 | my $result = FFI::Probe::Runner::Result->new(%args); 19 | 20 | Creates a new instance of the class. 21 | 22 | =cut 23 | 24 | sub new 25 | { 26 | my($class, %args) = @_; 27 | my $self = bless \%args, $class; 28 | $self; 29 | } 30 | 31 | =head1 METHODS 32 | 33 | =head2 stdout 34 | 35 | my $stdout = $result->stdout; 36 | 37 | =head2 stderr 38 | 39 | my $stderr = $result->stderr; 40 | 41 | =head2 rv 42 | 43 | my $rv = $result->rv; 44 | 45 | =head2 signal 46 | 47 | my $signal = $result->signal; 48 | 49 | =cut 50 | 51 | sub stdout { shift->{stdout} } 52 | sub stderr { shift->{stderr} } 53 | sub rv { shift->{rv} } 54 | sub signal { shift->{signal} } 55 | 56 | =head2 pass 57 | 58 | my $pass = $result->pass; 59 | 60 | =cut 61 | 62 | sub pass 63 | { 64 | my($self) = @_; 65 | $self->rv == 0 && $self->signal == 0; 66 | } 67 | 68 | 1; 69 | -------------------------------------------------------------------------------- /lib/FFI/Temp.pm: -------------------------------------------------------------------------------- 1 | package FFI::Temp; 2 | 3 | use strict; 4 | use warnings; 5 | use 5.008004; 6 | use Carp qw( croak ); 7 | use File::Spec; 8 | use File::Temp qw( tempdir ); 9 | 10 | # ABSTRACT: Temp Dir support for FFI::Platypus 11 | # VERSION 12 | 13 | =head1 DESCRIPTION 14 | 15 | This class is private to L<FFI::Platypus>. 16 | 17 | =cut 18 | 19 | # problem with vanilla File::Temp is that is often uses 20 | # as /tmp that has noexec turned on. Workaround is to 21 | # create a temp directory in the build directory, but 22 | # we have to be careful about cleanup. This puts all that 23 | # (attempted) carefulness in one place so that when we 24 | # later discover it isn't so careful we can fix it in 25 | # one place rather thabn alllll the places that we need 26 | # temp directories. 27 | 28 | my %root; 29 | 30 | sub _root 31 | { 32 | my $root = File::Spec->rel2abs(File::Spec->catdir(".tmp")); 33 | my $lock = File::Spec->catfile($root, "l$$"); 34 | 35 | foreach my $try (0..9) 36 | { 37 | sleep $try if $try != 0; 38 | mkdir $root or die "unable to create temp root $!" unless -d $root; 39 | 40 | # There is a race condition here if the FFI::Temp is 41 | # used in parallel. To work around we run this 10 42 | # times until it works. There is still a race condition 43 | # if it fails 10 times, but hopefully that is unlikely. 44 | 45 | # ??: doesn't account for fork, but probably doesn't need to. 46 | open my $fh, '>', $lock or next; 47 | close $fh or next; 48 | 49 | $root{$root} = 1; 50 | return $root; 51 | } 52 | } 53 | 54 | END { 55 | foreach my $root (keys %root) 56 | { 57 | my $lock = File::Spec->catfile($root, "l$$"); 58 | unlink $lock; 59 | # try to delete if possible. 60 | # if not possible then punt 61 | rmdir $root if -d $root; 62 | } 63 | } 64 | 65 | sub newdir 66 | { 67 | my $class = shift; 68 | croak "uneven" if @_ % 2; 69 | File::Temp->newdir(DIR => _root, @_); 70 | } 71 | 72 | sub new 73 | { 74 | my $class = shift; 75 | croak "uneven" if @_ % 2; 76 | File::Temp->new(DIR => _root, @_); 77 | } 78 | 79 | 1; 80 | -------------------------------------------------------------------------------- /lib/FFI/typemap: -------------------------------------------------------------------------------- 1 | ffi_pl_string T_FFI_PL_STRING 2 | ffi_pl_type* T_FFI_PL_TYPE 3 | ffi_pl_function* T_FFI_PL_FUNCTION 4 | ffi_pl_closure* T_FFI_PL_CLOSURE_DATA 5 | ffi_pl_arguments* T_FFI_PL_ARGUMENTS 6 | 7 | OUTPUT 8 | T_FFI_PL_STRING 9 | $var != NULL ? sv_setpv((SV*)$arg, $var) : sv_setsv((SV*)$arg, &PL_sv_undef); 10 | 11 | T_FFI_PL_TYPE 12 | sv_setref_pv($arg, \"FFI::Platypus::Type\", (void *) $var); 13 | 14 | T_FFI_PL_FUNCTION 15 | sv_setref_pv($arg, \"FFI::Platypus::Function::Function\", (void *) $var); 16 | 17 | T_FFI_PL_CLOSURE_DATA 18 | sv_setref_pv($arg, \"FFI::Platypus::ClosureData\", (void *) $var); 19 | 20 | INPUT 21 | T_FFI_PL_STRING 22 | $var = SvOK($arg) ? ($type)SvPV_nolen($arg) : NULL; 23 | 24 | T_FFI_PL_TYPE 25 | if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::Type\")) 26 | $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); 27 | else 28 | Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::Type\"); 29 | 30 | T_FFI_PL_FUNCTION 31 | if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::Function::Function\")) 32 | $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); 33 | else 34 | Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::Function::Function\"); 35 | 36 | T_FFI_PL_CLOSURE_DATA 37 | if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::ClosureData\")) 38 | $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); 39 | else 40 | Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::ClosureData\"); 41 | 42 | T_FFI_PL_ARGUMENTS 43 | if(sv_isobject($arg) && sv_derived_from($arg, \"FFI::Platypus::API::ARGV\")) 44 | $var = INT2PTR($type, SvIV((SV *) SvRV($arg))); 45 | else 46 | Perl_croak(aTHX_ \"$var is not of type FFI::Platypus::API::ARGV\"); 47 | -------------------------------------------------------------------------------- /maint/cip-before-install: -------------------------------------------------------------------------------- 1 | #!/bin/bash 2 | 3 | set -ex 4 | 5 | cip sudo apt-get update 6 | cip sudo apt-get install libffi-dev 7 | cip exec cpanm -n version 8 | 9 | if [ "$CIP_TAG" == "5.34" ]; then 10 | cip exec cpanm -n forks 11 | fi 12 | 13 | if [[ "$CIP_TAG" =~ ^5\.[0-9]+-debug(32)?$ ]]; then 14 | cip exec cpanm -n Test::LeakTrace 15 | fi 16 | -------------------------------------------------------------------------------- /maint/cip-test-examples: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | 3 | if echo $CIP_ENV | grep -q FFI_PLATYPUS_TEST_EXAMPLES ; then 4 | 5 | dir=$(ls -1d FFI-Platypus-* | grep -v tar.gz) 6 | cip sudo apt-get install libtcod1 libnotify4 libzmq5 7 | cip exec cpanm -n Capture::Tiny Test::Script Path::Tiny Convert::Binary::C YAML File::chdir Alien::Libbz2 FFI::Platypus FFI::C 8 | cip exec bash -c "cd $dir && prove -vm xt/author/example.t" 9 | 10 | fi 11 | -------------------------------------------------------------------------------- /maint/generate-abw: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Alien::Base::Wrapper 1.49; 6 | use File::Path qw( mkpath ); 7 | use File::Copy qw( copy ); 8 | 9 | mkpath 'inc/Alien/Base', 0, 0755; 10 | my $from = $INC{'Alien/Base/Wrapper.pm'}; 11 | my $to = 'inc/Alien/Base/Wrapper.pm'; 12 | 13 | print "+cp $from $to\n"; 14 | copy $from, $to or die "copy failed: $!"; 15 | -------------------------------------------------------------------------------- /maint/generate-readme: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use Pod::Abstract; 6 | use Pod::Simple::Text; 7 | 8 | my $root = Pod::Abstract->load_file("lib/FFI/Platypus.pm"); 9 | 10 | foreach my $name (qw( SUPPORT CONTRIBUTING )) 11 | { 12 | my($pod) = $root->select("/head1[\@heading=~{$name}]"); 13 | $_->detach for $pod->select('//#cut'); 14 | my $parser = Pod::Simple::Text->new; 15 | my $text; 16 | $parser->output_string( \$text ); 17 | $parser->parse_string_document( $pod->pod ); 18 | 19 | open my $fh, '>', $name; 20 | print $fh $text; 21 | close $fh; 22 | } 23 | 24 | -------------------------------------------------------------------------------- /maint/generate-record-accessor: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env perl 2 | 3 | use strict; 4 | use warnings; 5 | use autodie; 6 | use Template; 7 | 8 | my $tt2 = Template->new( 9 | INCLUDE_PATH => 'maint/tt', 10 | ); 11 | 12 | my @list = map { 13 | ( 14 | { ffi_type => "uint$_", c_type => "uint${_}_t", perl_type => "UV", zero => "0" }, 15 | { ffi_type => "sint$_", c_type => "int${_}_t", perl_type => "IV", zero => "0" }, 16 | ) 17 | } (8,16,32,64); 18 | 19 | push @list, map { { ffi_type => $_, c_type => $_, perl_type => "NV", zero => "0.0" } } qw( float double ); 20 | 21 | my $content = ''; 22 | 23 | foreach my $config (@list) 24 | { 25 | $tt2->process("accessor.tt", $config, \$content) || die $tt2->error; 26 | } 27 | 28 | open my $fh, '>', 'xs/record_simple.c'; 29 | $tt2->process("accessor_wrapper.tt", { content => $content }, $fh); 30 | close $fh; 31 | -------------------------------------------------------------------------------- /maint/run-after_build.pl: -------------------------------------------------------------------------------- 1 | use strict; 2 | use warnings; 3 | use autodie qw( :all ); 4 | 5 | my $content; 6 | 7 | open my $in, '<', 'Makefile.PL'; 8 | while(<$in>) 9 | { 10 | s/^(# This file was automatically generated by Dist::Zilla::Plugin::Author::Plicease::MakeMaker).*$/$1/; 11 | $content .= $_; 12 | } 13 | close $in; 14 | 15 | open my $out, '>', 'Makefile.PL'; 16 | print $out $content; 17 | close $out; 18 | -------------------------------------------------------------------------------- /maint/tt/accessor_wrapper.tt: -------------------------------------------------------------------------------- 1 | /* DO NOT MODIFY THIS FILE it is generated from these files: 2 | * inc/template/accessor.tt 3 | * inc/template/accessor_wrapper.tt 4 | * inc/run/generate_record_accessor.pl 5 | */ 6 | #include "EXTERN.h" 7 | #include "perl.h" 8 | #include "XSUB.h" 9 | #include "ppport.h" 10 | 11 | #include "ffi_platypus.h" 12 | #include "ffi_platypus_guts.h" 13 | 14 | [% content %] 15 | -------------------------------------------------------------------------------- /perlcriticrc: -------------------------------------------------------------------------------- 1 | severity = 1 2 | only = 1 3 | 4 | [Community::ArrayAssignAref] 5 | [Community::BarewordFilehandles] 6 | [Community::ConditionalDeclarations] 7 | [Community::ConditionalImplicitReturn] 8 | [Community::DeprecatedFeatures] 9 | [Community::DiscouragedModules] 10 | [Community::DollarAB] 11 | [Community::Each] 12 | [Community::IndirectObjectNotation] 13 | [Community::LexicalForeachIterator] 14 | [Community::LoopOnHash] 15 | [Community::ModPerl] 16 | [Community::OpenArgs] 17 | [Community::OverloadOptions] 18 | [Community::POSIXImports] 19 | [Community::PackageMatchesFilename] 20 | [Community::PreferredAlternatives] 21 | [Community::StrictWarnings] 22 | extra_importers = Test2::V0 23 | [Community::Threads] 24 | [Community::Wantarray] 25 | [Community::WarningsSwitch] 26 | [Community::WhileDiamondDefaultAssignment] 27 | 28 | [BuiltinFunctions::ProhibitBooleanGrep] 29 | ;[BuiltinFunctions::ProhibitStringyEval] 30 | [BuiltinFunctions::ProhibitStringySplit] 31 | [BuiltinFunctions::ProhibitVoidGrep] 32 | [BuiltinFunctions::ProhibitVoidMap] 33 | [ClassHierarchies::ProhibitExplicitISA] 34 | [ClassHierarchies::ProhibitOneArgBless] 35 | [CodeLayout::ProhibitHardTabs] 36 | allow_leading_tabs = 0 37 | [CodeLayout::ProhibitTrailingWhitespace] 38 | [CodeLayout::RequireConsistentNewlines] 39 | [ControlStructures::ProhibitLabelsWithSpecialBlockNames] 40 | [ControlStructures::ProhibitMutatingListFunctions] 41 | [ControlStructures::ProhibitUnreachableCode] 42 | [InputOutput::ProhibitBarewordFileHandles] 43 | [InputOutput::ProhibitJoinedReadline] 44 | [InputOutput::ProhibitTwoArgOpen] 45 | [Miscellanea::ProhibitFormats] 46 | [Miscellanea::ProhibitUselessNoCritic] 47 | [Modules::ProhibitConditionalUseStatements] 48 | ;[Modules::RequireEndWithOne] 49 | [Modules::RequireNoMatchVarsWithUseEnglish] 50 | [Objects::ProhibitIndirectSyntax] 51 | [RegularExpressions::ProhibitUselessTopic] 52 | [Subroutines::ProhibitNestedSubs] 53 | [ValuesAndExpressions::ProhibitLeadingZeros] 54 | [ValuesAndExpressions::ProhibitMixedBooleanOperators] 55 | [ValuesAndExpressions::ProhibitSpecialLiteralHeredocTerminator] 56 | [ValuesAndExpressions::RequireUpperCaseHeredocTerminator] 57 | [Variables::ProhibitPerl4PackageNames] 58 | [Variables::ProhibitUnusedVariables] 59 | -------------------------------------------------------------------------------- /t/ffi/align.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef struct _my_struct { 4 | char x1; 5 | uint64_t my_uint64; 6 | char x2; 7 | uint32_t my_uint32; 8 | char x3; 9 | uint16_t my_uint16; 10 | char x4; 11 | uint8_t my_uint8; 12 | 13 | char x5; 14 | int64_t my_sint64; 15 | char x6; 16 | int32_t my_sint32; 17 | char x7; 18 | int16_t my_sint16; 19 | char x8; 20 | int8_t my_sint8; 21 | 22 | char x9; 23 | float my_float; 24 | char x10; 25 | double my_double; 26 | 27 | char x11; 28 | void *my_opaque; 29 | } my_struct; 30 | 31 | 32 | EXTERN uint64_t 33 | align_get_uint64(my_struct *my_struct) 34 | { 35 | return my_struct->my_uint64; 36 | } 37 | 38 | EXTERN uint32_t 39 | align_get_uint32(my_struct *my_struct) 40 | { 41 | return my_struct->my_uint32; 42 | } 43 | 44 | EXTERN uint16_t 45 | align_get_uint16(my_struct *my_struct) 46 | { 47 | return my_struct->my_uint16; 48 | } 49 | 50 | EXTERN uint8_t 51 | align_get_uint8(my_struct *my_struct) 52 | { 53 | return my_struct->my_uint8; 54 | } 55 | 56 | EXTERN int64_t 57 | align_get_sint64(my_struct *my_struct) 58 | { 59 | return my_struct->my_sint64; 60 | } 61 | 62 | EXTERN int32_t 63 | align_get_sint32(my_struct *my_struct) 64 | { 65 | return my_struct->my_sint32; 66 | } 67 | 68 | EXTERN int16_t 69 | align_get_sint16(my_struct *my_struct) 70 | { 71 | return my_struct->my_sint16; 72 | } 73 | 74 | EXTERN int8_t 75 | align_get_sint8(my_struct *my_struct) 76 | { 77 | return my_struct->my_sint8; 78 | } 79 | 80 | EXTERN float 81 | align_get_float(my_struct *my_struct) 82 | { 83 | return my_struct->my_float; 84 | } 85 | 86 | EXTERN double 87 | align_get_double(my_struct *my_struct) 88 | { 89 | return my_struct->my_double; 90 | } 91 | 92 | EXTERN void * 93 | align_get_opaque(my_struct *my_struct) 94 | { 95 | return my_struct->my_opaque; 96 | } 97 | -------------------------------------------------------------------------------- /t/ffi/align_array.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef struct _my_struct { 4 | char x1; 5 | uint64_t my_uint64[3]; 6 | char x2; 7 | uint32_t my_uint32[3]; 8 | char x3; 9 | uint16_t my_uint16[3]; 10 | char x4; 11 | uint8_t my_uint8[3]; 12 | 13 | char x5; 14 | int64_t my_sint64[3]; 15 | char x6; 16 | int32_t my_sint32[3]; 17 | char x7; 18 | int16_t my_sint16[3]; 19 | char x8; 20 | int8_t my_sint8[3]; 21 | 22 | char x9; 23 | float my_float[3]; 24 | char x10; 25 | double my_double[3]; 26 | 27 | char x11; 28 | void *my_opaque[3]; 29 | } my_struct; 30 | 31 | 32 | EXTERN uint64_t * 33 | align_array_get_uint64(my_struct *my_struct) 34 | { 35 | return my_struct->my_uint64; 36 | } 37 | 38 | EXTERN uint32_t * 39 | align_array_get_uint32(my_struct *my_struct) 40 | { 41 | return my_struct->my_uint32; 42 | } 43 | 44 | EXTERN uint16_t * 45 | align_array_get_uint16(my_struct *my_struct) 46 | { 47 | return my_struct->my_uint16; 48 | } 49 | 50 | EXTERN uint8_t * 51 | align_array_get_uint8(my_struct *my_struct) 52 | { 53 | return my_struct->my_uint8; 54 | } 55 | 56 | EXTERN int64_t * 57 | align_array_get_sint64(my_struct *my_struct) 58 | { 59 | return my_struct->my_sint64; 60 | } 61 | 62 | EXTERN int32_t * 63 | align_array_get_sint32(my_struct *my_struct) 64 | { 65 | return my_struct->my_sint32; 66 | } 67 | 68 | EXTERN int16_t * 69 | align_array_get_sint16(my_struct *my_struct) 70 | { 71 | return my_struct->my_sint16; 72 | } 73 | 74 | EXTERN int8_t * 75 | align_array_get_sint8(my_struct *my_struct) 76 | { 77 | return my_struct->my_sint8; 78 | } 79 | 80 | EXTERN float * 81 | align_array_get_float(my_struct *my_struct) 82 | { 83 | return my_struct->my_float; 84 | } 85 | 86 | EXTERN double * 87 | align_array_get_double(my_struct *my_struct) 88 | { 89 | return my_struct->my_double; 90 | } 91 | 92 | EXTERN void ** 93 | align_array_get_opaque(my_struct *my_struct) 94 | { 95 | return my_struct->my_opaque; 96 | } 97 | -------------------------------------------------------------------------------- /t/ffi/align_fixed.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef struct { 4 | char mess_up_alignment; 5 | const char value[10]; 6 | } foo_t; 7 | 8 | EXTERN const char * 9 | align_fixed_get_value(foo_t *foo) 10 | { 11 | return foo->value; 12 | } 13 | -------------------------------------------------------------------------------- /t/ffi/align_string.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef struct { 4 | char mess_up_alignment; 5 | const char *value; 6 | } foo_t; 7 | 8 | EXTERN const char * 9 | align_string_get_value(foo_t *foo) 10 | { 11 | return foo->value; 12 | } 13 | 14 | EXTERN void 15 | align_string_set_value(foo_t *foo, const char *value) 16 | { 17 | static char buffer[512]; 18 | if(value != NULL) 19 | { 20 | strcpy(buffer, value); 21 | foo->value = buffer; 22 | } 23 | else 24 | { 25 | foo->value = NULL; 26 | } 27 | } 28 | -------------------------------------------------------------------------------- /t/ffi/basic.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN uint8_t 4 | f0(uint8_t input) 5 | { 6 | return input; 7 | } 8 | 9 | EXTERN int 10 | my_atoi(const char *string) 11 | { 12 | return atoi(string); 13 | } 14 | 15 | EXTERN void 16 | f1(void) 17 | { 18 | } 19 | 20 | EXTERN void 21 | f2(int *i) 22 | { 23 | *i = *i+1; 24 | } 25 | 26 | EXTERN int 27 | mystrangeprefix_bar(void) 28 | { 29 | return 42; 30 | } 31 | -------------------------------------------------------------------------------- /t/ffi/closure.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef int (*closure1_t)(void); 4 | typedef int (*closure2_t)(int); 5 | static closure1_t my_closure1; 6 | static closure2_t my_closure2; 7 | 8 | EXTERN void 9 | closure_set_closure1(closure1_t closure) 10 | { 11 | my_closure1 = closure; 12 | } 13 | 14 | EXTERN void 15 | closure_set_closure2(closure2_t closure) 16 | { 17 | my_closure2 = closure; 18 | } 19 | 20 | EXTERN int 21 | closure_call_closure1(void) 22 | { 23 | return my_closure1(); 24 | } 25 | 26 | EXTERN int 27 | closure_call_closure2(int arg) 28 | { 29 | return my_closure2(arg); 30 | } 31 | 32 | EXTERN int 33 | closure_call_closure_immediate(closure2_t closure, int arg) 34 | { 35 | return closure(arg); 36 | } 37 | 38 | typedef struct { 39 | const char *one; 40 | const char *two; 41 | int three; 42 | const char *four; 43 | int myarray1[2]; 44 | void *opaque1; 45 | void *myarray2[2]; 46 | char fixedfive[5]; 47 | } cx_struct_t; 48 | 49 | typedef void (*cx_closure_t)(cx_struct_t *, int); 50 | static cx_closure_t my_cx_closure; 51 | 52 | EXTERN void 53 | cx_closure_set(cx_closure_t closure) 54 | { 55 | my_cx_closure = closure; 56 | } 57 | 58 | EXTERN void 59 | cx_closure_call(cx_struct_t *s, int i) 60 | { 61 | my_cx_closure(s, i); 62 | } 63 | 64 | typedef void (*cxv_closure_t)(cx_struct_t, int); 65 | static cxv_closure_t my_cxv_closure; 66 | 67 | EXTERN void 68 | cxv_closure_set(cxv_closure_t closure) 69 | { 70 | my_cxv_closure = closure; 71 | } 72 | 73 | EXTERN void 74 | cxv_closure_call(cx_struct_t s, int i) 75 | { 76 | my_cxv_closure(s, i); 77 | } 78 | 79 | typedef struct { 80 | char foo; 81 | short bar; 82 | int baz; 83 | } cx_struct_simple_t; 84 | 85 | typedef cx_struct_simple_t (*cxv_closure_simple_t)(void); 86 | 87 | EXTERN cx_struct_simple_t* 88 | cxv_closure_simple_call(cxv_closure_simple_t closure) 89 | { 90 | static cx_struct_simple_t simple; 91 | simple = closure(); 92 | return &simple; 93 | } 94 | -------------------------------------------------------------------------------- /t/ffi/color.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | typedef struct _color { 4 | uint8_t red, green, blue; 5 | } color; 6 | 7 | 8 | EXTERN color * 9 | color_new(int red, int green, int blue) 10 | { 11 | static color _self; 12 | color *self = &_self; 13 | self->red = red; 14 | self->green = green; 15 | self->blue = blue; 16 | return self; 17 | } 18 | 19 | EXTERN int 20 | color_get_red(color *self) 21 | { 22 | return self->red; 23 | } 24 | 25 | EXTERN void 26 | color_set_red(color *self, int value) 27 | { 28 | self->red = value; 29 | } 30 | 31 | EXTERN int 32 | color_get_green(color *self) 33 | { 34 | return self->green; 35 | } 36 | 37 | EXTERN void 38 | color_set_green(color *self, int value) 39 | { 40 | self->green = value; 41 | } 42 | 43 | EXTERN int 44 | color_get_blue(color *self) 45 | { 46 | return self->blue; 47 | } 48 | 49 | EXTERN void 50 | color_set_blue(color *self, int value) 51 | { 52 | self->blue = value; 53 | } 54 | 55 | EXTERN void 56 | color_DESTROY(color *self) 57 | { 58 | free(self); 59 | } 60 | 61 | EXTERN size_t 62 | color_ffi_record_size() 63 | { 64 | return sizeof(color); 65 | } 66 | -------------------------------------------------------------------------------- /t/ffi/complex_double.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/complex_float.c 4 | * all instances of "float" have been changed to "double" 5 | */ 6 | #include "libtest.h" 7 | #if SIZEOF_DOUBLE_COMPLEX 8 | 9 | EXTERN double 10 | complex_double_get_real(double complex f) 11 | { 12 | return creal(f); 13 | } 14 | 15 | EXTERN double 16 | complex_double_get_imag(double complex f) 17 | { 18 | return cimag(f); 19 | } 20 | 21 | EXTERN const char * 22 | complex_double_to_string(double complex f) 23 | { 24 | static char buffer[1024]; 25 | sprintf(buffer, "%g + %g * i", creal(f), cimag(f)); 26 | return buffer; 27 | } 28 | 29 | EXTERN double 30 | complex_double_ptr_get_real(double complex *f) 31 | { 32 | return creal(*f); 33 | } 34 | 35 | EXTERN double 36 | complex_double_ptr_get_imag(double complex *f) 37 | { 38 | return cimag(*f); 39 | } 40 | 41 | EXTERN void 42 | complex_double_ptr_set(double complex *f, double r, double i) 43 | { 44 | *f = r + i*I; 45 | } 46 | 47 | EXTERN double complex 48 | complex_double_ret(double r, double i) 49 | { 50 | return r + i*I; 51 | } 52 | 53 | EXTERN double complex * 54 | complex_double_ptr_ret(double r, double i) 55 | { 56 | static double complex f; 57 | f = r + i*I; 58 | return &f; 59 | } 60 | 61 | EXTERN double complex 62 | complex_double_array_get(double complex *f, int index) 63 | { 64 | return f[index]; 65 | } 66 | 67 | EXTERN void 68 | complex_double_array_set(double complex *f, int index, double r, double i) 69 | { 70 | f[index] = r + i*I; 71 | } 72 | 73 | EXTERN double complex * 74 | complex_double_array_ret(void) 75 | { 76 | static double complex ret[3]; 77 | 78 | ret[0] = 0.0 + 0.0*I; 79 | ret[1] = 1.0 + 2.0*I; 80 | ret[2] = 3.0 + 4.0*I; 81 | 82 | return ret; 83 | } 84 | 85 | #endif 86 | -------------------------------------------------------------------------------- /t/ffi/complex_float.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | #if SIZEOF_FLOAT_COMPLEX 3 | 4 | EXTERN float 5 | complex_float_get_real(float complex f) 6 | { 7 | return crealf(f); 8 | } 9 | 10 | EXTERN float 11 | complex_float_get_imag(float complex f) 12 | { 13 | return cimagf(f); 14 | } 15 | 16 | EXTERN const char * 17 | complex_float_to_string(float complex f) 18 | { 19 | static char buffer[1024]; 20 | sprintf(buffer, "%g + %g * i", crealf(f), cimagf(f)); 21 | return buffer; 22 | } 23 | 24 | EXTERN float 25 | complex_float_ptr_get_real(float complex *f) 26 | { 27 | return crealf(*f); 28 | } 29 | 30 | EXTERN float 31 | complex_float_ptr_get_imag(float complex *f) 32 | { 33 | return cimagf(*f); 34 | } 35 | 36 | EXTERN void 37 | complex_float_ptr_set(float complex *f, float r, float i) 38 | { 39 | *f = r + i*I; 40 | } 41 | 42 | EXTERN float complex 43 | complex_float_ret(float r, float i) 44 | { 45 | return r + i*I; 46 | } 47 | 48 | EXTERN float complex * 49 | complex_float_ptr_ret(float r, float i) 50 | { 51 | static float complex f; 52 | f = r + i*I; 53 | return &f; 54 | } 55 | 56 | EXTERN float complex 57 | complex_float_array_get(float complex *f, int index) 58 | { 59 | return f[index]; 60 | } 61 | 62 | EXTERN void 63 | complex_float_array_set(float complex *f, int index, float r, float i) 64 | { 65 | f[index] = r + i*I; 66 | } 67 | 68 | EXTERN float complex * 69 | complex_float_array_ret(void) 70 | { 71 | static float complex ret[3]; 72 | 73 | ret[0] = 0.0 + 0.0*I; 74 | ret[1] = 1.0 + 2.0*I; 75 | ret[2] = 3.0 + 4.0*I; 76 | 77 | return ret; 78 | } 79 | 80 | #endif 81 | -------------------------------------------------------------------------------- /t/ffi/double.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/float.c 4 | * all instances of "float" have been changed to "double" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN double 9 | double_add(double a, double b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN double* 15 | double_inc(double *a, double b) 16 | { 17 | static double keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN double 23 | double_sum(double list[10]) 24 | { 25 | int i; 26 | double total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN double 35 | double_sum2(double *list, size_t size) 36 | { 37 | int i; 38 | double total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | double_array_inc(double list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN double * 57 | double_static_array(void) 58 | { 59 | static double foo[] = { -5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5 }; 60 | return foo; 61 | } 62 | 63 | typedef double (*closure_t)(double); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | double_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN double 73 | double_call_closure(double value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/float.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN float 4 | float_add(float a, float b) 5 | { 6 | return a + b; 7 | } 8 | 9 | EXTERN float* 10 | float_inc(float *a, float b) 11 | { 12 | static float keeper; 13 | keeper = *a += b; 14 | return &keeper; 15 | } 16 | 17 | EXTERN float 18 | float_sum(float list[10]) 19 | { 20 | int i; 21 | float total; 22 | for(i=0,total=0; i<10; i++) 23 | { 24 | total += list[i]; 25 | } 26 | return total; 27 | } 28 | 29 | EXTERN float 30 | float_sum2(float *list, size_t size) 31 | { 32 | int i; 33 | float total; 34 | for(i=0,total=0; i<size; i++) 35 | { 36 | total += list[i]; 37 | } 38 | return total; 39 | } 40 | 41 | EXTERN void 42 | float_array_inc(float list[10]) 43 | { 44 | int i; 45 | for(i=0; i<10; i++) 46 | { 47 | list[i]++; 48 | } 49 | } 50 | 51 | EXTERN float * 52 | float_static_array(void) 53 | { 54 | static float foo[] = { -5.5, 5.5, -10, 10, -15.5, 15.5, 20, -20, 25.5, -25.5 }; 55 | return foo; 56 | } 57 | 58 | typedef float (*closure_t)(float); 59 | static closure_t my_closure; 60 | 61 | EXTERN void 62 | float_set_closure(closure_t closure) 63 | { 64 | my_closure = closure; 65 | } 66 | 67 | EXTERN float 68 | float_call_closure(float value) 69 | { 70 | return my_closure(value); 71 | } 72 | -------------------------------------------------------------------------------- /t/ffi/gh117.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN uint64_t 4 | gh117() 5 | { 6 | return 0xffffffffff; 7 | } 8 | -------------------------------------------------------------------------------- /t/ffi/gh174.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN void 4 | gh174_func1 (void (*callback)()) 5 | { 6 | printf( "Inside func..\n"); 7 | (*callback)(); 8 | } 9 | -------------------------------------------------------------------------------- /t/ffi/longdouble.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | #ifdef FFI_PL_PROBE_LONGDOUBLE 3 | 4 | EXTERN long double 5 | longdouble_add(long double a, long double b) 6 | { 7 | return a + b; 8 | } 9 | 10 | EXTERN int 11 | longdouble_pointer_test(long double *a, long double *b) 12 | { 13 | if(*a + *b != 4.0L) 14 | return 0; 15 | 16 | *a = 4.0L; 17 | *b = 8.0L; 18 | 19 | return 1; 20 | } 21 | 22 | EXTERN long double * 23 | longdouble_pointer_return_test(long double a) 24 | { 25 | static long double *keep = NULL; 26 | if(keep == NULL) 27 | keep = malloc(sizeof(long double)); 28 | *keep = a; 29 | return keep; 30 | } 31 | 32 | EXTERN int 33 | longdouble_array_test(long double *a, int n) 34 | { 35 | long double sum; 36 | int i; 37 | int ret; 38 | 39 | for(sum=0.0,i=0; i < n; i++) 40 | { 41 | sum += a[i]; 42 | } 43 | 44 | if(sum == 100.00) 45 | ret = 1; 46 | else 47 | ret = 0; 48 | 49 | for(i=0; i < n; i++) 50 | a[i] = (long double) i+1; 51 | 52 | return ret; 53 | } 54 | 55 | EXTERN long double * 56 | longdouble_array_return_test() 57 | { 58 | static long double keep[3] = { 1.0, 2.0, 3.0 }; 59 | return keep; 60 | } 61 | 62 | #endif 63 | -------------------------------------------------------------------------------- /t/ffi/memcmp4.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN int 4 | memcmp4(void *buf1, size_t n1, void *buf2, size_t n2) 5 | { 6 | if (n1 != n2) 7 | return 1; 8 | 9 | return memcmp(buf1, buf2, n1); 10 | } 11 | -------------------------------------------------------------------------------- /t/ffi/meta.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | struct mymeta_t { 4 | int foo; 5 | char *bar; 6 | }; 7 | 8 | EXTERN struct mymeta_t* 9 | mymeta_new(int foo, const char *bar) 10 | { 11 | struct mymeta_t *self; 12 | self = malloc(sizeof(struct mymeta_t)); 13 | self->foo = foo; 14 | self->bar = malloc(strlen(bar)+1); 15 | strcpy(self->bar, bar); 16 | return self; 17 | } 18 | 19 | EXTERN void 20 | mymeta_delete(struct mymeta_t *self) 21 | { 22 | free(self->bar); 23 | free(self); 24 | } 25 | 26 | EXTERN const char * 27 | mymeta_test(struct mymeta_t *self, int count, const char *baz) 28 | { 29 | static char buffer[1024]; 30 | sprintf(buffer, 31 | "foo = %d, bar = %s, baz = %s, count = %d", 32 | self->foo, self->bar != NULL ? self->bar : "undef", baz != NULL ? baz : "undef", count 33 | ); 34 | return buffer; 35 | } 36 | -------------------------------------------------------------------------------- /t/ffi/record.c: -------------------------------------------------------------------------------- 1 | #include <string.h> 2 | #include "libtest.h" 3 | 4 | typedef struct { 5 | char name[16]; 6 | int32_t value; 7 | } foo_record_t; 8 | 9 | EXTERN const char * 10 | foo_get_name(foo_record_t *self) 11 | { 12 | static char ret[16]; 13 | if(self == NULL) 14 | return NULL; 15 | /* 16 | * TODO: we need to copy the name because the record 17 | * could fall out of scope before we start processing 18 | * the return values in ffi_platypus_call.h. If we 19 | * can rework that code to delay until after the SV* 20 | * is created for the return value then we wouldn't 21 | * need to do this. 22 | */ 23 | memcpy(ret, self->name, 16); 24 | return ret; 25 | } 26 | 27 | EXTERN const char * 28 | foo_value_get_name(foo_record_t self) 29 | { 30 | static char name[16]; 31 | strcpy(name, self.name); 32 | return name; 33 | } 34 | 35 | EXTERN int32_t 36 | foo_get_value(foo_record_t *self) 37 | { 38 | if(self == NULL) 39 | return 0; 40 | return self->value; 41 | } 42 | 43 | EXTERN int32_t 44 | foo_value_get_value(foo_record_t self) 45 | { 46 | return self.value; 47 | } 48 | 49 | EXTERN foo_record_t * 50 | foo_create(const char *name, int32_t value) 51 | { 52 | static foo_record_t self; 53 | int i; 54 | 55 | for(i=0; i<16; i++) 56 | self.name[i] = '\0'; 57 | 58 | strcpy(self.name, name); 59 | self.value = value; 60 | 61 | return &self; 62 | } 63 | 64 | EXTERN foo_record_t 65 | foo_value_create(const char *name, int32_t value) 66 | { 67 | foo_record_t self; 68 | int i; 69 | 70 | for(i=0; i<16; i++) 71 | self.name[i] = '\0'; 72 | 73 | strcpy(self.name, name); 74 | self.value = value; 75 | 76 | return self; 77 | } 78 | -------------------------------------------------------------------------------- /t/ffi/sint16.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/sint8.c 4 | * all instances of "int8" have been changed to "int16" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN int16_t 9 | sint16_add(int16_t a, int16_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN int16_t* 15 | sint16_inc(int16_t *a, int16_t b) 16 | { 17 | static int16_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN int16_t 23 | sint16_sum(int16_t list[10]) 24 | { 25 | int i; 26 | int16_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN int16_t 35 | sint16_sum2(int16_t *list, size_t size) 36 | { 37 | int i; 38 | int16_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | sint16_array_inc(int16_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN int16_t * 57 | sint16_static_array(void) 58 | { 59 | static int16_t foo[] = { -1,2,-3,4,-5,6,-7,8,-9,10 }; 60 | return foo; 61 | } 62 | 63 | typedef int16_t (*closure_t)(int16_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | sint16_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN int16_t 73 | sint16_call_closure(int16_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/sint32.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/sint8.c 4 | * all instances of "int8" have been changed to "int32" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN int32_t 9 | sint32_add(int32_t a, int32_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN int32_t* 15 | sint32_inc(int32_t *a, int32_t b) 16 | { 17 | static int32_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN int32_t 23 | sint32_sum(int32_t list[10]) 24 | { 25 | int i; 26 | int32_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN int32_t 35 | sint32_sum2(int32_t *list, size_t size) 36 | { 37 | int i; 38 | int32_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | sint32_array_inc(int32_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN int32_t * 57 | sint32_static_array(void) 58 | { 59 | static int32_t foo[] = { -1,2,-3,4,-5,6,-7,8,-9,10 }; 60 | return foo; 61 | } 62 | 63 | typedef int32_t (*closure_t)(int32_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | sint32_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN int32_t 73 | sint32_call_closure(int32_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/sint64.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/sint8.c 4 | * all instances of "int8" have been changed to "int64" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN int64_t 9 | sint64_add(int64_t a, int64_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN int64_t* 15 | sint64_inc(int64_t *a, int64_t b) 16 | { 17 | static int64_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN int64_t 23 | sint64_sum(int64_t list[10]) 24 | { 25 | int i; 26 | int64_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN int64_t 35 | sint64_sum2(int64_t *list, size_t size) 36 | { 37 | int i; 38 | int64_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | sint64_array_inc(int64_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN int64_t * 57 | sint64_static_array(void) 58 | { 59 | static int64_t foo[] = { -1,2,-3,4,-5,6,-7,8,-9,10 }; 60 | return foo; 61 | } 62 | 63 | typedef int64_t (*closure_t)(int64_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | sint64_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN int64_t 73 | sint64_call_closure(int64_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/sint8.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN int8_t 4 | sint8_add(int8_t a, int8_t b) 5 | { 6 | return a + b; 7 | } 8 | 9 | EXTERN int8_t* 10 | sint8_inc(int8_t *a, int8_t b) 11 | { 12 | static int8_t keeper; 13 | keeper = *a += b; 14 | return &keeper; 15 | } 16 | 17 | EXTERN int8_t 18 | sint8_sum(int8_t list[10]) 19 | { 20 | int i; 21 | int8_t total; 22 | for(i=0,total=0; i<10; i++) 23 | { 24 | total += list[i]; 25 | } 26 | return total; 27 | } 28 | 29 | EXTERN int8_t 30 | sint8_sum2(int8_t *list, size_t size) 31 | { 32 | int i; 33 | int8_t total; 34 | for(i=0,total=0; i<size; i++) 35 | { 36 | total += list[i]; 37 | } 38 | return total; 39 | } 40 | 41 | EXTERN void 42 | sint8_array_inc(int8_t list[10]) 43 | { 44 | int i; 45 | for(i=0; i<10; i++) 46 | { 47 | list[i]++; 48 | } 49 | } 50 | 51 | EXTERN int8_t * 52 | sint8_static_array(void) 53 | { 54 | static int8_t foo[] = { -1,2,-3,4,-5,6,-7,8,-9,10 }; 55 | return foo; 56 | } 57 | 58 | typedef int8_t (*closure_t)(int8_t); 59 | static closure_t my_closure; 60 | 61 | EXTERN void 62 | sint8_set_closure(closure_t closure) 63 | { 64 | my_closure = closure; 65 | } 66 | 67 | EXTERN int8_t 68 | sint8_call_closure(int8_t value) 69 | { 70 | return my_closure(value); 71 | } 72 | -------------------------------------------------------------------------------- /t/ffi/string.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN int 4 | string_matches_foobarbaz(const char *value) 5 | { 6 | return !strcmp(value, "foobarbaz"); 7 | } 8 | 9 | EXTERN const char * 10 | string_return_foobarbaz(void) 11 | { 12 | return "foobarbaz"; 13 | } 14 | 15 | typedef const char *my_string_t; 16 | typedef void (*closure_t)(my_string_t); 17 | static closure_t my_closure; 18 | 19 | EXTERN void 20 | string_set_closure(closure_t closure) 21 | { 22 | my_closure = closure; 23 | } 24 | 25 | EXTERN void 26 | string_call_closure(const char *value) 27 | { 28 | my_closure(value); 29 | } 30 | 31 | EXTERN const char * 32 | string_pointer_pointer_get(const char **ptr) 33 | { 34 | return *ptr; 35 | } 36 | 37 | EXTERN void 38 | string_pointer_pointer_set(const char **ptr, const char *value) 39 | { 40 | *ptr = value; 41 | } 42 | 43 | EXTERN char ** 44 | string_pointer_pointer_return(char *value) 45 | { 46 | static char buffer[512]; 47 | static char *tmp; 48 | if(value != NULL) 49 | { 50 | strcpy(buffer, value); 51 | tmp = buffer; 52 | } 53 | else 54 | { 55 | tmp = value; 56 | } 57 | return &tmp; 58 | } 59 | 60 | EXTERN const char * 61 | string_fixed_test(int i) 62 | { 63 | static char buffer[] = "zero one two threefour "; 64 | return &buffer[i*5]; 65 | } 66 | 67 | EXTERN const char * 68 | string_test_pointer_arg(char **arg) 69 | { 70 | static char buffer[512]; 71 | 72 | if(arg == NULL) 73 | return "arg==NULL"; 74 | 75 | if(*arg == NULL) 76 | sprintf(buffer, "*arg==NULL"); 77 | else 78 | sprintf(buffer, "*arg==%s", *arg); 79 | 80 | *arg = "out"; 81 | 82 | return buffer; 83 | } 84 | 85 | EXTERN char ** 86 | string_test_pointer_ret(char *arg) 87 | { 88 | static char buffer[512]; 89 | static char *null = NULL; 90 | if(arg == NULL) 91 | return &null; 92 | else 93 | sprintf(buffer, "%s", arg); 94 | return (char**) &buffer; 95 | } 96 | 97 | EXTERN void 98 | string_write_to_string(char *dst, char *src) 99 | { 100 | int i=0; 101 | while(src[i] != '\0') 102 | { 103 | dst[i]=src[i]; 104 | i++; 105 | } 106 | dst[i]=0; 107 | } 108 | -------------------------------------------------------------------------------- /t/ffi/string_array.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | #include <string.h> 3 | 4 | EXTERN const char * 5 | get_string_from_array(const char **array, int index) 6 | { 7 | static char buffer[512]; 8 | if(array[index] == NULL) 9 | return NULL; 10 | strcpy(buffer, array[index]); 11 | return buffer; 12 | } 13 | 14 | EXTERN const char ** 15 | onetwothree3() 16 | { 17 | static char *buffer[4] = { 18 | "one", 19 | "two", 20 | "three" 21 | }; 22 | return (const char **) buffer; 23 | } 24 | 25 | EXTERN const char ** 26 | onetwothree4() 27 | { 28 | static char *buffer[4] = { 29 | "one", 30 | "two", 31 | "three", 32 | NULL 33 | }; 34 | return (const char **) buffer; 35 | } 36 | 37 | EXTERN const char ** 38 | onenullthree3() 39 | { 40 | static char *buffer[3] = { 41 | "one", 42 | NULL, 43 | "three" 44 | }; 45 | return (const char **) buffer; 46 | } 47 | 48 | EXTERN const char ** 49 | ptrnull() 50 | { 51 | static char *buffer[1] = { 52 | NULL 53 | }; 54 | return (const char **) buffer; 55 | } 56 | 57 | EXTERN void 58 | string_array_arg_update(char **arg) 59 | { 60 | arg[0] = "one"; 61 | arg[1] = "two"; 62 | } 63 | -------------------------------------------------------------------------------- /t/ffi/uint16.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/uint8.c 4 | * all instances of "int8" have been changed to "int16" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN uint16_t 9 | uint16_add(uint16_t a, uint16_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN uint16_t* 15 | uint16_inc(uint16_t *a, uint16_t b) 16 | { 17 | static uint16_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN uint16_t 23 | uint16_sum(uint16_t list[10]) 24 | { 25 | int i; 26 | uint16_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN uint16_t 35 | uint16_sum2(uint16_t *list, size_t size) 36 | { 37 | int i; 38 | uint16_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | uint16_array_inc(uint16_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN uint16_t * 57 | uint16_static_array(void) 58 | { 59 | static uint16_t foo[] = { 1,4,6,8,10,12,14,16,18,20 }; 60 | return foo; 61 | } 62 | 63 | typedef uint16_t (*closure_t)(uint16_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | uint16_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN uint16_t 73 | uint16_call_closure(uint16_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/uint32.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/uint8.c 4 | * all instances of "int8" have been changed to "int32" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN uint32_t 9 | uint32_add(uint32_t a, uint32_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN uint32_t* 15 | uint32_inc(uint32_t *a, uint32_t b) 16 | { 17 | static uint32_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN uint32_t 23 | uint32_sum(uint32_t list[10]) 24 | { 25 | int i; 26 | uint32_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN uint32_t 35 | uint32_sum2(uint32_t *list, size_t size) 36 | { 37 | int i; 38 | uint32_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | uint32_array_inc(uint32_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN uint32_t * 57 | uint32_static_array(void) 58 | { 59 | static uint32_t foo[] = { 1,4,6,8,10,12,14,16,18,20 }; 60 | return foo; 61 | } 62 | 63 | typedef uint32_t (*closure_t)(uint32_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | uint32_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN uint32_t 73 | uint32_call_closure(uint32_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/uint64.c: -------------------------------------------------------------------------------- 1 | /* 2 | * DO NOT MODIFY THIS FILE. 3 | * This file generated from similar file t/ffi/uint8.c 4 | * all instances of "int8" have been changed to "int64" 5 | */ 6 | #include "libtest.h" 7 | 8 | EXTERN uint64_t 9 | uint64_add(uint64_t a, uint64_t b) 10 | { 11 | return a + b; 12 | } 13 | 14 | EXTERN uint64_t* 15 | uint64_inc(uint64_t *a, uint64_t b) 16 | { 17 | static uint64_t keeper; 18 | keeper = *a += b; 19 | return &keeper; 20 | } 21 | 22 | EXTERN uint64_t 23 | uint64_sum(uint64_t list[10]) 24 | { 25 | int i; 26 | uint64_t total; 27 | for(i=0,total=0; i<10; i++) 28 | { 29 | total += list[i]; 30 | } 31 | return total; 32 | } 33 | 34 | EXTERN uint64_t 35 | uint64_sum2(uint64_t *list, size_t size) 36 | { 37 | int i; 38 | uint64_t total; 39 | for(i=0,total=0; i<size; i++) 40 | { 41 | total += list[i]; 42 | } 43 | return total; 44 | } 45 | 46 | EXTERN void 47 | uint64_array_inc(uint64_t list[10]) 48 | { 49 | int i; 50 | for(i=0; i<10; i++) 51 | { 52 | list[i]++; 53 | } 54 | } 55 | 56 | EXTERN uint64_t * 57 | uint64_static_array(void) 58 | { 59 | static uint64_t foo[] = { 1,4,6,8,10,12,14,16,18,20 }; 60 | return foo; 61 | } 62 | 63 | typedef uint64_t (*closure_t)(uint64_t); 64 | static closure_t my_closure; 65 | 66 | EXTERN void 67 | uint64_set_closure(closure_t closure) 68 | { 69 | my_closure = closure; 70 | } 71 | 72 | EXTERN uint64_t 73 | uint64_call_closure(uint64_t value) 74 | { 75 | return my_closure(value); 76 | } 77 | -------------------------------------------------------------------------------- /t/ffi/uint8.c: -------------------------------------------------------------------------------- 1 | #include "libtest.h" 2 | 3 | EXTERN uint8_t 4 | uint8_add(uint8_t a, uint8_t b) 5 | { 6 | return a + b; 7 | } 8 | 9 | EXTERN uint8_t* 10 | uint8_inc(uint8_t *a, uint8_t b) 11 | { 12 | static uint8_t keeper; 13 | keeper = *a += b; 14 | return &keeper; 15 | } 16 | 17 | EXTERN uint8_t 18 | uint8_sum(uint8_t list[10]) 19 | { 20 | int i; 21 | uint8_t total; 22 | for(i=0,total=0; i<10; i++) 23 | { 24 | total += list[i]; 25 | } 26 | return total; 27 | } 28 | 29 | EXTERN uint8_t 30 | uint8_sum2(uint8_t *list, size_t size) 31 | { 32 | int i; 33 | uint8_t total; 34 | for(i=0,total=0; i<size; i++) 35 | { 36 | total += list[i]; 37 | } 38 | return total; 39 | } 40 | 41 | EXTERN void 42 | uint8_array_inc(uint8_t list[10]) 43 | { 44 | int i; 45 | for(i=0; i<10; i++) 46 | { 47 | list[i]++; 48 | } 49 | } 50 | 51 | EXTERN uint8_t * 52 | uint8_static_array(void) 53 | { 54 | static uint8_t foo[] = { 1,4,6,8,10,12,14,16,18,20 }; 55 | return foo; 56 | } 57 | 58 | typedef uint8_t (*closure_t)(uint8_t); 59 | static closure_t my_closure; 60 | 61 | EXTERN void 62 | uint8_set_closure(closure_t closure) 63 | { 64 | my_closure = closure; 65 | } 66 | 67 | EXTERN uint8_t 68 | uint8_call_closure(uint8_t value) 69 | { 70 | return my_closure(value); 71 | } 72 | -------------------------------------------------------------------------------- /t/ffi/variadic.c: -------------------------------------------------------------------------------- 1 | #include <ffi_platypus.h> 2 | #ifdef FFI_PL_PROBE_VARIADIC 3 | #include <stdio.h> 4 | #include <stdarg.h> 5 | #include "libtest.h" 6 | 7 | EXTERN int 8 | variadic_return_arg(int which, ...) 9 | { 10 | va_list ap; 11 | int i, val; 12 | 13 | va_start(ap, which); 14 | 15 | for(i=0; i<which; i++) 16 | { 17 | val = va_arg(ap, int); 18 | } 19 | 20 | va_end(ap); 21 | 22 | return val; 23 | } 24 | 25 | EXTERN const char * 26 | xprintf(const char *fmt, ...) 27 | { 28 | va_list ap; 29 | static char buffer[2046]; 30 | char *bp=buffer; 31 | 32 | va_start(ap, fmt); 33 | 34 | while(*fmt != '\0') 35 | { 36 | switch(*fmt) 37 | { 38 | case '%': 39 | { 40 | char buffer2[64]; 41 | const char *str=buffer2; 42 | switch(*(++fmt)) 43 | { 44 | case 'd': 45 | sprintf(buffer2, "%d", va_arg(ap, int)); 46 | break; 47 | case 's': 48 | str = va_arg(ap, char *); 49 | break; 50 | default: 51 | str = "[fmt error]"; 52 | break; 53 | } 54 | strcpy(bp, str); 55 | bp += strlen(str); 56 | } 57 | break; 58 | 59 | default: 60 | *(bp++) = *fmt; 61 | break; 62 | } 63 | fmt++; 64 | } 65 | 66 | va_end(ap); 67 | 68 | *bp = '\0'; 69 | 70 | return buffer; 71 | } 72 | 73 | #endif 74 | -------------------------------------------------------------------------------- /t/ffi_build_file_c.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use lib 't/lib'; 3 | use Test::Cleanup; 4 | use FFI::Build::File::C; 5 | use FFI::Build; 6 | use Capture::Tiny qw( capture_merged ); 7 | 8 | subtest 'basic' => sub { 9 | 10 | my $file = FFI::Build::File::C->new(['corpus','ffi_build_file_c','basic.c']); 11 | 12 | isa_ok $file, 'FFI::Build::File::C'; 13 | isa_ok $file, 'FFI::Build::File::Base'; 14 | is($file->default_suffix, '.c'); 15 | is($file->default_encoding, ':utf8'); 16 | 17 | }; 18 | 19 | subtest 'compile' => sub { 20 | 21 | my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_c foo1.c )]); 22 | my $object = $file->build_item; 23 | isa_ok $object, 'FFI::Build::File::Object'; 24 | 25 | is 26 | [ $object->build_item ], 27 | []; 28 | 29 | cleanup 'corpus/ffi_build_file_c/_build'; 30 | 31 | }; 32 | 33 | subtest 'headers' => sub { 34 | 35 | my $build = FFI::Build->new('foo', 36 | verbose => 2, 37 | cflags => "-Icorpus/ffi_build_file_c/include", 38 | ); 39 | 40 | note "cflags=$_" for @{ $build->cflags }; 41 | 42 | my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_c foo2.c )], build => $build ); 43 | 44 | my @deps = eval { $file->_deps }; 45 | is $@, '', 'no die'; 46 | 47 | foreach my $dep (@deps) 48 | { 49 | ok -f "$dep", "dep is a file: $dep"; 50 | } 51 | 52 | }; 53 | 54 | done_testing; 55 | -------------------------------------------------------------------------------- /t/ffi_build_file_cxx.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use lib 't/lib'; 3 | use Test::Cleanup; 4 | use FFI::Build::File::CXX; 5 | use FFI::Build; 6 | use FFI::Build::Platform; 7 | use Capture::Tiny qw( capture_merged ); 8 | 9 | skip_all 'Test requires C++ compiler' 10 | unless eval { FFI::Build::Platform->which(FFI::Build::Platform->cxx) }; 11 | 12 | subtest 'basic' => sub { 13 | 14 | my $file = FFI::Build::File::CXX->new(['corpus','ffi_build_file_cxx','basic.cxx']); 15 | 16 | isa_ok $file, 'FFI::Build::File::CXX'; 17 | isa_ok $file, 'FFI::Build::File::C'; 18 | isa_ok $file, 'FFI::Build::File::Base'; 19 | is($file->default_suffix, '.cxx'); 20 | is($file->default_encoding, ':utf8'); 21 | 22 | }; 23 | 24 | subtest 'compile' => sub { 25 | 26 | my $file = FFI::Build::File::CXX->new([qw( corpus ffi_build_file_cxx foo1.cxx )]); 27 | my $object = $file->build_item; 28 | isa_ok $object, 'FFI::Build::File::Object'; 29 | 30 | is 31 | [ $object->build_item ], 32 | []; 33 | 34 | cleanup 'corpus/ffi_build_file_cxx/_build'; 35 | 36 | }; 37 | 38 | subtest 'headers' => sub { 39 | 40 | my $build = FFI::Build->new('foo', 41 | verbose => 2, 42 | cflags => "-Icorpus/ffi_build_file_cxx/include", 43 | ); 44 | 45 | note "cflags=$_" for @{ $build->cflags }; 46 | 47 | my $file = FFI::Build::File::C->new([qw( corpus ffi_build_file_cxx foo2.cpp )], build => $build ); 48 | 49 | my @deps = eval { $file->_deps }; 50 | is $@, '', 'no die'; 51 | 52 | foreach my $dep (@deps) 53 | { 54 | ok -f "$dep", "dep is afile: $dep"; 55 | } 56 | 57 | }; 58 | 59 | done_testing; 60 | -------------------------------------------------------------------------------- /t/ffi_build_file_library.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Build::File::Library; 3 | use Config (); 4 | 5 | my $dll = FFI::Build::Platform->library_suffix; 6 | 7 | subtest 'basic' => sub { 8 | 9 | my $file = FFI::Build::File::Library->new(['corpus',"basic$dll"]); 10 | 11 | is($file->default_suffix, $dll); 12 | is($file->default_encoding, ':raw'); 13 | note "path = @{[ $file->path ]}"; 14 | 15 | }; 16 | 17 | done_testing; 18 | -------------------------------------------------------------------------------- /t/ffi_build_file_object.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Build::File::Object; 3 | 4 | my $o = FFI::Build::Platform->object_suffix; 5 | 6 | subtest 'basic' => sub { 7 | 8 | my $file = FFI::Build::File::Object->new(['corpus',"basic$o"]); 9 | 10 | is($file->default_suffix, $o); 11 | is($file->default_encoding, ':raw'); 12 | note "path = @{[ $file->path ]}"; 13 | 14 | }; 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/ffi_build_platform.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Build::Platform; 3 | use Capture::Tiny qw( capture_merged ); 4 | 5 | subtest basic => sub { 6 | 7 | my $platform = FFI::Build::Platform->new; 8 | isa_ok $platform, 'FFI::Build::Platform'; 9 | 10 | note($platform->diag); 11 | }; 12 | 13 | subtest 'cc mm works' => sub { 14 | 15 | my $platform = FFI::Build::Platform->new; 16 | 17 | my($out, $cc_mm_works) = capture_merged { 18 | $platform->cc_mm_works(1); 19 | }; 20 | 21 | note $out; 22 | 23 | ok(defined $cc_mm_works); 24 | note "cc_mm_works = $cc_mm_works"; 25 | 26 | }; 27 | 28 | done_testing; 29 | -------------------------------------------------------------------------------- /t/ffi_build_plugin.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Build::Plugin; 3 | use File::Spec::Functions qw( catdir rel2abs ); 4 | 5 | { 6 | note "\@INC[]=$_" for @INC; 7 | 8 | is( 9 | FFI::Build::Plugin->new, 10 | object { 11 | call [isa => 'FFI::Build::Plugin'] => T(); 12 | }, 13 | 'works with local config', 14 | ); 15 | } 16 | 17 | { 18 | local @INC = @INC; 19 | push @INC, rel2abs(catdir(qw( corpus ffi_build_plugin lib2 ))); 20 | note "\@INC[]=$_" for @INC; 21 | 22 | is( 23 | FFI::Build::Plugin->new, 24 | object { 25 | call [isa => 'FFI::Build::Plugin'] => T(); 26 | }, 27 | 'works with local + empty dir', 28 | ); 29 | } 30 | 31 | { 32 | local @INC = rel2abs(catdir(qw( corpus ffi_build_plugin lib2 ))); 33 | note "\@INC[]=$_" for @INC; 34 | 35 | is( 36 | FFI::Build::Plugin->new, 37 | object { 38 | call [isa => 'FFI::Build::Plugin'] => T(); 39 | call [call => 'bar', 'one', 'two','three'] => T(); 40 | field Foo1 => object { 41 | call [isa => 'FFI::Build::Plugin::Foo1'] => T(); 42 | field bar => [qw( one two three )]; 43 | }; 44 | field Foo2 => object { 45 | call [isa => 'FFI::Build::Plugin::Foo2'] => T(); 46 | }; 47 | }, 48 | ); 49 | } 50 | 51 | done_testing; 52 | -------------------------------------------------------------------------------- /t/ffi_build_plugindata.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | 3 | { package Foo; 4 | 5 | use FFI::Build::PluginData 'plugin_data'; 6 | 7 | sub new { bless {}, __PACKAGE__ } 8 | } 9 | 10 | { package FFI::Build::Plugin::Bar; 11 | 12 | sub new { bless {}, __PACKAGE__ } 13 | 14 | sub call_plugin_data 15 | { 16 | my($self, $foo) = @_; 17 | $foo->plugin_data; 18 | } 19 | 20 | } 21 | 22 | my $foo = Foo->new; 23 | 24 | is( 25 | dies { $foo->plugin_data }, 26 | match qr/^plugin_data must be called by a plugin/, 27 | ); 28 | 29 | is( 30 | FFI::Build::Plugin::Bar->new, 31 | object { 32 | call [call_plugin_data => $foo] => {}; 33 | call sub { 34 | my $plugin = shift; 35 | $plugin->call_plugin_data($foo)->{baz} = 1; 36 | 1; 37 | } => 1; 38 | call [call_plugin_data => $foo] => { baz => 1 }; 39 | }, 40 | ); 41 | 42 | is( 43 | $foo, 44 | { plugin_data => { Bar => { baz => 1 } } }, 45 | ); 46 | 47 | done_testing; 48 | 49 | 1; 50 | -------------------------------------------------------------------------------- /t/ffi_platypus_api.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::API; 3 | 4 | subtest 'basic' => sub { 5 | 6 | { 7 | package FFI::Platypus::Type::C1; 8 | 9 | sub ffi_custom_type_api_1 10 | { 11 | return { 12 | native_type => 'sint8', 13 | perl_to_native => sub { $_[0] * 2 }, 14 | } 15 | } 16 | } 17 | 18 | my $ffi = FFI::Platypus->new; 19 | $ffi->load_custom_type('::C1' => 'c1'); 20 | is( 21 | $ffi->function( 0 => ['c1'] => 'sint8' )->call(10), 22 | 20, 23 | ); 24 | 25 | }; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/ffi_platypus_constant.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::Constant; 3 | use File::Path qw( mkpath ); 4 | use File::Basename qw( dirname ); 5 | use FFI::Temp; 6 | 7 | subtest 'very very basic...' => sub { 8 | 9 | my $api = FFI::Platypus::Constant->new; 10 | isa_ok $api, 'FFI::Platypus::Constant'; 11 | undef $api; 12 | ok 'did not appear to crash :tada:'; 13 | 14 | }; 15 | 16 | subtest 'create constants' => sub { 17 | 18 | my $root = FFI::Temp->newdir; 19 | spew("$root/lib/Foo/Bar1.pm", <<'EOF'); 20 | package Foo::Bar1; 21 | use strict; 22 | use warnings; 23 | use FFI::Platypus; 24 | my $ffi = FFI::Platypus->new( api => 1, lang => 'ASM' ); 25 | $ffi->bundle; 26 | 1; 27 | EOF 28 | 29 | spew("$root/ffi/bar1.c", <<'EOF'); 30 | #include <ffi_platypus_bundle.h> 31 | void ffi_pl_bundle_constant(const char *package, ffi_platypus_constant_t *b) 32 | { 33 | b->set_str("FOO1", "VAL1"); 34 | b->set_str("Foo::Bar1::Baz::FOO2", "VAL2"); 35 | b->set_sint("FOO3", -42); 36 | b->set_uint("FOO4", 512); 37 | b->set_double("FOO5", 2.5); 38 | b->set_str("FOO6", package); 39 | } 40 | EOF 41 | 42 | local @INC = @INC; 43 | unshift @INC, "$root/lib"; 44 | local $@ = ''; 45 | eval " require Foo::Bar1; "; 46 | is "$@", ''; 47 | 48 | is( Foo::Bar1::FOO1(), "VAL1" ); 49 | is( Foo::Bar1::Baz::FOO2(), "VAL2" ); 50 | is( Foo::Bar1::FOO3(), -42 ); 51 | is( Foo::Bar1::FOO4(), 512 ); 52 | is( Foo::Bar1::FOO5(), 2.5 ); 53 | is( Foo::Bar1::FOO6(), "Foo::Bar1" ); 54 | 55 | }; 56 | 57 | done_testing; 58 | 59 | sub spew 60 | { 61 | my($fn, $content) = @_; 62 | 63 | note "spew(start)[$fn]\n"; 64 | note $content; 65 | note "spew(end)\n"; 66 | 67 | my $dir = dirname $fn; 68 | mkpath $dir, 0, oct(755) unless -d $dir; 69 | open my $fh, '>', $fn; 70 | print $fh $content; 71 | close $fh; 72 | } 73 | -------------------------------------------------------------------------------- /t/ffi_platypus_dl.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::DL; 3 | use FFI::CheckLib qw( find_lib ); 4 | 5 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 6 | 7 | subtest 'flags' => sub { 8 | 9 | ok(FFI::Platypus::DL->can('RTLD_PLATYPUS_DEFAULT'), "RTLD_PLATYPUS_DEFAULT is defined"); 10 | 11 | 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::; 12 | 13 | }; 14 | 15 | subtest 'dlopen' => sub { 16 | 17 | subtest 'bad library' => sub { 18 | is dlopen("t/ffi/libbogus.so", RTLD_PLATYPUS_DEFAULT), undef, 'Returns undef on fail'; 19 | note "dlerror = @{[ dlerror ]}"; 20 | }; 21 | 22 | subtest 'good library' => sub { 23 | my $h = dlopen $libtest, RTLD_PLATYPUS_DEFAULT; 24 | ok($h, "Returns handle on good"); 25 | note "h = $h"; 26 | dlclose $h; 27 | }; 28 | 29 | }; 30 | 31 | subtest 'dlsym' => sub { 32 | 33 | my $h = dlopen $libtest, RTLD_PLATYPUS_DEFAULT; 34 | 35 | subtest 'good symbol' => sub { 36 | my $address = dlsym $h, 'f0'; 37 | ok $address, 'returns an address'; 38 | note "address = $address"; 39 | }; 40 | 41 | subtest 'bad symbol' => sub { 42 | my $address = dlsym $h, 'bogus'; 43 | is $address, undef, 'bad symbol returns undef'; 44 | note "dlerror = @{[ dlerror ]}"; 45 | }; 46 | 47 | dlclose $h; 48 | 49 | }; 50 | 51 | done_testing; 52 | 53 | -------------------------------------------------------------------------------- /t/ffi_platypus_function_wrapper.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::Function; 3 | use FFI::Platypus; 4 | use FFI::CheckLib; 5 | 6 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 7 | 8 | subtest 'built in type' => sub { 9 | my $ffi = FFI::Platypus->new; 10 | $ffi->lib($libtest); 11 | my $wrapper = sub { 12 | my($xsub, $arg1) = @_; 13 | $xsub->( $arg1 * 2 ); 14 | }; 15 | my $function = eval { $ffi->function('f0', [ 'uint8' ] => 'uint8', $wrapper ) }; 16 | is $@, '', 'ffi.function(f0, [uint8] => uint8)'; 17 | isa_ok $function, 'FFI::Platypus::Function'; 18 | isa_ok $function, 'FFI::Platypus::Function::Wrapper'; 19 | is $function->call(22), 44, 'function.call(22) = 44'; 20 | is $function->(22), 44, 'function.(22) = 44'; 21 | 22 | $function->attach('baboon'); 23 | is( baboon(11), 22, "baboon(11) = 22" ); 24 | }; 25 | 26 | subtest 'sub_ref' => sub { 27 | 28 | my $ffi = FFI::Platypus->new; 29 | $ffi->lib($libtest); 30 | my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8', sub { my($xsub, $arg) = @_; $arg*2})->sub_ref; 31 | 32 | is $sub_ref->(99), 99*2, 'calls okay'; 33 | is ref($sub_ref), 'CODE', 'it is a code reference'; 34 | 35 | if(eval { require Sub::Identify; 1 }) 36 | { 37 | my $name = Sub::Identify::sub_name($sub_ref); 38 | my $package = Sub::Identify::stash_name($sub_ref); 39 | note "name = ${package}::$name"; 40 | } 41 | }; 42 | 43 | subtest 'prototype' => sub { 44 | 45 | subtest one => sub { 46 | 47 | my $ffi = FFI::Platypus->new; 48 | $ffi->lib($libtest); 49 | my $sub_ref = $ffi->attach(['f0' => 'f0_prototyped1'], [ 'uint8' ] => 'uint8', '$', sub { my($xsub, $arg) = @_; $arg*2}); 50 | 51 | is(f0_prototyped1(2), 4); # just make sure it attached okay 52 | is(prototype(\&f0_prototyped1), '$'); 53 | 54 | }; 55 | 56 | subtest two => sub { 57 | 58 | my $ffi = FFI::Platypus->new; 59 | $ffi->lib($libtest); 60 | my $sub_ref = $ffi->function('f0', [ 'uint8' ] => 'uint8', sub { my($xsub, $arg) = @_; $arg*2})->attach('f0_prototyped2', '$'); 61 | 62 | is(f0_prototyped2(2), 4); # just make sure it attached okay 63 | is(prototype(\&f0_prototyped2), '$'); 64 | 65 | }; 66 | 67 | }; 68 | 69 | done_testing; 70 | -------------------------------------------------------------------------------- /t/ffi_platypus_internal.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::Internal; 3 | 4 | subtest 'basic' => sub { 5 | 6 | note "alpha order:"; 7 | 8 | foreach my $const (sort @FFI::Platypus::Internal::EXPORT) 9 | { 10 | pass sprintf("%-30s 0x%04x", $const, __PACKAGE__->$const); 11 | } 12 | 13 | note "value order:"; 14 | 15 | foreach my $const (sort { __PACKAGE__->$a <=> __PACKAGE__->$b } @FFI::Platypus::Internal::EXPORT) 16 | { 17 | pass sprintf("%-30s 0x%04x", $const, __PACKAGE__->$const); 18 | } 19 | 20 | }; 21 | 22 | done_testing; 23 | -------------------------------------------------------------------------------- /t/ffi_platypus_lang_asm.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib; 3 | use FFI::Platypus; 4 | 5 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 6 | 7 | subtest ASM => sub { 8 | my $ffi = FFI::Platypus->new(lang => 'ASM'); 9 | $ffi->lib($libtest); 10 | 11 | eval { $ffi->type('int') }; 12 | isnt $@, '', 'int is not an okay type'; 13 | note $@; 14 | eval { $ffi->type('foo_t') }; 15 | isnt $@, '', 'foo_t is not an okay type'; 16 | note $@; 17 | eval { $ffi->type('sint16') }; 18 | is $@, '', 'sint16 is an okay type'; 19 | 20 | is $ffi->find_symbol('UnMangled::Name(int i)'), undef, 'unable to find unmangled name'; 21 | 22 | }; 23 | 24 | done_testing; 25 | -------------------------------------------------------------------------------- /t/ffi_platypus_lang_c.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib; 3 | use FFI::Platypus; 4 | 5 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 6 | 7 | subtest C => sub { 8 | my $ffi = FFI::Platypus->new; 9 | $ffi->lib($libtest); 10 | 11 | eval { $ffi->type('int') }; 12 | is $@, '', 'int is an okay type'; 13 | eval { $ffi->type('foo_t') }; 14 | isnt $@, '', 'foo_t is not an okay type'; 15 | note $@; 16 | eval { $ffi->type('sint16') }; 17 | is $@, '', 'sint16 is an okay type'; 18 | 19 | is $ffi->find_symbol('UnMangled::Name(int i)'), undef, 'unable to find unmangled name'; 20 | 21 | }; 22 | 23 | done_testing; 24 | -------------------------------------------------------------------------------- /t/ffi_platypus_lang_win32.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::Lang::Win32; 3 | 4 | { 5 | require FFI::Platypus::Type::WideString; 6 | my($encoding,$width) = eval { FFI::Platypus::Type::WideString->_compute_wide_string_encoding() }; 7 | if(my $error = $@) 8 | { 9 | $error =~ s/ at .*$//; 10 | skip_all "Unable to detect wide string details: $error\n"; 11 | } 12 | 13 | note "encoding = $encoding"; 14 | note "width = $width"; 15 | } 16 | 17 | subtest 'native type map diagnostic' => sub { 18 | 19 | my $map = FFI::Platypus::Lang::Win32->native_type_map; 20 | 21 | foreach my $alias (sort keys %$map) 22 | { 23 | my $type = $map->{$alias}; 24 | note sprintf("%-30s %s", $alias, $type); 25 | } 26 | 27 | pass 'good'; 28 | }; 29 | 30 | my $ffi = FFI::Platypus->new( api => 1, lib => [undef] ); 31 | 32 | subtest 'load' => sub { 33 | local $@ = ""; 34 | eval { $ffi->lang('Win32') }; 35 | is "$@", ""; 36 | }; 37 | 38 | my @strings = ( 39 | [ "trivial" => "" ], 40 | [ "simple" => "abcde" ], 41 | [ "fancy" => "abcd\x{E9}" ], 42 | [ "complex" => "I \x{2764} Platypus" ], 43 | ); 44 | 45 | subtest 'LPCWSTR' => sub { 46 | skip_all 'Test only works on Windows' unless $^O eq 'MSWin32'; 47 | 48 | my $lstrlenW = $ffi->function( lstrlenW => [ 'LPCWSTR' ] => 'int' ); 49 | 50 | foreach my $test (@strings) 51 | { 52 | my($name, $string) = @$test; 53 | is($lstrlenW->call($string), length($string), $name); 54 | } 55 | }; 56 | 57 | subtest 'LPWSTR' => sub { 58 | skip_all 'Test only works on Windows' unless $^O eq 'MSWin32'; 59 | 60 | my $GetCurrentDirectoryW = $ffi->function( GetCurrentDirectoryW => ['DWORD','LPWSTR'] => 'DWORD' ); 61 | 62 | my $size = $GetCurrentDirectoryW->call(0, undef); 63 | cmp_ok $size, '>', 0; 64 | 65 | my $buf = "\0" x ($size*2); 66 | $GetCurrentDirectoryW->call($size, \$buf); 67 | 68 | note "buf = $buf"; 69 | 70 | ok( -d $buf, "returned directory exists"); 71 | }; 72 | 73 | done_testing; 74 | -------------------------------------------------------------------------------- /t/ffi_platypus_legacy.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | 4 | subtest 'only load as needed' => sub { 5 | 6 | my $ffi = FFI::Platypus->new; 7 | 8 | ok( ! FFI::Platypus->can('_package') ); 9 | 10 | $ffi->package; 11 | 12 | ok( !! FFI::Platypus->can('_package') ); 13 | 14 | }; 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/ffi_platypus_record_meta.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::Platypus::Record::Meta; 4 | use Data::Dumper qw( Dumper ); 5 | 6 | my $ffi = FFI::Platypus->new; 7 | $ffi->lib(undef); 8 | 9 | subtest 'basic' => sub { 10 | 11 | my $meta = FFI::Platypus::Record::Meta->new( 12 | [ 'uint8', 'uint8', 'pointer', 'float', 'double' ], 13 | ); 14 | isa_ok $meta, 'FFI::Platypus::Record::Meta'; 15 | like $meta->ffi_type, qr/^-?[0-9]+$/, "meta->ffi_type = @{[ $meta->ffi_type ]}"; 16 | is $meta->size, 0, 'meta->size'; 17 | is $meta->alignment, 0, 'meta->alignment'; 18 | 19 | my $got = $meta->element_pointers; 20 | my $exp = [map { FFI::Platypus::Record::Meta::_find_symbol($_) } qw( uint8 uint8 pointer float double )]; 21 | 22 | is 23 | $got, 24 | $exp, 25 | 'meta->element_pointers' 26 | or diag Dumper([[map { sprintf "0x%x", $_ } @$got],[ map { sprintf "0x%x", $_ } @$exp]]); 27 | }; 28 | 29 | subtest 'bogus types' => sub { 30 | 31 | { 32 | local $@ = ''; 33 | eval { FFI::Platypus::Record::Meta->new(qw( completely bogsu )) }; 34 | like "$@", qr/passed something other than a array ref/; 35 | } 36 | 37 | { 38 | local $@ = ''; 39 | eval { FFI::Platypus::Record::Meta->new([qw( completely bogsu )]) }; 40 | like "$@", qr/unknown type: completely/; 41 | } 42 | 43 | }; 44 | 45 | done_testing; 46 | -------------------------------------------------------------------------------- /t/ffi_platypus_record_tiearray.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | 3 | do { 4 | package 5 | Foo; 6 | 7 | use FFI::Platypus::Record; 8 | use FFI::Platypus::Record::TieArray; 9 | 10 | record_layout(qw( 11 | int[20] _bar 12 | )); 13 | 14 | sub bar 15 | { 16 | my($self) = @_; 17 | tie my @list, 'FFI::Platypus::Record::TieArray', $self, '_bar', 20; 18 | \@list; 19 | } 20 | }; 21 | 22 | 23 | my $foo = Foo->new( _bar => [1..20] ); 24 | isa_ok $foo, 'Foo'; 25 | 26 | is $foo->bar->[1], 2; 27 | $foo->bar->[1] = 22; 28 | is $foo->bar->[1], 22; 29 | 30 | is scalar(@{ $foo->bar }), 20; 31 | is $#{ $foo->bar}, 19; 32 | 33 | @{ $foo->bar } = (); 34 | 35 | is $foo->bar->[$_], 0 for 0..19; 36 | 37 | @{ $foo->bar } = (0..5); 38 | 39 | is $foo->bar->[$_], $_ for 0..5; 40 | is $foo->bar->[$_], 0 for 6..19; 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/ffi_platypus_shareconfig.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus::ShareConfig; 3 | use Data::Dumper; 4 | 5 | sub xdump ($) 6 | { 7 | my($object) = @_; 8 | note(Data::Dumper->new([$object])->Indent(2)->Terse(1)->Sortkeys(1)->Dump); 9 | } 10 | 11 | note(xdump(FFI::Platypus::ShareConfig->get)); 12 | 13 | is(ref(FFI::Platypus::ShareConfig->get), 'HASH'); 14 | is(FFI::Platypus::ShareConfig->get('test-key'), 'test-value'); 15 | 16 | done_testing; 17 | -------------------------------------------------------------------------------- /t/ffi_platypus_type_pointersizebuffer.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib; 3 | use FFI::Platypus; 4 | use FFI::Platypus::Memory qw( malloc ); 5 | 6 | my $ffi = FFI::Platypus->new; 7 | 8 | $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer_t'); 9 | $ffi->load_custom_type('::PointerSizeBuffer' => 'buffer_t2'); 10 | 11 | $ffi->lib(undef); 12 | $ffi->attach(memcpy => ['opaque', 'buffer_t'] => 'void'); 13 | 14 | my $string = "luna park\0"; 15 | my $pointer = malloc length $string; 16 | memcpy($pointer, $string); 17 | 18 | my $string2 = $ffi->cast('opaque' => 'string', $pointer); 19 | 20 | is $string2, 'luna park'; 21 | 22 | SKIP: { 23 | 24 | eval { $ffi->attach(snprintf => ['buffer_t', 'string' ] => 'int') }; 25 | skip "test require working snprintf", 2 if $@; 26 | 27 | is snprintf($string2, "this is a very long string"), 26; 28 | is $string2, "this is \000"; 29 | 30 | } 31 | 32 | $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); 33 | 34 | $ffi->attach(memcmp4 => ['buffer_t', 'buffer_t'] => 'int'); 35 | 36 | my $str1 = "test"; 37 | my $str2 = "test2"; 38 | is !!memcmp4($str1, $str2), 1; 39 | is memcmp4($str1, $str1), 0; 40 | 41 | done_testing; 42 | -------------------------------------------------------------------------------- /t/ffi_platypus_type_stringpointer.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::CheckLib; 4 | 5 | my $ffi = FFI::Platypus->new; 6 | $ffi->load_custom_type('::StringPointer' => 'string_p'); 7 | 8 | $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); 9 | $ffi->attach( string_pointer_pointer_get => ['string_p'] => 'string'); 10 | $ffi->attach( string_pointer_pointer_set => ['string_p', 'string'] => 'void'); 11 | $ffi->attach( pointer_pointer_is_null => ['string_p'] => 'int'); 12 | $ffi->attach( pointer_is_null => ['string_p'] => 'int'); 13 | $ffi->attach( string_pointer_pointer_return => ['string'] => 'string_p'); 14 | $ffi->attach( pointer_null => [] => 'string_p'); 15 | 16 | subtest 'arg pass in' => sub { 17 | is string_pointer_pointer_get(\"hello there"), "hello there", "not null"; 18 | is pointer_pointer_is_null(\undef), 1, "\\undef is null"; 19 | is pointer_is_null(undef), 1, "undef is null"; 20 | }; 21 | 22 | subtest 'arg pass out' => sub { 23 | my $string = ''; 24 | string_pointer_pointer_set(\$string, "hi there"); 25 | is $string, "hi there", "not null string = $string"; 26 | 27 | my $string2; 28 | string_pointer_pointer_set(\$string2, "and another"); 29 | is $string2, "and another", "not null string = $string2"; 30 | 31 | }; 32 | 33 | subtest 'return value' => sub { 34 | my $string = "once more onto"; 35 | 36 | is string_pointer_pointer_return($string), \"once more onto", "not null string = $string"; 37 | is string_pointer_pointer_return(undef), \undef, "\\null"; 38 | my $value = pointer_null(); 39 | is $value, undef, "null"; 40 | 41 | }; 42 | 43 | done_testing; 44 | -------------------------------------------------------------------------------- /t/ffi_platypus_typeparser.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::Platypus::TypeParser; 4 | 5 | subtest 'basic' => sub { 6 | 7 | my $tp = FFI::Platypus::TypeParser->new; 8 | isa_ok $tp, 'FFI::Platypus::TypeParser'; 9 | 10 | }; 11 | 12 | subtest 'pick the right one' => sub { 13 | 14 | isa_ok( 15 | FFI::Platypus->new( api => 0 )->{tp}, 16 | 'FFI::Platypus::TypeParser::Version0', 17 | ); 18 | 19 | # ignore api=1 warning 20 | local $SIG{__WARN__} = sub { note "[warnings]\n", $_[0] }; 21 | 22 | isa_ok( 23 | FFI::Platypus->new( api => 1 )->{tp}, 24 | 'FFI::Platypus::TypeParser::Version1', 25 | ); 26 | 27 | }; 28 | 29 | done_testing; 30 | -------------------------------------------------------------------------------- /t/ffi_probe_runner_builder.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Temp; 3 | use Capture::Tiny qw( capture_merged ); 4 | use FFI::Probe::Runner::Builder; 5 | use IPC::Cmd qw( can_run ); 6 | 7 | $FFI::Probe::Runner::Builder::VERBOSE = 1; 8 | 9 | my $dir = FFI::Temp->newdir( TEMPLATE => 'test-probe-XXXXXX' ); 10 | 11 | note "dir = $dir"; 12 | 13 | my $builder = FFI::Probe::Runner::Builder->new( 14 | dir => $dir, 15 | ); 16 | 17 | foreach my $lib (@{ $builder->libs }) 18 | { 19 | note "libs=" . join(' ', @$lib) 20 | } 21 | 22 | isa_ok $builder, 'FFI::Probe::Runner::Builder'; 23 | 24 | my($out1, $exe, $error) = capture_merged { 25 | my $exe = eval { $builder->build }; 26 | ($exe, $@); 27 | }; 28 | note $out1; 29 | 30 | is $error, '', 'no error'; 31 | 32 | ok -f $exe, "executable exists"; 33 | note "exe = $exe"; 34 | 35 | my($out2, $ret) = capture_merged { 36 | print "+ $exe verify self\n"; 37 | system $exe, 'verify', 'self'; 38 | $?; 39 | }; 40 | 41 | note $out2; 42 | is $ret, 0, 'verify ok'; 43 | 44 | if($^O eq 'linux' && can_run('ldd')) 45 | { 46 | note capture_merged { 47 | print "+ ldd $exe\n"; 48 | system "ldd", $exe; 49 | (); 50 | }; 51 | } 52 | 53 | done_testing; 54 | -------------------------------------------------------------------------------- /t/ffi_probe_runner_result.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Probe::Runner::Result; 3 | 4 | my %std = ( stdout => "foo\n", stderr => "bar\n", rv => 0, signal => 0 ); 5 | 6 | my $result1 = FFI::Probe::Runner::Result->new( 7 | %std 8 | ); 9 | 10 | isa_ok $result1, 'FFI::Probe::Runner::Result'; 11 | ok($result1->pass); 12 | 13 | my $result2 = FFI::Probe::Runner::Result->new( 14 | %std, 15 | rv => 2, 16 | ); 17 | 18 | isa_ok $result2, 'FFI::Probe::Runner::Result'; 19 | is($result2->rv, 2); 20 | ok(!$result2->pass); 21 | 22 | my $result3 = FFI::Probe::Runner::Result->new( 23 | %std, 24 | signal => 9, 25 | ); 26 | 27 | isa_ok $result3, 'FFI::Probe::Runner::Result'; 28 | is($result3->signal, 9); 29 | ok(!$result3->pass); 30 | 31 | done_testing; 32 | -------------------------------------------------------------------------------- /t/ffi_temp.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Temp; 3 | 4 | my $dir = FFI::Temp->newdir; 5 | ok -d $dir; 6 | note "dir = $dir"; 7 | 8 | my $fh = FFI::Temp->new; 9 | close $fh; 10 | note "file = @{[ $fh->filename ]}"; 11 | 12 | done_testing; 13 | -------------------------------------------------------------------------------- /t/forks.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib; 3 | use FFI::Platypus; 4 | use File::Spec; 5 | 6 | BEGIN 7 | { 8 | my $path; 9 | foreach my $inc (@INC) 10 | { 11 | $path = File::Spec->catfile($inc, 'forks.pm'); 12 | last if -f $path; 13 | } 14 | 15 | skip_all 'Test requires forks' unless defined $path && -f $path; 16 | } 17 | 18 | use forks; 19 | 20 | my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi' )); 21 | 22 | sub f0 23 | { 24 | $ffi->function(f0 => ['uint8'] => 'uint8')->call(@_); 25 | } 26 | 27 | sub otherthread 28 | { 29 | my $val = f0(22); 30 | undef $ffi; 31 | $val; 32 | } 33 | 34 | ok 1; 35 | 36 | is(threads->create(\&otherthread)->join(), 22, 'works in a thread'); 37 | 38 | is f0(24), 24, 'works in main thread'; 39 | 40 | done_testing; 41 | -------------------------------------------------------------------------------- /t/gh117.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib qw( find_lib ); 3 | use FFI::Platypus; 4 | 5 | my $libtest = find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'; 6 | my $ffi = FFI::Platypus->new; 7 | $ffi->lib($libtest); 8 | 9 | my $value64 = $ffi->function('gh117' => [] => 'uint64')->call; 10 | note "value64 = $value64"; 11 | 12 | is($value64, "1099511627775"); 13 | 14 | done_testing; 15 | -------------------------------------------------------------------------------- /t/gh129.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::CheckLib qw( find_lib ); 3 | use FFI::Platypus; 4 | use Carp (); 5 | 6 | my $ffi = FFI::Platypus->new; 7 | $ffi->lib(find_lib lib => 'test', symbol => 'f0', libpath => 't/ffi'); 8 | 9 | subtest 'attached function' => sub { 10 | 11 | $ffi->attach( f0 => ['uint8'] => 'uint8' => sub { 12 | package Foo::Bar; 13 | my($xsub, $arg) = @_; 14 | Carp::croak "here"; 15 | $xsub->($arg); 16 | }); 17 | 18 | local $@ = ''; 19 | eval { f0(1) }; my $line = __LINE__; 20 | like "$@", qr/^here .*gh129\.t line \Q$line\E/; 21 | 22 | }; 23 | 24 | subtest 'dynamic function' => sub { 25 | 26 | my $f0 = $ffi->function( f0 => ['uint8'] => 'uint8' => sub { 27 | package Foo::Bar; 28 | my($xsub, $arg) = @_; 29 | Carp::croak "here"; 30 | $xsub->($arg); 31 | }); 32 | 33 | local $@ = ''; 34 | eval { $f0->call(1) }; my $line = __LINE__; 35 | like "$@", qr/^here .*gh129\.t line \Q$line\E/; 36 | 37 | }; 38 | 39 | subtest 'type wrapper argument' => sub { 40 | 41 | $ffi->custom_type( foo_t => { 42 | native_type => 'uint8', 43 | perl_to_native => sub { 44 | package Foo::Bar; 45 | Carp::croak "here"; 46 | }, 47 | }); 48 | 49 | my $f0 = $ffi->function( f0 => ['foo_t'] => 'uint8'); 50 | 51 | local $@ = ''; 52 | eval { $f0->call(22) }; my $line = __LINE__; 53 | like "$@", qr/^here .*gh129\.t line \Q$line\E/; 54 | 55 | }; 56 | 57 | subtest 'type wrapper argument post' => sub { 58 | 59 | $ffi->custom_type( baz_t => { 60 | native_type => 'uint8', 61 | perl_to_native_post => sub { 62 | package Foo::Bar; 63 | Carp::croak "here"; 64 | }, 65 | }); 66 | 67 | my $f0 = $ffi->function( f0 => ['baz_t'] => 'uint8'); 68 | 69 | local $@ = ''; 70 | eval { $f0->call(22) }; my $line = __LINE__; 71 | like "$@", qr/^here .*gh129\.t line \Q$line\E/; 72 | 73 | }; 74 | 75 | subtest 'type wrapper return type' => sub { 76 | 77 | $ffi->custom_type( bar_t => { 78 | native_type => 'uint8', 79 | native_to_perl => sub { 80 | package Foo::Bar; 81 | Carp::croak "here"; 82 | }, 83 | }); 84 | 85 | my $f0 = $ffi->function( f0 => ['uint8'] => 'bar_t'); 86 | 87 | local $@ = ''; 88 | eval { $f0->call(22) }; my $line = __LINE__; 89 | like "$@", qr/^here .*gh129\.t line \Q$line\E/; 90 | 91 | }; 92 | 93 | done_testing; 94 | -------------------------------------------------------------------------------- /t/gh323.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::Platypus::Memory qw( malloc free ); 4 | 5 | skip_all 'test requires variadic function support' 6 | unless eval { FFI::Platypus->new( lib => [undef] )->function( 7 | sprintf => ['opaque', 'string'] => ['float'] ) }; 8 | 9 | foreach my $api (0,1,2) 10 | { 11 | 12 | subtest "api => $api" => sub { 13 | 14 | our $ffi = FFI::Platypus->new( api => $api, lib => [undef], experimental => ($api > 2 ? $api : undef)); 15 | 16 | $ffi->type('float' => 'my_float'); 17 | 18 | sub callit 19 | { 20 | my($type) = @_; 21 | 22 | my $ptr = malloc 1024; 23 | $ffi->function( sprintf => ['opaque','string'] => [$type] )->call($ptr, "%f", 3.14); 24 | my $string = $ffi->cast('opaque' => 'string', $ptr); 25 | free $ptr; 26 | return $string; 27 | } 28 | 29 | my $double = callit('double'); 30 | my $float = callit('float'); 31 | note "double = $double"; 32 | note "float = $float"; 33 | is $float, $double; 34 | 35 | $float = callit('my_float'); 36 | note "my_float = $float"; 37 | is $float, $double; 38 | 39 | }; 40 | } 41 | 42 | done_testing; 43 | -------------------------------------------------------------------------------- /t/lib/Test/Cleanup.pm: -------------------------------------------------------------------------------- 1 | package Test::Cleanup; 2 | 3 | use strict; 4 | use warnings; 5 | use Exporter qw( import ); 6 | use File::Path qw( rmtree ); 7 | 8 | our @EXPORT = qw( cleanup ); 9 | 10 | my @cleanup; 11 | 12 | sub cleanup 13 | { 14 | push @cleanup, @_; 15 | } 16 | 17 | END 18 | { 19 | foreach my $item (@cleanup) 20 | { 21 | if(ref $item eq 'CODE') 22 | { 23 | $item->(); 24 | } 25 | else 26 | { 27 | rmtree("$item", { verbose => 0 }); 28 | } 29 | } 30 | } 31 | 32 | 1; 33 | -------------------------------------------------------------------------------- /t/lib/Test/FauxAttach.pm: -------------------------------------------------------------------------------- 1 | package Test::FauxAttach; 2 | 3 | use strict; 4 | use warnings; 5 | use Test2::V0 (); 6 | 7 | my @funcs; 8 | 9 | # This plugin implements an alternative to attach/sub_ref 10 | # without the process level-leak which makes it easier to 11 | # find real leaks. It relies on no attached sub being called 12 | # in END, etc. blocks, which we cannot normally rely on. 13 | # it's also probably a lot slower than a real xsub. 14 | 15 | sub import 16 | { 17 | die "load Test::FauxAttach before FFI::Platypus::Function" 18 | if $INC{'FFI/Platypus/Function.pm'}; 19 | require FFI::Platypus::Function; 20 | 21 | no warnings 'redefine'; 22 | *FFI::Platypus::Function::Function::_sub_ref = sub { 23 | my($self, $location) = @_; 24 | push @funcs, $self; 25 | my $i = $#funcs; 26 | sub { $funcs[$i]->call(@_) }; 27 | }; 28 | 29 | *FFI::Platypus::Function::Function::_attach = sub { 30 | my($self, $perl_name, $location, $proto) = @_; 31 | Test2::V0::note(" attaching: $perl_name"); 32 | my $xsub = $self->_sub_ref($location); 33 | FFI::Platypus::Function::Wrapper::_set_prototype($proto, $xsub) if defined $proto; 34 | no strict 'refs'; 35 | *{"$perl_name"} = $xsub; 36 | }; 37 | } 38 | 39 | END { 40 | Test2::V0::note("deleting @{[ scalar @funcs ]} attached functions"); 41 | @funcs = (); 42 | } 43 | 44 | 1; 45 | -------------------------------------------------------------------------------- /t/lib/Test/Platypus.pm: -------------------------------------------------------------------------------- 1 | package Test::Platypus; 2 | 3 | use strict; 4 | use warnings; 5 | use Test2::API qw( context ); 6 | use Exporter qw( import ); 7 | 8 | our @EXPORT = qw( platypus ); 9 | 10 | sub platypus { 11 | my($count, $code) = @_; 12 | 13 | my $ffi = eval { 14 | require FFI::Platypus; 15 | FFI::Platypus->new; 16 | }; 17 | 18 | if($ffi) 19 | { 20 | $code->($ffi); 21 | } 22 | else 23 | { 24 | my $ctx = context(); 25 | $ctx->skip('', "Test requires FFI::Platypus") for 1..$count; 26 | $ctx->release; 27 | } 28 | 29 | } 30 | 31 | 1; 32 | -------------------------------------------------------------------------------- /t/memory.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use Config; 3 | use Capture::Tiny qw( capture_merged ); 4 | use FFI::Temp; 5 | 6 | # libexpat1-dev 7 | 8 | skip_all 'tested only in CI' if ($ENV{CIPSOMETHING}||'') ne 'true'; 9 | skip_all 'tested only in CI -debug' if $Config{ccflags} !~ /-DDEBUG_LEAKING_SCALARS/; 10 | 11 | my %exfail = map { $_ => 1 } qw( attach.pl ); 12 | 13 | # you can run this on just one (or more) test file in corpus/memory by 14 | # perl -Mblib t/memory.t foo.pl 15 | 16 | my @list = @ARGV ? @ARGV : do { 17 | my $dh; 18 | opendir $dh, 'corpus/memory'; 19 | grep /\.pl$/, sort readdir $dh; 20 | }; 21 | 22 | my @supp = do { 23 | my $dh; 24 | opendir $dh, 'corpus/memory/supp'; 25 | map { "--suppressions=corpus/memory/supp/$_" } grep /\.supp/, sort readdir $dh; 26 | }; 27 | 28 | foreach my $name (@list) 29 | { 30 | subtest $name => sub { 31 | 32 | local $ENV{PERL_DESTRUCT_LEVEL} = 2; 33 | 34 | my $log = FFI::Temp->new; 35 | 36 | my @command = ( 37 | 'valgrind', 38 | '--leak-check=yes', 39 | "--log-file=$log", 40 | '--error-exitcode=2', 41 | #'--gen-suppressions=all', 42 | #'-v', 43 | @supp, 44 | $^X, 45 | '-Mblib', 46 | "corpus/memory/$name", 47 | ); 48 | 49 | my($out, $exit) = capture_merged { 50 | print "+ @command\n"; 51 | system @command; 52 | $?; 53 | }; 54 | 55 | if($exfail{$name}) 56 | { 57 | note "expected fail"; 58 | { 59 | my $todo = todo 'expected fail'; 60 | is($exit, 0, 'valgrind') or do { 61 | note "[output]\n$out"; 62 | note "[log]\n", do { local $/; <$log> }; 63 | }; 64 | }; 65 | } 66 | else 67 | { 68 | note "expected pass"; 69 | is($exit, 0, 'valgrind') or do { 70 | diag "[output]\n$out"; 71 | diag "[log]\n", do { local $/; <$log> }; 72 | }; 73 | } 74 | 75 | }; 76 | } 77 | 78 | done_testing; 79 | -------------------------------------------------------------------------------- /t/threads.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | BEGIN { skip_all 'Test requires a threading Perl' unless eval q{ use threads; 1 } } 3 | use FFI::CheckLib; 4 | use FFI::Platypus; 5 | use Config; 6 | 7 | my $ffi = FFI::Platypus->new(lib => find_lib(lib => 'test', symbol => 'f0', libpath => 't/ffi' )); 8 | 9 | sub f0 10 | { 11 | $ffi->function(f0 => ['uint8'] => 'uint8')->call(@_); 12 | } 13 | 14 | sub otherthread 15 | { 16 | my $val = f0(22); 17 | undef $ffi; 18 | $val; 19 | } 20 | 21 | ok 1; 22 | 23 | is(threads->create(\&otherthread)->join(), 22, 'works in a thread'); 24 | 25 | is f0(24), 24, 'works in main thread'; 26 | 27 | done_testing; 28 | -------------------------------------------------------------------------------- /t/type_longdouble__array.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::Platypus::TypeParser; 4 | use FFI::CheckLib; 5 | use Config; 6 | 7 | BEGIN { 8 | skip_all 'test requires support for long double' 9 | unless FFI::Platypus::TypeParser->have_type('longdouble'); 10 | } 11 | 12 | my $ffi = FFI::Platypus->new; 13 | $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); 14 | 15 | subtest 'Math::LongDouble is loaded when needed for return type' => sub { 16 | $ffi->function( 0 => ['longdouble'] => 'int'); 17 | $ffi->function( 0 => ['int'] => 'int'); 18 | 19 | is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); 20 | $ffi->function( 0 => ['longdouble[]'] => 'int' ); 21 | 22 | my $pm = $INC{'Math/LongDouble.pm'}; 23 | 24 | if(eval q{ use Math::LongDouble; 1 }) 25 | { 26 | is($pm, $INC{'Math/LongDouble.pm'}); 27 | isnt $pm, undef; 28 | } 29 | else 30 | { 31 | is($pm, undef); 32 | is($INC{'Math/LongDouble.pm'}, undef); 33 | } 34 | }; 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /t/type_longdouble__ptr.t: -------------------------------------------------------------------------------- 1 | use Test2::V0 -no_srand => 1; 2 | use FFI::Platypus; 3 | use FFI::Platypus::TypeParser; 4 | use FFI::CheckLib; 5 | use Config; 6 | 7 | BEGIN { 8 | skip_all 'test requires support for long double' 9 | unless FFI::Platypus::TypeParser->have_type('longdouble'); 10 | } 11 | 12 | my $ffi = FFI::Platypus->new; 13 | $ffi->lib(find_lib lib => 'test', libpath => 't/ffi'); 14 | 15 | subtest 'Math::LongDouble is loaded when needed for return type' => sub { 16 | $ffi->function( 0 => ['longdouble'] => 'int'); 17 | $ffi->function( 0 => ['int'] => 'int'); 18 | 19 | is($INC{'Math/LongDouble.pm'}, undef, 'not pre-loaded'); 20 | $ffi->function( 0 => ['longdouble*'] => 'int' ); 21 | 22 | my $pm = $INC{'Math/LongDouble.pm'}; 23 | 24 | if(eval q{ use Math::LongDouble; 1 }) 25 | { 26 | is($pm, $INC{'Math/LongDouble.pm'}); 27 | isnt $pm, undef; 28 | } 29 | else 30 | { 31 | is($pm, undef); 32 | is($INC{'Math/LongDouble.pm'}, undef); 33 | } 34 | }; 35 | 36 | done_testing; 37 | -------------------------------------------------------------------------------- /xs/ABI.xs: -------------------------------------------------------------------------------- 1 | MODULE = FFI::Platypus PACKAGE = FFI::Platypus::ABI 2 | 3 | int 4 | verify(abi) 5 | int abi 6 | PREINIT: 7 | ffi_abi ffi_abi; 8 | ffi_cif ffi_cif; 9 | ffi_type *args[1]; 10 | CODE: 11 | /* 12 | * I had at least one report from (unknown version of) libffi 13 | * where 999999 was accepted as a legal ABI, and all the other 14 | * tests passed 15 | */ 16 | if(abi < FFI_FIRST_ABI || abi > FFI_LAST_ABI) 17 | { 18 | RETVAL = 0; 19 | } 20 | else 21 | { 22 | ffi_abi = abi; 23 | if(ffi_prep_cif(&ffi_cif, ffi_abi, 0, &ffi_type_void, args) == FFI_OK) 24 | { 25 | RETVAL = 1; 26 | } 27 | else 28 | { 29 | RETVAL = 0; 30 | } 31 | } 32 | OUTPUT: 33 | RETVAL 34 | -------------------------------------------------------------------------------- /xs/Closure.xs: -------------------------------------------------------------------------------- 1 | MODULE = FFI::Platypus PACKAGE = FFI::Platypus::Closure 2 | 3 | void 4 | _sticky(self) 5 | SV *self 6 | CODE: 7 | if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) 8 | { 9 | SvREFCNT_inc_simple_void_NN(SvRV(self)); 10 | SvREFCNT_inc_simple_void_NN(SvRV(self)); 11 | } 12 | else 13 | croak("object is not a closure"); 14 | 15 | void 16 | _unstick(self) 17 | SV *self 18 | CODE: 19 | if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) 20 | { 21 | SvREFCNT_dec(SvRV(self)); 22 | SvREFCNT_dec(SvRV(self)); 23 | } 24 | else 25 | croak("object is not a closure"); 26 | 27 | 28 | U32 29 | _svrefcnt(self) 30 | SV *self 31 | CODE: 32 | /* used in test only */ 33 | if(sv_isobject(self) && sv_derived_from(self, "FFI::Platypus::Closure")) 34 | { 35 | RETVAL = SvREFCNT(SvRV(self)); 36 | } 37 | else 38 | croak("object is not a closure"); 39 | OUTPUT: 40 | RETVAL 41 | -------------------------------------------------------------------------------- /xs/ClosureData.xs: -------------------------------------------------------------------------------- 1 | MODULE = FFI::Platypus PACKAGE = FFI::Platypus::ClosureData 2 | 3 | void 4 | DESTROY(self) 5 | ffi_pl_closure *self 6 | CODE: 7 | SvREFCNT_dec(self->coderef); 8 | ffi_closure_free(self->ffi_closure); 9 | Safefree(self); 10 | -------------------------------------------------------------------------------- /xs/DL.xs: -------------------------------------------------------------------------------- 1 | MODULE = FFI::Platypus PACKAGE = FFI::Platypus::DL 2 | 3 | BOOT: 4 | { 5 | HV *stash; 6 | stash = gv_stashpv("FFI::Platypus::DL", TRUE); 7 | #ifdef RTLD_LAZY 8 | newCONSTSUB(stash, "RTLD_PLATYPUS_DEFAULT", newSViv(RTLD_LAZY)); 9 | newCONSTSUB(stash, "RTLD_LAZY", newSViv(RTLD_LAZY)); 10 | #else 11 | newCONSTSUB(stash, "RTLD_PLATYPUS_DEFAULT", newSViv(0)); 12 | #endif 13 | #ifdef RTLD_NOW 14 | newCONSTSUB(stash, "RTLD_NOW", newSViv(RTLD_NOW)); 15 | #endif 16 | #ifdef RTLD_GLOBAL 17 | newCONSTSUB(stash, "RTLD_GLOBAL", newSViv(RTLD_GLOBAL)); 18 | #endif 19 | #ifdef RTLD_LOCAL 20 | newCONSTSUB(stash, "RTLD_LOCAL", newSViv(RTLD_LOCAL)); 21 | #endif 22 | #ifdef RTLD_NODELETE 23 | newCONSTSUB(stash, "RTLD_NODELETE", newSViv(RTLD_NODELETE)); 24 | #endif 25 | #ifdef RTLD_NOLOAD 26 | newCONSTSUB(stash, "RTLD_NOLOAD", newSViv(RTLD_NOLOAD)); 27 | #endif 28 | #ifdef RTLD_DEEPBIND 29 | newCONSTSUB(stash, "RTLD_DEEPBIND", newSViv(RTLD_DEEPBIND)); 30 | #endif 31 | } 32 | 33 | void * 34 | dlopen(filename, flags); 35 | ffi_pl_string filename 36 | int flags 37 | INIT: 38 | void *ptr; 39 | CODE: 40 | ptr = dlopen(filename, flags); 41 | if(ptr == NULL) 42 | { 43 | XSRETURN_EMPTY; 44 | } 45 | else 46 | { 47 | RETVAL = ptr; 48 | } 49 | OUTPUT: 50 | RETVAL 51 | 52 | const char * 53 | dlerror(); 54 | 55 | void * 56 | dlsym(handle, symbol); 57 | void *handle 58 | const char *symbol 59 | INIT: 60 | void *ptr; 61 | CODE: 62 | ptr = dlsym(handle, symbol); 63 | if(ptr == NULL) 64 | { 65 | XSRETURN_EMPTY; 66 | } 67 | else 68 | { 69 | RETVAL = ptr; 70 | } 71 | OUTPUT: 72 | RETVAL 73 | 74 | int 75 | dlclose(handle); 76 | void *handle 77 | CODE: 78 | if(!PL_dirty) 79 | RETVAL = dlclose(handle); 80 | else 81 | RETVAL = 0; 82 | OUTPUT: 83 | RETVAL 84 | -------------------------------------------------------------------------------- /xs/cast.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | 3 | #if SIZEOF_VOIDP == 4 4 | uint64_t 5 | cast0(void) 6 | { 7 | return 0LL; 8 | } 9 | #else 10 | void * 11 | cast0(void) 12 | { 13 | return NULL; 14 | } 15 | #endif 16 | 17 | #if SIZEOF_VOIDP == 4 18 | uint64_t 19 | cast1(uint64_t value) 20 | { 21 | return value; 22 | } 23 | #else 24 | void * 25 | cast1(void *value) 26 | { 27 | return value; 28 | } 29 | #endif 30 | -------------------------------------------------------------------------------- /xs/custom.c: -------------------------------------------------------------------------------- 1 | #include "EXTERN.h" 2 | #include "perl.h" 3 | #include "XSUB.h" 4 | #include "ppport.h" 5 | #include "ffi_platypus.h" 6 | #include "ffi_platypus_guts.h" 7 | 8 | SV* 9 | ffi_pl_custom_perl(SV *subref, SV *in_arg, int i) 10 | { 11 | if(subref == NULL) 12 | { 13 | return newSVsv(in_arg); 14 | } 15 | else 16 | { 17 | dSP; 18 | 19 | int count; 20 | SV *out_arg; 21 | 22 | ENTER; 23 | SAVETMPS; 24 | PUSHMARK(SP); 25 | XPUSHs(in_arg); 26 | XPUSHs(sv_2mortal(newSViv(i))); 27 | PUTBACK; 28 | 29 | count = call_sv(subref, G_ARRAY); 30 | 31 | SPAGAIN; 32 | 33 | if(count >= 1) 34 | out_arg = SvREFCNT_inc(POPs); 35 | else 36 | out_arg = NULL; 37 | 38 | PUTBACK; 39 | FREETMPS; 40 | LEAVE; 41 | 42 | return out_arg; 43 | } 44 | } 45 | 46 | void 47 | ffi_pl_custom_perl_cb(SV *subref, SV *in_arg, int i) 48 | { 49 | dSP; 50 | ENTER; 51 | SAVETMPS; 52 | PUSHMARK(SP); 53 | XPUSHs(in_arg); 54 | XPUSHs(sv_2mortal(newSViv(i))); 55 | PUTBACK; 56 | call_sv(subref, G_VOID|G_DISCARD); 57 | FREETMPS; 58 | LEAVE; 59 | } 60 | -------------------------------------------------------------------------------- /xs/names.c: -------------------------------------------------------------------------------- 1 | #include "ffi_platypus.h" 2 | #include <stdio.h> 3 | 4 | ffi_type * 5 | ffi_pl_type_to_libffi_type(ffi_pl_type *type) 6 | { 7 | int type_code = type->type_code; 8 | if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_CUSTOM_PERL) 9 | type_code = type_code & ~(FFI_PL_SHAPE_MASK); 10 | if((type_code & FFI_PL_SHAPE_MASK) == FFI_PL_SHAPE_OBJECT) 11 | type_code = type_code & ~(FFI_PL_SHAPE_MASK); 12 | switch(type_code) 13 | { 14 | case FFI_PL_TYPE_VOID: 15 | return &ffi_type_void; 16 | case FFI_PL_TYPE_SINT8: 17 | return &ffi_type_sint8; 18 | case FFI_PL_TYPE_SINT16: 19 | return &ffi_type_sint16; 20 | case FFI_PL_TYPE_SINT32: 21 | return &ffi_type_sint32; 22 | case FFI_PL_TYPE_SINT64: 23 | return &ffi_type_sint64; 24 | case FFI_PL_TYPE_UINT8: 25 | return &ffi_type_uint8; 26 | case FFI_PL_TYPE_UINT16: 27 | return &ffi_type_uint16; 28 | case FFI_PL_TYPE_UINT32: 29 | return &ffi_type_uint32; 30 | case FFI_PL_TYPE_UINT64: 31 | return &ffi_type_uint64; 32 | case FFI_PL_TYPE_FLOAT: 33 | return &ffi_type_float; 34 | case FFI_PL_TYPE_DOUBLE: 35 | return &ffi_type_double; 36 | #ifdef FFI_PL_PROBE_LONGDOUBLE 37 | case FFI_PL_TYPE_LONG_DOUBLE: 38 | return &ffi_type_longdouble; 39 | #endif 40 | #if FFI_PL_PROBE_COMPLEX 41 | case FFI_PL_TYPE_COMPLEX_FLOAT: 42 | return &ffi_type_complex_float; 43 | case FFI_PL_TYPE_COMPLEX_DOUBLE: 44 | return &ffi_type_complex_double; 45 | #endif 46 | case FFI_PL_TYPE_OPAQUE: 47 | case FFI_PL_TYPE_STRING: 48 | case FFI_PL_TYPE_CLOSURE: 49 | case FFI_PL_TYPE_RECORD: 50 | return &ffi_type_pointer; 51 | case FFI_PL_TYPE_RECORD_VALUE: 52 | return type->extra[0].record.meta != NULL ? &type->extra[0].record.meta->ffi_type : NULL; 53 | } 54 | switch(type_code & (FFI_PL_SHAPE_MASK)) 55 | { 56 | case FFI_PL_SHAPE_POINTER: 57 | case FFI_PL_SHAPE_ARRAY: 58 | return &ffi_type_pointer; 59 | default: 60 | fprintf(stderr, "FFI::Platypus: internal error: type = %04x\n", type_code); 61 | fflush(stderr); 62 | return NULL; 63 | } 64 | } 65 | -------------------------------------------------------------------------------- /xt/author/critic.t: -------------------------------------------------------------------------------- 1 | use Test2::Require::Module 'Test2::Tools::PerlCritic'; 2 | use Test2::Require::Module 'Perl::Critic'; 3 | use Test2::Require::Module 'Perl::Critic::Community'; 4 | use Test2::V0; 5 | use Perl::Critic; 6 | use Test2::Tools::PerlCritic; 7 | 8 | my $critic = Perl::Critic->new( 9 | -profile => 'perlcriticrc', 10 | ); 11 | 12 | perl_critic_ok ['lib','t'], $critic; 13 | 14 | done_testing; 15 | -------------------------------------------------------------------------------- /xt/author/pod_link.t: -------------------------------------------------------------------------------- 1 | use Test2::Require::Module 'Test::Pod::LinkCheck::Lite'; 2 | use Test2::Require::EnvVar 'POD_CHECK'; 3 | use Test2::V0; 4 | use Test::Pod::LinkCheck::Lite; 5 | use Path::Tiny qw( path ); 6 | use HTTP::Tiny::Mech; 7 | use WWW::Mechanize::Cached; 8 | use CHI; 9 | 10 | my @checks; 11 | 12 | if(-d 'blib/script') 13 | { 14 | push @checks, 'blib/script'; 15 | } 16 | elsif(-d 'bin') 17 | { 18 | push @checks, 'bin'; 19 | } 20 | 21 | if(-d 'blib') 22 | { 23 | push @checks, 'blib'; 24 | } 25 | else 26 | { 27 | push @checks, 'lib'; 28 | diag "checking lib instead of blib"; 29 | } 30 | 31 | my $dir = path('~/.xor/cache'); 32 | $dir->mkpath; 33 | $dir->chmod(0700); 34 | my $ua = HTTP::Tiny::Mech->new( 35 | mechua => WWW::Mechanize::Cached->new( 36 | cache => CHI->new( 37 | # keep cache around for 24hrs 38 | expires_in => 60*60*24, 39 | driver => 'File', 40 | root_dir => $dir->stringify, 41 | ), 42 | ), 43 | ); 44 | 45 | my $mock1 = mock 'Test::Pod::LinkCheck::Lite' => ( 46 | override => [ 47 | _user_agent => sub { $ua }, 48 | ], 49 | ); 50 | 51 | # WWW::Mechanize::Cached gets confused by HEAD 52 | # requests and thinks they are invalid because 53 | # content-length is non-zero (as it should be) 54 | my $mock2 = mock 'HTTP::Tiny::Mech' => ( 55 | override => [ 56 | head => sub { shift->get(@_) }, 57 | ], 58 | ); 59 | 60 | Test::Pod::LinkCheck::Lite 61 | ->new 62 | ->all_pod_files_ok(@checks); 63 | 64 | done_testing; 65 | --------------------------------------------------------------------------------