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;

my $magic = [];

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