This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
5b9eb07d001613152af0bebdeb5173a34bc620c6
[perl5.git] / cpan / IPC-SysV / lib / IPC / Msg.pm
1 ################################################################################
2 #
3 #  $Revision: 19 $
4 #  $Author: mhx $
5 #  $Date: 2010/05/23 10:37:46 +0200 $
6 #
7 ################################################################################
8 #
9 #  Version 2.x, Copyright (C) 2007-2010, Marcus Holland-Moritz <mhx@cpan.org>.
10 #  Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>.
11 #
12 #  This program is free software; you can redistribute it and/or
13 #  modify it under the same terms as Perl itself.
14 #
15 ################################################################################
16
17 package IPC::Msg;
18
19 use IPC::SysV qw(IPC_STAT IPC_SET IPC_RMID);
20 use strict;
21 use vars qw($VERSION);
22 use Carp;
23
24 $VERSION = do { my @r = '$Snapshot: /IPC-SysV/2.03 $' =~ /(\d+\.\d+(?:_\d+)?)/; @r ? $r[0] : '9.99' };
25 $VERSION = eval $VERSION;
26
27 # Figure out if we have support for native sized types
28 my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' };
29
30 {
31     package IPC::Msg::stat;
32
33     use Class::Struct qw(struct);
34
35     struct 'IPC::Msg::stat' => [
36         uid     => '$',
37         gid     => '$',
38         cuid    => '$',
39         cgid    => '$',
40         mode    => '$',
41         qnum    => '$',
42         qbytes  => '$',
43         lspid   => '$',
44         lrpid   => '$',
45         stime   => '$',
46         rtime   => '$',
47         ctime   => '$',
48     ];
49 }
50
51 sub new {
52     @_ == 3 || croak 'new IPC::Msg ( KEY , FLAGS )';
53     my $class = shift;
54
55     my $id = msgget($_[0],$_[1]);
56
57     defined($id)
58         ? bless \$id, $class
59         : undef;
60 }
61
62 sub id {
63     my $self = shift;
64     $$self;
65 }
66
67 sub stat {
68     my $self = shift;
69     my $data = "";
70     msgctl($$self,IPC_STAT,$data) or
71         return undef;
72     IPC::Msg::stat->new->unpack($data);
73 }
74
75 sub set {
76     my $self = shift;
77     my $ds;
78
79     if(@_ == 1) {
80         $ds = shift;
81     }
82     else {
83         croak 'Bad arg count' if @_ % 2;
84         my %arg = @_;
85         $ds = $self->stat
86                 or return undef;
87         my($key,$val);
88         $ds->$key($val)
89             while(($key,$val) = each %arg);
90     }
91
92     msgctl($$self,IPC_SET,$ds->pack);
93 }
94
95 sub remove {
96     my $self = shift;
97     (msgctl($$self,IPC_RMID,0), undef $$self)[0];
98 }
99
100 sub rcv {
101     @_ <= 5 && @_ >= 3 or croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )';
102     my $self = shift;
103     my $buf = "";
104     msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or
105         return;
106     my $type;
107     ($type,$_[0]) = unpack("l$N a*",$buf);
108     $type;
109 }
110
111 sub snd {
112     @_ <= 4 && @_ >= 3 or  croak '$msg->snd( TYPE, BUF, FLAGS )';
113     my $self = shift;
114     msgsnd($$self,pack("l$N a*",$_[0],$_[1]), $_[2] || 0);
115 }
116
117
118 1;
119
120 __END__
121
122 =head1 NAME
123
124 IPC::Msg - SysV Msg IPC object class
125
126 =head1 SYNOPSIS
127
128     use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR);
129     use IPC::Msg;
130
131     $msg = IPC::Msg->new(IPC_PRIVATE, S_IRUSR | S_IWUSR);
132
133     $msg->snd($msgtype, $msgdata);
134
135     $msg->rcv($buf, 256);
136
137     $ds = $msg->stat;
138
139     $msg->remove;
140
141 =head1 DESCRIPTION
142
143 A class providing an object based interface to SysV IPC message queues.
144
145 =head1 METHODS
146
147 =over 4
148
149 =item new ( KEY , FLAGS )
150
151 Creates a new message queue associated with C<KEY>. A new queue is
152 created if
153
154 =over 4
155
156 =item *
157
158 C<KEY> is equal to C<IPC_PRIVATE>
159
160 =item *
161
162 C<KEY> does not already have a message queue associated with
163 it, and C<I<FLAGS> & IPC_CREAT> is true.
164
165 =back
166
167 On creation of a new message queue C<FLAGS> is used to set the
168 permissions.  Be careful not to set any flags that the Sys V
169 IPC implementation does not allow: in some systems setting
170 execute bits makes the operations fail.
171
172 =item id
173
174 Returns the system message queue identifier.
175
176 =item rcv ( BUF, LEN [, TYPE [, FLAGS ]] )
177
178 Read a message from the queue. Returns the type of the message read.
179 See L<msgrcv>.  The BUF becomes tainted.
180
181 =item remove
182
183 Remove and destroy the message queue from the system.
184
185 =item set ( STAT )
186
187 =item set ( NAME => VALUE [, NAME => VALUE ...] )
188
189 C<set> will set the following values of the C<stat> structure associated
190 with the message queue.
191
192     uid
193     gid
194     mode (oly the permission bits)
195     qbytes
196
197 C<set> accepts either a stat object, as returned by the C<stat> method,
198 or a list of I<name>-I<value> pairs.
199
200 =item snd ( TYPE, MSG [, FLAGS ] )
201
202 Place a message on the queue with the data from C<MSG> and with type C<TYPE>.
203 See L<msgsnd>.
204
205 =item stat
206
207 Returns an object of type C<IPC::Msg::stat> which is a sub-class of
208 C<Class::Struct>. It provides the following fields. For a description
209 of these fields see you system documentation.
210
211     uid
212     gid
213     cuid
214     cgid
215     mode
216     qnum
217     qbytes
218     lspid
219     lrpid
220     stime
221     rtime
222     ctime
223
224 =back
225
226 =head1 SEE ALSO
227
228 L<IPC::SysV>, L<Class::Struct>
229
230 =head1 AUTHORS
231
232 Graham Barr <gbarr@pobox.com>,
233 Marcus Holland-Moritz <mhx@cpan.org>
234
235 =head1 COPYRIGHT
236
237 Version 2.x, Copyright (C) 2007-2010, Marcus Holland-Moritz.
238
239 Version 1.x, Copyright (c) 1997, Graham Barr.
240
241 This program is free software; you can redistribute it and/or
242 modify it under the same terms as Perl itself.
243
244 =cut
245