lib/AnyEvent/Strict.pm

=head1 NAME

AnyEvent::Strict - force strict mode on for the whole process

=head1 SYNOPSIS

   use AnyEvent::Strict;
   # strict mode now switched on

=head1 DESCRIPTION

This module implements AnyEvent's strict mode.

Loading it makes AnyEvent check all arguments to AnyEvent-methods, at the
expense of being slower (often the argument checking takes longer than the
actual function). It also wraps all callbacks to check for modifications
of C<$_>, which indicates a programming bug inside the watcher callback.

Normally, you don't load this module yourself but instead use it
indirectly via the C<PERL_ANYEVENT_STRICT> environment variable (see
L<AnyEvent>). However, this module can be loaded manually at any time.

=cut

package AnyEvent::Strict;

use Carp qw(croak);
use Fcntl ();

use AnyEvent (); BEGIN { AnyEvent::common_sense }

AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;

BEGIN {
   if (defined &Internals::SvREADONLY) {
      # readonly available (at least 5.8.9+, working better in 5.10.1+)
      *wrap = sub {
         my $cb = shift;

         sub {
            Internals::SvREADONLY $_, 1;
            &$cb;
            Internals::SvREADONLY $_, 0;
         }
      };
   } else {
      # or not :/
      my $magic = []; # a unique magic value

      *wrap = sub {
         my $cb = shift;

         sub {
            local $_ = $magic;

            &$cb;

            if (!ref $_ || $_ != $magic) {
               require AnyEvent::Debug;
               die "callback $cb (" . AnyEvent::Debug::cb2str ($cb) . ") modified \$_ without restoring it.\n";
            }
         }
      };
   }
}

our (@FD_INUSE, @FD_FH, $FD_I);
our $FD_CHECK_W = AE::timer 4, 4, sub {
   my $cnt = (@FD_INUSE < 100 * 10 ? int @FD_INUSE * 0.1 : 100) || 1;

   if ($FD_I <= 0) {
      #pop @FD_INUSE while @FD_INUSE && !$FD_INUSE[-1]; # also $FD_FH
      ($FD_I = @FD_INUSE) >= 0
         or return; # empty
   }

   $cnt = $FD_I + 1 if $cnt > $FD_I;

   eval {
      do {
         !$FD_FH[--$FD_I]
            or fcntl $FD_FH[$FD_I], Fcntl::F_GETFL(), 0
            or die;
      } while --$cnt;
      1
   } or AE::log crit => "file descriptor $FD_I registered with AnyEvent but prematurely closed, event loop might malfunction.\n";
};

sub io {
   my $class = shift;
   my (%arg, $fh, $cb) = @_;

   ref $arg{cb}
      or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'";
   $cb = wrap delete $arg{cb};
 
   $arg{poll} =~ /^[rw]$/
      or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'";

   $fh = delete $arg{fh};

   if ($fh =~ /^\s*\d+\s*$/) {
      $fh = AnyEvent::_dupfh $arg{poll}, $fh;
   } else {
      defined eval { fileno $fh }
         or croak "AnyEvent->io called with illegal fh argument '$fh'";
   }

   -f $fh
      and croak "AnyEvent->io called with fh argument pointing to a file";

   delete $arg{poll};
 
   croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   ++$FD_INUSE[fileno $fh];
   $FD_FH[fileno $$fh] = $fh;

   bless [
      fileno $fh,
      $class->SUPER::io (@_, cb => $cb)
   ], "AnyEvent::Strict::io";
}

sub AnyEvent::Strict::io::DESTROY {
   --$FD_INUSE[$_[0][0]]
      or delete $FD_FH[$_[0][0]];
}

sub timer {
   my $class = shift;
   my %arg = @_;

   ref $arg{cb}
      or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   exists $arg{after}
      or croak "AnyEvent->timer called without mandatory 'after' parameter";
   delete $arg{after};
 
   !$arg{interval} or $arg{interval} > 0
      or croak "AnyEvent->timer called with illegal interval argument '$arg{interval}'";
   delete $arg{interval};
 
   croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   $class->SUPER::timer (@_, cb => $cb)
}

sub signal {
   my $class = shift;
   my %arg = @_;

   ref $arg{cb}
      or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
      or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'";
   delete $arg{signal};
 
   croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   $class->SUPER::signal (@_, cb => $cb)
}

sub child {
   my $class = shift;
   my %arg = @_;

   ref $arg{cb}
      or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   $arg{pid} =~ /^-?\d+$/
      or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
   delete $arg{pid};
 
   croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   $class->SUPER::child (@_, cb => $cb)
}

sub idle {
   my $class = shift;
   my %arg = @_;

   ref $arg{cb}
      or croak "AnyEvent->idle called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   $class->SUPER::idle (@_, cb => $cb)
}

sub condvar {
   my $class = shift;
   my %arg = @_;

   !exists $arg{cb} or ref $arg{cb}
      or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
   my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
 
   croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

   $class->SUPER::condvar (@cb);
}

sub time {
   my $class = shift;

   @_
      and croak "AnyEvent->time wrongly called with paramaters";

   $class->SUPER::time (@_)
}

sub now {
   my $class = shift;

   @_
      and croak "AnyEvent->now wrongly called with paramaters";

   $class->SUPER::now (@_)
}

1;

=head1 AUTHOR

 Marc Lehmann <schmorp@schmorp.de>
 http://home.schmorp.de/

=cut

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