This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #31843] warnings::warn($obj,...) fails when $obj overloads ""
[perl5.git] / lib / warnings.pm
1
2 # !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!
3 # This file was created by warnings.pl
4 # Any changes made here will be lost.
5 #
6
7 package warnings;
8
9 our $VERSION = '1.03';
10
11 =head1 NAME
12
13 warnings - Perl pragma to control optional warnings
14
15 =head1 SYNOPSIS
16
17     use warnings;
18     no warnings;
19
20     use warnings "all";
21     no warnings "all";
22
23     use warnings::register;
24     if (warnings::enabled()) {
25         warnings::warn("some warning");
26     }
27
28     if (warnings::enabled("void")) {
29         warnings::warn("void", "some warning");
30     }
31
32     if (warnings::enabled($object)) {
33         warnings::warn($object, "some warning");
34     }
35
36     warnings::warnif("some warning");
37     warnings::warnif("void", "some warning");
38     warnings::warnif($object, "some warning");
39
40 =head1 DESCRIPTION
41
42 The C<warnings> pragma is a replacement for the command line flag C<-w>,
43 but the pragma is limited to the enclosing block, while the flag is global.
44 See L<perllexwarn> for more information.
45
46 If no import list is supplied, all possible warnings are either enabled
47 or disabled.
48
49 A number of functions are provided to assist module authors.
50
51 =over 4
52
53 =item use warnings::register
54
55 Creates a new warnings category with the same name as the package where
56 the call to the pragma is used.
57
58 =item warnings::enabled()
59
60 Use the warnings category with the same name as the current package.
61
62 Return TRUE if that warnings category is enabled in the calling module.
63 Otherwise returns FALSE.
64
65 =item warnings::enabled($category)
66
67 Return TRUE if the warnings category, C<$category>, is enabled in the
68 calling module.
69 Otherwise returns FALSE.
70
71 =item warnings::enabled($object)
72
73 Use the name of the class for the object reference, C<$object>, as the
74 warnings category.
75
76 Return TRUE if that warnings category is enabled in the first scope
77 where the object is used.
78 Otherwise returns FALSE.
79
80 =item warnings::warn($message)
81
82 Print C<$message> to STDERR.
83
84 Use the warnings category with the same name as the current package.
85
86 If that warnings category has been set to "FATAL" in the calling module
87 then die. Otherwise return.
88
89 =item warnings::warn($category, $message)
90
91 Print C<$message> to STDERR.
92
93 If the warnings category, C<$category>, has been set to "FATAL" in the
94 calling module then die. Otherwise return.
95
96 =item warnings::warn($object, $message)
97
98 Print C<$message> to STDERR.
99
100 Use the name of the class for the object reference, C<$object>, as the
101 warnings category.
102
103 If that warnings category has been set to "FATAL" in the scope where C<$object>
104 is first used then die. Otherwise return.
105
106
107 =item warnings::warnif($message)
108
109 Equivalent to:
110
111     if (warnings::enabled())
112       { warnings::warn($message) }
113
114 =item warnings::warnif($category, $message)
115
116 Equivalent to:
117
118     if (warnings::enabled($category))
119       { warnings::warn($category, $message) }
120
121 =item warnings::warnif($object, $message)
122
123 Equivalent to:
124
125     if (warnings::enabled($object))
126       { warnings::warn($object, $message) }
127
128 =back
129
130 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
131
132 =cut
133
134 use Carp ();
135
136 our %Offsets = (
137
138     # Warnings Categories added in Perl 5.008
139
140     'all'               => 0,
141     'closure'           => 2,
142     'deprecated'        => 4,
143     'exiting'           => 6,
144     'glob'              => 8,
145     'io'                => 10,
146     'closed'            => 12,
147     'exec'              => 14,
148     'layer'             => 16,
149     'newline'           => 18,
150     'pipe'              => 20,
151     'unopened'          => 22,
152     'misc'              => 24,
153     'numeric'           => 26,
154     'once'              => 28,
155     'overflow'          => 30,
156     'pack'              => 32,
157     'portable'          => 34,
158     'recursion'         => 36,
159     'redefine'          => 38,
160     'regexp'            => 40,
161     'severe'            => 42,
162     'debugging'         => 44,
163     'inplace'           => 46,
164     'internal'          => 48,
165     'malloc'            => 50,
166     'signal'            => 52,
167     'substr'            => 54,
168     'syntax'            => 56,
169     'ambiguous'         => 58,
170     'bareword'          => 60,
171     'digit'             => 62,
172     'parenthesis'       => 64,
173     'precedence'        => 66,
174     'printf'            => 68,
175     'prototype'         => 70,
176     'qw'                => 72,
177     'reserved'          => 74,
178     'semicolon'         => 76,
179     'taint'             => 78,
180     'threads'           => 80,
181     'uninitialized'     => 82,
182     'unpack'            => 84,
183     'untie'             => 86,
184     'utf8'              => 88,
185     'void'              => 90,
186     'y2k'               => 92,
187
188     # Warnings Categories added in Perl 5.009
189
190     'assertions'        => 94,
191   );
192
193 our %Bits = (
194     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55", # [0..47]
195     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
196     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40", # [47]
197     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
198     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
199     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
200     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
201     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
202     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
203     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
204     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
205     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
206     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
207     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
208     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
209     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
210     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
211     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
212     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
213     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
214     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
215     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
216     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
217     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
218     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
219     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
220     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
221     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
222     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
223     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
224     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
225     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
226     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
227     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
228     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
229     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
230     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
231     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
232     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
233     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
234     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
235     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
236     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
237     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
238     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
239     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
240     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
241     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
242   );
243
244 our %DeadBits = (
245     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa", # [0..47]
246     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
247     'assertions'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80", # [47]
248     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
249     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
250     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
251     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
252     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
253     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
254     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
255     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
256     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
257     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
258     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
259     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
260     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
261     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
262     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
263     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
264     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
265     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
266     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
267     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
268     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
269     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
270     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
271     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
272     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
273     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
274     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
275     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
276     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
277     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
278     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
279     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
280     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
281     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
282     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
283     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
284     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
285     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
286     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
287     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
288     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
289     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
290     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
291     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
292     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
293   );
294
295 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
296 $LAST_BIT = 96 ;
297 $BYTES    = 12 ;
298
299 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
300
301 sub Croaker
302 {
303     delete $Carp::CarpInternal{'warnings'};
304     Carp::croak(@_);
305 }
306
307 sub bits
308 {
309     # called from B::Deparse.pm
310
311     push @_, 'all' unless @_;
312
313     my $mask;
314     my $catmask ;
315     my $fatal = 0 ;
316     my $no_fatal = 0 ;
317
318     foreach my $word ( @_ ) {
319         if ($word eq 'FATAL') {
320             $fatal = 1;
321             $no_fatal = 0;
322         }
323         elsif ($word eq 'NONFATAL') {
324             $fatal = 0;
325             $no_fatal = 1;
326         }
327         elsif ($catmask = $Bits{$word}) {
328             $mask |= $catmask ;
329             $mask |= $DeadBits{$word} if $fatal ;
330             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
331         }
332         else
333           { Croaker("Unknown warnings category '$word'")}
334     }
335
336     return $mask ;
337 }
338
339 sub import 
340 {
341     shift;
342
343     my $catmask ;
344     my $fatal = 0 ;
345     my $no_fatal = 0 ;
346
347     my $mask = ${^WARNING_BITS} ;
348
349     if (vec($mask, $Offsets{'all'}, 1)) {
350         $mask |= $Bits{'all'} ;
351         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
352     }
353     
354     push @_, 'all' unless @_;
355
356     foreach my $word ( @_ ) {
357         if ($word eq 'FATAL') {
358             $fatal = 1;
359             $no_fatal = 0;
360         }
361         elsif ($word eq 'NONFATAL') {
362             $fatal = 0;
363             $no_fatal = 1;
364         }
365         elsif ($catmask = $Bits{$word}) {
366             $mask |= $catmask ;
367             $mask |= $DeadBits{$word} if $fatal ;
368             $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
369         }
370         else
371           { Croaker("Unknown warnings category '$word'")}
372     }
373
374     ${^WARNING_BITS} = $mask ;
375 }
376
377 sub unimport 
378 {
379     shift;
380
381     my $catmask ;
382     my $mask = ${^WARNING_BITS} ;
383
384     if (vec($mask, $Offsets{'all'}, 1)) {
385         $mask |= $Bits{'all'} ;
386         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
387     }
388
389     push @_, 'all' unless @_;
390
391     foreach my $word ( @_ ) {
392         if ($word eq 'FATAL') {
393             next; 
394         }
395         elsif ($catmask = $Bits{$word}) {
396             $mask &= ~($catmask | $DeadBits{$word} | $All);
397         }
398         else
399           { Croaker("Unknown warnings category '$word'")}
400     }
401
402     ${^WARNING_BITS} = $mask ;
403 }
404
405 my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
406
407 sub __chk
408 {
409     my $category ;
410     my $offset ;
411     my $isobj = 0 ;
412
413     if (@_) {
414         # check the category supplied.
415         $category = shift ;
416         if (my $type = ref $category) {
417             Croaker("not an object")
418                 if exists $builtin_type{$type};
419             $category = $type;
420             $isobj = 1 ;
421         }
422         $offset = $Offsets{$category};
423         Croaker("Unknown warnings category '$category'")
424             unless defined $offset;
425     }
426     else {
427         $category = (caller(1))[0] ;
428         $offset = $Offsets{$category};
429         Croaker("package '$category' not registered for warnings")
430             unless defined $offset ;
431     }
432
433     my $this_pkg = (caller(1))[0] ;
434     my $i = 2 ;
435     my $pkg ;
436
437     if ($isobj) {
438         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
439             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
440         }
441         $i -= 2 ;
442     }
443     else {
444         $i = _error_loc(); # see where Carp will allocate the error
445     }
446
447     my $callers_bitmask = (caller($i))[9] ;
448     return ($callers_bitmask, $offset, $i) ;
449 }
450
451 sub _error_loc {
452     require Carp::Heavy;
453     goto &Carp::short_error_loc; # don't introduce another stack frame
454 }                                                             
455
456 sub enabled
457 {
458     Croaker("Usage: warnings::enabled([category])")
459         unless @_ == 1 || @_ == 0 ;
460
461     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
462
463     return 0 unless defined $callers_bitmask ;
464     return vec($callers_bitmask, $offset, 1) ||
465            vec($callers_bitmask, $Offsets{'all'}, 1) ;
466 }
467
468
469 sub warn
470 {
471     Croaker("Usage: warnings::warn([category,] 'message')")
472         unless @_ == 2 || @_ == 1 ;
473
474     my $message = pop ;
475     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
476     Carp::croak($message)
477         if vec($callers_bitmask, $offset+1, 1) ||
478            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
479     Carp::carp($message) ;
480 }
481
482 sub warnif
483 {
484     Croaker("Usage: warnings::warnif([category,] 'message')")
485         unless @_ == 2 || @_ == 1 ;
486
487     my $message = pop ;
488     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
489
490     return
491         unless defined $callers_bitmask &&
492                 (vec($callers_bitmask, $offset, 1) ||
493                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
494
495     Carp::croak($message)
496         if vec($callers_bitmask, $offset+1, 1) ||
497            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
498
499     Carp::carp($message) ;
500 }
501
502 1;