line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
# You may distribute under the terms of either the GNU General Public License |
2
|
|
|
|
|
|
|
# or the Artistic License (the same terms as Perl itself) |
3
|
|
|
|
|
|
|
# |
4
|
|
|
|
|
|
|
# (C) Paul Evans, 2010-2016 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package ExtUtils::H2PM; |
7
|
|
|
|
|
|
|
|
8
|
10
|
|
|
10
|
|
129980
|
use strict; |
|
10
|
|
|
|
|
15
|
|
|
10
|
|
|
|
|
258
|
|
9
|
10
|
|
|
10
|
|
35
|
use warnings; |
|
10
|
|
|
|
|
13
|
|
|
10
|
|
|
|
|
228
|
|
10
|
|
|
|
|
|
|
|
11
|
10
|
|
|
10
|
|
44
|
use Carp; |
|
10
|
|
|
|
|
14
|
|
|
10
|
|
|
|
|
747
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
our $VERSION = '0.10'; |
14
|
|
|
|
|
|
|
|
15
|
10
|
|
|
10
|
|
37
|
use Exporter 'import'; |
|
10
|
|
|
|
|
10
|
|
|
10
|
|
|
|
|
477
|
|
16
|
|
|
|
|
|
|
our @EXPORT = qw( |
17
|
|
|
|
|
|
|
module |
18
|
|
|
|
|
|
|
include |
19
|
|
|
|
|
|
|
constant |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
structure |
22
|
|
|
|
|
|
|
member_numeric |
23
|
|
|
|
|
|
|
member_strarray |
24
|
|
|
|
|
|
|
member_constant |
25
|
|
|
|
|
|
|
|
26
|
|
|
|
|
|
|
no_export use_export use_export_ok |
27
|
|
|
|
|
|
|
|
28
|
|
|
|
|
|
|
gen_output |
29
|
|
|
|
|
|
|
write_output |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
include_path |
32
|
|
|
|
|
|
|
define |
33
|
|
|
|
|
|
|
); |
34
|
|
|
|
|
|
|
|
35
|
10
|
|
|
10
|
|
4597
|
use ExtUtils::CBuilder; |
|
10
|
|
|
|
|
620838
|
|
|
10
|
|
|
|
|
358
|
|
36
|
|
|
|
|
|
|
|
37
|
10
|
|
|
10
|
|
62
|
use List::Util 1.29 qw( pairs ); |
|
10
|
|
|
|
|
237
|
|
|
10
|
|
|
|
|
37950
|
|
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
=head1 NAME |
40
|
|
|
|
|
|
|
|
41
|
|
|
|
|
|
|
C - automatically generate perl modules to wrap C header files |
42
|
|
|
|
|
|
|
|
43
|
|
|
|
|
|
|
=head1 DESCRIPTION |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
This module assists in generating wrappers around system functionallity, such |
46
|
|
|
|
|
|
|
as C types or C calls, where the only interesting features |
47
|
|
|
|
|
|
|
required are the values of some constants or layouts of structures normally |
48
|
|
|
|
|
|
|
only known to the C header files. Rather than writing an entire XS module just |
49
|
|
|
|
|
|
|
to contain some constants and pack/unpack functions, this module allows the |
50
|
|
|
|
|
|
|
author to generate, at module build time, a pure perl module containing |
51
|
|
|
|
|
|
|
constant declarations and structure utility functions. The module then |
52
|
|
|
|
|
|
|
requires no XS module to be loaded at run time. |
53
|
|
|
|
|
|
|
|
54
|
|
|
|
|
|
|
In comparison to F, C, and so on, this module works |
55
|
|
|
|
|
|
|
by generating a small C program containing C lines to output the |
56
|
|
|
|
|
|
|
values of the constants, compiling it, and running it. This allows it to |
57
|
|
|
|
|
|
|
operate without needing tricky syntax parsing or guessing of the contents of |
58
|
|
|
|
|
|
|
C header files. |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
It can also automatically build pack/unpack functions for simple structure |
61
|
|
|
|
|
|
|
layouts, whose members are all simple integer or character array fields. |
62
|
|
|
|
|
|
|
It is not intended as a full replacement of arbitrary code written in XS |
63
|
|
|
|
|
|
|
modules. If structures should contain pointers, or require special custom |
64
|
|
|
|
|
|
|
handling, then likely an XS module will need to be written. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=cut |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my $output = ""; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
my @preamble; |
71
|
|
|
|
|
|
|
my @fragments; |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
my $done_carp; |
74
|
|
|
|
|
|
|
|
75
|
|
|
|
|
|
|
my @perlcode; |
76
|
|
|
|
|
|
|
my @genblocks; |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
my $export_mode; use_export_ok(); |
79
|
|
|
|
|
|
|
my @exports; my @exports_ok; |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
=head1 FUNCTIONS |
82
|
|
|
|
|
|
|
|
83
|
|
|
|
|
|
|
=cut |
84
|
|
|
|
|
|
|
|
85
|
|
|
|
|
|
|
sub push_export |
86
|
|
|
|
|
|
|
{ |
87
|
26
|
|
|
26
|
0
|
46
|
my $name = shift; |
88
|
|
|
|
|
|
|
|
89
|
26
|
100
|
|
|
|
91
|
if( $export_mode eq "OK" ) { |
|
|
50
|
|
|
|
|
|
90
|
23
|
|
|
|
|
42
|
push @exports_ok, $name; |
91
|
|
|
|
|
|
|
} |
92
|
|
|
|
|
|
|
elsif( $export_mode ) { |
93
|
0
|
|
|
|
|
0
|
push @exports, $name; |
94
|
|
|
|
|
|
|
} |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
=head2 module $name |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
Sets the name of the perl module to generate. This will apply a C |
100
|
|
|
|
|
|
|
header. |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=cut |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
my $modulename; |
105
|
|
|
|
|
|
|
sub module |
106
|
|
|
|
|
|
|
{ |
107
|
18
|
|
|
18
|
1
|
9858
|
$modulename = shift; |
108
|
|
|
|
|
|
|
|
109
|
18
|
50
|
|
|
|
72
|
$output .= gen_perl() if @fragments; |
110
|
|
|
|
|
|
|
|
111
|
18
|
|
|
|
|
112
|
$output .= "package $modulename;\n" . |
112
|
|
|
|
|
|
|
"# This module was generated automatically by ExtUtils::H2PM from $0\n" . |
113
|
|
|
|
|
|
|
"\n"; |
114
|
|
|
|
|
|
|
|
115
|
18
|
|
|
|
|
38
|
undef $done_carp; |
116
|
|
|
|
|
|
|
} |
117
|
|
|
|
|
|
|
|
118
|
|
|
|
|
|
|
=head2 include $file |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
Adds a file to the list of headers which will be included by the C program, to |
121
|
|
|
|
|
|
|
obtain the constants or structures from |
122
|
|
|
|
|
|
|
|
123
|
|
|
|
|
|
|
=cut |
124
|
|
|
|
|
|
|
|
125
|
|
|
|
|
|
|
sub include |
126
|
|
|
|
|
|
|
{ |
127
|
18
|
|
|
18
|
1
|
124
|
my ( $file, %params ) = @_; |
128
|
|
|
|
|
|
|
|
129
|
|
|
|
|
|
|
# undocumented but useful for testing |
130
|
18
|
50
|
|
|
|
56
|
if( $params{local} ) { |
131
|
18
|
|
|
|
|
77
|
push @preamble, qq[#include "$file"]; |
132
|
|
|
|
|
|
|
} |
133
|
|
|
|
|
|
|
else { |
134
|
0
|
|
|
|
|
0
|
push @preamble, "#include <$file>"; |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
} |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
# undocumented so far |
139
|
|
|
|
|
|
|
sub perlcode |
140
|
|
|
|
|
|
|
{ |
141
|
0
|
|
|
0
|
0
|
0
|
my ( $code ) = @_; |
142
|
0
|
|
|
|
|
0
|
push @perlcode, $code; |
143
|
|
|
|
|
|
|
} |
144
|
|
|
|
|
|
|
|
145
|
|
|
|
|
|
|
=head2 constant $name, %args |
146
|
|
|
|
|
|
|
|
147
|
|
|
|
|
|
|
Adds a numerical constant. |
148
|
|
|
|
|
|
|
|
149
|
|
|
|
|
|
|
The following additional named arguments are also recognised: |
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
=over 8 |
152
|
|
|
|
|
|
|
|
153
|
|
|
|
|
|
|
=item * name => STRING |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
Use the given name for the generated constant function. If not specified, the |
156
|
|
|
|
|
|
|
C name for the constant will be used. |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
=item * ifdef => STRING |
159
|
|
|
|
|
|
|
|
160
|
|
|
|
|
|
|
If present, guard the constant with an C<#ifdef STRING> preprocessor macro. If |
161
|
|
|
|
|
|
|
the given string is not defined, no constant will be generated. |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
=back |
164
|
|
|
|
|
|
|
|
165
|
|
|
|
|
|
|
=cut |
166
|
|
|
|
|
|
|
|
167
|
|
|
|
|
|
|
sub constant |
168
|
|
|
|
|
|
|
{ |
169
|
9
|
|
|
9
|
1
|
35
|
my $constname = shift; |
170
|
9
|
|
|
|
|
17
|
my %args = @_; |
171
|
|
|
|
|
|
|
|
172
|
9
|
|
66
|
|
|
54
|
my $name = $args{name} || $constname; |
173
|
|
|
|
|
|
|
|
174
|
9
|
|
|
|
|
26
|
push @fragments, qq{ printf("$constname=%ld\\n", (long)$constname);}; |
175
|
|
|
|
|
|
|
|
176
|
9
|
100
|
|
|
|
28
|
if( my $symbol = $args{ifdef} ) { |
177
|
1
|
|
|
|
|
6
|
$fragments[-1] = "#ifdef $symbol\n$fragments[-1]\n#endif"; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
push @genblocks, [ $constname => sub { |
181
|
9
|
|
|
9
|
|
21
|
my ( $result ) = @_; |
182
|
9
|
100
|
|
|
|
45
|
return () unless defined $result; |
183
|
|
|
|
|
|
|
|
184
|
8
|
|
|
|
|
45
|
push_export $name; |
185
|
8
|
|
|
|
|
48
|
"use constant $name => $result;"; |
186
|
9
|
|
|
|
|
74
|
} ]; |
187
|
|
|
|
|
|
|
} |
188
|
|
|
|
|
|
|
|
189
|
|
|
|
|
|
|
=head2 structure $name, %args |
190
|
|
|
|
|
|
|
|
191
|
|
|
|
|
|
|
Adds a structure definition. This requires a named argument, C. This |
192
|
|
|
|
|
|
|
should be an ARRAY ref containing an even number of name-definition pairs. The |
193
|
|
|
|
|
|
|
first of each pair should be a member name. The second should be one of the |
194
|
|
|
|
|
|
|
following structure member definitions. |
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
The following additional named arguments are also recognised: |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=over 8 |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
=item * pack_func => STRING |
201
|
|
|
|
|
|
|
|
202
|
|
|
|
|
|
|
=item * unpack_func => STRING |
203
|
|
|
|
|
|
|
|
204
|
|
|
|
|
|
|
Use the given names for the generated pack or unpack functions. |
205
|
|
|
|
|
|
|
|
206
|
|
|
|
|
|
|
=item * with_tail => BOOL |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
If true, the structure is a header with more data behind it. The pack function |
209
|
|
|
|
|
|
|
takes an optional extra string value for the data tail, and the unpack |
210
|
|
|
|
|
|
|
function will return an extra string value containing it. |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
=item * no_length_check => BOOL |
213
|
|
|
|
|
|
|
|
214
|
|
|
|
|
|
|
If true, the generated unpack function will not first check the length of its |
215
|
|
|
|
|
|
|
argument before attempting to unpack it. If the buffer is not long enough to |
216
|
|
|
|
|
|
|
unpack all the required values, the remaining ones will not be returned. This |
217
|
|
|
|
|
|
|
may be useful, for example, in cases where various versions of a structure |
218
|
|
|
|
|
|
|
have been designed, later versions adding extra members, but where the exact |
219
|
|
|
|
|
|
|
version found may not be easy to determine beforehand. |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
=item * arg_style => STRING |
222
|
|
|
|
|
|
|
|
223
|
|
|
|
|
|
|
Defines the style in which the functions take arguments or return values. |
224
|
|
|
|
|
|
|
Defaults to C, which take or return a list of values in the given order. |
225
|
|
|
|
|
|
|
The other allowed value is C, where the pack function takes a HASH |
226
|
|
|
|
|
|
|
reference and the unpack function returns one. Each will consist of keys named |
227
|
|
|
|
|
|
|
after the structure members. If a data tail is included, it will use the hash |
228
|
|
|
|
|
|
|
key of C<_tail>. |
229
|
|
|
|
|
|
|
|
230
|
|
|
|
|
|
|
=item * ifdef => STRING |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
If present, guard the structure with an C<#ifdef STRING> preprocessor macro. |
233
|
|
|
|
|
|
|
If the given string is not defined, no functions will be generated. |
234
|
|
|
|
|
|
|
|
235
|
|
|
|
|
|
|
=back |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub structure |
240
|
|
|
|
|
|
|
{ |
241
|
10
|
|
|
10
|
1
|
37
|
my ( $name, %params ) = @_; |
242
|
|
|
|
|
|
|
|
243
|
10
|
|
|
|
|
62
|
( my $basename = $name ) =~ s/^struct //; |
244
|
|
|
|
|
|
|
|
245
|
10
|
|
66
|
|
|
55
|
my $packfunc = $params{pack_func} || "pack_$basename"; |
246
|
10
|
|
66
|
|
|
41
|
my $unpackfunc = $params{unpack_func} || "unpack_$basename"; |
247
|
|
|
|
|
|
|
|
248
|
10
|
|
|
|
|
17
|
my $with_tail = $params{with_tail}; |
249
|
10
|
|
|
|
|
35
|
my $no_length_check = $params{no_length_check}; |
250
|
|
|
|
|
|
|
|
251
|
10
|
|
100
|
|
|
59
|
my $arg_style = $params{arg_style} || "list"; |
252
|
|
|
|
|
|
|
|
253
|
10
|
|
|
|
|
67
|
my @membernames; |
254
|
|
|
|
|
|
|
my @argnames; |
255
|
0
|
|
|
|
|
0
|
my @memberhandlers; |
256
|
|
|
|
|
|
|
|
257
|
10
|
|
|
|
|
17
|
my $argindex = 0; |
258
|
10
|
|
|
|
|
11
|
my @members = @{ $params{members} }; |
|
10
|
|
|
|
|
31
|
|
259
|
10
|
|
|
|
|
131
|
foreach ( pairs @members ) { |
260
|
20
|
|
|
|
|
101
|
my $memname = $_->key; |
261
|
20
|
|
|
|
|
73
|
my $handler = $_->value; |
262
|
|
|
|
|
|
|
|
263
|
20
|
|
|
|
|
26
|
push @membernames, $memname; |
264
|
20
|
|
|
|
|
23
|
push @memberhandlers, $handler; |
265
|
|
|
|
|
|
|
|
266
|
20
|
|
|
|
|
61
|
$handler->{set_names}->( $basename, $memname ); |
267
|
|
|
|
|
|
|
|
268
|
20
|
|
|
|
|
19
|
my $wasindex = $argindex; |
269
|
20
|
|
|
|
|
31
|
$handler->{set_arg}( $argindex ); |
270
|
|
|
|
|
|
|
|
271
|
20
|
100
|
|
|
|
134
|
push @argnames, $memname if $argindex > $wasindex; |
272
|
|
|
|
|
|
|
} |
273
|
|
|
|
|
|
|
|
274
|
10
|
100
|
|
|
|
60
|
push @fragments, "#ifdef $params{ifdef}" if $params{ifdef}; |
275
|
|
|
|
|
|
|
push @fragments, |
276
|
|
|
|
|
|
|
" {", |
277
|
|
|
|
|
|
|
" $name $basename;", |
278
|
|
|
|
|
|
|
qq[ printf("$basename=%lu,", (unsigned long)sizeof($basename));], |
279
|
10
|
|
|
|
|
49
|
( map { " " . $_->{gen_c}->() } @memberhandlers ), |
|
20
|
|
|
|
|
42
|
|
280
|
|
|
|
|
|
|
qq[ printf("\\n");], |
281
|
|
|
|
|
|
|
" }"; |
282
|
10
|
100
|
|
|
|
32
|
push @fragments, "#endif" if $params{ifdef}; |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
push @genblocks, [ $basename => sub { |
285
|
10
|
|
|
10
|
|
35
|
my ( $result ) = @_; |
286
|
10
|
100
|
|
|
|
42
|
return () unless defined $result; |
287
|
|
|
|
|
|
|
|
288
|
9
|
|
|
|
|
38
|
my @result = split m/,/, $result; |
289
|
|
|
|
|
|
|
|
290
|
9
|
|
|
|
|
32
|
my $curpos = 0; |
291
|
|
|
|
|
|
|
|
292
|
9
|
|
|
|
|
21
|
my $format = ""; |
293
|
|
|
|
|
|
|
|
294
|
9
|
|
|
|
|
19
|
my $sizeof = shift @result; |
295
|
|
|
|
|
|
|
|
296
|
9
|
|
|
|
|
14
|
my ( @postargs, @preret ); |
297
|
|
|
|
|
|
|
|
298
|
9
|
|
|
|
|
25
|
foreach my $def ( @result ) { |
299
|
19
|
|
|
|
|
48
|
my $handler = shift @memberhandlers; |
300
|
|
|
|
|
|
|
|
301
|
19
|
|
|
|
|
75
|
$format .= $handler->{gen_format}( $def, $curpos, \@postargs, \@preret ) . " "; |
302
|
|
|
|
|
|
|
} |
303
|
|
|
|
|
|
|
|
304
|
9
|
100
|
|
|
|
38
|
if( $curpos < $sizeof ) { |
305
|
2
|
|
|
|
|
8
|
$format .= "x" . ( $sizeof - $curpos ); |
306
|
|
|
|
|
|
|
} |
307
|
|
|
|
|
|
|
|
308
|
9
|
|
|
|
|
24
|
my $eq = "=="; |
309
|
9
|
100
|
|
|
|
28
|
if( $with_tail ) { |
310
|
1
|
|
|
|
|
3
|
$format .= "a*"; |
311
|
1
|
|
|
|
|
2
|
$eq = ">="; |
312
|
|
|
|
|
|
|
} |
313
|
|
|
|
|
|
|
|
314
|
9
|
50
|
|
|
|
50
|
unshift( @perlcode, "use Carp;" ), $done_carp++ unless $done_carp; |
315
|
|
|
|
|
|
|
|
316
|
9
|
|
|
|
|
14
|
my ( @argcode, @retcode ); |
317
|
9
|
100
|
|
|
|
27
|
if( $arg_style eq "list" ) { |
|
|
50
|
|
|
|
|
|
318
|
8
|
100
|
|
|
|
31
|
my $members = join( ", ", @argnames, ( $with_tail ? "[tail]" : () ) ); |
319
|
|
|
|
|
|
|
|
320
|
8
|
|
|
|
|
54
|
@argcode = ( |
321
|
|
|
|
|
|
|
qq{ \@_ $eq $argindex or croak "usage: $packfunc($members)";}, |
322
|
|
|
|
|
|
|
qq{ my \@v = \@_;} ); |
323
|
8
|
|
|
|
|
17
|
@retcode = ( |
324
|
|
|
|
|
|
|
qq{ \@v;} ); |
325
|
|
|
|
|
|
|
} |
326
|
|
|
|
|
|
|
elsif( $arg_style eq "hashref" ) { |
327
|
1
|
50
|
|
|
|
5
|
my $qmembers = join( ", ", map { "'$_'" } @membernames, ( $with_tail ? "_tail" : () ) ); |
|
2
|
|
|
|
|
5
|
|
328
|
|
|
|
|
|
|
|
329
|
1
|
|
|
|
|
4
|
@argcode = ( |
330
|
|
|
|
|
|
|
qq{ ref(\$_[0]) eq "HASH" or croak "usage: $packfunc(\\%args)";}, |
331
|
|
|
|
|
|
|
qq( my \@v = \@{\$_[0]}{$qmembers};) ); |
332
|
1
|
|
|
|
|
4
|
@retcode = ( |
333
|
|
|
|
|
|
|
# Seems we can't easily do this without a temporary |
334
|
|
|
|
|
|
|
qq( my %ret; \@ret{$qmembers} = \@v;), |
335
|
|
|
|
|
|
|
qq{ \\%ret;} ); |
336
|
|
|
|
|
|
|
} |
337
|
|
|
|
|
|
|
else { |
338
|
0
|
|
|
|
|
0
|
carp "Unrecognised arg_style $arg_style"; |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
|
341
|
9
|
|
|
|
|
44
|
push_export $packfunc; |
342
|
9
|
|
|
|
|
29
|
push_export $unpackfunc; |
343
|
|
|
|
|
|
|
|
344
|
9
|
100
|
|
|
|
127
|
join( "\n", |
345
|
|
|
|
|
|
|
"", |
346
|
|
|
|
|
|
|
"sub $packfunc", |
347
|
|
|
|
|
|
|
"{", |
348
|
|
|
|
|
|
|
@argcode, |
349
|
|
|
|
|
|
|
@postargs, |
350
|
|
|
|
|
|
|
qq{ pack "$format", \@v;}, |
351
|
|
|
|
|
|
|
"}", |
352
|
|
|
|
|
|
|
"", |
353
|
|
|
|
|
|
|
"sub $unpackfunc", |
354
|
|
|
|
|
|
|
"{", |
355
|
|
|
|
|
|
|
( $no_length_check ? '' : |
356
|
|
|
|
|
|
|
qq{ length \$_[0] $eq $sizeof or croak "$unpackfunc: expected $sizeof bytes, got " . length \$_[0];} |
357
|
|
|
|
|
|
|
), |
358
|
|
|
|
|
|
|
qq{ my \@v = unpack "$format", \$_[0];}, |
359
|
|
|
|
|
|
|
@preret, |
360
|
|
|
|
|
|
|
@retcode, |
361
|
|
|
|
|
|
|
"}" |
362
|
|
|
|
|
|
|
); |
363
|
10
|
|
|
|
|
125
|
} ]; |
364
|
|
|
|
|
|
|
} |
365
|
|
|
|
|
|
|
|
366
|
|
|
|
|
|
|
=pod |
367
|
|
|
|
|
|
|
|
368
|
|
|
|
|
|
|
The following structure member definitions are allowed: |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
=over 8 |
371
|
|
|
|
|
|
|
|
372
|
|
|
|
|
|
|
=cut |
373
|
|
|
|
|
|
|
|
374
|
|
|
|
|
|
|
my %struct_formats = ( |
375
|
|
|
|
|
|
|
map { |
376
|
|
|
|
|
|
|
my $bytes = length( pack "$_", 0 ); |
377
|
|
|
|
|
|
|
"${bytes}u" => uc $_, |
378
|
|
|
|
|
|
|
"${bytes}s" => lc $_ |
379
|
|
|
|
|
|
|
} qw( C S L ) |
380
|
|
|
|
|
|
|
); |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
if( eval { pack "Q", 0 } ) { |
383
|
|
|
|
|
|
|
my $bytes = length( pack "Q", 0 ); |
384
|
|
|
|
|
|
|
$struct_formats{"${bytes}u"} = "Q"; |
385
|
|
|
|
|
|
|
$struct_formats{"${bytes}s"} = "q"; |
386
|
|
|
|
|
|
|
} |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
=item * member_numeric |
389
|
|
|
|
|
|
|
|
390
|
|
|
|
|
|
|
The field contains a single signed or unsigned number. Its size and signedness |
391
|
|
|
|
|
|
|
will be automatically detected. |
392
|
|
|
|
|
|
|
|
393
|
|
|
|
|
|
|
=cut |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
my $done_u64; |
396
|
|
|
|
|
|
|
|
397
|
|
|
|
|
|
|
sub member_numeric |
398
|
|
|
|
|
|
|
{ |
399
|
18
|
|
|
18
|
1
|
41
|
my $varname; |
400
|
|
|
|
|
|
|
my $membername; |
401
|
0
|
|
|
|
|
0
|
my $argindex; |
402
|
|
|
|
|
|
|
|
403
|
|
|
|
|
|
|
return { |
404
|
18
|
|
|
18
|
|
31
|
set_names => sub { ( $varname, $membername ) = @_; }, |
405
|
17
|
|
|
17
|
|
19
|
set_arg => sub { $argindex = $_[0]++; }, |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
gen_c => sub { |
408
|
18
|
|
|
18
|
|
120
|
qq{printf("$membername@%ld+%lu%c,", } . |
409
|
|
|
|
|
|
|
"(long)((char*)&$varname.$membername-(char*)&$varname), " . # offset |
410
|
|
|
|
|
|
|
"(unsigned long)sizeof($varname.$membername), " . # size |
411
|
|
|
|
|
|
|
"($varname.$membername=-1)>0?'u':'s'" . # signedness |
412
|
|
|
|
|
|
|
");"; |
413
|
|
|
|
|
|
|
}, |
414
|
|
|
|
|
|
|
gen_format => sub { |
415
|
17
|
|
|
17
|
|
35
|
my ( $def, undef, $postarg, $preret ) = @_; |
416
|
|
|
|
|
|
|
# ( undef, curpos ) = @_; |
417
|
|
|
|
|
|
|
|
418
|
17
|
50
|
|
|
|
127
|
my ( $member, $offs, $size, $sign ) = $def =~ m/^([\w.]+)@(\d+)\+(\d+)([us])$/ |
419
|
|
|
|
|
|
|
or die "Could not parse member definition out of '$def'"; |
420
|
|
|
|
|
|
|
|
421
|
17
|
50
|
|
|
|
96
|
$member eq $membername or die "Expected definition of $membername but found $member instead"; |
422
|
|
|
|
|
|
|
|
423
|
17
|
|
|
|
|
30
|
my $format = ""; |
424
|
17
|
50
|
|
|
|
96
|
if( $offs > $_[1] ) { |
|
|
50
|
|
|
|
|
|
425
|
0
|
|
|
|
|
0
|
my $pad = $offs - $_[1]; |
426
|
|
|
|
|
|
|
|
427
|
0
|
|
|
|
|
0
|
$format .= "x" x $pad; |
428
|
0
|
|
|
|
|
0
|
$_[1] += $pad; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
elsif( $offs < $_[1] ) { |
431
|
0
|
|
|
|
|
0
|
die "Err.. need to go backwards for structure $varname member $member"; |
432
|
|
|
|
|
|
|
} |
433
|
|
|
|
|
|
|
|
434
|
17
|
50
|
0
|
|
|
57
|
if( exists $struct_formats{"$size$sign"} ) { |
|
|
0
|
|
|
|
|
|
435
|
17
|
|
|
|
|
34
|
$format .= $struct_formats{"$size$sign"}; |
436
|
|
|
|
|
|
|
} |
437
|
|
|
|
|
|
|
elsif( $size == 8 and $sign eq "u" ) { |
438
|
|
|
|
|
|
|
# 64bit int on a 64bit-challenged perl. We'll have to improvise |
439
|
|
|
|
|
|
|
|
440
|
0
|
0
|
|
|
|
0
|
unless( $done_u64 ) { |
441
|
0
|
|
|
|
|
0
|
my $hilo = pack("S",0x0201) eq "\x02\x01" ? "\$hi, \$lo" : "\$lo, \$hi"; |
442
|
|
|
|
|
|
|
|
443
|
0
|
|
|
|
|
0
|
perlcode join "\n", |
444
|
|
|
|
|
|
|
"require Math::BigInt;", |
445
|
|
|
|
|
|
|
"", |
446
|
|
|
|
|
|
|
"sub __pack_u64 {", |
447
|
|
|
|
|
|
|
" my ( \$hi, \$lo ) = ( int(\$_[0] / 2**32), \$_[0] & 0xffffffff );", |
448
|
|
|
|
|
|
|
" pack( \"L L\", $hilo );", |
449
|
|
|
|
|
|
|
"}", |
450
|
|
|
|
|
|
|
"", |
451
|
|
|
|
|
|
|
"sub __unpack_u64 {", |
452
|
|
|
|
|
|
|
" length \$_[0] == 8 or return undef;", # in case of no_length_check |
453
|
|
|
|
|
|
|
" my ( $hilo ) = unpack( \"L L\", \$_[0] );", |
454
|
|
|
|
|
|
|
" return \$lo if \$hi == 0;", |
455
|
|
|
|
|
|
|
" my \$n = Math::BigInt->new(\$hi); \$n <<= 32; \$n |= \$lo;", |
456
|
|
|
|
|
|
|
" return \$n;", |
457
|
|
|
|
|
|
|
"}", |
458
|
|
|
|
|
|
|
""; |
459
|
|
|
|
|
|
|
|
460
|
0
|
|
|
|
|
0
|
$done_u64++; |
461
|
|
|
|
|
|
|
} |
462
|
|
|
|
|
|
|
|
463
|
0
|
|
|
|
|
0
|
push @$postarg, " \$v[$argindex] = __pack_u64( \$v[$argindex] );"; |
464
|
0
|
|
|
|
|
0
|
push @$preret, " \$v[$argindex] = __unpack_u64( \$v[$argindex] );"; |
465
|
|
|
|
|
|
|
|
466
|
|
|
|
|
|
|
|
467
|
0
|
|
|
|
|
0
|
$format .= "a8"; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
else { |
470
|
0
|
|
|
|
|
0
|
die "Cannot find a pack format for size $size sign $sign"; |
471
|
|
|
|
|
|
|
} |
472
|
|
|
|
|
|
|
|
473
|
17
|
|
|
|
|
24
|
$_[1] += $size; |
474
|
17
|
|
|
|
|
529
|
return $format; |
475
|
|
|
|
|
|
|
}, |
476
|
18
|
|
|
|
|
291
|
}; |
477
|
|
|
|
|
|
|
} |
478
|
|
|
|
|
|
|
|
479
|
|
|
|
|
|
|
=item * member_strarray |
480
|
|
|
|
|
|
|
|
481
|
|
|
|
|
|
|
The field contains a NULL-padded string of characters. Its size will be |
482
|
|
|
|
|
|
|
automatically detected. |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
=cut |
485
|
|
|
|
|
|
|
|
486
|
|
|
|
|
|
|
sub member_strarray |
487
|
|
|
|
|
|
|
{ |
488
|
2
|
|
|
2
|
1
|
4
|
my $varname; |
489
|
|
|
|
|
|
|
my $membername; |
490
|
0
|
|
|
|
|
0
|
my $argindex; |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
return { |
493
|
2
|
|
|
2
|
|
3
|
set_names => sub { ( $varname, $membername ) = @_; }, |
494
|
2
|
|
|
2
|
|
5
|
set_arg => sub { $argindex = $_[0]++; }, |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
gen_c => sub { |
497
|
2
|
|
|
2
|
|
14
|
qq{printf("$membername@%ld+%lu,", } . |
498
|
|
|
|
|
|
|
"(long)((char*)&$varname.$membername-(char*)&$varname), " . # offset |
499
|
|
|
|
|
|
|
"(unsigned long)sizeof($varname.$membername)" . # size |
500
|
|
|
|
|
|
|
");"; |
501
|
|
|
|
|
|
|
}, |
502
|
|
|
|
|
|
|
gen_format => sub { |
503
|
2
|
|
|
2
|
|
5
|
my ( $def ) = @_; |
504
|
|
|
|
|
|
|
|
505
|
2
|
50
|
|
|
|
17
|
my ( $member, $offs, $size ) = $def =~ m/^([\w.]+)@(\d+)\+(\d+)$/ |
506
|
|
|
|
|
|
|
or die "Could not parse member definition out of '$def'"; |
507
|
|
|
|
|
|
|
|
508
|
2
|
50
|
|
|
|
7
|
$member eq $membername or die "Expected definition of $membername but found $member instead"; |
509
|
|
|
|
|
|
|
|
510
|
2
|
|
|
|
|
4
|
my $format = ""; |
511
|
2
|
50
|
|
|
|
11
|
if( $offs > $_[1] ) { |
|
|
50
|
|
|
|
|
|
512
|
0
|
|
|
|
|
0
|
my $pad = $offs - $_[1]; |
513
|
|
|
|
|
|
|
|
514
|
0
|
|
|
|
|
0
|
$format .= "x" x $pad; |
515
|
0
|
|
|
|
|
0
|
$_[1] += $pad; |
516
|
|
|
|
|
|
|
} |
517
|
|
|
|
|
|
|
elsif( $offs < $_[1] ) { |
518
|
0
|
|
|
|
|
0
|
die "Err.. need to go backwards for structure $varname member $member"; |
519
|
|
|
|
|
|
|
} |
520
|
|
|
|
|
|
|
|
521
|
2
|
|
|
|
|
5
|
$format .= "Z$size"; |
522
|
2
|
|
|
|
|
3
|
$_[1] += $size; |
523
|
|
|
|
|
|
|
|
524
|
2
|
|
|
|
|
46
|
return $format; |
525
|
|
|
|
|
|
|
}, |
526
|
2
|
|
|
|
|
36
|
}; |
527
|
|
|
|
|
|
|
} |
528
|
|
|
|
|
|
|
|
529
|
|
|
|
|
|
|
=item * member_constant($code) |
530
|
|
|
|
|
|
|
|
531
|
|
|
|
|
|
|
The field contains a single number as for C. Instead of |
532
|
|
|
|
|
|
|
consuming/returning a value in the arguments list, this member will be packed |
533
|
|
|
|
|
|
|
from an expression, or asserted that it contains the given value. The string |
534
|
|
|
|
|
|
|
C<$code> will be inserted into the generated pack and unpack functions, so it |
535
|
|
|
|
|
|
|
can be used for constants generated by the C directive. |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
=cut |
538
|
|
|
|
|
|
|
|
539
|
|
|
|
|
|
|
sub member_constant |
540
|
|
|
|
|
|
|
{ |
541
|
1
|
|
|
1
|
1
|
6
|
my $value = shift; |
542
|
|
|
|
|
|
|
|
543
|
1
|
|
|
|
|
2
|
my $constant = member_numeric; |
544
|
|
|
|
|
|
|
|
545
|
1
|
|
|
|
|
2
|
my $arg_index; |
546
|
1
|
|
|
1
|
|
4
|
$constant->{set_arg} = sub { $arg_index = $_[0] }; # no inc |
|
1
|
|
|
|
|
2
|
|
547
|
|
|
|
|
|
|
|
548
|
1
|
|
|
|
|
5
|
my $gen_format = delete $constant->{gen_format}; |
549
|
|
|
|
|
|
|
$constant->{gen_format} = sub { |
550
|
1
|
|
|
1
|
|
3
|
my ( $def, undef, $postarg, $preret ) = @_; |
551
|
|
|
|
|
|
|
|
552
|
1
|
50
|
|
|
|
16
|
my ( $member ) = $def =~ m/^([\w.]+)@/ |
553
|
|
|
|
|
|
|
or die "Could not parse member definition out of '$def'"; |
554
|
|
|
|
|
|
|
|
555
|
1
|
|
|
|
|
8
|
push @$postarg, " splice \@v, $arg_index, 0, $value;"; |
556
|
|
|
|
|
|
|
|
557
|
1
|
|
|
|
|
4
|
my $format = $gen_format->( @_ ); |
558
|
|
|
|
|
|
|
|
559
|
1
|
|
|
|
|
7
|
push @$preret, " splice( \@v, $arg_index, 1 ) == $value or croak \"expected $member == $value\";"; |
560
|
|
|
|
|
|
|
|
561
|
1
|
|
|
|
|
56
|
return $format; |
562
|
1
|
|
|
|
|
5
|
}; |
563
|
|
|
|
|
|
|
|
564
|
1
|
|
|
|
|
3
|
$constant; |
565
|
|
|
|
|
|
|
} |
566
|
|
|
|
|
|
|
|
567
|
|
|
|
|
|
|
=back |
568
|
|
|
|
|
|
|
|
569
|
|
|
|
|
|
|
The structure definition results in two new functions being created, |
570
|
|
|
|
|
|
|
C and C, where C<$name> is the name of the structure |
571
|
|
|
|
|
|
|
(with the leading C prefix stripped). These behave similarly to the |
572
|
|
|
|
|
|
|
familiar functions such as C; the C function will |
573
|
|
|
|
|
|
|
take a list of fields and return a packed string, the C function will |
574
|
|
|
|
|
|
|
take a string and return a list of fields. |
575
|
|
|
|
|
|
|
|
576
|
|
|
|
|
|
|
=cut |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
=head2 no_export, use_export, use_export_ok |
579
|
|
|
|
|
|
|
|
580
|
|
|
|
|
|
|
Controls the export behaviour of the generated symbols. C creates |
581
|
|
|
|
|
|
|
symbols that are not exported by their package, they must be used fully- |
582
|
|
|
|
|
|
|
qualified. C creates symbols that are exported by default. |
583
|
|
|
|
|
|
|
C creates symbols that are exported if they are specifically |
584
|
|
|
|
|
|
|
requested at C |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
The mode can be changed at any time to affect only the symbols that follow |
587
|
|
|
|
|
|
|
it. It defaults to C. |
588
|
|
|
|
|
|
|
|
589
|
|
|
|
|
|
|
=cut |
590
|
|
|
|
|
|
|
|
591
|
1
|
|
|
1
|
1
|
7
|
sub no_export { $export_mode = 0 } |
592
|
1
|
|
|
1
|
1
|
7
|
sub use_export { $export_mode = 1 } |
593
|
10
|
|
|
10
|
1
|
15
|
sub use_export_ok { $export_mode = "OK" } |
594
|
|
|
|
|
|
|
|
595
|
|
|
|
|
|
|
my $cbuilder = ExtUtils::CBuilder->new( quiet => 1 ); |
596
|
|
|
|
|
|
|
my %compile_args; |
597
|
|
|
|
|
|
|
my %link_args; |
598
|
|
|
|
|
|
|
|
599
|
|
|
|
|
|
|
if( my $mb = eval { require Module::Build and Module::Build->current } ) { |
600
|
|
|
|
|
|
|
$compile_args{include_dirs} = $mb->include_dirs; |
601
|
|
|
|
|
|
|
$compile_args{extra_compiler_flags} = $mb->extra_compiler_flags; |
602
|
|
|
|
|
|
|
|
603
|
|
|
|
|
|
|
$link_args{extra_linker_flags} = $mb->extra_linker_flags; |
604
|
|
|
|
|
|
|
} |
605
|
|
|
|
|
|
|
|
606
|
|
|
|
|
|
|
sub gen_perl |
607
|
|
|
|
|
|
|
{ |
608
|
18
|
50
|
|
18
|
0
|
51
|
return "" unless @fragments; |
609
|
|
|
|
|
|
|
|
610
|
18
|
|
|
|
|
87
|
my $c_file = join "\n", |
611
|
|
|
|
|
|
|
"#include ", |
612
|
|
|
|
|
|
|
@preamble, |
613
|
|
|
|
|
|
|
"", |
614
|
|
|
|
|
|
|
"int main(void) {", |
615
|
|
|
|
|
|
|
@fragments, |
616
|
|
|
|
|
|
|
" return 0;", |
617
|
|
|
|
|
|
|
"}\n"; |
618
|
|
|
|
|
|
|
|
619
|
18
|
|
|
|
|
47
|
undef @preamble; |
620
|
18
|
|
|
|
|
25
|
undef @fragments; |
621
|
|
|
|
|
|
|
|
622
|
18
|
50
|
|
|
|
43
|
die "Cannot generate a C file yet - no module name\n" unless defined $modulename; |
623
|
|
|
|
|
|
|
|
624
|
18
|
|
|
|
|
30
|
my $tempname = "gen-$modulename"; |
625
|
|
|
|
|
|
|
|
626
|
18
|
|
|
|
|
47
|
my $sourcename = "$tempname.c"; |
627
|
|
|
|
|
|
|
{ |
628
|
18
|
50
|
|
|
|
32
|
open( my $source_fh, "> $sourcename" ) or die "Cannot write $sourcename - $!"; |
|
18
|
|
|
|
|
1467
|
|
629
|
18
|
|
|
|
|
752
|
print $source_fh $c_file; |
630
|
|
|
|
|
|
|
} |
631
|
|
|
|
|
|
|
|
632
|
18
|
|
|
|
|
41
|
my $objname = eval { $cbuilder->compile( source => $sourcename, %compile_args ) }; |
|
18
|
|
|
|
|
281
|
|
633
|
|
|
|
|
|
|
|
634
|
18
|
|
|
|
|
604674
|
unlink $sourcename; |
635
|
|
|
|
|
|
|
|
636
|
18
|
50
|
|
|
|
146
|
if( !defined $objname ) { |
637
|
0
|
|
|
|
|
0
|
die "Failed to compile source\n"; |
638
|
|
|
|
|
|
|
} |
639
|
|
|
|
|
|
|
|
640
|
18
|
|
|
|
|
53
|
my $exename = eval { $cbuilder->link_executable( objects => $objname, %link_args ) }; |
|
18
|
|
|
|
|
697
|
|
641
|
|
|
|
|
|
|
|
642
|
18
|
|
|
|
|
405588
|
unlink $objname; |
643
|
|
|
|
|
|
|
|
644
|
18
|
50
|
|
|
|
134
|
if( !defined $exename ) { |
645
|
0
|
|
|
|
|
0
|
die "Failed to link executable\n"; |
646
|
|
|
|
|
|
|
} |
647
|
|
|
|
|
|
|
|
648
|
18
|
|
|
|
|
47
|
my $output; |
649
|
|
|
|
|
|
|
{ |
650
|
18
|
50
|
|
|
|
38
|
open( my $runh, "./$exename |" ) or die "Cannot pipeopen $exename - $!"; |
|
18
|
|
|
|
|
33230
|
|
651
|
|
|
|
|
|
|
|
652
|
18
|
|
|
|
|
227
|
local $/; |
653
|
18
|
|
|
|
|
6913
|
$output = <$runh>; |
654
|
|
|
|
|
|
|
} |
655
|
|
|
|
|
|
|
|
656
|
18
|
|
|
|
|
1044
|
unlink $exename; |
657
|
|
|
|
|
|
|
|
658
|
18
|
|
|
|
|
180
|
my %results = map { m/^(\w+)=(.*)$/ } split m/\n/, $output; |
|
17
|
|
|
|
|
258
|
|
659
|
|
|
|
|
|
|
|
660
|
18
|
|
|
|
|
59
|
my $perl = ""; |
661
|
|
|
|
|
|
|
|
662
|
18
|
|
|
|
|
27
|
my @bodylines; |
663
|
|
|
|
|
|
|
|
664
|
|
|
|
|
|
|
# Evaluate these first, so they have a chance to push_export() |
665
|
18
|
|
|
|
|
80
|
foreach my $genblock ( @genblocks ) { |
666
|
19
|
|
|
|
|
101
|
my ( $key, $code ) = @$genblock; |
667
|
|
|
|
|
|
|
|
668
|
19
|
|
|
|
|
118
|
push @bodylines, $code->( $results{$key} ); |
669
|
|
|
|
|
|
|
} |
670
|
|
|
|
|
|
|
|
671
|
18
|
50
|
|
|
|
57
|
if( @exports ) { |
672
|
0
|
|
|
|
|
0
|
$perl .= "push \@EXPORT, " . join( ", ", map { "'$_'" } @exports ) . ";\n"; |
|
0
|
|
|
|
|
0
|
|
673
|
0
|
|
|
|
|
0
|
undef @exports; |
674
|
|
|
|
|
|
|
} |
675
|
|
|
|
|
|
|
|
676
|
18
|
100
|
|
|
|
46
|
if( @exports_ok ) { |
677
|
13
|
|
|
|
|
21
|
$perl .= "push \@EXPORT_OK, " . join( ", ", map { "'$_'" } @exports_ok ) . ";\n"; |
|
23
|
|
|
|
|
79
|
|
678
|
13
|
|
|
|
|
59
|
undef @exports_ok; |
679
|
|
|
|
|
|
|
} |
680
|
|
|
|
|
|
|
|
681
|
18
|
|
|
|
|
52
|
$perl .= join "", map { "$_\n" } @bodylines; |
|
17
|
|
|
|
|
63
|
|
682
|
|
|
|
|
|
|
|
683
|
18
|
|
|
|
|
303
|
undef @genblocks; |
684
|
|
|
|
|
|
|
|
685
|
18
|
|
|
|
|
36
|
my @thisperlcode = @perlcode; |
686
|
18
|
|
|
|
|
32
|
undef @perlcode; |
687
|
|
|
|
|
|
|
|
688
|
18
|
|
|
|
|
155
|
return join "\n", @thisperlcode, $perl; |
689
|
|
|
|
|
|
|
} |
690
|
|
|
|
|
|
|
|
691
|
|
|
|
|
|
|
=head2 $perl = gen_output |
692
|
|
|
|
|
|
|
|
693
|
|
|
|
|
|
|
Returns the generated perl code. This is used internally for testing purposes |
694
|
|
|
|
|
|
|
but normally would not be necessary; see instead C. |
695
|
|
|
|
|
|
|
|
696
|
|
|
|
|
|
|
=cut |
697
|
|
|
|
|
|
|
|
698
|
|
|
|
|
|
|
sub gen_output |
699
|
|
|
|
|
|
|
{ |
700
|
18
|
|
|
18
|
1
|
102
|
my $ret = $output . gen_perl . "\n1;\n"; |
701
|
18
|
|
|
|
|
44
|
$output = ""; |
702
|
|
|
|
|
|
|
|
703
|
18
|
|
|
|
|
116
|
return $ret; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=head2 write_output $filename |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Write the generated perl code into the named file. This would normally be used |
709
|
|
|
|
|
|
|
as the last function in the containing script, to generate the output file. In |
710
|
|
|
|
|
|
|
the case of C or C invoking the script, |
711
|
|
|
|
|
|
|
the path to the file to be generated should be given in C<$ARGV[0]>. Normally, |
712
|
|
|
|
|
|
|
therefore, the script would end with |
713
|
|
|
|
|
|
|
|
714
|
|
|
|
|
|
|
write_output $ARGV[0]; |
715
|
|
|
|
|
|
|
|
716
|
|
|
|
|
|
|
=cut |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
sub write_output |
719
|
|
|
|
|
|
|
{ |
720
|
0
|
|
|
0
|
1
|
0
|
my ( $filename ) = @_; |
721
|
|
|
|
|
|
|
|
722
|
0
|
|
|
|
|
0
|
my $output = gen_output(); |
723
|
|
|
|
|
|
|
|
724
|
0
|
0
|
|
|
|
0
|
open( my $outfile, ">", $filename ) or die "Cannot write '$filename' - $!"; |
725
|
|
|
|
|
|
|
|
726
|
0
|
|
|
|
|
0
|
print $outfile $output; |
727
|
|
|
|
|
|
|
} |
728
|
|
|
|
|
|
|
|
729
|
|
|
|
|
|
|
=head2 include_path |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
Adds an include path to the list of paths used by the compiler |
732
|
|
|
|
|
|
|
|
733
|
|
|
|
|
|
|
include_path $path |
734
|
|
|
|
|
|
|
|
735
|
|
|
|
|
|
|
=cut |
736
|
|
|
|
|
|
|
|
737
|
|
|
|
|
|
|
sub include_path |
738
|
|
|
|
|
|
|
{ |
739
|
1
|
|
|
1
|
1
|
5
|
my ( $path ) = @_; |
740
|
|
|
|
|
|
|
|
741
|
1
|
|
|
|
|
2
|
push @{ $compile_args{include_dirs} }, $path; |
|
1
|
|
|
|
|
4
|
|
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
|
|
|
|
|
|
=head2 define |
745
|
|
|
|
|
|
|
|
746
|
|
|
|
|
|
|
Adds a symbol to be defined on the compiler's commandline, by using the C<-D> |
747
|
|
|
|
|
|
|
option. This is sometimes required to turn on particular optional parts of the |
748
|
|
|
|
|
|
|
included files. An optional value can also be specified. |
749
|
|
|
|
|
|
|
|
750
|
|
|
|
|
|
|
define $symbol |
751
|
|
|
|
|
|
|
define $symbol, $value; |
752
|
|
|
|
|
|
|
|
753
|
|
|
|
|
|
|
=cut |
754
|
|
|
|
|
|
|
|
755
|
|
|
|
|
|
|
sub define |
756
|
|
|
|
|
|
|
{ |
757
|
1
|
|
|
1
|
1
|
5
|
my ( $symbol, $value ) = @_; |
758
|
|
|
|
|
|
|
|
759
|
1
|
50
|
|
|
|
2
|
if( defined $value ) { |
760
|
1
|
|
|
|
|
2
|
push @{ $compile_args{extra_compiler_flags} }, "-D$symbol=$value"; |
|
1
|
|
|
|
|
5
|
|
761
|
|
|
|
|
|
|
} |
762
|
|
|
|
|
|
|
else { |
763
|
0
|
|
|
|
|
|
push @{ $compile_args{extra_compiler_flags} }, "-D$symbol"; |
|
0
|
|
|
|
|
|
|
764
|
|
|
|
|
|
|
} |
765
|
|
|
|
|
|
|
} |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
=head1 EXAMPLES |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
Normally this module would be used by another module at build time, to |
770
|
|
|
|
|
|
|
construct the relevant constants and structure functions from system headers. |
771
|
|
|
|
|
|
|
|
772
|
|
|
|
|
|
|
For example, suppose your operating system defines a new type of socket, which |
773
|
|
|
|
|
|
|
has its own packet and address families, and perhaps some new socket options |
774
|
|
|
|
|
|
|
which are valid on this socket. We can build a module to contain the relevant |
775
|
|
|
|
|
|
|
constants and structure functions by writing, for example: |
776
|
|
|
|
|
|
|
|
777
|
|
|
|
|
|
|
#!/usr/bin/perl |
778
|
|
|
|
|
|
|
|
779
|
|
|
|
|
|
|
use ExtUtils::H2PM; |
780
|
|
|
|
|
|
|
|
781
|
|
|
|
|
|
|
module "Socket::Moonlaser"; |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
include "moon/laser.h"; |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
constant "AF_MOONLASER"; |
786
|
|
|
|
|
|
|
constant "PF_MOONLASER"; |
787
|
|
|
|
|
|
|
|
788
|
|
|
|
|
|
|
constant "SOL_MOONLASER"; |
789
|
|
|
|
|
|
|
|
790
|
|
|
|
|
|
|
constant "MOONLASER_POWER", name => "POWER"; |
791
|
|
|
|
|
|
|
constant "MOONLASER_WAVELENGTH", name => "WAVELENGTH"; |
792
|
|
|
|
|
|
|
|
793
|
|
|
|
|
|
|
structure "struct laserwl", |
794
|
|
|
|
|
|
|
members => [ |
795
|
|
|
|
|
|
|
lwl_nm_coarse => member_numeric, |
796
|
|
|
|
|
|
|
lwl_nm_fine => member_numeric, |
797
|
|
|
|
|
|
|
]; |
798
|
|
|
|
|
|
|
|
799
|
|
|
|
|
|
|
write_output $ARGV[0]; |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
If we save this script as, say, F, then when the |
802
|
|
|
|
|
|
|
distribution is built, the script will be used to generate the contents of the |
803
|
|
|
|
|
|
|
file F. Once installed, any other code can simply |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
use Socket::Moonlaser qw( AF_MOONLASER ); |
806
|
|
|
|
|
|
|
|
807
|
|
|
|
|
|
|
to import a constant. |
808
|
|
|
|
|
|
|
|
809
|
|
|
|
|
|
|
The method described above doesn't allow us any room to actually include other |
810
|
|
|
|
|
|
|
code in the module. Perhaps, as well as these simple constants, we'd like to |
811
|
|
|
|
|
|
|
include functions, documentation, etc... To allow this, name the script |
812
|
|
|
|
|
|
|
instead something like F, so that this is |
813
|
|
|
|
|
|
|
the name used for the generated output. The code can then be included in the |
814
|
|
|
|
|
|
|
actual F (which will just be a normal perl module) by |
815
|
|
|
|
|
|
|
|
816
|
|
|
|
|
|
|
package Socket::Moonlaser; |
817
|
|
|
|
|
|
|
|
818
|
|
|
|
|
|
|
use Socket::Moonlaser_const; |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
sub get_power |
821
|
|
|
|
|
|
|
{ |
822
|
|
|
|
|
|
|
getsockopt( $_[0], SOL_MOONLASER, POWER ); |
823
|
|
|
|
|
|
|
} |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
sub set_power |
826
|
|
|
|
|
|
|
{ |
827
|
|
|
|
|
|
|
setsockopt( $_[0], SOL_MOONLASER, POWER, $_[1] ); |
828
|
|
|
|
|
|
|
} |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
sub get_wavelength |
831
|
|
|
|
|
|
|
{ |
832
|
|
|
|
|
|
|
my $wl = getsockopt( $_[0], SOL_MOONLASER, WAVELENGTH ); |
833
|
|
|
|
|
|
|
defined $wl or return; |
834
|
|
|
|
|
|
|
unpack_laserwl( $wl ); |
835
|
|
|
|
|
|
|
} |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
sub set_wavelength |
838
|
|
|
|
|
|
|
{ |
839
|
|
|
|
|
|
|
my $wl = pack_laserwl( $_[1], $_[2] ); |
840
|
|
|
|
|
|
|
setsockopt( $_[0], SOL_MOONLASER, WAVELENGTH, $wl ); |
841
|
|
|
|
|
|
|
} |
842
|
|
|
|
|
|
|
|
843
|
|
|
|
|
|
|
1; |
844
|
|
|
|
|
|
|
|
845
|
|
|
|
|
|
|
Sometimes, the actual C structure layout may not exactly match the semantics |
846
|
|
|
|
|
|
|
we wish to present to perl modules using this extension wrapper. Socket |
847
|
|
|
|
|
|
|
address structures typically contain their address family as the first member, |
848
|
|
|
|
|
|
|
whereas this detail isn't exposed by, for example, the C and |
849
|
|
|
|
|
|
|
C functions. To cope with this case, the low-level structure |
850
|
|
|
|
|
|
|
packing and unpacking functions can be generated with a different name, and |
851
|
|
|
|
|
|
|
wrapped in higher-level functions in the main code. For example, in |
852
|
|
|
|
|
|
|
F: |
853
|
|
|
|
|
|
|
|
854
|
|
|
|
|
|
|
no_export; |
855
|
|
|
|
|
|
|
|
856
|
|
|
|
|
|
|
structure "struct sockaddr_ml", |
857
|
|
|
|
|
|
|
pack_func => "_pack_sockaddr_ml", |
858
|
|
|
|
|
|
|
unpack_func => "_unpack_sockaddr_ml", |
859
|
|
|
|
|
|
|
members => [ |
860
|
|
|
|
|
|
|
ml_family => member_numeric, |
861
|
|
|
|
|
|
|
ml_lat_deg => member_numeric, |
862
|
|
|
|
|
|
|
ml_long_deg => member_numeric, |
863
|
|
|
|
|
|
|
ml_lat_fine => member_numeric, |
864
|
|
|
|
|
|
|
ml_long_fine => member_numeric, |
865
|
|
|
|
|
|
|
]; |
866
|
|
|
|
|
|
|
|
867
|
|
|
|
|
|
|
This will generate a pack/unpack function pair taking or returning five |
868
|
|
|
|
|
|
|
arguments; these functions will not be exported. In our main F |
869
|
|
|
|
|
|
|
file we can wrap these to actually expose a different API: |
870
|
|
|
|
|
|
|
|
871
|
|
|
|
|
|
|
sub pack_sockaddr_ml |
872
|
|
|
|
|
|
|
{ |
873
|
|
|
|
|
|
|
@_ == 2 or croak "usage: pack_sockaddr_ml(lat, long)"; |
874
|
|
|
|
|
|
|
my ( $lat, $long ) = @_; |
875
|
|
|
|
|
|
|
|
876
|
|
|
|
|
|
|
return _pack_sockaddr_ml( AF_MOONLASER, int $lat, int $long, |
877
|
|
|
|
|
|
|
($lat - int $lat) * 1_000_000, ($long - int $long) * 1_000_000); |
878
|
|
|
|
|
|
|
} |
879
|
|
|
|
|
|
|
|
880
|
|
|
|
|
|
|
sub unpack_sockaddr_ml |
881
|
|
|
|
|
|
|
{ |
882
|
|
|
|
|
|
|
my ( $family, $lat, $long, $lat_fine, $long_fine ) = |
883
|
|
|
|
|
|
|
_unpack_sockaddr_ml( $_[0] ); |
884
|
|
|
|
|
|
|
|
885
|
|
|
|
|
|
|
$family == AF_MOONLASER or croak "expected family AF_MOONLASER"; |
886
|
|
|
|
|
|
|
|
887
|
|
|
|
|
|
|
return ( $lat + $lat_fine/1_000_000, $long + $long_fine/1_000_000 ); |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
Sometimes, a structure will contain members which are themselves structures. |
891
|
|
|
|
|
|
|
Suppose a different definition of the above address, which at the C layer is |
892
|
|
|
|
|
|
|
defined as |
893
|
|
|
|
|
|
|
|
894
|
|
|
|
|
|
|
struct angle |
895
|
|
|
|
|
|
|
{ |
896
|
|
|
|
|
|
|
short deg; |
897
|
|
|
|
|
|
|
unsigned long fine; |
898
|
|
|
|
|
|
|
}; |
899
|
|
|
|
|
|
|
|
900
|
|
|
|
|
|
|
struct sockaddr_ml |
901
|
|
|
|
|
|
|
{ |
902
|
|
|
|
|
|
|
short ml_family; |
903
|
|
|
|
|
|
|
struct angle ml_lat, ml_long; |
904
|
|
|
|
|
|
|
}; |
905
|
|
|
|
|
|
|
|
906
|
|
|
|
|
|
|
We can instead "flatten" this structure tree to obtain the five fields by |
907
|
|
|
|
|
|
|
naming the sub-members of the outer structure: |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
structure "struct sockaddr_ml", |
910
|
|
|
|
|
|
|
members => [ |
911
|
|
|
|
|
|
|
"ml_family" => member_numeric, |
912
|
|
|
|
|
|
|
"ml_lat.deg" => member_numeric, |
913
|
|
|
|
|
|
|
"ml_lat.fine" => member_numeric, |
914
|
|
|
|
|
|
|
"ml_long.deg" => member_numeric, |
915
|
|
|
|
|
|
|
"ml_long.fine" => member_numeric, |
916
|
|
|
|
|
|
|
]; |
917
|
|
|
|
|
|
|
|
918
|
|
|
|
|
|
|
=head1 TODO |
919
|
|
|
|
|
|
|
|
920
|
|
|
|
|
|
|
=over 4 |
921
|
|
|
|
|
|
|
|
922
|
|
|
|
|
|
|
=item * |
923
|
|
|
|
|
|
|
|
924
|
|
|
|
|
|
|
Consider more structure members. With strings comes the requirement to have |
925
|
|
|
|
|
|
|
members that store a size. This requires cross-referential members. And while |
926
|
|
|
|
|
|
|
we're at it it might be nice to have constant members; fill in constants |
927
|
|
|
|
|
|
|
without consuming arguments when packing, assert the right value on unpacking. |
928
|
|
|
|
|
|
|
|
929
|
|
|
|
|
|
|
=back |
930
|
|
|
|
|
|
|
|
931
|
|
|
|
|
|
|
=head1 AUTHOR |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
Paul Evans |
934
|
|
|
|
|
|
|
|
935
|
|
|
|
|
|
|
=cut |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
0x55AA; |