ViewVC Help
View File | Revision Log | Show Annotations | Download File
/cvs/AnyEvent/lib/AnyEvent/Strict.pm
(Generate patch)

Comparing AnyEvent/lib/AnyEvent/Strict.pm (file contents):
Revision 1.4 by root, Wed Jul 9 11:00:02 2008 UTC vs.
Revision 1.35 by root, Fri Sep 2 04:35:03 2011 UTC

1=head1 NAME
2
3AnyEvent::Strict - force strict mode on for the whole process
4
5=head1 SYNOPSIS
6
7 use AnyEvent::Strict;
8 # strict mode now switched on
9
10=head1 DESCRIPTION
11
12This module implements AnyEvent's strict mode.
13
14Loading it makes AnyEvent check all arguments to AnyEvent-methods, at the
15expense of being slower (often the argument checking takes longer than the
16actual function). It also wraps all callbacks to check for modifications
17of C<$_>, which indicates a programming bug inside the watcher callback.
18
19Normally, you don't load this module yourself but instead use it
20indirectly via the C<PERL_ANYEVENT_STRICT> environment variable (see
21L<AnyEvent>). However, this module can be loaded manually at any time.
22
23=cut
24
1package AnyEvent::Strict; 25package AnyEvent::Strict;
2 26
3# supply checks for argument validity for many functions
4# this is an internal module. although it could be loaded
5# at any time, this is not really documented.
6
7use Carp qw(croak); 27use Carp qw(croak);
8use AnyEvent (); 28use Errno ();
29use POSIX ();
9 30
10AnyEvent::post_detect { 31use AnyEvent (); BEGIN { AnyEvent::common_sense }
11 # assume the first ISA member is the implementation 32
12 # # and link us in before it in the chain. 33AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;
13 my $MODEL = shift @AnyEvent::ISA; 34
14 unshift @ISA, $MODEL; 35BEGIN {
15 unshift @AnyEvent::ISA, AnyEvent::Strict:: 36 if (defined &Internals::SvREADONLY) {
37 # readonly available (at least 5.8.9+, working better in 5.10.1+)
38 *wrap = sub {
39 my $cb = shift;
40
41 sub {
42 Internals::SvREADONLY $_, 1;
43 &$cb;
44 Internals::SvREADONLY $_, 0;
45 }
46 };
47 } else {
48 # or not :/
49 my $magic = []; # a unique magic value
50
51 *wrap = sub {
52 my $cb = shift;
53
54 sub {
55 local $_ = $magic;
56
57 &$cb;
58
59 if (!ref $_ || $_ != $magic) {
60 require AnyEvent::Debug;
61 die "callback $cb (" . AnyEvent::Debug::cb2str ($cb) . ") modified \$_ without restoring it.\n";
62 }
63 }
64 };
65 }
66}
67
68our (@FD_INUSE, $FD_I);
69our $FD_CHECK_W = AE::timer 4, 4, sub {
70 my $cnt = (@FD_INUSE < 100 * 10 ? int @FD_INUSE * 0.1 : 100) || 10;
71
72 if ($FD_I <= 0) {
73 #pop @FD_INUSE while @FD_INUSE && !$FD_INUSE[-1];
74 ($FD_I = @FD_INUSE) >= 0
75 or return; # empty
76 }
77
78 $cnt = $FD_I if $cnt > $FD_I;
79
80 eval {
81 do {
82 !$FD_INUSE[--$FD_I]
83 or (POSIX::lseek $FD_I, 0, 1) != -1
84 or $! != Errno::EBADF
85 or die;
86 } while --$cnt;
87 1
88 } or AE::log crit => "file descriptor $FD_I registered with AnyEvent but prematurely closed, event loop might malfunction.\n";
16}; 89};
17 90
18sub io { 91sub io {
19 my $class = shift; 92 my $class = shift;
20 my %arg = @_; 93 my (%arg, $fh, $cb, $fd) = @_;
21 94
22 ref $arg{cb} 95 ref $arg{cb}
23 or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'"; 96 or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'";
24 delete $arg{cb}; 97 $cb = wrap delete $arg{cb};
25
26 fileno $arg{fh}
27 or croak "AnyEvent->io called with illegal fh argument '$arg{fh}'";
28 delete $arg{fh};
29 98
30 $arg{poll} =~ /^[rw]$/ 99 $arg{poll} =~ /^[rw]$/
31 or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'"; 100 or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'";
101
102 $fh = delete $arg{fh};
103
104 if ($fh =~ /^\s*\d+\s*$/) {
105 $fd = $fh;
106 $fh = AnyEvent::_dupfh $arg{poll}, $fh;
107 } else {
108 defined eval { $fd = fileno $fh }
109 or croak "AnyEvent->io called with illegal fh argument '$fh'";
110 }
111
112 -f $fh
113 and croak "AnyEvent->io called with fh argument pointing to a file";
114
32 delete $arg{poll}; 115 delete $arg{poll};
33 116
34 croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg 117 croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
35 if keys %arg; 118 if keys %arg;
36 119
120 ++$FD_INUSE[$fd];
121
122 bless [
123 $fd,
37 $class->SUPER::io (@_) 124 $class->SUPER::io (@_, cb => $cb)
125 ], "AnyEvent::Strict::io";
126}
127
128sub AnyEvent::Strict::io::DESTROY {
129 --$FD_INUSE[$_[0][0]];
38} 130}
39 131
40sub timer { 132sub timer {
41 my $class = shift; 133 my $class = shift;
42 my %arg = @_; 134 my %arg = @_;
43 135
44 ref $arg{cb} 136 ref $arg{cb}
45 or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'"; 137 or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
46 delete $arg{cb}; 138 my $cb = wrap delete $arg{cb};
47 139
48 exists $arg{after} 140 exists $arg{after}
49 or croak "AnyEvent->timer called without mandatory 'after' parameter"; 141 or croak "AnyEvent->timer called without mandatory 'after' parameter";
50 delete $arg{after}; 142 delete $arg{after};
51 143
… …
54 delete $arg{interval}; 146 delete $arg{interval};
55 147
56 croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg 148 croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
57 if keys %arg; 149 if keys %arg;
58 150
59 $class->SUPER::timer (@_) 151 $class->SUPER::timer (@_, cb => $cb)
60} 152}
61 153
62sub signal { 154sub signal {
63 my $class = shift; 155 my $class = shift;
64 my %arg = @_; 156 my %arg = @_;
65 157
66 ref $arg{cb} 158 ref $arg{cb}
67 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'"; 159 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
68 delete $arg{cb}; 160 my $cb = wrap delete $arg{cb};
69 161
70 eval "require POSIX; 0 < &POSIX::SIG$arg{signal}" 162 defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
71 or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'"; 163 or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'";
72 delete $arg{signal}; 164 delete $arg{signal};
73 165
74 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg 166 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
75 if keys %arg; 167 if keys %arg;
76 168
77 $class->SUPER::signal (@_) 169 $class->SUPER::signal (@_, cb => $cb)
78} 170}
79 171
80sub child { 172sub child {
81 my $class = shift; 173 my $class = shift;
82 my %arg = @_; 174 my %arg = @_;
83 175
84 ref $arg{cb} 176 ref $arg{cb}
85 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'"; 177 or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
86 delete $arg{cb}; 178 my $cb = wrap delete $arg{cb};
87 179
88 $arg{pid} =~ /^-?\d+$/ 180 $arg{pid} =~ /^-?\d+$/
89 or croak "AnyEvent->signal called with illegal pid value '$arg{pid}'"; 181 or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
90 delete $arg{pid}; 182 delete $arg{pid};
91 183
184 croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
185 if keys %arg;
186
187 $class->SUPER::child (@_, cb => $cb)
188}
189
190sub idle {
191 my $class = shift;
192 my %arg = @_;
193
194 ref $arg{cb}
195 or croak "AnyEvent->idle called with illegal cb argument '$arg{cb}'";
196 my $cb = wrap delete $arg{cb};
197
92 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg 198 croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
93 if keys %arg; 199 if keys %arg;
94 200
95 $class->SUPER::child (@_) 201 $class->SUPER::idle (@_, cb => $cb)
96} 202}
97 203
98sub condvar { 204sub condvar {
99 my $class = shift; 205 my $class = shift;
100 my %arg = @_; 206 my %arg = @_;
101 207
102 !exists $arg{cb} or ref $arg{cb} 208 !exists $arg{cb} or ref $arg{cb}
103 or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'"; 209 or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
104 delete $arg{cb}; 210 my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
105 211
106 croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg 212 croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
107 if keys %arg; 213 if keys %arg;
108 214
109 $class->SUPER::condvar (@_) 215 $class->SUPER::condvar (@cb);
110} 216}
111 217
112sub time { 218sub time {
113 my $class = shift; 219 my $class = shift;
114 220
… …
125 and croak "AnyEvent->now wrongly called with paramaters"; 231 and croak "AnyEvent->now wrongly called with paramaters";
126 232
127 $class->SUPER::now (@_) 233 $class->SUPER::now (@_)
128} 234}
129 235
1301 2361;
237
238=head1 AUTHOR
239
240 Marc Lehmann <schmorp@schmorp.de>
241 http://home.schmorp.de/
242
243=cut
244

Diff Legend

– Removed lines
+ Added lines
< Changed lines
> Changed lines