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 0 => "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.30
Committed:	Thu Aug 18 19:35:15 2011 UTC (12 years, 10 months ago) by root
Branch:	MAIN
Changes since 1.29:	+28 -12 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
29	use AnyEvent (); BEGIN { AnyEvent::common_sense }
30
31	AnyEvent::_isa_hook 0 => "AnyEvent::Strict", 1;
32
33	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
49	*wrap = sub {
50	my $cb = shift;
51
52	sub {
53	local $_ = $magic;
54
55	&$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	}
64	}
65
66	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	my $cb = wrap delete $arg{cb};
73
74	$arg{poll} =~ /^[rw]$/
75	or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'";
76
77	if ($arg{fh} =~ /^\s\d+\s$/) {
78	$arg{fh} = AnyEvent::_dupfh $arg{poll}, $arg{fh};
79	} else {
80	defined eval { fileno $arg{fh} }
81	or croak "AnyEvent->io called with illegal fh argument '$arg{fh}'";
82	}
83
84	-f $arg{fh}
85	and croak "AnyEvent->io called with fh argument pointing to a file";
86
87	delete $arg{poll};
88	delete $arg{fh};
89
90	croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
91	if keys %arg;
92
93	$class->SUPER::io (@_, cb => $cb)
94	}
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	my $cb = wrap delete $arg{cb};
103
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	$class->SUPER::timer (@_, cb => $cb)
116	}
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	my $cb = wrap delete $arg{cb};
125
126	defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
127	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	$class->SUPER::signal (@_, cb => $cb)
134	}
135
136	sub child {
137	my $class = shift;
138	my %arg = @_;
139
140	ref $arg{cb}
141	or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'";
142	my $cb = wrap delete $arg{cb};
143
144	$arg{pid} =~ /^-?\d+$/
145	or croak "AnyEvent->child called with malformed pid value '$arg{pid}'";
146	delete $arg{pid};
147
148	croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
149	if keys %arg;
150
151	$class->SUPER::child (@_, cb => $cb)
152	}
153
154	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	my $cb = wrap delete $arg{cb};
161
162	croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
163	if keys %arg;
164
165	$class->SUPER::idle (@_, cb => $cb)
166	}
167
168	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	my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
175
176	croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
177	if keys %arg;
178
179	$class->SUPER::condvar (@cb);
180	}
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	1;
201
202	=head1 AUTHOR
203
204	Marc Lehmann <schmorp@schmorp.de>
205	http://home.schmorp.de/
206
207	=cut
208