├── .gitignore ├── .travis.yml ├── META6.json ├── README.md ├── foo.c ├── lib └── NativeLibs.pm6 └── t ├── 01-basic.t ├── 02-cannon-name.t ├── 10-search.t └── 20-compile.t /.gitignore: -------------------------------------------------------------------------------- 1 | *.swp 2 | .precomp 3 | lib/.precomp 4 | foo.o 5 | libfoo.so 6 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: perl6 2 | perl6: 3 | - latest 4 | -------------------------------------------------------------------------------- /META6.json: -------------------------------------------------------------------------------- 1 | { 2 | "perl" : "6.c", 3 | "name" : "NativeLibs", 4 | "version" : "0.0.9", 5 | "auth" : "github:salortiz", 6 | "description" : "Native libraries utilities", 7 | "depends" : [ ], 8 | "build-depends" : [ ], 9 | "test-depends" : [ ], 10 | "provides" : { 11 | "NativeLibs" : "lib/NativeLibs.pm6" 12 | }, 13 | "repo-type" : "git", 14 | "source-url": "git://github.com/salortiz/NativeLibs.git", 15 | "authors" : [ "Salvador Ortiz " ], 16 | "licence" : "Artistic-2.0", 17 | "support" : { 18 | "email" : "sog@msg.mx", 19 | "source" : "https://github.com/salortiz/NativeLibs.git" 20 | }, 21 | "tags" : [ 22 | "NativeCall", "MoarVM", "Utilities" 23 | ] 24 | } 25 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # NativeLibs 2 | 3 | The simple use in your module is: 4 | 5 | ```perl6 6 | use NativeLibs; # This also re-exports NativeCall :DEFAULTS for convenience 7 | my $Lib; # To keep the reference 8 | 9 | sub some_native_func() is native { * } # Note no library needed 10 | … The rest of your module 11 | 12 | INIT { 13 | # Load the needed library 14 | without $Lib = NativeLibs::Loader.load('libsomelib.so.4') { 15 | .fail; 16 | } 17 | } 18 | … 19 | ``` 20 | 21 | If in your native library binding you need to support a range of versions: 22 | 23 | ```perl6 24 | use NativeLibs; 25 | 26 | constant LIB = NativeLibs::Searcher.at-runtime( 27 | 'mysqlclient', # The library short name 28 | 'mysql_init', # A 'well known symbol' 29 | 16..20 # A List of supported versions, a range in this example 30 | ); 31 | 32 | sub mysql_get_client_info(--> Str) is export is native(LIB) { * } 33 | 34 | ... 35 | ``` 36 | 37 | This is a grow-up version of the original NativeLibs (v0.0.3) included in DBIish now released 38 | to allow the interested people the testing and discussion of the module. 39 | 40 | So, if you use this in your own module, please use with a version, for example: 41 | 42 | ```perl6 43 | use NativeLibs:ver<0.0.5>; 44 | ``` 45 | 46 | and include `"NativeLibs:ver<0.0.5+>"` in your META6's depends 47 | 48 | Other examples in the drivers of https://github.com/perl6/DBIish 49 | -------------------------------------------------------------------------------- /foo.c: -------------------------------------------------------------------------------- 1 | #include 2 | #ifdef _WIN32 3 | #define FRMT "%I64u" 4 | #else 5 | #define FRMT "%lu" 6 | #endif 7 | int main() { 8 | printf("size: "FRMT, sizeof(int)); 9 | } 10 | -------------------------------------------------------------------------------- /lib/NativeLibs.pm6: -------------------------------------------------------------------------------- 1 | use v6; 2 | 3 | use NativeCall; 4 | sub EXPORT(|) { 5 | my $exp = &trait_mod:.candidates.first: { .signature ~~ :(Routine, :$native!) }; 6 | Map.new( 7 | 'NativeCall' => NativeCall, 8 | '&trait_mod:' => $exp.dispatcher 9 | ) 10 | } 11 | unit module NativeLibs:auth:ver<0.0.9>; 12 | 13 | our constant is-win = Rakudo::Internals.IS-WIN(); 14 | 15 | our proto sub cannon-name(|) { * } 16 | multi sub cannon-name(Str $libname, Version $version = Version) { 17 | with $libname.IO { 18 | if .extension { 19 | .Str; # Assume resolved, so don't touch 20 | } else { 21 | $*VM.platform-library-name($_, :$version).Str; 22 | } 23 | } 24 | } 25 | multi sub cannon-name(Str $libname, Cool $ver) { 26 | cannon-name($libname, Version.new($ver)); 27 | } 28 | 29 | class Loader { 30 | # This is an HLL clone of MoarVM's loadlib, freelib, et.al. ops. 31 | # not available in rakudo. 32 | class DLLib is repr('CPointer') { }; 33 | 34 | my %Libraries; 35 | my \dyncall = $*VM.config eq 'dyncall'; 36 | constant k32 = 'kernel32'; # Main windows dll 37 | 38 | has Str $.name; 39 | has DLLib $.library; 40 | 41 | sub dlerror(--> Str) is native { * } # For linux or darwin/OS X 42 | sub GetLastError(--> uint32) is native(k32) { * } # On Microsoft land 43 | method !dlerror() { 44 | is-win ?? "error({ GetLastError })" !! (dlerror() // ''); 45 | } 46 | 47 | sub dlLoadLibrary(Str --> DLLib) is native { * } # dyncall 48 | sub dlopen(Str, uint32 --> DLLib) is native { * } # libffi 49 | sub LoadLibraryA(Str --> DLLib) is native(k32) { * } 50 | method !dlLoadLibrary(Str $libname --> DLLib) { 51 | is-win ?? LoadLibraryA($libname) !! 52 | dyncall ?? dlLoadLibrary($libname) !! 53 | dlopen($libname, 0x102); # RTLD_GLOBAL | RTLD_NOW 54 | 55 | } 56 | 57 | method load(::?CLASS:U: $libname) { 58 | with self!dlLoadLibrary($libname) { 59 | self.bless(:name($libname), :library($_)); 60 | } else { 61 | fail "Cannot load native library '$libname'"; 62 | } 63 | } 64 | 65 | sub dlFindSymbol( DLLib, Str --> Pointer) is native { * } # dyncall 66 | sub dlsym( DLLib, Str --> Pointer) is native { * } # libffi 67 | sub GetProcAddress(DLLib, Str --> Pointer) is native(k32) { * } 68 | sub GetModuleHandleA( Str --> DLLib) is native(k32) { * } 69 | method symbol(::?CLASS $self: Str $symbol, Mu $want = Pointer) { 70 | my \c = \( 71 | $self.DEFINITE ?? $!library !! 72 | is-win ?? GetModuleHandleA(Str) !! DLLib, 73 | $symbol 74 | ); 75 | with ( 76 | is-win ?? &GetProcAddress !! dyncall ?? &dlFindSymbol !! &dlsym 77 | )(|c) { 78 | if $want !=== Pointer { 79 | nativecast($want, $_); 80 | } else { 81 | $_ 82 | } 83 | } else { 84 | fail "Symbol '$symbol' not found"; 85 | } 86 | } 87 | 88 | sub dlFreeLibrary(DLLib) is native { * } 89 | sub dlclose( DLLib) is native { * } 90 | sub FreeLibrary( DLLib --> int32) is native(k32) { * } 91 | method dispose(--> True) { 92 | with $!library { 93 | is-win ?? FreeLibrary($_) !! 94 | dyncall ?? dlFreeLibrary($_) !! dlclose($_); 95 | $_ = Nil; 96 | } 97 | } 98 | } 99 | 100 | class Searcher { 101 | method !test($try, $wks) { 102 | (try cglobal($try, $wks, Pointer)) ~~ Pointer ?? $try !! Nil 103 | } 104 | method try-versions(Str $libname, Str $wks, *@vers) { 105 | my $wlibname; 106 | for @vers { 107 | my $version = $_.defined ?? Version.new($_) !! Version; 108 | $wlibname = $_ and last with self!test: 109 | cannon-name($libname, $version), $wks; 110 | } 111 | # Try unversionized 112 | $wlibname //= self!test: cannon-name($libname), $wks unless @vers; 113 | # Try common practice in Windows; 114 | $wlibname //= self!test: "lib$libname.dll", $wks if is-win; 115 | $wlibname; 116 | } 117 | 118 | method at-runtime($libname, $wks, *@vers) { 119 | -> { 120 | with self.try-versions($libname, $wks, |@vers) { 121 | $_ 122 | } else { 123 | # The sensate thing to do is die, but somehow that don't work 124 | # ( 'Cannot invoke this object' ... ) 125 | # so let NC::!setup die for us returning $libname. 126 | #die "Cannot locate native library '$libname'" 127 | $libname; 128 | } 129 | } 130 | } 131 | } 132 | 133 | class Compile { 134 | has @.files; 135 | has $.name; 136 | has $.lib; 137 | has $.outdir; 138 | 139 | my $cfg = $*VM.config; 140 | submethod BUILD(:$!name!, :$!outdir, :@!files) { 141 | @!files.push: $!name unless @!files; 142 | $!lib = $*VM.platform-library-name($!name.IO); 143 | $_ .= subst(/\.c$/,'') for @!files; 144 | } 145 | 146 | method compile-file($file is copy) { 147 | my $CC = "$cfg -c $cfg $cfg"; 148 | my $c-line = join(' ', $CC, "$cfg$file$cfg", "$file.c"); 149 | shell($c-line); 150 | } 151 | 152 | method compile-all { 153 | self.compile-file($_) for @!files; 154 | my $lds = is-win ?? '' !! $cfg; 155 | my $LD = "$cfg $lds $cfg $cfg"; 156 | my $l-line = join(' ', $LD, "$cfg$!lib", @!files.map(* ~ $cfg)); 157 | shell($l-line); 158 | } 159 | } 160 | 161 | # Reexport on demand all of NativeCall 162 | CHECK for NativeCall::EXPORT::.keys { 163 | UNIT::EXPORT::{$_} := NativeCall::EXPORT::{$_}; 164 | } 165 | # vim: ft=perl6:st=4:sw=4:et 166 | -------------------------------------------------------------------------------- /t/01-basic.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | plan 23; 5 | 6 | use-ok 'NativeLibs:v<0.0.9>' or do { diag "Can't continue"; exit 1 }; 7 | use NativeLibs:ver<0.0.9>; 8 | 9 | # Our own classes 10 | ok ::('NativeLibs::Loader') !~~ Failure, 'Class Loader exists'; 11 | ok ::('NativeLibs::Searcher') !~~ Failure, 'Class Searcher exists'; 12 | ok ::('NativeLibs::&cannon-name') !~~ Failure, 'sub cannon-name exists'; 13 | ok ::('NativeLibs::is-win') !~~ Failure, 'constant is-win exists'; 14 | 15 | # Test transitive imports 16 | ok ::('NativeCall') !~~ Failure, 'NativeCall loaded too'; 17 | 18 | my \NCexports = ::('NativeCall::EXPORT::ALL'); 19 | for '&trait_mod:', 20 | | 23 | { 24 | ok NCexports::{$_}:exists, "'$_' loaded too"; 25 | } 26 | 27 | # vim: et 28 | -------------------------------------------------------------------------------- /t/02-cannon-name.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | 4 | plan 10; 5 | use NativeLibs:ver<0.0.9>; 6 | my &cn = &NativeLibs::cannon-name; 7 | 8 | given $*VM.config.lc { 9 | when 'linux'|'freebsd' { 10 | is cn('foo'), 'libfoo.so', 'libfoo.so'; 11 | is cn('libfoo.so'), 'libfoo.so', 'the same'; 12 | 13 | is cn('foo', v2), 'libfoo.so.2', 'libfoo.so.2'; 14 | is cn('libfoo.so.2'), 'libfoo.so.2', 'the same'; 15 | 16 | is cn('foo', 2), 'libfoo.so.2', 'libfoo.so.2'; 17 | is cn('libfoo.so.2'), 'libfoo.so.2', 'the same'; 18 | 19 | is cn('./foo'), "$*CWD/libfoo.so", 'In CWD'; 20 | is cn('./libfoo.so'), './libfoo.so', 'Not modified'; 21 | 22 | is cn('/bar/foo'), "/bar/libfoo.so", 'Absolute'; 23 | is cn('/bar/libfoo.so'), '/bar/libfoo.so', 'Not modified'; 24 | } 25 | when 'darwin' { 26 | is cn('foo'), 'libfoo.dylib', 'libfoo.dylib'; 27 | is cn('libfoo.dylib'), 'libfoo.dylib', 'libfoo.dylib'; 28 | 29 | is cn('foo', v2), 'libfoo.2.dylib', 'libfoo.2.dylib'; 30 | is cn('libfoo.2.dylib'), 'libfoo.2.dylib', 'libfoo.2.dylib'; 31 | 32 | is cn('foo', 2), 'libfoo.2.dylib', 'libfoo.2.dylib'; 33 | is cn('libfoo.2.dylib'), 'libfoo.2.dylib', 'libfoo.2.dylib'; 34 | 35 | skip-rest, "Tests missing"; # TODO 36 | } 37 | when 'mswin32' | 'mingw' | 'msys' | 'cygwin' { 38 | is cn('foo'), 'foo.dll', 'foo.dll'; 39 | is cn('foo.dll'), 'foo.dll', 'foo.dll'; 40 | 41 | skip-rest, "Tests missing"; # TODO 42 | } 43 | } 44 | -------------------------------------------------------------------------------- /t/10-search.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use NativeLibs:ver<0.0.9>; 4 | 5 | # A simple shortcut 6 | my \Util = ::NativeLibs::Searcher; 7 | 8 | my $lib; 9 | # A 'must be there' test 10 | given $*VM.config.lc { 11 | when 'linux' { 12 | $lib = Util.try-versions('m', 'sin', 5, 6, 7); 13 | ok $lib ~~ / 'libm.so.' (\d) /, "found libm.so.$0"; 14 | my $ver = $0; 15 | ok $ver == any(5, 6, 7), 'In version range'; 16 | 17 | ok my $dll = NativeLibs::Loader.load($lib), 'So can be loaded'; 18 | is $dll.symbol('sin', :(num64 --> num64))(pi / 2), 1e0, 'used'; 19 | is $dll.symbol('cos', :(num64 --> num64))(pi), -1e0, 'twice'; 20 | ok $dll.dispose, 'and disposed'; 21 | unless "/etc/os-release".IO.lines[0] eq 'NAME="Alpine Linux"' { 22 | nok Util.try-versions('m', 'sin', 8, 9, 10), 'No version found'; 23 | 24 | dies-ok { 25 | NativeLibs::Loader.load('libm.so.9'); 26 | }, "Can't be loaded"; 27 | } 28 | } 29 | when 'darwin' { 30 | } 31 | when 'mswin32' | 'mingw' | 'msys' | 'cygwin' { 32 | $lib = Util.try-versions('kernel32', 'GetLastError'); 33 | ok $lib ~~ / 'kernel32.dll' /, 'found kernel32.dll'; 34 | pass 'Unversionized'; 35 | 36 | ok my $dll = NativeLibs::Loader.load($lib), 'Can be loaded'; 37 | is $dll.symbol('GetCurrentProcessId', :(--> uint32))(), $*PID, 'used'; 38 | ok $dll.dispose, 'and disposed'; 39 | 40 | } 41 | } 42 | my $dbclient = 'mysql'; 43 | $dbclient ~= 'client' unless NativeLibs::is-win; 44 | # Test delayed search 45 | my $sub = Util.at-runtime($dbclient, 'mysql_init', 16 .. 22); 46 | 47 | does-ok $sub, Callable; 48 | lives-ok { $lib = $sub() }, 'Closure can be called'; 49 | 50 | todo "Can fail if the mysqlclient library isn't installed", 1; 51 | like $lib, NativeLibs::is-win ?? / 'mysql' / !! / 'mysql' .* \d+ /, "Indeed $lib"; 52 | 53 | done-testing; 54 | 55 | # vim: et 56 | -------------------------------------------------------------------------------- /t/20-compile.t: -------------------------------------------------------------------------------- 1 | use v6; 2 | use Test; 3 | use NativeLibs:ver<0.0.9>; 4 | 5 | plan 2; 6 | 7 | my \Compile = NativeLibs::Compile; 8 | my \is-win = NativeLibs::is-win; 9 | my \is-darwin = $*VM.config ~~ 'darwin'; 10 | 11 | ok (my $lc = Compile.new(:name)), 'Can create compiler'; 12 | 13 | if !is-darwin { 14 | $lc.compile-all; 15 | ok $lc.lib.IO.e, "Object builded" 16 | } else { 17 | skip "Not ready for darwin" 18 | } 19 | # vim: et 20 | --------------------------------------------------------------------------------