File Coverage

blib/lib/IO/Socket/Netlink/Taskstats.pm
Criterion Covered Total %
statement 31 52 59.6
branch 0 12 0.0
condition n/a
subroutine 11 18 61.1
pod 3 5 60.0
total 45 87 51.7


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::Taskstats;
7              
8 2     2   41437 use strict;
  2         4  
  2         91  
9 2     2   11 use warnings;
  2         5  
  2         79  
10 2     2   13 use base qw( IO::Socket::Netlink::Generic );
  2         4  
  2         2262  
11              
12             our $VERSION = '0.03';
13              
14 2     2   112827 use Carp;
  2         5  
  2         130  
15              
16 2     2   11 use Socket::Netlink qw( :DEFAULT );
  2         3  
  2         395  
17 2     2   789 use Socket::Netlink::Taskstats;
  2         4  
  2         1007  
18              
19             __PACKAGE__->register_family_name( "TASKSTATS" );
20              
21             =head1 NAME
22              
23             C - Object interface to C generic
24             netlink protocol sockets
25              
26             =head1 SYNOPSIS
27              
28             use IO::Socket::Netlink::Taskstats;
29              
30             my $sock = IO::Socket::Netlink::Taskstats->new;
31              
32             my $stats = $sock->get_process_info_by_pid( $$ );
33              
34             printf "So far, %s has consumed %d usec in userland and %d in kernel\n",
35             $stats->{ac_comm},
36             $stats->{ac_utime},
37             $stats->{ac_stime};
38              
39             =head1 DESCRIPTION
40              
41             This subclass of L implements the C
42             generic netlink protocol. This protocol allows detailed statistics gathering
43             of resource usage on a per-process basis, and notification of resources used
44             by processes at the time they exit.
45              
46             This module is currently a work-in-progress, and this documentation is fairly
47             minimal. The reader is expected to be familiar with C, only a
48             fairly minimal description of the Perl-level wrapping is given here.
49              
50             =cut
51              
52             =head1 METHODS
53              
54             =cut
55              
56             sub message_class
57             {
58 2     2 0 1182 return "IO::Socket::Netlink::Taskstats::_Message";
59             }
60              
61             sub command_class
62             {
63 0     0 0   return "IO::Socket::Netlink::Taskstats::_Command";
64             }
65              
66             sub _get_process_info
67             {
68 0     0     my $self = shift;
69 0           my %searchattrs = @_;
70              
71 0 0         $self->send_nlmsg( $self->new_command(
72             cmd => CMD_GET,
73             nlattrs => \%searchattrs,
74             ) ) or croak "Cannot send - $!";
75              
76 0 0         $self->recv_nlmsg( my $message, 32768 ) or
77             croak "Cannot recv - $!";
78              
79 0           return $message->nlattrs;
80             }
81              
82             =head2 $info = $sock->get_process_info_by_pid( $pid )
83              
84             Returns an information structure containing the statistics about the process
85             with the given PID.
86              
87             =cut
88              
89             sub get_process_info_by_pid
90             {
91 0     0 1   my $self = shift;
92 0           my ( $pid ) = @_;
93 0           return $self->_get_process_info( pid => $pid )->{aggr_pid}{stats};
94             }
95              
96             =head2 $sock->register_cpumask( $mask )
97              
98             =head2 $sock->deregister_cpumask( $mask )
99              
100             Register or deregister this socket to receive process exit notifications, for
101             processes exiting on CPUs given by the C<$mask>.
102              
103             =cut
104              
105             sub register_cpumask
106             {
107 0     0 1   my $self = shift;
108 0           my ( $mask ) = @_;
109              
110 0           $self->send_nlmsg( $self->new_command(
111             cmd => CMD_GET,
112             nlattrs => {
113             register_cpumask => $mask,
114             },
115             ) );
116              
117 0 0         $self->recv_nlmsg( my $message, 32768 ) or
118             croak "Cannot recv - $!";
119 0 0         ( $! = $message->nlerr_error ) and croak "Received NLMSG_ERROR - $!";
120             }
121              
122             sub deregister_cpumask
123             {
124 0     0 1   my $self = shift;
125 0           my ( $mask ) = @_;
126              
127 0           $self->send_nlmsg( $self->new_command(
128             cmd => CMD_GET,
129             nlattrs => {
130             deregister_cpumask => $mask,
131             },
132             ) );
133              
134 0 0         $self->recv_nlmsg( my $message, 32768 ) or
135             croak "Cannot recv - $!";
136 0 0         ( $! = $message->nlerr_error ) and croak "Received NLMSG_ERROR - $!";
137             }
138              
139             =head1 MESSAGE OBJECTS
140              
141             =cut
142              
143             package IO::Socket::Netlink::Taskstats::_Message;
144              
145 2     2   12 use base qw( IO::Socket::Netlink::Generic::_Message );
  2         3  
  2         1222  
146              
147 2     2   17 use Socket::Netlink::Taskstats qw( :DEFAULT );
  2         5  
  2         698  
148              
149             =pod
150              
151             Provides the following netlink attributes
152              
153             =over 4
154              
155             =item * pid => INT
156              
157             =item * tgid => INT
158              
159             =item * stats => HASH
160              
161             =item * aggr_pid => HASH
162              
163             =item * aggr_tgid => HASH
164              
165             =back
166              
167             =cut
168              
169             __PACKAGE__->has_nlattrs(
170             "genlmsg",
171             pid => [ TYPE_PID, "u32" ],
172             tgid => [ TYPE_TGID, "u32" ],
173             stats => [ TYPE_STATS, "stats" ],
174             aggr_pid => [ TYPE_AGGR_PID, "nested" ],
175             aggr_tgid => [ TYPE_AGGR_TGID, "nested" ],
176             );
177              
178 0     0     sub pack_nlattr_stats { pack_taskstats $_[1] }
179 0     0     sub unpack_nlattr_stats { unpack_taskstats $_[1] }
180              
181             package IO::Socket::Netlink::Taskstats::_Command;
182              
183 2     2   10 use base qw( IO::Socket::Netlink::Generic::_Message );
  2         2  
  2         1164  
184              
185 2     2   23 use Socket::Netlink::Taskstats qw( :DEFAULT );
  2         3  
  2         470  
186              
187             __PACKAGE__->has_nlattrs(
188             "genlmsg",
189             pid => [ CMD_ATTR_PID, "u32" ],
190             tgid => [ CMD_ATTR_TGID, "u32" ],
191             register_cpumask => [ CMD_ATTR_REGISTER_CPUMASK, "raw" ],
192             deregister_cpumask => [ CMD_ATTR_DEREGISTER_CPUMASK, "raw" ],
193             );
194              
195             =head1 SEE ALSO
196              
197             =over 4
198              
199             =item *
200              
201             L - interface to Linux's C generic
202             netlink socket protocol
203              
204             =item *
205              
206             L - Object interface to C domain sockets
207              
208             =back
209              
210             =head1 AUTHOR
211              
212             Paul Evans
213              
214             =cut
215              
216             0x55AA;