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-2011 -- leonerd@leonerd.org.uk |
5
|
|
|
|
|
|
|
|
6
|
|
|
|
|
|
|
package IO::Socket::Netlink; |
7
|
|
|
|
|
|
|
|
8
|
8
|
|
|
8
|
|
73707
|
use strict; |
|
8
|
|
|
|
|
18
|
|
|
8
|
|
|
|
|
260
|
|
9
|
8
|
|
|
8
|
|
39
|
use warnings; |
|
8
|
|
|
|
|
14
|
|
|
8
|
|
|
|
|
213
|
|
10
|
8
|
|
|
8
|
|
42
|
use base qw( IO::Socket ); |
|
8
|
|
|
|
|
12
|
|
|
8
|
|
|
|
|
8344
|
|
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
our $VERSION = '0.04'; |
13
|
|
|
|
|
|
|
|
14
|
8
|
|
|
8
|
|
228829
|
use Carp; |
|
8
|
|
|
|
|
51
|
|
|
8
|
|
|
|
|
446
|
|
15
|
|
|
|
|
|
|
|
16
|
8
|
|
|
8
|
|
45
|
use Socket qw( SOCK_RAW ); |
|
8
|
|
|
|
|
17
|
|
|
8
|
|
|
|
|
1929
|
|
17
|
|
|
|
|
|
|
|
18
|
8
|
|
|
|
|
7755
|
use Socket::Netlink qw( |
19
|
|
|
|
|
|
|
PF_NETLINK AF_NETLINK |
20
|
|
|
|
|
|
|
NLMSG_NOOP NLMSG_DONE NLMSG_ERROR |
21
|
|
|
|
|
|
|
NLM_F_REQUEST NLM_F_MULTI |
22
|
|
|
|
|
|
|
pack_sockaddr_nl unpack_sockaddr_nl |
23
|
8
|
|
|
8
|
|
3390
|
); |
|
8
|
|
|
|
|
27
|
|
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
__PACKAGE__->register_domain( AF_NETLINK ); |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
=head1 NAME |
28
|
|
|
|
|
|
|
|
29
|
|
|
|
|
|
|
C - Object interface to C domain sockets |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
=head1 SYNOPSIS |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
use Socket::Netlink; |
34
|
|
|
|
|
|
|
use IO::Socket::Netlink; |
35
|
|
|
|
|
|
|
|
36
|
|
|
|
|
|
|
my $sock = IO::Socket::Netlink->new( Protocol => 0 ) or die "socket: $!"; |
37
|
|
|
|
|
|
|
|
38
|
|
|
|
|
|
|
$sock->send_nlmsg( $sock->new_request( |
39
|
|
|
|
|
|
|
nlmsg_type => 18, |
40
|
|
|
|
|
|
|
nlmsg_flags => NLM_F_DUMP, |
41
|
|
|
|
|
|
|
nlmsg => "\0\0\0\0\0\0\0\0", |
42
|
|
|
|
|
|
|
) ) or die "send: $!"; |
43
|
|
|
|
|
|
|
|
44
|
|
|
|
|
|
|
$sock->recv_nlmsg( my $message, 65536 ) or die "recv: $!"; |
45
|
|
|
|
|
|
|
|
46
|
|
|
|
|
|
|
printf "Received type=%d flags=%x:\n%v02x\n", |
47
|
|
|
|
|
|
|
$message->nlmsg_type, $message->nlmsg_flags, $message->nlmsg; |
48
|
|
|
|
|
|
|
|
49
|
|
|
|
|
|
|
=head1 DESCRIPTION |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
This module provides an object interface to C sockets on Linux, by |
52
|
|
|
|
|
|
|
building on top of the L class. While useful on its own, it is |
53
|
|
|
|
|
|
|
intended itself to serve as a base class, for particular netlink protocols to |
54
|
|
|
|
|
|
|
extend. |
55
|
|
|
|
|
|
|
|
56
|
|
|
|
|
|
|
=cut |
57
|
|
|
|
|
|
|
|
58
|
|
|
|
|
|
|
=head1 CLASS METHODS |
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
=head2 $class->register_protocol( $proto ) |
61
|
|
|
|
|
|
|
|
62
|
|
|
|
|
|
|
May be called by a subclass implementing a Netlink protocol. If so, then any |
63
|
|
|
|
|
|
|
object constructed using a known protocol on this base class will be |
64
|
|
|
|
|
|
|
automatically reblessed into the appropriate package. |
65
|
|
|
|
|
|
|
|
66
|
|
|
|
|
|
|
=cut |
67
|
|
|
|
|
|
|
|
68
|
|
|
|
|
|
|
my %protocol2pkg; |
69
|
|
|
|
|
|
|
|
70
|
|
|
|
|
|
|
sub register_protocol |
71
|
|
|
|
|
|
|
{ |
72
|
3
|
|
|
3
|
1
|
25
|
my ( $pkg, $proto ) = @_; |
73
|
3
|
|
|
|
|
12
|
$protocol2pkg{$proto} = $pkg; |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
=head1 CONSTRUCTOR |
77
|
|
|
|
|
|
|
|
78
|
|
|
|
|
|
|
=cut |
79
|
|
|
|
|
|
|
|
80
|
|
|
|
|
|
|
=head2 $sock = IO::Socket::Netlink->new( %args ) |
81
|
|
|
|
|
|
|
|
82
|
|
|
|
|
|
|
Creates a new C object. |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
The recognised arguments are: |
85
|
|
|
|
|
|
|
|
86
|
|
|
|
|
|
|
=over 8 |
87
|
|
|
|
|
|
|
|
88
|
|
|
|
|
|
|
=item Protocol => INT |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
The netlink protocol. This is a required argument. |
91
|
|
|
|
|
|
|
|
92
|
|
|
|
|
|
|
=item Pid => INT |
93
|
|
|
|
|
|
|
|
94
|
|
|
|
|
|
|
Socket identifier (usually the process identifier) |
95
|
|
|
|
|
|
|
|
96
|
|
|
|
|
|
|
=item Groups => INT |
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
32bit bitmask of multicast groups to join |
99
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
=back |
101
|
|
|
|
|
|
|
|
102
|
|
|
|
|
|
|
=cut |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
sub new |
105
|
|
|
|
|
|
|
{ |
106
|
7
|
|
|
7
|
1
|
88
|
my $class = shift; |
107
|
7
|
|
|
|
|
123
|
$class->SUPER::new( Domain => PF_NETLINK, @_ ); |
108
|
|
|
|
|
|
|
} |
109
|
|
|
|
|
|
|
|
110
|
|
|
|
|
|
|
sub configure |
111
|
|
|
|
|
|
|
{ |
112
|
7
|
|
|
7
|
0
|
7487
|
my $self = shift; |
113
|
7
|
|
|
|
|
18
|
my ( $arg ) = @_; |
114
|
|
|
|
|
|
|
|
115
|
7
|
|
50
|
|
|
60
|
my $type = $arg->{Type} || SOCK_RAW; |
116
|
|
|
|
|
|
|
|
117
|
7
|
50
|
|
|
|
32
|
if( !exists $arg->{Protocol} ) { |
118
|
0
|
|
|
|
|
0
|
croak "Require a Protocol for a Netlink socket"; |
119
|
|
|
|
|
|
|
} |
120
|
|
|
|
|
|
|
|
121
|
7
|
50
|
|
|
|
69
|
$self->socket( AF_NETLINK, $type, $arg->{Protocol} ) or return undef; |
122
|
|
|
|
|
|
|
|
123
|
7
|
50
|
50
|
|
|
658
|
$self->bind( pack_sockaddr_nl( $arg->{Pid} || 0, $arg->{Groups} || 0 ) ) or return undef; |
|
|
|
50
|
|
|
|
|
124
|
|
|
|
|
|
|
|
125
|
7
|
100
|
|
|
|
173
|
if( ref($self) eq __PACKAGE__ ) { |
126
|
3
|
100
|
|
|
|
30
|
my $class = $protocol2pkg{$arg->{Protocol}} or return $self; |
127
|
1
|
|
|
|
|
2
|
bless $self, $class; |
128
|
|
|
|
|
|
|
|
129
|
1
|
|
|
|
|
6
|
return $self->configure( $arg ); |
130
|
|
|
|
|
|
|
} |
131
|
|
|
|
|
|
|
else { |
132
|
4
|
|
|
|
|
16
|
return $self; |
133
|
|
|
|
|
|
|
} |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
|
136
|
|
|
|
|
|
|
=head1 METHODS |
137
|
|
|
|
|
|
|
|
138
|
|
|
|
|
|
|
=cut |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
=head2 $pid = $sock->sockpid |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
Returns the socket identifier |
143
|
|
|
|
|
|
|
|
144
|
|
|
|
|
|
|
=cut |
145
|
|
|
|
|
|
|
|
146
|
|
|
|
|
|
|
sub sockpid |
147
|
|
|
|
|
|
|
{ |
148
|
1
|
|
|
1
|
1
|
2574
|
my $self = shift; |
149
|
1
|
|
|
|
|
9
|
( unpack_sockaddr_nl( $self->sockname ) )[0]; |
150
|
|
|
|
|
|
|
} |
151
|
|
|
|
|
|
|
|
152
|
|
|
|
|
|
|
=head2 $groups = $sock->sockgroups |
153
|
|
|
|
|
|
|
|
154
|
|
|
|
|
|
|
Returns the 32bit bitmask of multicast groups |
155
|
|
|
|
|
|
|
|
156
|
|
|
|
|
|
|
=cut |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
sub sockgroups |
159
|
|
|
|
|
|
|
{ |
160
|
1
|
|
|
1
|
1
|
495
|
my $self = shift; |
161
|
1
|
|
|
|
|
5
|
( unpack_sockaddr_nl( $self->sockname ) )[1]; |
162
|
|
|
|
|
|
|
} |
163
|
|
|
|
|
|
|
|
164
|
|
|
|
|
|
|
# It is intended subclasses override this |
165
|
|
|
|
|
|
|
sub message_class |
166
|
|
|
|
|
|
|
{ |
167
|
6
|
|
|
6
|
0
|
45
|
return "IO::Socket::Netlink::_Message"; |
168
|
|
|
|
|
|
|
} |
169
|
|
|
|
|
|
|
|
170
|
|
|
|
|
|
|
# And possibly this |
171
|
|
|
|
|
|
|
sub command_class |
172
|
|
|
|
|
|
|
{ |
173
|
0
|
|
|
0
|
0
|
0
|
return shift->message_class; |
174
|
|
|
|
|
|
|
} |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
=head2 $msg = $sock->new_message( %args ) |
177
|
|
|
|
|
|
|
|
178
|
|
|
|
|
|
|
Returns a new message object containing the given arguments. The named |
179
|
|
|
|
|
|
|
arguments are in fact read as an list of key/value pairs, not a hash, so order |
180
|
|
|
|
|
|
|
is significant. The basic C keys should come first, followed by any |
181
|
|
|
|
|
|
|
required by the inner level header. |
182
|
|
|
|
|
|
|
|
183
|
|
|
|
|
|
|
For more detail, see the L section below. |
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
=cut |
186
|
|
|
|
|
|
|
|
187
|
|
|
|
|
|
|
sub new_message |
188
|
|
|
|
|
|
|
{ |
189
|
10
|
|
|
10
|
1
|
65
|
my $self = shift; |
190
|
10
|
|
|
|
|
49
|
return $self->message_class->new( @_ ); |
191
|
|
|
|
|
|
|
} |
192
|
|
|
|
|
|
|
|
193
|
|
|
|
|
|
|
=head2 $msg = $sock->new_request( %args ) |
194
|
|
|
|
|
|
|
|
195
|
|
|
|
|
|
|
A convenience wrapper around C which sets the C |
196
|
|
|
|
|
|
|
flag on the returned message. |
197
|
|
|
|
|
|
|
|
198
|
|
|
|
|
|
|
=cut |
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
sub new_request |
201
|
|
|
|
|
|
|
{ |
202
|
3
|
|
|
3
|
1
|
6
|
my $self = shift; |
203
|
3
|
|
|
|
|
13
|
my $message = $self->new_message( @_ ); |
204
|
3
|
|
50
|
|
|
15
|
$message->nlmsg_flags( ($message->nlmsg_flags||0) | NLM_F_REQUEST ); |
205
|
3
|
|
|
|
|
16
|
return $message; |
206
|
|
|
|
|
|
|
} |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
=head2 $sock->new_command( %args ) |
209
|
|
|
|
|
|
|
|
210
|
|
|
|
|
|
|
As C, but may use a different class for messages. This is for |
211
|
|
|
|
|
|
|
such netlink protocols as C, which uses a different set of message |
212
|
|
|
|
|
|
|
attributes for userland-to-kernel commands, as for kernel-to-userland event |
213
|
|
|
|
|
|
|
messages. |
214
|
|
|
|
|
|
|
|
215
|
|
|
|
|
|
|
=cut |
216
|
|
|
|
|
|
|
|
217
|
|
|
|
|
|
|
sub new_command |
218
|
|
|
|
|
|
|
{ |
219
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
220
|
0
|
|
|
|
|
0
|
my $message = $self->command_class->new( @_ ); |
221
|
0
|
|
0
|
|
|
0
|
$message->nlmsg_flags( ($message->nlmsg_flags||0) | NLM_F_REQUEST ); |
222
|
0
|
|
|
|
|
0
|
return $message; |
223
|
|
|
|
|
|
|
} |
224
|
|
|
|
|
|
|
|
225
|
|
|
|
|
|
|
# undoc'ed for now |
226
|
|
|
|
|
|
|
sub unpack_message |
227
|
|
|
|
|
|
|
{ |
228
|
7
|
|
|
7
|
0
|
3204
|
my $self = shift; |
229
|
7
|
|
|
|
|
31
|
return $self->message_class->unpack( @_ ); |
230
|
|
|
|
|
|
|
} |
231
|
|
|
|
|
|
|
|
232
|
|
|
|
|
|
|
=head2 $sock->send_nlmsg( $message ) |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
Sends the given message object to the kernel. C<$message> should be a message |
235
|
|
|
|
|
|
|
object, constructed using the socket's C factory method. |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
=cut |
238
|
|
|
|
|
|
|
|
239
|
|
|
|
|
|
|
sub send_nlmsg |
240
|
|
|
|
|
|
|
{ |
241
|
2
|
|
|
2
|
1
|
3
|
my $self = shift; |
242
|
2
|
|
|
|
|
5
|
my ( $message ) = @_; |
243
|
|
|
|
|
|
|
|
244
|
2
|
|
|
|
|
10
|
$self->send( $message->pack ); |
245
|
|
|
|
|
|
|
} |
246
|
|
|
|
|
|
|
|
247
|
|
|
|
|
|
|
=head2 $sock->recv_nlmsg( $message, $maxlen ) |
248
|
|
|
|
|
|
|
|
249
|
|
|
|
|
|
|
Receives a single message from the kernel. The C<$message> parameter should be |
250
|
|
|
|
|
|
|
a variable, which will contain the new message object when this method returns |
251
|
|
|
|
|
|
|
successfully. |
252
|
|
|
|
|
|
|
|
253
|
|
|
|
|
|
|
Sometimes the kernel will respond multiple messages in reply to just one. If |
254
|
|
|
|
|
|
|
this may be the case, see instead C. |
255
|
|
|
|
|
|
|
|
256
|
|
|
|
|
|
|
This method returns success or failure depending only on the result of the |
257
|
|
|
|
|
|
|
underlying socket C call. If a message was successfully received it |
258
|
|
|
|
|
|
|
returns true, even if that message contains an error. To detect the error, see |
259
|
|
|
|
|
|
|
the C accessor. |
260
|
|
|
|
|
|
|
|
261
|
|
|
|
|
|
|
=cut |
262
|
|
|
|
|
|
|
|
263
|
|
|
|
|
|
|
sub recv_nlmsg |
264
|
|
|
|
|
|
|
{ |
265
|
2
|
|
|
2
|
1
|
5
|
my $self = shift; |
266
|
2
|
|
|
|
|
6
|
my ( undef, $maxlen ) = @_; |
267
|
|
|
|
|
|
|
# Holes in @_ because we'll unpack to here |
268
|
|
|
|
|
|
|
|
269
|
2
|
|
|
|
|
3
|
my $ret; |
270
|
|
|
|
|
|
|
|
271
|
2
|
|
|
|
|
5
|
do { |
272
|
2
|
|
|
|
|
12
|
$ret = $self->recv( my $buffer, $maxlen ); |
273
|
2
|
50
|
|
|
|
58
|
defined $ret or return undef; |
274
|
|
|
|
|
|
|
|
275
|
2
|
|
|
|
|
18
|
$_[0] = $self->unpack_message( $buffer ); |
276
|
|
|
|
|
|
|
# Ignore NLMSG_NOOP and try again |
277
|
|
|
|
|
|
|
} while( $_[0]->nlmsg_type == NLMSG_NOOP ); |
278
|
|
|
|
|
|
|
|
279
|
2
|
|
|
|
|
10
|
return $ret; |
280
|
|
|
|
|
|
|
} |
281
|
|
|
|
|
|
|
|
282
|
|
|
|
|
|
|
=head2 $sock->recv_nlmsgs( \@messages, $maxlen ) |
283
|
|
|
|
|
|
|
|
284
|
|
|
|
|
|
|
Receives message from the kernel. If the first message received has the |
285
|
|
|
|
|
|
|
C flag, then messages will be collected up until the final |
286
|
|
|
|
|
|
|
C which indicates the end of the list. Each message is pushed |
287
|
|
|
|
|
|
|
into the C<@messages> array (which is I cleared initially), excluding |
288
|
|
|
|
|
|
|
the final C. |
289
|
|
|
|
|
|
|
|
290
|
|
|
|
|
|
|
This method returns success or failure depending only on the result of the |
291
|
|
|
|
|
|
|
underlying socket C call or calls. If any calls fails then the method |
292
|
|
|
|
|
|
|
will return false. If messages were successfully received it returns true, |
293
|
|
|
|
|
|
|
even if a message contains an error. To detect the error, see the |
294
|
|
|
|
|
|
|
C accessor. |
295
|
|
|
|
|
|
|
|
296
|
|
|
|
|
|
|
=cut |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
sub recv_nlmsgs |
299
|
|
|
|
|
|
|
{ |
300
|
0
|
|
|
0
|
1
|
0
|
my $self = shift; |
301
|
0
|
|
|
|
|
0
|
my ( $msgs, $maxlen ) = @_; |
302
|
|
|
|
|
|
|
|
303
|
0
|
|
|
|
|
0
|
my $buffer; |
304
|
|
|
|
|
|
|
my $message; |
305
|
|
|
|
|
|
|
|
306
|
0
|
|
|
|
|
0
|
do { |
307
|
0
|
0
|
|
|
|
0
|
defined $self->recv( $buffer, $maxlen ) or return; |
308
|
|
|
|
|
|
|
|
309
|
0
|
|
|
|
|
0
|
$message = $self->unpack_message( $buffer ); |
310
|
|
|
|
|
|
|
# Ignore NLMSG_NOOP and try again |
311
|
|
|
|
|
|
|
} while( $message->nlmsg_type == NLMSG_NOOP ); |
312
|
|
|
|
|
|
|
|
313
|
0
|
|
|
|
|
0
|
push @$msgs, $message; |
314
|
0
|
0
|
|
|
|
0
|
return scalar @$msgs unless $message->nlmsg_flags & NLM_F_MULTI; |
315
|
|
|
|
|
|
|
|
316
|
|
|
|
|
|
|
# We may still have to make more recv calls: |
317
|
0
|
|
|
|
|
0
|
while(1) { |
318
|
0
|
|
|
|
|
0
|
while( defined $buffer ) { |
319
|
0
|
|
|
|
|
0
|
$message = $self->message_class->unpack( $buffer ); |
320
|
|
|
|
|
|
|
|
321
|
0
|
0
|
|
|
|
0
|
return scalar @$msgs if $message->nlmsg_type == NLMSG_DONE; |
322
|
|
|
|
|
|
|
|
323
|
0
|
0
|
|
|
|
0
|
push @$msgs, $message if $message->nlmsg_type != NLMSG_NOOP; |
324
|
|
|
|
|
|
|
} |
325
|
|
|
|
|
|
|
|
326
|
0
|
0
|
|
|
|
0
|
defined $self->recv( $buffer, $maxlen ) or return; |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
} |
329
|
|
|
|
|
|
|
|
330
|
|
|
|
|
|
|
package IO::Socket::Netlink::_Message; |
331
|
|
|
|
|
|
|
|
332
|
8
|
|
|
8
|
|
54
|
use Carp; |
|
8
|
|
|
|
|
14
|
|
|
8
|
|
|
|
|
550
|
|
333
|
|
|
|
|
|
|
|
334
|
8
|
|
|
|
|
2574
|
use Socket::Netlink qw( |
335
|
|
|
|
|
|
|
:DEFAULT |
336
|
|
|
|
|
|
|
pack_nlmsghdr unpack_nlmsghdr pack_nlattrs unpack_nlattrs |
337
|
8
|
|
|
8
|
|
63
|
); |
|
8
|
|
|
|
|
17
|
|
338
|
|
|
|
|
|
|
|
339
|
|
|
|
|
|
|
# Don't hard-depend on Sub::Name since it's only a niceness for stack traces |
340
|
|
|
|
|
|
|
BEGIN { |
341
|
8
|
50
|
|
8
|
|
16
|
if( eval { require Sub::Name } ) { |
|
8
|
|
|
|
|
2977
|
|
342
|
0
|
|
|
|
|
0
|
*subname = \&Sub::Name::subname; |
343
|
|
|
|
|
|
|
} |
344
|
|
|
|
|
|
|
else { |
345
|
|
|
|
|
|
|
# Ignore the name, return the CODEref |
346
|
8
|
|
|
81
|
|
5314
|
*subname = sub { return $_[1] }; |
|
81
|
|
|
|
|
119
|
|
347
|
|
|
|
|
|
|
} |
348
|
|
|
|
|
|
|
} |
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
=head1 MESSAGE OBJECTS |
351
|
|
|
|
|
|
|
|
352
|
|
|
|
|
|
|
Netlink messages are passed in to C and returned by C |
353
|
|
|
|
|
|
|
and C in the form of objects, which wrap the protocol headers. |
354
|
|
|
|
|
|
|
These objects are not directly constructed; instead you should use the |
355
|
|
|
|
|
|
|
C method on the socket to build a new message to send. |
356
|
|
|
|
|
|
|
|
357
|
|
|
|
|
|
|
These objects exist also to wrap higher-level protocol fields, for messages in |
358
|
|
|
|
|
|
|
some particular netlink protocol. A subclass of C would |
359
|
|
|
|
|
|
|
likely use its own subclass of message object; extra fields may exist on these |
360
|
|
|
|
|
|
|
objects. |
361
|
|
|
|
|
|
|
|
362
|
|
|
|
|
|
|
The following accessors may be used to set or obtain the fields in the |
363
|
|
|
|
|
|
|
toplevel C structure: |
364
|
|
|
|
|
|
|
|
365
|
|
|
|
|
|
|
=cut |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
sub new |
368
|
|
|
|
|
|
|
{ |
369
|
17
|
|
|
17
|
|
55
|
my $class = shift; |
370
|
|
|
|
|
|
|
|
371
|
17
|
|
|
|
|
72
|
my $self = bless {}, $class; |
372
|
|
|
|
|
|
|
|
373
|
|
|
|
|
|
|
# Important that these happen in order |
374
|
17
|
|
|
|
|
81
|
for ( my $i=0; $i<@_; $i+=2 ) { |
375
|
50
|
|
|
|
|
78
|
my $method = $_[$i]; |
376
|
50
|
|
|
|
|
159
|
$self->$method( $_[$i+1] ); |
377
|
|
|
|
|
|
|
} |
378
|
|
|
|
|
|
|
|
379
|
17
|
|
|
|
|
89
|
return $self; |
380
|
|
|
|
|
|
|
} |
381
|
|
|
|
|
|
|
|
382
|
|
|
|
|
|
|
sub pack : method |
383
|
|
|
|
|
|
|
{ |
384
|
8
|
|
|
8
|
|
860
|
my $self = shift; |
385
|
|
|
|
|
|
|
|
386
|
8
|
|
100
|
|
|
37
|
return pack_nlmsghdr( |
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
387
|
|
|
|
|
|
|
$self->nlmsg_type || 0, |
388
|
|
|
|
|
|
|
$self->nlmsg_flags || 0, |
389
|
|
|
|
|
|
|
$self->nlmsg_seq || 0, |
390
|
|
|
|
|
|
|
$self->nlmsg_pid || 0, |
391
|
|
|
|
|
|
|
$self->nlmsg |
392
|
|
|
|
|
|
|
); |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
sub unpack : method |
396
|
|
|
|
|
|
|
{ |
397
|
7
|
|
|
7
|
|
51
|
my $class = shift; |
398
|
|
|
|
|
|
|
|
399
|
7
|
|
|
|
|
56
|
( my ( $type, $flags, $seq, $pid, $body ), $_[0] ) = unpack_nlmsghdr( $_[0] ); |
400
|
|
|
|
|
|
|
|
401
|
7
|
|
|
|
|
39
|
return $class->new( |
402
|
|
|
|
|
|
|
nlmsg_type => $type, |
403
|
|
|
|
|
|
|
nlmsg_flags => $flags, |
404
|
|
|
|
|
|
|
nlmsg_seq => $seq, |
405
|
|
|
|
|
|
|
nlmsg_pid => $pid, |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
nlmsg => $body, |
408
|
|
|
|
|
|
|
); |
409
|
|
|
|
|
|
|
} |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
=over 4 |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
=item * $message->nlmsg_type |
414
|
|
|
|
|
|
|
|
415
|
|
|
|
|
|
|
=item * $message->nlmsg_flags |
416
|
|
|
|
|
|
|
|
417
|
|
|
|
|
|
|
=item * $message->nlmsg_seq |
418
|
|
|
|
|
|
|
|
419
|
|
|
|
|
|
|
=item * $message->nlmsg_pid |
420
|
|
|
|
|
|
|
|
421
|
|
|
|
|
|
|
Set or obtain the fields in the C structure. |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
=item * $message->nlmsg |
424
|
|
|
|
|
|
|
|
425
|
|
|
|
|
|
|
Set or obtain the packed message body. This method is intended to be |
426
|
|
|
|
|
|
|
overridden by specific protocol implementations, to pack or unpack their own |
427
|
|
|
|
|
|
|
structure type. |
428
|
|
|
|
|
|
|
|
429
|
|
|
|
|
|
|
=back |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
Many Netlink-based protocols use standard message headers with attribute |
432
|
|
|
|
|
|
|
bodies. Messages may start with structure layouts containing standard fields, |
433
|
|
|
|
|
|
|
optionally followed by a sequence of one or more attributes in a standard |
434
|
|
|
|
|
|
|
format. Each attribute is an ID number and a value. |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
Because this class is intended to be subclassed by specific Netlink protocol |
437
|
|
|
|
|
|
|
implementations, a number of class methods exist to declare metadata about the |
438
|
|
|
|
|
|
|
protocol to assist generating the code required to support it. A message class |
439
|
|
|
|
|
|
|
can declare its header format, which defines what extra accessor fields will be |
440
|
|
|
|
|
|
|
created, and functions to pack and unpack the fields to or from the message |
441
|
|
|
|
|
|
|
body. It can also declare its mapping of attribute names, ID numbers, and data |
442
|
|
|
|
|
|
|
types. The message class will then support automatic encoding and decoding of |
443
|
|
|
|
|
|
|
named attributes to or from the buffer. |
444
|
|
|
|
|
|
|
|
445
|
|
|
|
|
|
|
=cut |
446
|
|
|
|
|
|
|
|
447
|
|
|
|
|
|
|
sub nlmsg_type |
448
|
|
|
|
|
|
|
{ |
449
|
32
|
|
|
32
|
|
2694
|
my $self = shift; |
450
|
32
|
100
|
|
|
|
331
|
$self->{nlmsg_type} = $_[0] if @_; |
451
|
32
|
100
|
100
|
|
|
142
|
if( @_ and $self->{nlmsg_type} == NLMSG_ERROR ) { |
452
|
2
|
|
|
|
|
8
|
bless $self, "IO::Socket::Netlink::_ErrorMessage"; |
453
|
|
|
|
|
|
|
} |
454
|
32
|
100
|
|
|
|
281
|
$self->{nlmsg_type} || 0; |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
__PACKAGE__->is_header( |
458
|
|
|
|
|
|
|
no_data => 1, |
459
|
|
|
|
|
|
|
fields => [ |
460
|
|
|
|
|
|
|
[ nlmsg_type => "decimal", no_accessor => 1 ], |
461
|
|
|
|
|
|
|
[ nlmsg_flags => "hex" ], |
462
|
|
|
|
|
|
|
[ nlmsg_seq => "decimal" ], |
463
|
|
|
|
|
|
|
[ nlmsg_pid => "decimal" ], |
464
|
|
|
|
|
|
|
[ nlmsg => "bytes" ], |
465
|
|
|
|
|
|
|
], |
466
|
|
|
|
|
|
|
); |
467
|
|
|
|
|
|
|
|
468
|
0
|
|
|
0
|
|
0
|
sub nlerr_error { 0 } |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
=head2 $messageclass->is_header( %args ) |
471
|
|
|
|
|
|
|
|
472
|
|
|
|
|
|
|
Called by a subclass of the message class, this class method declares that |
473
|
|
|
|
|
|
|
messages of this particular type contain a message header. The four required |
474
|
|
|
|
|
|
|
fields of C<%args> define how this behaves: |
475
|
|
|
|
|
|
|
|
476
|
|
|
|
|
|
|
=over 4 |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
=item * data => STRING |
479
|
|
|
|
|
|
|
|
480
|
|
|
|
|
|
|
Gives the name of the accessor method on its parent class which contains the |
481
|
|
|
|
|
|
|
data buffer for the header. Normally this would be C for direct |
482
|
|
|
|
|
|
|
subclasses of the base message class, but further subclasses would need to use |
483
|
|
|
|
|
|
|
the trailing data buffer accessor of their parent class. |
484
|
|
|
|
|
|
|
|
485
|
|
|
|
|
|
|
=item * fields => ARRAY |
486
|
|
|
|
|
|
|
|
487
|
|
|
|
|
|
|
Reference to an array of definitions for the fields, in the order returned by |
488
|
|
|
|
|
|
|
the pack function or expected by the unpack function. A new accessor method |
489
|
|
|
|
|
|
|
will be created for each. |
490
|
|
|
|
|
|
|
|
491
|
|
|
|
|
|
|
Each field item should either be an ARRAY reference containing the following |
492
|
|
|
|
|
|
|
structure, or a plain scalar denoting simply its name |
493
|
|
|
|
|
|
|
|
494
|
|
|
|
|
|
|
[ $name, $type, %opts ] |
495
|
|
|
|
|
|
|
|
496
|
|
|
|
|
|
|
The C<$type> defines the default value of the attribute, and determines how |
497
|
|
|
|
|
|
|
it will be printed by the C method: |
498
|
|
|
|
|
|
|
|
499
|
|
|
|
|
|
|
=over 4 |
500
|
|
|
|
|
|
|
|
501
|
|
|
|
|
|
|
=item * decimal |
502
|
|
|
|
|
|
|
|
503
|
|
|
|
|
|
|
Default 0, printed with printf "%d" |
504
|
|
|
|
|
|
|
|
505
|
|
|
|
|
|
|
=item * hex |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
Default 0, printed with printf "%x" |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
=item * bytes |
510
|
|
|
|
|
|
|
|
511
|
|
|
|
|
|
|
Default "", printed with printf "%v02x" |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
=item * string |
514
|
|
|
|
|
|
|
|
515
|
|
|
|
|
|
|
Default "", printed with printf "%s" |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
=back |
518
|
|
|
|
|
|
|
|
519
|
|
|
|
|
|
|
The following options are recognised: |
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
=over 8 |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
=item default => SCALAR |
524
|
|
|
|
|
|
|
|
525
|
|
|
|
|
|
|
A value to set for the field when the message header is packed, if no other |
526
|
|
|
|
|
|
|
value has been provided. |
527
|
|
|
|
|
|
|
|
528
|
|
|
|
|
|
|
=back |
529
|
|
|
|
|
|
|
|
530
|
|
|
|
|
|
|
Fields defined simply by name are given the type of C with a default |
531
|
|
|
|
|
|
|
value of 0, and no other options. |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
=item * pack => CODE |
534
|
|
|
|
|
|
|
|
535
|
|
|
|
|
|
|
=item * unpack => CODE |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
References to code that, respectively, packs a list of field values into a |
538
|
|
|
|
|
|
|
packed string value, or unpacks a packed string value back out into a list of |
539
|
|
|
|
|
|
|
values. |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
=back |
542
|
|
|
|
|
|
|
|
543
|
|
|
|
|
|
|
When the header is declared, the base class's method named by C will be |
544
|
|
|
|
|
|
|
overridden by generated code. This overridden method unpacks the values of the |
545
|
|
|
|
|
|
|
fields into accessors when it is set, or packs the accessors into a value when |
546
|
|
|
|
|
|
|
queried. |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
This arrangement can be continued by further subclasses which implement |
549
|
|
|
|
|
|
|
further levels of wrapping, if the pack and unpack functions implement a data |
550
|
|
|
|
|
|
|
tail area; that is, the pack function takes an extra string buffer and the |
551
|
|
|
|
|
|
|
unpack function returns one, for extra bytes after the header itself. The last |
552
|
|
|
|
|
|
|
named field will then contain this buffer. |
553
|
|
|
|
|
|
|
|
554
|
|
|
|
|
|
|
=cut |
555
|
|
|
|
|
|
|
|
556
|
|
|
|
|
|
|
sub is_header |
557
|
|
|
|
|
|
|
{ |
558
|
19
|
|
|
19
|
|
63
|
my $class = shift; |
559
|
19
|
|
|
|
|
70
|
my %args = @_; |
560
|
|
|
|
|
|
|
|
561
|
|
|
|
|
|
|
# This function is also used internally to bootstrap the bottom layer. It |
562
|
|
|
|
|
|
|
# contains a number of undocumented features. |
563
|
|
|
|
|
|
|
|
564
|
19
|
|
|
|
|
32
|
my $no_data = $args{no_data}; |
565
|
|
|
|
|
|
|
|
566
|
19
|
50
|
66
|
|
|
119
|
my $datafield = $args{data} or $no_data or croak "Expected 'data'"; |
567
|
|
|
|
|
|
|
|
568
|
19
|
50
|
|
|
|
62
|
ref( my $fields = $args{fields} ) eq "ARRAY" or croak "Expected 'fields' as ARRAY ref"; |
569
|
|
|
|
|
|
|
|
570
|
19
|
50
|
66
|
|
|
95
|
$no_data or ref( my $packfunc = $args{pack} ) eq "CODE" or croak "Expected 'pack' as CODE ref"; |
571
|
19
|
50
|
66
|
|
|
82
|
$no_data or ref( my $unpackfunc = $args{unpack} ) eq "CODE" or croak "Expected 'unpack' as CODE ref"; |
572
|
|
|
|
|
|
|
|
573
|
19
|
|
|
|
|
22
|
my @fieldnames; |
574
|
|
|
|
|
|
|
my @formats; |
575
|
|
|
|
|
|
|
|
576
|
19
|
|
|
|
|
36
|
foreach my $f ( @$fields ) { |
577
|
64
|
100
|
|
|
|
163
|
my ( $name, $type, %opts ) = ref $f eq "ARRAY" ? @$f |
578
|
|
|
|
|
|
|
: ( $f, "decimal" ); |
579
|
64
|
|
|
|
|
80
|
push @fieldnames, $name; |
580
|
|
|
|
|
|
|
|
581
|
64
|
|
|
|
|
62
|
my $default; |
582
|
|
|
|
|
|
|
my $format; |
583
|
64
|
100
|
|
|
|
142
|
if( $type eq "decimal" ) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
584
|
38
|
|
|
|
|
43
|
$default = 0; |
585
|
38
|
|
|
|
|
46
|
$format = "%d"; |
586
|
|
|
|
|
|
|
} |
587
|
|
|
|
|
|
|
elsif( $type eq "hex" ) { |
588
|
8
|
|
|
|
|
13
|
$default = 0; |
589
|
8
|
|
|
|
|
10
|
$format = "%x"; |
590
|
|
|
|
|
|
|
} |
591
|
|
|
|
|
|
|
elsif( $type eq "bytes" ) { |
592
|
18
|
|
|
|
|
89
|
$default = ""; |
593
|
18
|
|
|
|
|
23
|
$format = "%v02x"; |
594
|
|
|
|
|
|
|
} |
595
|
|
|
|
|
|
|
elsif( $type eq "string" ) { |
596
|
0
|
|
|
|
|
0
|
$default = ""; |
597
|
0
|
|
|
|
|
0
|
$format = "%s"; |
598
|
|
|
|
|
|
|
} |
599
|
|
|
|
|
|
|
else { |
600
|
0
|
|
|
|
|
0
|
croak "Unrecognised field type '$type'"; |
601
|
|
|
|
|
|
|
} |
602
|
|
|
|
|
|
|
|
603
|
64
|
50
|
|
|
|
128
|
$default = $opts{default} if defined $opts{default}; |
604
|
|
|
|
|
|
|
|
605
|
8
|
|
|
8
|
|
46
|
no strict 'refs'; |
|
8
|
|
|
|
|
22
|
|
|
8
|
|
|
|
|
974
|
|
606
|
|
|
|
|
|
|
|
607
|
56
|
|
|
|
|
338
|
*{"${class}::$name"} = subname $name => sub { |
608
|
156
|
|
|
156
|
|
3182
|
my $self = shift; |
609
|
156
|
100
|
|
|
|
806
|
$self->{$name} = shift if @_; |
610
|
156
|
100
|
|
|
|
966
|
defined $self->{$name} ? $self->{$name} : $default; |
611
|
64
|
100
|
|
|
|
282
|
} unless $opts{no_accessor}; |
612
|
|
|
|
|
|
|
|
613
|
64
|
|
|
|
|
194
|
push @formats, "$name=$format"; |
614
|
|
|
|
|
|
|
} |
615
|
|
|
|
|
|
|
|
616
|
8
|
|
|
8
|
|
42
|
no strict 'refs'; |
|
8
|
|
|
|
|
29
|
|
|
8
|
|
|
|
|
2630
|
|
617
|
11
|
|
|
|
|
55
|
*{"${class}::$datafield"} = subname $datafield => sub { |
618
|
9
|
|
|
9
|
|
16
|
my $self = shift; |
619
|
9
|
100
|
|
|
|
30
|
if( @_ ) { |
620
|
4
|
|
|
|
|
20
|
my @values = $unpackfunc->( shift ); |
621
|
4
|
|
|
|
|
29
|
$self->${ \$fieldnames[$_] }( $values[$_] ) for 0 .. $#fieldnames; |
|
10
|
|
|
|
|
46
|
|
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
|
624
|
9
|
|
|
|
|
32
|
return $packfunc->( map { $self->${ \$fieldnames[$_] }() } 0 .. $#fieldnames ); |
|
23
|
|
|
|
|
28
|
|
|
23
|
|
|
|
|
70
|
|
625
|
19
|
100
|
|
|
|
104
|
} unless $no_data; |
626
|
|
|
|
|
|
|
|
627
|
|
|
|
|
|
|
# Debugging support |
628
|
19
|
100
|
100
|
|
|
89
|
if( defined $datafield and !defined &{"${class}::${datafield}_string"} ) { |
|
11
|
|
|
|
|
88
|
|
629
|
8
|
|
|
|
|
24
|
my $formatstring = join ",", @formats; |
630
|
8
|
|
|
|
|
58
|
*{"${class}::${datafield}_string"} = subname "${datafield}_string" => sub { |
631
|
0
|
|
|
0
|
|
0
|
my $self = shift; |
632
|
0
|
|
|
|
|
0
|
sprintf "${datafield}={$formatstring}", map $self->$_, @fieldnames; |
633
|
8
|
|
|
|
|
38
|
}; |
634
|
|
|
|
|
|
|
} |
635
|
|
|
|
|
|
|
} |
636
|
|
|
|
|
|
|
|
637
|
|
|
|
|
|
|
=head2 $messageclass->is_subclassed_by_type |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
Called by a subclass of the message class, this class method declares that |
640
|
|
|
|
|
|
|
messages are further subclassed according to the value of their C. |
641
|
|
|
|
|
|
|
This will override the C accessor to re-C the object into |
642
|
|
|
|
|
|
|
its declared subclass according to the types declared to the generated |
643
|
|
|
|
|
|
|
C method. |
644
|
|
|
|
|
|
|
|
645
|
|
|
|
|
|
|
For example |
646
|
|
|
|
|
|
|
|
647
|
|
|
|
|
|
|
package IO::Socket::Netlink::SomeProto::_Message; |
648
|
|
|
|
|
|
|
use base qw( IO::Socket::Netlink::_Message ); |
649
|
|
|
|
|
|
|
|
650
|
|
|
|
|
|
|
__PACKAGE__->is_subclassed_by_type; |
651
|
|
|
|
|
|
|
|
652
|
|
|
|
|
|
|
package IO::Socket::Netlink::SomeProto::_InfoMessage; |
653
|
|
|
|
|
|
|
|
654
|
|
|
|
|
|
|
__PACKAGE__->register_nlmsg_type( 123 ); |
655
|
|
|
|
|
|
|
|
656
|
|
|
|
|
|
|
... |
657
|
|
|
|
|
|
|
|
658
|
|
|
|
|
|
|
At this point, if a message is constructed with this type number, either by |
659
|
|
|
|
|
|
|
code calling C, or received from the socket, it will be |
660
|
|
|
|
|
|
|
automatically reblessed to the appropriate class. |
661
|
|
|
|
|
|
|
|
662
|
|
|
|
|
|
|
This feature is intended for use by netlink protocols where different message |
663
|
|
|
|
|
|
|
types have different stucture types. |
664
|
|
|
|
|
|
|
|
665
|
|
|
|
|
|
|
=cut |
666
|
|
|
|
|
|
|
|
667
|
|
|
|
|
|
|
sub is_subclassed_by_type |
668
|
|
|
|
|
|
|
{ |
669
|
3
|
|
|
3
|
|
26
|
my $class = shift; |
670
|
|
|
|
|
|
|
|
671
|
3
|
|
|
|
|
5
|
my %type2pkg; |
672
|
|
|
|
|
|
|
|
673
|
8
|
|
|
8
|
|
43
|
no strict 'refs'; |
|
8
|
|
|
|
|
31
|
|
|
8
|
|
|
|
|
2324
|
|
674
|
|
|
|
|
|
|
|
675
|
3
|
|
|
|
|
24
|
*{"${class}::register_nlmsg_type"} = subname "register_nlmsg_type" => sub { |
676
|
4
|
|
|
4
|
|
24
|
my $pkg = shift; |
677
|
4
|
|
|
|
|
7
|
my ( $type ) = @_; |
678
|
|
|
|
|
|
|
|
679
|
4
|
|
|
|
|
14
|
$type2pkg{$type} = $pkg; |
680
|
3
|
|
|
|
|
21
|
}; |
681
|
|
|
|
|
|
|
|
682
|
|
|
|
|
|
|
# SUPER:: happens in the context of the current package. So we need some |
683
|
|
|
|
|
|
|
# massive hackery to make this work |
684
|
3
|
|
|
|
|
247
|
my $SUPER_nlmsg_type = eval " |
685
|
|
|
|
|
|
|
package $class; |
686
|
|
|
|
|
|
|
sub { shift->SUPER::nlmsg_type( \@_ ) } |
687
|
|
|
|
|
|
|
"; |
688
|
|
|
|
|
|
|
|
689
|
3
|
|
|
|
|
22
|
*{"${class}::nlmsg_type"} = subname "nlmsg_type" => sub { |
690
|
15
|
|
|
15
|
|
1167
|
my $self = shift; |
691
|
15
|
|
|
|
|
480
|
my $nlmsg_type = $SUPER_nlmsg_type->( $self, @_ ); |
692
|
|
|
|
|
|
|
|
693
|
15
|
100
|
|
|
|
57
|
return $nlmsg_type unless @_; |
694
|
7
|
50
|
|
|
|
15
|
return unless defined $nlmsg_type; |
695
|
|
|
|
|
|
|
|
696
|
7
|
100
|
|
|
|
24
|
my $pkg = $type2pkg{$nlmsg_type} or return; # no known type |
697
|
6
|
100
|
|
|
|
26
|
return if ref $self eq $pkg; # already right type |
698
|
|
|
|
|
|
|
|
699
|
|
|
|
|
|
|
# Only rebless upwards or downwards, not sideways |
700
|
2
|
50
|
33
|
|
|
7
|
if( ref $self eq $class or $pkg eq $class ) { |
701
|
2
|
|
|
|
|
8
|
bless $self, $pkg; |
702
|
|
|
|
|
|
|
} |
703
|
3
|
|
|
|
|
17
|
}; |
704
|
|
|
|
|
|
|
} |
705
|
|
|
|
|
|
|
|
706
|
|
|
|
|
|
|
=head2 $messageclass->has_nlattrs( $fieldname, %attrs ) |
707
|
|
|
|
|
|
|
|
708
|
|
|
|
|
|
|
Called by a subclass of the message class, this class method is intended to be |
709
|
|
|
|
|
|
|
used by subclass authors to declare the attributes the message protocol |
710
|
|
|
|
|
|
|
understands. The data declared here is used by the C method. |
711
|
|
|
|
|
|
|
|
712
|
|
|
|
|
|
|
C<$fieldname> should be the name of an existing method on the object class; |
713
|
|
|
|
|
|
|
this method will be used to obtain or set the data field containing the |
714
|
|
|
|
|
|
|
attributes (typically this will be the trailing message body). C<%attrs> |
715
|
|
|
|
|
|
|
should be a hash, mapping symbolic names of fields into their typeid and |
716
|
|
|
|
|
|
|
data format. Each entry should be of the form |
717
|
|
|
|
|
|
|
|
718
|
|
|
|
|
|
|
$name => [ $typeid, $datatype ] |
719
|
|
|
|
|
|
|
|
720
|
|
|
|
|
|
|
When the C method is packing attributes into the message body, it will |
721
|
|
|
|
|
|
|
read attributes by C<$name> and encode them using the given C<$datatype> to |
722
|
|
|
|
|
|
|
store in the body by C<$typeid>. When it is unpacking attributes from the |
723
|
|
|
|
|
|
|
body, it will use the C<$typeid> to decode the data, and return it in a hash |
724
|
|
|
|
|
|
|
key of the given C<$name>. |
725
|
|
|
|
|
|
|
|
726
|
|
|
|
|
|
|
=cut |
727
|
|
|
|
|
|
|
|
728
|
|
|
|
|
|
|
my %attr_bytype; # typeid => [ name, unpacker ] |
729
|
|
|
|
|
|
|
my %attr_byname; # name => [ typeid, packer ] |
730
|
|
|
|
|
|
|
|
731
|
|
|
|
|
|
|
sub has_nlattrs |
732
|
|
|
|
|
|
|
{ |
733
|
3
|
|
|
3
|
|
33
|
my $class = shift; |
734
|
3
|
|
|
|
|
30
|
my ( $fieldname, %attrs ) = @_; |
735
|
|
|
|
|
|
|
|
736
|
3
|
50
|
|
|
|
42
|
my $fieldfunc = $class->can( $fieldname ) |
737
|
|
|
|
|
|
|
or croak "$class cannot $fieldname"; |
738
|
|
|
|
|
|
|
|
739
|
|
|
|
|
|
|
{ |
740
|
8
|
|
|
8
|
|
41
|
no strict 'refs'; |
|
8
|
|
|
|
|
22
|
|
|
8
|
|
|
|
|
10702
|
|
|
3
|
|
|
|
|
6
|
|
741
|
3
|
|
|
|
|
5
|
*{"${class}::nlattrdata"} = $fieldfunc; |
|
3
|
|
|
|
|
18
|
|
742
|
|
|
|
|
|
|
} |
743
|
|
|
|
|
|
|
|
744
|
3
|
|
|
|
|
12
|
foreach my $name ( keys %attrs ) { |
745
|
16
|
|
|
|
|
18
|
my ( $typeid, $datatype ) = @{ $attrs{$name} }; |
|
16
|
|
|
|
|
24
|
|
746
|
|
|
|
|
|
|
|
747
|
16
|
50
|
|
|
|
133
|
my $packer = $class->can( "pack_nlattr_$datatype" ) or |
748
|
|
|
|
|
|
|
croak "$class cannot pack_nlattr_$datatype"; |
749
|
16
|
50
|
|
|
|
134
|
my $unpacker = $class->can( "unpack_nlattr_$datatype" ) or |
750
|
|
|
|
|
|
|
croak "$class cannot unpack_nlattr_$datatype"; |
751
|
|
|
|
|
|
|
|
752
|
16
|
|
|
|
|
62
|
$attr_bytype{$class}{$typeid} = [ $name, $unpacker ]; |
753
|
16
|
|
|
|
|
59
|
$attr_byname{$class}{$name} = [ $typeid, $packer ]; |
754
|
|
|
|
|
|
|
} |
755
|
|
|
|
|
|
|
} |
756
|
|
|
|
|
|
|
|
757
|
|
|
|
|
|
|
=pod |
758
|
|
|
|
|
|
|
|
759
|
|
|
|
|
|
|
The following standard definitions exist for C<$datatype>: |
760
|
|
|
|
|
|
|
|
761
|
|
|
|
|
|
|
=over 4 |
762
|
|
|
|
|
|
|
|
763
|
|
|
|
|
|
|
=cut |
764
|
|
|
|
|
|
|
|
765
|
|
|
|
|
|
|
=item * u8 |
766
|
|
|
|
|
|
|
|
767
|
|
|
|
|
|
|
An unsigned 8-bit number |
768
|
|
|
|
|
|
|
|
769
|
|
|
|
|
|
|
=cut |
770
|
|
|
|
|
|
|
|
771
|
2
|
|
|
2
|
|
11
|
sub pack_nlattr_u8 { pack "C", $_[1] } |
772
|
6
|
|
|
6
|
|
21
|
sub unpack_nlattr_u8 { unpack "C", $_[1] } |
773
|
|
|
|
|
|
|
|
774
|
|
|
|
|
|
|
=item * u16 |
775
|
|
|
|
|
|
|
|
776
|
|
|
|
|
|
|
An unsigned 16-bit number |
777
|
|
|
|
|
|
|
|
778
|
|
|
|
|
|
|
=cut |
779
|
|
|
|
|
|
|
|
780
|
2
|
|
|
2
|
|
15
|
sub pack_nlattr_u16 { pack "S", $_[1] } |
781
|
5
|
|
|
5
|
|
26
|
sub unpack_nlattr_u16 { unpack "S", $_[1] } |
782
|
|
|
|
|
|
|
|
783
|
|
|
|
|
|
|
=item * u32 |
784
|
|
|
|
|
|
|
|
785
|
|
|
|
|
|
|
An unsigned 32-bit number |
786
|
|
|
|
|
|
|
|
787
|
|
|
|
|
|
|
=cut |
788
|
|
|
|
|
|
|
|
789
|
2
|
|
|
2
|
|
9
|
sub pack_nlattr_u32 { pack "L", $_[1] } |
790
|
9
|
|
|
9
|
|
83
|
sub unpack_nlattr_u32 { unpack "L", $_[1] } |
791
|
|
|
|
|
|
|
|
792
|
|
|
|
|
|
|
=item * u64 |
793
|
|
|
|
|
|
|
|
794
|
|
|
|
|
|
|
An unsigned 64-bit number |
795
|
|
|
|
|
|
|
|
796
|
|
|
|
|
|
|
=cut |
797
|
|
|
|
|
|
|
|
798
|
0
|
|
|
0
|
|
0
|
sub pack_nlattr_u64 { pack "Q", $_[1] } |
799
|
0
|
|
|
0
|
|
0
|
sub unpack_nlattr_u64 { unpack "Q", $_[1] } |
800
|
|
|
|
|
|
|
|
801
|
|
|
|
|
|
|
=item * asciiz |
802
|
|
|
|
|
|
|
|
803
|
|
|
|
|
|
|
A NULL-terminated string of ASCII text |
804
|
|
|
|
|
|
|
|
805
|
|
|
|
|
|
|
=cut |
806
|
|
|
|
|
|
|
|
807
|
3
|
|
|
3
|
|
21
|
sub pack_nlattr_asciiz { pack "Z*", $_[1] } |
808
|
5
|
|
|
5
|
|
23
|
sub unpack_nlattr_asciiz { unpack "Z*", $_[1] } |
809
|
|
|
|
|
|
|
|
810
|
|
|
|
|
|
|
=item * raw |
811
|
|
|
|
|
|
|
|
812
|
|
|
|
|
|
|
No encoding or decoding will take place; the value contains the raw byte |
813
|
|
|
|
|
|
|
buffer |
814
|
|
|
|
|
|
|
|
815
|
|
|
|
|
|
|
=cut |
816
|
|
|
|
|
|
|
|
817
|
1
|
|
|
1
|
|
4
|
sub pack_nlattr_raw { $_[1] } |
818
|
3
|
|
|
3
|
|
9
|
sub unpack_nlattr_raw { $_[1] } |
819
|
|
|
|
|
|
|
|
820
|
|
|
|
|
|
|
=item * nested |
821
|
|
|
|
|
|
|
|
822
|
|
|
|
|
|
|
The buffer itself contains more attributes in the same schema. These will be |
823
|
|
|
|
|
|
|
taken or returned in a HASH reference. |
824
|
|
|
|
|
|
|
|
825
|
|
|
|
|
|
|
=cut |
826
|
|
|
|
|
|
|
|
827
|
1
|
|
|
1
|
|
11
|
sub pack_nlattr_nested { $_[0]->_pack_nlattrs( $_[1] ) } |
828
|
3
|
|
|
3
|
|
17
|
sub unpack_nlattr_nested { $_[0]->_unpack_nlattrs( $_[1] ) } |
829
|
|
|
|
|
|
|
|
830
|
|
|
|
|
|
|
=back |
831
|
|
|
|
|
|
|
|
832
|
|
|
|
|
|
|
A subclass can define new data types by providing methods called |
833
|
|
|
|
|
|
|
C and C which will be used to |
834
|
|
|
|
|
|
|
encode or decode the attribute value into a string buffer. |
835
|
|
|
|
|
|
|
|
836
|
|
|
|
|
|
|
=cut |
837
|
|
|
|
|
|
|
|
838
|
|
|
|
|
|
|
=head2 $message->nlattrs( \%newattrs ) |
839
|
|
|
|
|
|
|
|
840
|
|
|
|
|
|
|
Sets the message body field by encoding the attributes given by C<%newattrs>, |
841
|
|
|
|
|
|
|
keyed by name, into Netlink attribute values, by using the definitions |
842
|
|
|
|
|
|
|
declared by the subclass's C method. |
843
|
|
|
|
|
|
|
|
844
|
|
|
|
|
|
|
=head2 \%attrs = $message->nlattrs |
845
|
|
|
|
|
|
|
|
846
|
|
|
|
|
|
|
Returns the decoded attributes from the message body field. |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
=cut |
849
|
|
|
|
|
|
|
|
850
|
|
|
|
|
|
|
sub _pack_nlattrs |
851
|
|
|
|
|
|
|
{ |
852
|
10
|
|
|
10
|
|
12
|
my $self = shift; |
853
|
10
|
|
|
|
|
13
|
my $class = ref $self; |
854
|
10
|
|
|
|
|
14
|
my ( $values ) = @_; |
855
|
|
|
|
|
|
|
|
856
|
10
|
50
|
|
|
|
39
|
my $attrmap = $attr_byname{$class} or |
857
|
|
|
|
|
|
|
croak "No attribute defintions for $class have been declared"; |
858
|
|
|
|
|
|
|
|
859
|
10
|
|
|
|
|
19
|
my %attrs; |
860
|
10
|
|
|
|
|
34
|
foreach my $name ( keys %$values ) { |
861
|
9
|
50
|
|
|
|
22
|
$attrmap->{$name} or croak "Unknown netlink message attribute $name"; |
862
|
9
|
|
|
|
|
11
|
my ( $typeid, $packer ) = @{ $attrmap->{$name} }; |
|
9
|
|
|
|
|
20
|
|
863
|
9
|
|
|
|
|
28
|
$attrs{$typeid} = $packer->( $self, $values->{$name} ); |
864
|
|
|
|
|
|
|
} |
865
|
|
|
|
|
|
|
|
866
|
10
|
|
|
|
|
67
|
return pack_nlattrs( %attrs ); |
867
|
|
|
|
|
|
|
} |
868
|
|
|
|
|
|
|
|
869
|
|
|
|
|
|
|
sub _unpack_nlattrs |
870
|
|
|
|
|
|
|
{ |
871
|
8
|
|
|
8
|
|
10
|
my $self = shift; |
872
|
8
|
|
|
|
|
22
|
my $class = ref $self; |
873
|
8
|
|
|
|
|
13
|
my ( $data ) = @_; |
874
|
|
|
|
|
|
|
|
875
|
8
|
50
|
|
|
|
27
|
my $attrmap = $attr_bytype{$class} or |
876
|
|
|
|
|
|
|
croak "No attribute definitions for $class have been declared"; |
877
|
|
|
|
|
|
|
|
878
|
8
|
|
|
|
|
75
|
my %attrs = unpack_nlattrs( $data ); |
879
|
|
|
|
|
|
|
|
880
|
8
|
|
|
|
|
17
|
my %values; |
881
|
8
|
|
|
|
|
25
|
foreach my $typeid ( keys %attrs ) { |
882
|
34
|
100
|
|
|
|
86
|
$attrmap->{$typeid} or next; |
883
|
30
|
|
|
|
|
32
|
my ( $name, $unpacker ) = @{ $attrmap->{$typeid} }; |
|
30
|
|
|
|
|
59
|
|
884
|
30
|
|
|
|
|
72
|
$values{$name} = $unpacker->( $self, $attrs{$typeid} ); |
885
|
|
|
|
|
|
|
} |
886
|
|
|
|
|
|
|
|
887
|
8
|
|
|
|
|
72
|
return \%values; |
888
|
|
|
|
|
|
|
} |
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
sub nlattrs |
891
|
|
|
|
|
|
|
{ |
892
|
14
|
|
|
14
|
|
3057
|
my $self = shift; |
893
|
|
|
|
|
|
|
|
894
|
14
|
100
|
|
|
|
32
|
if( @_ ) { |
895
|
9
|
|
|
|
|
37
|
$self->nlattrdata( $self->_pack_nlattrs( @_ ) ); |
896
|
|
|
|
|
|
|
} |
897
|
|
|
|
|
|
|
else { |
898
|
5
|
|
|
|
|
14
|
return $self->_unpack_nlattrs( $self->nlattrdata ); |
899
|
|
|
|
|
|
|
} |
900
|
|
|
|
|
|
|
} |
901
|
|
|
|
|
|
|
|
902
|
|
|
|
|
|
|
=head2 $value = $message->get_nlattr( $name ) |
903
|
|
|
|
|
|
|
|
904
|
|
|
|
|
|
|
Returns the decoded value of a single attribute from the message body field. |
905
|
|
|
|
|
|
|
Similar to |
906
|
|
|
|
|
|
|
|
907
|
|
|
|
|
|
|
$value = $message->nlattrs->{$name} |
908
|
|
|
|
|
|
|
|
909
|
|
|
|
|
|
|
except it does not incur the extra cost of decoding the other attribute values |
910
|
|
|
|
|
|
|
that remain unused. |
911
|
|
|
|
|
|
|
|
912
|
|
|
|
|
|
|
=cut |
913
|
|
|
|
|
|
|
|
914
|
|
|
|
|
|
|
sub get_nlattr |
915
|
|
|
|
|
|
|
{ |
916
|
1
|
|
|
1
|
|
2
|
my $self = shift; |
917
|
1
|
|
|
|
|
3
|
my $class = ref $self; |
918
|
1
|
|
|
|
|
2
|
my ( $wantname ) = @_; |
919
|
|
|
|
|
|
|
|
920
|
1
|
50
|
|
|
|
5
|
my $attrmap = $attr_bytype{$class} or |
921
|
|
|
|
|
|
|
croak "No attribute definitions for $class have been declared"; |
922
|
|
|
|
|
|
|
|
923
|
1
|
|
|
|
|
4
|
my %attrs = unpack_nlattrs( $self->nlattrdata ); |
924
|
|
|
|
|
|
|
|
925
|
1
|
|
|
|
|
6
|
foreach my $typeid ( keys %attrs ) { |
926
|
1
|
50
|
|
|
|
6
|
$attrmap->{$typeid} or next; |
927
|
1
|
|
|
|
|
1
|
my ( $name, $unpacker ) = @{ $attrmap->{$typeid} }; |
|
1
|
|
|
|
|
3
|
|
928
|
1
|
50
|
|
|
|
18
|
return $unpacker->( $self, $attrs{$typeid} ) if $name eq $wantname; |
929
|
|
|
|
|
|
|
} |
930
|
|
|
|
|
|
|
|
931
|
0
|
|
|
|
|
0
|
return undef; |
932
|
|
|
|
|
|
|
} |
933
|
|
|
|
|
|
|
|
934
|
|
|
|
|
|
|
=head2 $message->change_nlattrs( %newvalues ) |
935
|
|
|
|
|
|
|
|
936
|
|
|
|
|
|
|
Changes the stored values of the given attributes in the message body field. |
937
|
|
|
|
|
|
|
Similar to |
938
|
|
|
|
|
|
|
|
939
|
|
|
|
|
|
|
$message->nlattrs( { %{ $message->nlattrs }, %newvalues } ); |
940
|
|
|
|
|
|
|
|
941
|
|
|
|
|
|
|
except it does not incur the extra cost of decoding and reencoding the |
942
|
|
|
|
|
|
|
unmodified attribute values. |
943
|
|
|
|
|
|
|
|
944
|
|
|
|
|
|
|
A value of C may be assigned to delete an attribute. |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
=cut |
947
|
|
|
|
|
|
|
|
948
|
|
|
|
|
|
|
sub change_nlattrs |
949
|
|
|
|
|
|
|
{ |
950
|
2
|
|
|
2
|
|
5
|
my $self = shift; |
951
|
2
|
|
|
|
|
3
|
my $class = ref $self; |
952
|
2
|
|
|
|
|
6
|
my %newvalues = @_; |
953
|
|
|
|
|
|
|
|
954
|
2
|
50
|
|
|
|
8
|
my $attrmap = $attr_byname{$class} or |
955
|
|
|
|
|
|
|
croak "No attribute definitions for $class have been declared"; |
956
|
|
|
|
|
|
|
|
957
|
2
|
|
|
|
|
5
|
my %attrs = unpack_nlattrs( $self->nlattrdata ); |
958
|
|
|
|
|
|
|
|
959
|
2
|
|
|
|
|
8
|
foreach my $name ( keys %newvalues ) { |
960
|
3
|
50
|
|
|
|
9
|
$attrmap->{$name} or croak "Unknown netlink message attribute $name"; |
961
|
3
|
|
|
|
|
4
|
my ( $typeid, $packer ) = @{ $attrmap->{$name} }; |
|
3
|
|
|
|
|
7
|
|
962
|
3
|
100
|
|
|
|
8
|
if( defined( my $value = $newvalues{$name} ) ) { |
963
|
2
|
|
|
|
|
6
|
$attrs{$typeid} = $packer->( $self, $newvalues{$name} ); |
964
|
|
|
|
|
|
|
} |
965
|
|
|
|
|
|
|
else { |
966
|
1
|
|
|
|
|
4
|
delete $attrs{$typeid}; |
967
|
|
|
|
|
|
|
} |
968
|
|
|
|
|
|
|
} |
969
|
|
|
|
|
|
|
|
970
|
2
|
|
|
|
|
14
|
$self->nlattrdata( pack_nlattrs( %attrs ) ); |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
=pod |
974
|
|
|
|
|
|
|
|
975
|
|
|
|
|
|
|
The following accessors are provided for debugging purposes |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
=cut |
978
|
|
|
|
|
|
|
|
979
|
|
|
|
|
|
|
=head2 $str = $message->nlmsg_type_string |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
Renders the message type into a readable string form. Subclasses may wish to |
982
|
|
|
|
|
|
|
override this method to return other strings they recognise, or call to |
983
|
|
|
|
|
|
|
C if they don't. |
984
|
|
|
|
|
|
|
|
985
|
|
|
|
|
|
|
=cut |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
# Some useful debugging accessors |
988
|
|
|
|
|
|
|
sub nlmsg_type_string |
989
|
|
|
|
|
|
|
{ |
990
|
4
|
|
|
4
|
|
6
|
my $self = shift; |
991
|
4
|
|
100
|
|
|
12
|
my $type = $self->nlmsg_type || 0; |
992
|
4
|
50
|
|
|
|
51
|
return $type == NLMSG_NOOP ? "NLMSG_NOOP" : |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
993
|
|
|
|
|
|
|
$type == NLMSG_DONE ? "NLMSG_DONE" : |
994
|
|
|
|
|
|
|
$type == NLMSG_ERROR ? "NLMSG_ERROR" : |
995
|
|
|
|
|
|
|
"$type"; |
996
|
|
|
|
|
|
|
} |
997
|
|
|
|
|
|
|
|
998
|
|
|
|
|
|
|
=head2 $str = $message->nlmsg_flags_string |
999
|
|
|
|
|
|
|
|
1000
|
|
|
|
|
|
|
Renders the flags into a readable string form. Each flag present is named, |
1001
|
|
|
|
|
|
|
joined by C<|> characters. |
1002
|
|
|
|
|
|
|
|
1003
|
|
|
|
|
|
|
=cut |
1004
|
|
|
|
|
|
|
|
1005
|
|
|
|
|
|
|
sub nlmsg_flags_string |
1006
|
|
|
|
|
|
|
{ |
1007
|
4
|
|
|
4
|
|
9
|
my $self = shift; |
1008
|
4
|
|
100
|
|
|
23
|
my $flags = $self->nlmsg_flags || 0; |
1009
|
4
|
|
|
|
|
7
|
my @flags; |
1010
|
|
|
|
|
|
|
|
1011
|
4
|
|
|
|
|
15
|
foreach my $f (qw( |
1012
|
|
|
|
|
|
|
NLM_F_REQUEST NLM_F_MULTI NLM_F_ACK NLM_F_ECHO |
1013
|
|
|
|
|
|
|
NLM_F_ROOT NLM_F_MATCH NLM_F_ATOMIC NLM_F_DUMP |
1014
|
|
|
|
|
|
|
NLM_F_REPLACE NLM_F_EXCL NLM_F_CREATE NLM_F_APPEND |
1015
|
|
|
|
|
|
|
)) { |
1016
|
6
|
|
|
|
|
50
|
my $val = __PACKAGE__->$f; |
1017
|
6
|
100
|
|
|
|
19
|
push @flags, $f if $flags & $val; |
1018
|
6
|
|
|
|
|
9
|
$flags &= ~$val; |
1019
|
|
|
|
|
|
|
|
1020
|
6
|
100
|
|
|
|
17
|
last unless $flags; |
1021
|
|
|
|
|
|
|
} |
1022
|
|
|
|
|
|
|
|
1023
|
4
|
50
|
|
|
|
12
|
push @flags, sprintf "0x%x", $flags if $flags; |
1024
|
|
|
|
|
|
|
|
1025
|
4
|
100
|
|
|
|
24
|
return @flags ? join "|", @flags : "0"; |
1026
|
|
|
|
|
|
|
} |
1027
|
|
|
|
|
|
|
|
1028
|
|
|
|
|
|
|
=head2 $str = $message->nlmsg_string |
1029
|
|
|
|
|
|
|
|
1030
|
|
|
|
|
|
|
Intended for subclasses to override, to include more of their own information |
1031
|
|
|
|
|
|
|
about nested headers. |
1032
|
|
|
|
|
|
|
|
1033
|
|
|
|
|
|
|
=cut |
1034
|
|
|
|
|
|
|
|
1035
|
|
|
|
|
|
|
sub nlmsg_string |
1036
|
|
|
|
|
|
|
{ |
1037
|
2
|
|
|
2
|
|
3
|
my $self = shift; |
1038
|
2
|
|
|
|
|
4
|
return sprintf "nlmsg={%d bytes}", length $self->nlmsg; |
1039
|
|
|
|
|
|
|
} |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
=head2 $str = $message->STRING |
1042
|
|
|
|
|
|
|
|
1043
|
|
|
|
|
|
|
=head2 $str = "$message" |
1044
|
|
|
|
|
|
|
|
1045
|
|
|
|
|
|
|
Returns a human-readable string form of the message, giving details of the |
1046
|
|
|
|
|
|
|
values of the fields. Provided primarily for debugging purposes. |
1047
|
|
|
|
|
|
|
|
1048
|
|
|
|
|
|
|
=cut |
1049
|
|
|
|
|
|
|
|
1050
|
8
|
|
|
8
|
|
11703
|
use overload '""' => "STRING"; |
|
8
|
|
|
|
|
14103
|
|
|
8
|
|
|
|
|
1335
|
|
1051
|
|
|
|
|
|
|
sub STRING |
1052
|
|
|
|
|
|
|
{ |
1053
|
4
|
|
|
4
|
|
1147
|
my $self = shift; |
1054
|
4
|
|
100
|
|
|
30
|
return sprintf "%s(type=%s,flags=%s,seq=%d,pid=%d,%s)", |
|
|
|
100
|
|
|
|
|
1055
|
|
|
|
|
|
|
ref $self, |
1056
|
|
|
|
|
|
|
$self->nlmsg_type_string, |
1057
|
|
|
|
|
|
|
$self->nlmsg_flags_string, |
1058
|
|
|
|
|
|
|
$self->nlmsg_seq || 0, |
1059
|
|
|
|
|
|
|
$self->nlmsg_pid || 0, |
1060
|
|
|
|
|
|
|
$self->nlmsg_string; |
1061
|
|
|
|
|
|
|
} |
1062
|
|
|
|
|
|
|
|
1063
|
|
|
|
|
|
|
package IO::Socket::Netlink::_ErrorMessage; |
1064
|
|
|
|
|
|
|
|
1065
|
8
|
|
|
8
|
|
1040
|
use base qw( IO::Socket::Netlink::_Message ); |
|
8
|
|
|
|
|
30
|
|
|
8
|
|
|
|
|
4680
|
|
1066
|
8
|
|
|
|
|
906
|
use Socket::Netlink qw( |
1067
|
|
|
|
|
|
|
pack_nlmsgerr unpack_nlmsgerr |
1068
|
8
|
|
|
8
|
|
56
|
); |
|
8
|
|
|
|
|
13
|
|
1069
|
|
|
|
|
|
|
|
1070
|
|
|
|
|
|
|
=head1 ERROR MESSAGE OBJECTS |
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
If a message object has its C field set to C then the |
1073
|
|
|
|
|
|
|
object will be reblessed into a subclass that encapsulates the error message. |
1074
|
|
|
|
|
|
|
|
1075
|
|
|
|
|
|
|
=head2 $message->nlerr_error |
1076
|
|
|
|
|
|
|
|
1077
|
|
|
|
|
|
|
Accessor for the error value from the kernel. This will be a system error |
1078
|
|
|
|
|
|
|
value such used by C<$!>. This accessor also exists on non-error messages, but |
1079
|
|
|
|
|
|
|
returns false. This makes it easy to test for an error after C: |
1080
|
|
|
|
|
|
|
|
1081
|
|
|
|
|
|
|
$sock->recv_nlmsg( my $message, 2**15 ) or die "Cannot recv - $!"; |
1082
|
|
|
|
|
|
|
( $! = $message->nlerr_error ) and die "Received NLMSG_ERROR - $!"; |
1083
|
|
|
|
|
|
|
|
1084
|
|
|
|
|
|
|
=head2 $message->nlerr_msg |
1085
|
|
|
|
|
|
|
|
1086
|
|
|
|
|
|
|
Accessor for the original netlink message header that invoked the error. This |
1087
|
|
|
|
|
|
|
value may be unpacked using C. |
1088
|
|
|
|
|
|
|
|
1089
|
|
|
|
|
|
|
=cut |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
__PACKAGE__->is_header( |
1092
|
|
|
|
|
|
|
data => "nlmsg", |
1093
|
|
|
|
|
|
|
fields => [ |
1094
|
|
|
|
|
|
|
[ nlerr_error => "decimal" ], |
1095
|
|
|
|
|
|
|
[ nlerr_msg => "bytes" ], |
1096
|
|
|
|
|
|
|
], |
1097
|
|
|
|
|
|
|
pack => \&pack_nlmsgerr, |
1098
|
|
|
|
|
|
|
unpack => \&unpack_nlmsgerr, |
1099
|
|
|
|
|
|
|
); |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
=head1 SEE ALSO |
1102
|
|
|
|
|
|
|
|
1103
|
|
|
|
|
|
|
=over 4 |
1104
|
|
|
|
|
|
|
|
1105
|
|
|
|
|
|
|
=item * |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
L - interface to Linux's C socket family |
1108
|
|
|
|
|
|
|
|
1109
|
|
|
|
|
|
|
=back |
1110
|
|
|
|
|
|
|
|
1111
|
|
|
|
|
|
|
=head1 AUTHOR |
1112
|
|
|
|
|
|
|
|
1113
|
|
|
|
|
|
|
Paul Evans |
1114
|
|
|
|
|
|
|
|
1115
|
|
|
|
|
|
|
=cut |
1116
|
|
|
|
|
|
|
|
1117
|
|
|
|
|
|
|
0x55AA; |