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 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";
            }
         }
      };
   }
}

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

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

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

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

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

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

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.31
Committed:	Sun Aug 21 03:02:33 2011 UTC (12 years, 10 months ago) by root
Branch:	MAIN
CVS Tags:	rel-6_02, rel-6_01
Changes since 1.30:	+1 -1 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.2
29	root	1.17	use AnyEvent (); BEGIN { AnyEvent::common_sense }
30	root	1.1
31	root	1.31	AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;
32	root	1.1
33	root	1.30	BEGIN {
34			if (defined &Internals::SvREADONLY) {
35			# readonly available (at least 5.8.9+, working better in 5.10.1+)
36			*wrap = sub {
37			my $cb = shift;
38
39			sub {
40			Internals::SvREADONLY $_, 1;
41			&$cb;
42			Internals::SvREADONLY $_, 0;
43			}
44			};
45			} else {
46			# or not :/
47			my $magic = []; # a unique magic value
48	root	1.27
49	root	1.30	*wrap = sub {
50			my $cb = shift;
51	root	1.27
52	root	1.30	sub {
53			local $_ = $magic;
54	root	1.27
55	root	1.30	&$cb;
56
57			if (!ref $_ \|\| $_ != $magic) {
58			require AnyEvent::Debug;
59			die "callback $cb (" . AnyEvent::Debug::cb2str ($cb) . ") modified \$_ without restoring it.\n";
60			}
61			}
62			};
63	root	1.27	}
64			}
65
66	root	1.1	sub io {
67			my $class = shift;
68			my %arg = @_;
69
70			ref $arg{cb}
71			or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'";
72	root	1.27	my $cb = wrap delete $arg{cb};
73	root	1.1
74	root	1.13	$arg{poll} =~ /^[rw]$/
75			or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'";
76
77	root	1.21	if ($arg{fh} =~ /^\s\d+\s$/) {
78			$arg{fh} = AnyEvent::_dupfh $arg{poll}, $arg{fh};
79			} else {
80			defined eval { fileno $arg{fh} }
81	root	1.13	or croak "AnyEvent->io called with illegal fh argument '$arg{fh}'";
82			}
83
84	root	1.9	-f $arg{fh}
85			and croak "AnyEvent->io called with fh argument pointing to a file";
86	root	1.13
87			delete $arg{poll};
88	root	1.1	delete $arg{fh};
89
90			croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
91			if keys %arg;
92
93	root	1.27	$class->SUPER::io (@_, cb => $cb)
94	root	1.1	}
95
96			sub timer {
97			my $class = shift;
98			my %arg = @_;
99
100			ref $arg{cb}
101			or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
102	root	1.27	my $cb = wrap delete $arg{cb};
103	root	1.1
104			exists $arg{after}
105			or croak "AnyEvent->timer called without mandatory 'after' parameter";
106			delete $arg{after};
107
108			!$arg{interval} or $arg{interval} > 0
109			or croak "AnyEvent->timer called with illegal interval argument '$arg{interval}'";
110			delete $arg{interval};
111
112			croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
113			if keys %arg;
114
115	root	1.27	$class->SUPER::timer (@_, cb => $cb)
116	root	1.1	}
117
118			sub signal {
119			my $class = shift;
120			my %arg = @_;
121
122			ref $arg{cb}
123			or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
124	root	1.27	my $cb = wrap delete $arg{cb};
125	root	1.1
126	root	1.19	defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
127	root	1.1	or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'";
128			delete $arg{signal};
129
130			croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
131			if keys %arg;
132
133	root	1.27	$class->SUPER::signal (@_, cb => $cb)
134	root	1.1	}
135
136			sub child {
137			my $class = shift;
138			my %arg = @_;
139
140			ref $arg{cb}
141	root	1.11	or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
142	root	1.27	my $cb = wrap delete $arg{cb};
143	root	1.1
144			$arg{pid} =~ /^-?\d+$/
145	root	1.11	or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
146	root	1.1	delete $arg{pid};
147
148	root	1.11	croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
149	root	1.1	if keys %arg;
150
151	root	1.27	$class->SUPER::child (@_, cb => $cb)
152	root	1.1	}
153
154	root	1.12	sub idle {
155			my $class = shift;
156			my %arg = @_;
157
158			ref $arg{cb}
159			or croak "AnyEvent->idle called with illegal cb argument '$arg{cb}'";
160	root	1.27	my $cb = wrap delete $arg{cb};
161	root	1.12
162			croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
163			if keys %arg;
164
165	root	1.27	$class->SUPER::idle (@_, cb => $cb)
166	root	1.12	}
167
168	root	1.1	sub condvar {
169			my $class = shift;
170			my %arg = @_;
171
172			!exists $arg{cb} or ref $arg{cb}
173			or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
174	root	1.27	my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
175	root	1.1
176			croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
177			if keys %arg;
178
179	root	1.29	$class->SUPER::condvar (@cb);
180	root	1.1	}
181
182			sub time {
183			my $class = shift;
184
185			@_
186			and croak "AnyEvent->time wrongly called with paramaters";
187
188			$class->SUPER::time (@_)
189			}
190
191			sub now {
192			my $class = shift;
193
194			@_
195			and croak "AnyEvent->now wrongly called with paramaters";
196
197			$class->SUPER::now (@_)
198			}
199
200	root	1.5	1;
201
202			=head1 AUTHOR
203
204			Marc Lehmann <schmorp@schmorp.de>
205			http://home.schmorp.de/
206
207			=cut
208