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.1 by root, Tue Jul 8 23:53:37 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
3use Carp qw(croak); 27use Carp qw(croak);
4use AnyEvent (); 28use Errno ();
29use POSIX ();
5 30
6AnyEvent::post_detect { 31use AnyEvent (); BEGIN { AnyEvent::common_sense }
7 my $MODEL = shift @AnyEvent::ISA; 32
8 unshift @ISA, $MODEL; 33AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;
9 unshift @AnyEvent::ISA, AnyEvent::Strict:: 34
35BEGIN {
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";
10}; 89};
11 90
12# supply checks for argument validity for many functions
13
14sub io { 91sub io {
15 my $class = shift; 92 my $class = shift;
16 my %arg = @_; 93 my (%arg, $fh, $cb, $fd) = @_;
17 94
18 ref $arg{cb} 95 ref $arg{cb}
19 or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'"; 96 or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'";
20 delete $arg{cb}; 97 $cb = wrap delete $arg{cb};
21
22 fileno $arg{fh}
23 or croak "AnyEvent->io called with illegal fh argument '$arg{fh}'";
24 delete $arg{fh};
25 98
26 $arg{poll} =~ /^[rw]$/ 99 $arg{poll} =~ /^[rw]$/
27 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
28 delete $arg{poll}; 115 delete $arg{poll};
29 116
30 croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg 117 croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
31 if keys %arg; 118 if keys %arg;
32 119
120 ++$FD_INUSE[$fd];
121
122 bless [
123 $fd,
33 $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]];
34} 130}
35 131
36sub timer { 132sub timer {
37 my $class = shift; 133 my $class = shift;
38 my %arg = @_; 134 my %arg = @_;
39 135
40 ref $arg{cb} 136 ref $arg{cb}
41 or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'"; 137 or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
42 delete $arg{cb}; 138 my $cb = wrap delete $arg{cb};
43 139
44 exists $arg{after} 140 exists $arg{after}
45 or croak "AnyEvent->timer called without mandatory 'after' parameter"; 141 or croak "AnyEvent->timer called without mandatory 'after' parameter";
46 delete $arg{after}; 142 delete $arg{after};
47 143
… …
50 delete $arg{interval}; 146 delete $arg{interval};
51 147
52 croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg 148 croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
53 if keys %arg; 149 if keys %arg;
54 150
55 $class->SUPER::timer (@_) 151 $class->SUPER::timer (@_, cb => $cb)
56} 152}
57 153
58sub signal { 154sub signal {
59 my $class = shift; 155 my $class = shift;
60 my %arg = @_; 156 my %arg = @_;
61 157
62 ref $arg{cb} 158 ref $arg{cb}
63 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'"; 159 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
64 delete $arg{cb}; 160 my $cb = wrap delete $arg{cb};
65 161
66 eval "require POSIX; defined &POSIX::SIG$arg{signal}" 162 defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
67 or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'"; 163 or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'";
68 delete $arg{signal}; 164 delete $arg{signal};
69 165
70 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg 166 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
71 if keys %arg; 167 if keys %arg;
72 168
73 $class->SUPER::signal (@_) 169 $class->SUPER::signal (@_, cb => $cb)
74} 170}
75 171
76sub child { 172sub child {
77 my $class = shift; 173 my $class = shift;
78 my %arg = @_; 174 my %arg = @_;
79 175
80 ref $arg{cb} 176 ref $arg{cb}
81 or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'"; 177 or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
82 delete $arg{cb}; 178 my $cb = wrap delete $arg{cb};
83 179
84 $arg{pid} =~ /^-?\d+$/ 180 $arg{pid} =~ /^-?\d+$/
85 or croak "AnyEvent->signal called with illegal pid value '$arg{pid}'"; 181 or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
86 delete $arg{pid}; 182 delete $arg{pid};
87 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
88 croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg 198 croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
89 if keys %arg; 199 if keys %arg;
90 200
91 $class->SUPER::child (@_) 201 $class->SUPER::idle (@_, cb => $cb)
92} 202}
93 203
94sub condvar { 204sub condvar {
95 my $class = shift; 205 my $class = shift;
96 my %arg = @_; 206 my %arg = @_;
97 207
98 !exists $arg{cb} or ref $arg{cb} 208 !exists $arg{cb} or ref $arg{cb}
99 or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'"; 209 or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
100 delete $arg{cb}; 210 my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
101 211
102 croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg 212 croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
103 if keys %arg; 213 if keys %arg;
104 214
105 $class->SUPER::condvar (@_) 215 $class->SUPER::condvar (@cb);
106} 216}
107 217
108sub time { 218sub time {
109 my $class = shift; 219 my $class = shift;
110 220
… …
121 and croak "AnyEvent->now wrongly called with paramaters"; 231 and croak "AnyEvent->now wrongly called with paramaters";
122 232
123 $class->SUPER::now (@_) 233 $class->SUPER::now (@_)
124} 234}
125 235
1261 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