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(confess);
use Errno ();
use POSIX ();

$Carp::Internal{AE}               = 1;
$Carp::Internal{AnyEvent::Strict} = 1;

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 {
            local $_;
            Internals::SvREADONLY $_, 1;
            &$cb;
         }
      };
   } 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_I);
our $FD_CHECK_W = AE::timer 4, 4, sub {
   my $cnt = (@FD_INUSE < 100 * 10 ? int @FD_INUSE * 0.1 : 100) || 10;

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

   $cnt = $FD_I if $cnt > $FD_I;

   eval {
      do {
         !$FD_INUSE[--$FD_I]
            or (POSIX::lseek $FD_I, 0, 1) != -1
            or $! != Errno::EBADF
            or die;
      } while --$cnt;
      1
   } or AE::log crit => "File descriptor $FD_I registered with AnyEvent but prematurely closed, event loop might malfunction.";
};

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

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

   $fh = delete $arg{fh};

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

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

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

   ++$FD_INUSE[$fd];

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

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

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

   ref $arg{cb}
      or confess "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   exists $arg{after}
      or confess "AnyEvent->timer called without mandatory 'after' parameter";
   delete $arg{after};
 
   !$arg{interval} or $arg{interval} > 0
      or confess "AnyEvent->timer called with illegal interval argument '$arg{interval}'";
   delete $arg{interval};
 
   confess "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 confess "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 confess "AnyEvent->signal called with illegal signal name '$arg{signal}'";
   delete $arg{signal};
 
   confess "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 confess "AnyEvent->child called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   $arg{pid} =~ /^-?\d+$/
      or confess "AnyEvent->child called with malformed pid value '$arg{pid}'";
   delete $arg{pid};
 
   confess "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 confess "AnyEvent->idle called with illegal cb argument '$arg{cb}'";
   my $cb = wrap delete $arg{cb};
 
   confess "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 confess "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
   my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
 
   confess "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
      if keys %arg;

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

sub time {
   my $class = shift;

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

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

sub now {
   my $class = shift;

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

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

=head1 AUTHOR

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

=cut

1

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