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

Diff Legend

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