From Code to Community: Sponsoring The Perl and Raku Conference 2025 Learn more

ETJ / NativeCall-0.006 / lib / NativeCall.pm 

            

              
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
—
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125

              
package NativeCall;
use strict;
use warnings;
use 5.016;
use Sub::Util qw(subname);
use FFI::Platypus;
use FFI::CheckLib 0.06;
our $VERSION = '0.006';
my %attr21 = (
  Native => 1,
  Args => 1,
  Returns => 1,
  Symbol => 1,
);
sub _attr_parse {
  my ($attr) = @_;
  my ($attribute, $args) = ($attr =~ /
    (\w+)
    (?:
      \(
      (.*)
      \)
    )?
  /x);
  return ($attribute, [ map { s/;/,/gr; } split /,\s*/, ($args//'') =~ s/(\([^)]*\))/$1 =~ s{,}{;}rg /ger ]);
}
sub MODIFY_CODE_ATTRIBUTES {
  my ($package, $subref, @attrs) = @_;
  my @bad;
  my %attr2args;
  for my $attr (@attrs) {
    my ($attribute, $args) = _attr_parse($attr);
    if (!$attr21{$attribute}) {
      push @bad, $attribute;
      next;
    } else {
      $attr2args{$attribute} ||= [];
      push @{ $attr2args{$attribute} }, @$args;
    }
  }
  my $subname = subname $subref;
  my $sub_base = $attr2args{Symbol}->[0] // (split /::/, $subname)[-1];
  my $ffi = FFI::Platypus->new;
  my $lib = $attr2args{Native}->[0] || undef; # undef means standard library
  $ffi->lib($lib ? find_lib_or_die lib => $lib : undef);
  my $argtypes = $attr2args{Args};
  my $returntype = $attr2args{Returns}->[0] || 'void';
  no warnings qw(redefine);
  undef &{ $subname }; # avoid "redefine" warning in Platypus
  $ffi->attach([ $sub_base => $subname ] => $argtypes => $returntype);
  return @bad;
}
1;
__END__
=head1 NAME
NativeCall - Perl 5 interface to foreign functions in Perl code without XS
=head1 SYNOPSIS
  use parent qw(NativeCall);
  use feature 'say';
  sub cdio_eject_media_drive :Args(string) :Native(cdio) {}
  sub cdio_close_tray :Args(string, int) :Native(cdio) {}
  say "Gimme a CD!";
  cdio_eject_media_drive undef;
  sleep 1;
  say "Ha! Too slow!";
  cdio_close_tray undef, 0;
  sub fmax :Args(double, double) :Native :Returns(double) {}
  say "fmax(2.0, 3.0) = " . fmax(2.0, 3.0);
   
  # avoid Perl built in also called "abs"
  sub myabs :Args(int) :Native :Returns(int) :Symbol(abs) {}
  say "abs(-3) = " . abs(-3);
=head1 DESCRIPTION
Mimics the C<NativeCall> module and interface from Perl 6. Uses
L<FFI::Platypus>, by the mighty Graham Ollis, for the actual hard
work. Uses inheritance and L<attributes>.
See F<examples/troll.pl> for the example given above in SYNOPSIS.
=head2 ATTRIBUTES
=over
=item Native
If an argument is given, try to load from that library. If none given,
use what is already loaded.
=item Args
A comma-separated list of L<FFI::Platypus::Type>s.  All types are supported,
including L<closures|FFI::Platypus::Type#Closures>.
=item Returns
A single L<FFI::Platypus::Type>.
=item Symbol
The native symbol name, if different from the Perl sub name.
=back
=head1 INSPIRATION
This module is entirely inspired by the article about Perl 6 NativeCall at
L<http://blogs.perl.org/users/zoffix_znet/2016/05/perl-6-nativecall-look-ma-im-a-c-programmer-1.html>.
All credit for clear explanation to Zoffix. All brickbats to me.