File Coverage

blib/lib/Linux/Perl/aio.pm
Criterion Covered Total %
statement 98 109 89.9
branch 15 24 62.5
condition 8 10 80.0
subroutine 22 22 100.0
pod 4 4 100.0
total 147 169 86.9


line stmt bran cond sub pod time code
1             package Linux::Perl::aio;
2              
3             =encoding utf-8
4              
5             =head1 NAME
6              
7             Linux:Perl::aio - asynchronous I/O
8              
9             =head1 SYNOPSIS
10              
11             #Platform-specific invocation uses e.g.:
12             # Linux::Perl::aio::x86_64->new(...)
13             # Linux::Perl::aio::Control::x86_64->new(...)
14              
15             my $aio = Linux::Perl::aio->new(16);
16              
17             my $ctrl = Linux::Perl::aio::Control->new(
18             $filehandle,
19             \$buffer,
20             lio_opcode => 'PREAD',
21             );
22              
23             #Multiple $ctrl objects can be submitted in a list.
24             $aio->submit($ctrl);
25              
26             my @events = $aio->getevents( $min, $max, $timeout );
27              
28             =head1 DESCRIPTION
29              
30             This module provides support for the kernel-level AIO interface.
31              
32             DESTROY handlers are provided for automatic reaping of unused
33             instances/contexts.
34              
35             This module is EXPERIMENTAL. For now only the C architecture
36             is supported; others may follow, though 32-bit architectures would
37             take a bit more work.
38              
39             =cut
40              
41 2     2   5005 use strict;
  2         19  
  2         122  
42 2     2   31 use warnings;
  2         19  
  2         143  
43              
44 2     2   1145 use Linux::Perl;
  2         4  
  2         107  
45 2     2   969 use Linux::Perl::EasyPack;
  2         5  
  2         65  
46 2     2   1013 use Linux::Perl::TimeSpec;
  2         6  
  2         60  
47              
48 2     2   14 use parent qw( Linux::Perl::Base::BitsTest );
  2         4  
  2         11  
49              
50             my ($io_event_keys_ar, $io_event_pack, $io_event_size);
51              
52             BEGIN {
53 2     2   213 my @_io_event_src = (
54             data => __PACKAGE__->_PACK_u64(),
55             obj => __PACKAGE__->_PACK_u64(),
56             res => __PACKAGE__->_PACK_i64(),
57             res2 => __PACKAGE__->_PACK_i64(),
58             );
59              
60 2         6 ($io_event_keys_ar, $io_event_pack) = Linux::Perl::EasyPack::split_pack_list(@_io_event_src);
61 2         1207 $io_event_size = length pack $io_event_pack;
62             }
63              
64             =head1 METHODS
65              
66             =head2 I->new( NR_EVENTS )
67              
68             Calls C with the referred number of events to create
69             an AIO context. An object of CLASS is returned.
70              
71             =cut
72              
73             sub new {
74 6     6 1 6542 my ( $class, $nr_events ) = @_;
75              
76 6 50       26 die "Need number of events!" if !$nr_events;
77              
78 6 100       60 if (!$class->can('NR_io_setup')) {
79 3         536 require Linux::Perl::ArchLoader;
80 3         13 $class = Linux::Perl::ArchLoader::get_arch_module($class);
81             }
82              
83 6         19 my $context = "\0" x 8;
84              
85 6         66 Linux::Perl::call( $class->NR_io_setup(), 0 + $nr_events, $context );
86              
87 6         41 $context = unpack $class->_PACK_u64(), $context;
88              
89 6         23 return bless \$context, $class;
90             }
91              
92             =head2 I->create_control( FILEHANDLE, BUFFER_SR, %OPTS )
93              
94             Returns an instance of the relevant L
95             subclass for your architecture.
96              
97             FILEHANDLE is a Perl filehandle object, and BUFFER_SR is a reference
98             to the buffer string. This buffer must be pre-initialized to at least
99             the needed/desired length.
100              
101             %OPTS is:
102              
103             =over
104              
105             =item * C: Required, one of: C, C, C,
106             C, C, C, C.
107              
108             =item * C: The byte offset in BUFFER_SR at which to start
109             the I/O operation. Defaults to 0.
110              
111             =item * C: The number of bytes on which to operate. This value
112             plus C must be less than the length of BUFFER_SR. Defaults
113             to length(BUFFER_SR) minus C.
114              
115             =item * C: Optional, an array reference of any or all of: C,
116             C, C, C, C. Not supported in all kernel versions;
117             in fact, support seems more the exception than the rule!
118             See the kernel documentation (e.g., C) for details on
119             what these flags mean and whether your system supports them.
120              
121             =item * C: Optional. See the kernel’s documentation.
122              
123             =item * C: Optional, an eventfd file descriptor
124             (i.e., unsigned integer) to receive updates when aio events are finished.
125             (See L for one way of making this work.)
126              
127             =back
128              
129             For more information, consult the definition and documentation
130             for struct C. (cf. F)
131              
132             =cut
133              
134             sub create_control {
135 12     12 1 8509 my $self = shift;
136              
137 12         68 return Linux::Perl::aio::Control->new(@_);
138             }
139              
140             =head2 $num = I->submit( CTRL1, CTRL2, .. )
141              
142             Calls C. Each CTRL* is an instance of
143             L and represets an I/O request.
144              
145             The return value is the number of control objects submitted.
146              
147             =cut
148              
149              
150             sub submit {
151 10     10 1 65 my ( $self, @control_objs ) = @_;
152              
153 10         26 my $ptrs = join( q<>, map { $_->pointer() } @control_objs );
  12         28  
154              
155 10         65 return Linux::Perl::call( $self->NR_io_submit(), 0 + $$self, 0 + @control_objs, $ptrs );
156             }
157              
158             =head2 @events = I->getevents( MIN, MAX, TIMEOUT )
159              
160             Calls C with the relevant minimum, maximum, and timeout
161             values. (TIMEOUT can be a float.)
162              
163             If more than one event is requested (i.e., MAX > 1), then list
164             context is required.
165              
166             The return is a list of hash references; each hash reference has the following
167             values as in the kernel C struct:
168              
169             =over
170              
171             =item * C
172              
173             =item * C (corresponds to the Control instance C)
174              
175             =item * C
176              
177             =item * C
178              
179             =back
180              
181             =cut
182              
183             sub getevents {
184 10     10 1 5867 my ( $self, $min_events, $max_events, $timeout ) = @_;
185              
186             #If they only asked for one, then allow scalar context.
187 10 100       37 if ($max_events > 1) {
188 2         1383 require Call::Context;
189 2         599 Call::Context::must_be_list();
190             }
191              
192 10 50       48 if (!$max_events) {
193 0         0 die '$max_events must be >0!';
194             }
195              
196 10         34 my $buf = "\0" x ( $max_events * $io_event_size );
197              
198 10         77 my $evts = Linux::Perl::call(
199             $self->NR_io_getevents(),
200             $$self,
201             0 + $min_events,
202             0 + $max_events,
203             $buf,
204             Linux::Perl::TimeSpec::from_float($timeout),
205             );
206              
207 10         22 my @events;
208 10         39 for my $idx ( 0 .. ( $evts - 1 ) ) {
209 12         58 my @data = unpack $io_event_pack, substr( $buf, $idx * $io_event_size, $io_event_size );
210 12         18 my %event;
211 12         55 @event{ @$io_event_keys_ar } = @data;
212 12         40 push @events, \%event;
213             }
214              
215 10 50       49 return wantarray ? @events : $events[0];
216             }
217              
218             sub DESTROY {
219 6     6   11216 my ($self) = @_;
220              
221 6         61 Linux::Perl::call( $self->NR_io_destroy(), 0 + $$self);
222              
223 6         147 return;
224             }
225              
226             #----------------------------------------------------------------------
227              
228             package Linux::Perl::aio::Control;
229              
230 2     2   15 use Linux::Perl::EasyPack;
  2         5  
  2         56  
231 2     2   1163 use Linux::Perl::Endian;
  2         5  
  2         79  
232              
233             =encoding utf-8
234              
235             =head1 NAME
236              
237             Linux::Perl::aio::Control
238              
239             =head1 SYNOPSIS
240              
241             my $ctrl = Linux::Perl::aio::Control->new(
242             $filehandle,
243             \$buffer,
244             lio_opcode => 'PREAD',
245             buffer_offset => 4,
246             nbytes => 2,
247             );
248              
249             =head1 DESCRIPTION
250              
251             This class encapsulates a kernel C struct, i.e., an I/O request.
252              
253             You should not instantiate it directly; instead, use
254             L’s C method.
255              
256             =cut
257              
258 2     2   12 use parent -norequire => 'Linux::Perl::Base::BitsTest';
  2         4  
  2         11  
259              
260 2     2   1110 use Linux::Perl::Pointer ();
  2         5  
  2         81  
261              
262             use constant {
263 2         507 _RWF_HIPRI => 1,
264             _RWF_DSYNC => 2,
265             _RWF_SYNC => 4,
266             _RWF_NOWAIT => 8,
267             _RWF_APPEND => 16,
268              
269             _IOCB_CMD_PREAD => 0,
270             _IOCB_CMD_PWRITE => 1,
271             _IOCB_CMD_FSYNC => 2,
272             _IOCB_CMD_FDSYNC => 3,
273              
274             #experimental
275             #_IOCB_CMD_PREADX => 4,
276             #_IOCB_CMD_POLL => 5,
277              
278             _IOCB_CMD_NOOP => 6,
279             _IOCB_CMD_PREADV => 7,
280             _IOCB_CMD_PWRITEV => 8,
281              
282             _IOCB_FLAG_RESFD => 1,
283 2     2   13 };
  2         5  
284              
285             my ($iocb_keys_ar, $iocb_pack);
286              
287             BEGIN {
288 2     2   25 my @_iocb_src = (
289             data => __PACKAGE__->_PACK_u64(), #aio_data
290              
291             (
292             Linux::Perl::Endian::SYSTEM_IS_BIG_ENDIAN()
293             ? (
294             rw_flags => 'L',
295             key => 'L',
296             )
297             : (
298             key => 'L',
299             rw_flags => 'L',
300             )
301             ),
302              
303             lio_opcode => 'S',
304             reqprio => 's',
305             fildes => 'L',
306              
307             #Would be a P, but we grab the P and do some byte arithmetic on it
308             #for the case of a buffer_offset.
309             buf => __PACKAGE__->_PACK_u64(),
310              
311             nbytes => __PACKAGE__->_PACK_u64(),
312              
313             offset => __PACKAGE__->_PACK_i64(),
314              
315             reserved2 => 'x8',
316              
317             flags => 'L',
318             resfd => 'L',
319             );
320              
321 2         8 ($iocb_keys_ar, $iocb_pack) = Linux::Perl::EasyPack::split_pack_list(@_iocb_src);
322             }
323              
324             =head1 METHODS
325              
326             =head2 I->new( FILEHANDLE, BUFFER_SR, %OPTS )
327              
328             =cut
329              
330             sub new {
331 12     12   60 my ( $class, $fh, $buf_sr, %args ) = @_;
332              
333 12 50       47 my $opcode = $args{'lio_opcode'} or do {
334 0         0 die "Need “lio_opcode”!";
335             };
336              
337 12 50       123 my $opcode_cr = $class->can("_IOCB_CMD_$opcode") or do {
338 0         0 die "Unknown “lio_opcode” ($opcode)";
339             };
340              
341 12         27 my %opts;
342 12         39 @opts{'nbytes', 'buffer_offset'} = @args{'nbytes', 'buffer_offset'};
343              
344 12         34 $opts{'lio_opcode'} = 0 + $opcode_cr->();
345 12         30 $opts{'fildes'} = fileno $fh;
346 12         39 $opts{'reserved2'} = 0;
347 12         28 $opts{'reqprio'} = $args{'reqprio'};
348              
349 12 50       74 if ($args{'rw_flags'}) {
350 0         0 my $flag = 0;
351 0         0 for my $flag_name ( @{ $args{'rw_flags'} } ) {
  0         0  
352 0 0       0 my $num = $class->can("_RWF_$flag_name") or do {
353 0         0 die "Unknown -rw_flags- value ($flag_name)";
354             };
355 0         0 $flag |= 0 + $num->();
356             }
357              
358 0         0 $opts{'rw_flags'} = $flag;
359             }
360              
361 12 100       35 if (defined $args{'eventfd'}) {
362 4         6 $opts{'flags'} = _IOCB_FLAG_RESFD;
363 4         10 $opts{'resfd'} = $args{'eventfd'};
364             }
365              
366 12         38 my $buf_ptr = Linux::Perl::Pointer::get_address($$buf_sr);
367              
368 12   100     50 my $buffer_offset = $opts{'buffer_offset'} || 0;
369              
370 12 100       31 if ( $opts{'buffer_offset'} ) {
371 4   66     25 $opts{'nbytes'} ||= length($$buf_sr) - $opts{'buffer_offset'};
372              
373 4         11 $buf_ptr += $opts{'buffer_offset'};
374             }
375             else {
376 8   66     32 $opts{'nbytes'} ||= length $$buf_sr;
377             }
378              
379 12 50       33 if ( $opts{'nbytes'} + $buffer_offset > length $$buf_sr ) {
380 0         0 die sprintf( "nbytes($opts{'nbytes'}) + buffer_offset($buffer_offset) > buffer_length(%d)", length $$buf_sr );
381             }
382              
383 12         25 $opts{'buf'} = $buf_ptr;
384              
385 12   100     210 $_ ||= 0 for @opts{ @$iocb_keys_ar };
386              
387 12         83 my $packed = pack $iocb_pack, @opts{ @$iocb_keys_ar };
388 12         25 my $ptr = pack 'P', $packed;
389              
390             #We need $packed not to be garbage-collected.
391 12         90 return bless [ \$packed, $buf_sr, $ptr, unpack( Linux::Perl::Pointer::UNPACK_TMPL(), $ptr) ], $class;
392             }
393              
394             =head2 $sref = I->buffer_sr()
395              
396             Returns the string buffer reference given originally to C.
397              
398             =cut
399              
400 4     4   38583 sub buffer_sr { return $_[0][1] }
401              
402             =head2 $sref = I->pointer()
403              
404             Returns the internal C’s memory address as an octet string.
405              
406             =cut
407              
408 12     12   57 sub pointer { return $_[0][2] }
409              
410             =head2 $sref = I->id()
411              
412             Returns the internal C’s ID.
413              
414             =cut
415              
416 6     6   124 sub id { return $_[0][3] }
417              
418             1;