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.24 by root, Sun Nov 14 02:26:52 2010 UTC vs.
Revision 1.35 by root, Fri Sep 2 04:35:03 2011 UTC

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

Diff Legend

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