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

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_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];
      ($FD_I = @FD_INUSE) >= 0
         or return; # empty
   }

   $cnt = $FD_I + 1 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.\n";
};

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

   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*$/) {
      $fd = $fh;
      $fh = AnyEvent::_dupfh $arg{poll}, $fh;
   } else {
      defined eval { $fd = 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[$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 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.33
Committed:	Fri Sep 2 04:29:11 2011 UTC (12 years, 9 months ago) by root
Branch:	MAIN
Changes since 1.32:	+13 -12 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.5	use Carp qw(croak);
28	root	1.33	use Errno ();
29			use POSIX ();
30	root	1.2
31	root	1.17	use AnyEvent (); BEGIN { AnyEvent::common_sense }
32	root	1.1
33	root	1.31	AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;
34	root	1.1
35	root	1.30	BEGIN {
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	root	1.27
51	root	1.30	*wrap = sub {
52			my $cb = shift;
53	root	1.27
54	root	1.30	sub {
55			local $_ = $magic;
56	root	1.27
57	root	1.30	&$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	root	1.27	}
66			}
67
68	root	1.33	our (@FD_INUSE, $FD_I);
69	root	1.32	our $FD_CHECK_W = AE::timer 4, 4, sub {
70			my $cnt = (@FD_INUSE < 100 * 10 ? int @FD_INUSE * 0.1 : 100) \|\| 1;
71
72			if ($FD_I <= 0) {
73	root	1.33	#pop @FD_INUSE while @FD_INUSE && !$FD_INUSE[-1];
74	root	1.32	($FD_I = @FD_INUSE) >= 0
75			or return; # empty
76			}
77
78			$cnt = $FD_I + 1 if $cnt > $FD_I;
79
80			eval {
81			do {
82	root	1.33	!$FD_INUSE[--$FD_I]
83			or (POSIX::lseek $FD_I, 0, 1) != -1
84			or $! != Errno::EBADF
85	root	1.32	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";
89			};
90
91	root	1.1	sub io {
92			my $class = shift;
93	root	1.33	my (%arg, $fh, $cb, $fd) = @_;
94	root	1.1
95			ref $arg{cb}
96			or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'";
97	root	1.32	$cb = wrap delete $arg{cb};
98	root	1.1
99	root	1.13	$arg{poll} =~ /^[rw]$/
100			or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'";
101
102	root	1.32	$fh = delete $arg{fh};
103
104			if ($fh =~ /^\s\d+\s$/) {
105	root	1.33	$fd = $fh;
106	root	1.32	$fh = AnyEvent::_dupfh $arg{poll}, $fh;
107	root	1.21	} else {
108	root	1.33	defined eval { $fd = fileno $fh }
109	root	1.32	or croak "AnyEvent->io called with illegal fh argument '$fh'";
110	root	1.13	}
111
112	root	1.32	-f $fh
113	root	1.9	and croak "AnyEvent->io called with fh argument pointing to a file";
114	root	1.13
115			delete $arg{poll};
116	root	1.1
117			croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
118			if keys %arg;
119
120	root	1.33	++$FD_INUSE[$fd];
121	root	1.32
122			bless [
123	root	1.33	$fd,
124	root	1.32	$class->SUPER::io (@_, cb => $cb)
125			], "AnyEvent::Strict::io";
126			}
127
128			sub AnyEvent::Strict::io::DESTROY {
129	root	1.33	--$FD_INUSE[$_[0][0]];
130	root	1.1	}
131
132			sub timer {
133			my $class = shift;
134			my %arg = @_;
135
136			ref $arg{cb}
137			or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
138	root	1.27	my $cb = wrap delete $arg{cb};
139	root	1.1
140			exists $arg{after}
141			or croak "AnyEvent->timer called without mandatory 'after' parameter";
142			delete $arg{after};
143
144			!$arg{interval} or $arg{interval} > 0
145			or croak "AnyEvent->timer called with illegal interval argument '$arg{interval}'";
146			delete $arg{interval};
147
148			croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
149			if keys %arg;
150
151	root	1.27	$class->SUPER::timer (@_, cb => $cb)
152	root	1.1	}
153
154			sub signal {
155			my $class = shift;
156			my %arg = @_;
157
158			ref $arg{cb}
159			or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
160	root	1.27	my $cb = wrap delete $arg{cb};
161	root	1.1
162	root	1.19	defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
163	root	1.1	or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'";
164			delete $arg{signal};
165
166			croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
167			if keys %arg;
168
169	root	1.27	$class->SUPER::signal (@_, cb => $cb)
170	root	1.1	}
171
172			sub child {
173			my $class = shift;
174			my %arg = @_;
175
176			ref $arg{cb}
177	root	1.11	or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
178	root	1.27	my $cb = wrap delete $arg{cb};
179	root	1.1
180			$arg{pid} =~ /^-?\d+$/
181	root	1.11	or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
182	root	1.1	delete $arg{pid};
183
184	root	1.11	croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
185	root	1.1	if keys %arg;
186
187	root	1.27	$class->SUPER::child (@_, cb => $cb)
188	root	1.1	}
189
190	root	1.12	sub 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	root	1.27	my $cb = wrap delete $arg{cb};
197	root	1.12
198			croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
199			if keys %arg;
200
201	root	1.27	$class->SUPER::idle (@_, cb => $cb)
202	root	1.12	}
203
204	root	1.1	sub condvar {
205			my $class = shift;
206			my %arg = @_;
207
208			!exists $arg{cb} or ref $arg{cb}
209			or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
210	root	1.27	my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
211	root	1.1
212			croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
213			if keys %arg;
214
215	root	1.29	$class->SUPER::condvar (@cb);
216	root	1.1	}
217
218			sub time {
219			my $class = shift;
220
221			@_
222			and croak "AnyEvent->time wrongly called with paramaters";
223
224			$class->SUPER::time (@_)
225			}
226
227			sub now {
228			my $class = shift;
229
230			@_
231			and croak "AnyEvent->now wrongly called with paramaters";
232
233			$class->SUPER::now (@_)
234			}
235
236	root	1.5	1;
237
238			=head1 AUTHOR
239
240			Marc Lehmann <schmorp@schmorp.de>
241			http://home.schmorp.de/
242
243			=cut
244