[ PATCH ] mymalloc on HP-UX
[p5sagit/p5-mst-13.2.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.00';
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 If no import list is supplied, all possible warnings are either enabled
43 or disabled.
44
45 A number of functions are provided to assist module authors.
46
47 =over 4
48
49 =item use warnings::register
50
51 Creates a new warnings category with the same name as the package where
52 the call to the pragma is used.
53
54 =item warnings::enabled()
55
56 Use the warnings category with the same name as the current package.
57
58 Return TRUE if that warnings category is enabled in the calling module.
59 Otherwise returns FALSE.
60
61 =item warnings::enabled($category)
62
63 Return TRUE if the warnings category, C<$category>, is enabled in the
64 calling module.
65 Otherwise returns FALSE.
66
67 =item warnings::enabled($object)
68
69 Use the name of the class for the object reference, C<$object>, as the
70 warnings category.
71
72 Return TRUE if that warnings category is enabled in the first scope
73 where the object is used.
74 Otherwise returns FALSE.
75
76 =item warnings::warn($message)
77
78 Print C<$message> to STDERR.
79
80 Use the warnings category with the same name as the current package.
81
82 If that warnings category has been set to "FATAL" in the calling module
83 then die. Otherwise return.
84
85 =item warnings::warn($category, $message)
86
87 Print C<$message> to STDERR.
88
89 If the warnings category, C<$category>, has been set to "FATAL" in the
90 calling module then die. Otherwise return.
91
92 =item warnings::warn($object, $message)
93
94 Print C<$message> to STDERR.
95
96 Use the name of the class for the object reference, C<$object>, as the
97 warnings category.
98
99 If that warnings category has been set to "FATAL" in the scope where C<$object>
100 is first used then die. Otherwise return.
101
102
103 =item warnings::warnif($message)
104
105 Equivalent to:
106
107     if (warnings::enabled())
108       { warnings::warn($message) }
109
110 =item warnings::warnif($category, $message)
111
112 Equivalent to:
113
114     if (warnings::enabled($category))
115       { warnings::warn($category, $message) }
116
117 =item warnings::warnif($object, $message)
118
119 Equivalent to:
120
121     if (warnings::enabled($object))
122       { warnings::warn($object, $message) }
123
124 =back
125
126 See L<perlmodlib/Pragmatic Modules> and L<perllexwarn>.
127
128 =cut
129
130 use Carp ;
131
132 %Offsets = (
133
134     # Warnings Categories added in Perl 5.008
135
136     'all'               => 0,
137     'closure'           => 2,
138     'deprecated'        => 4,
139     'exiting'           => 6,
140     'glob'              => 8,
141     'io'                => 10,
142     'closed'            => 12,
143     'exec'              => 14,
144     'layer'             => 16,
145     'newline'           => 18,
146     'pipe'              => 20,
147     'unopened'          => 22,
148     'misc'              => 24,
149     'numeric'           => 26,
150     'once'              => 28,
151     'overflow'          => 30,
152     'pack'              => 32,
153     'portable'          => 34,
154     'recursion'         => 36,
155     'redefine'          => 38,
156     'regexp'            => 40,
157     'severe'            => 42,
158     'debugging'         => 44,
159     'inplace'           => 46,
160     'internal'          => 48,
161     'malloc'            => 50,
162     'signal'            => 52,
163     'substr'            => 54,
164     'syntax'            => 56,
165     'ambiguous'         => 58,
166     'bareword'          => 60,
167     'digit'             => 62,
168     'parenthesis'       => 64,
169     'precedence'        => 66,
170     'printf'            => 68,
171     'prototype'         => 70,
172     'qw'                => 72,
173     'reserved'          => 74,
174     'semicolon'         => 76,
175     'taint'             => 78,
176     'threads'           => 80,
177     'uninitialized'     => 82,
178     'unpack'            => 84,
179     'untie'             => 86,
180     'utf8'              => 88,
181     'void'              => 90,
182     'y2k'               => 92,
183   );
184
185 %Bits = (
186     'all'               => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15", # [0..46]
187     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00", # [29]
188     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00", # [30]
189     'closed'            => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
190     'closure'           => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
191     'debugging'         => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00", # [22]
192     'deprecated'        => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
193     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00", # [31]
194     'exec'              => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
195     'exiting'           => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
196     'glob'              => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
197     'inplace'           => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00", # [23]
198     'internal'          => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00", # [24]
199     'io'                => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
200     'layer'             => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
201     'malloc'            => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00", # [25]
202     'misc'              => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
203     'newline'           => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
204     'numeric'           => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
205     'once'              => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
206     'overflow'          => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
207     'pack'              => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00", # [16]
208     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00", # [32]
209     'pipe'              => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
210     'portable'          => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00", # [17]
211     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00", # [33]
212     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00", # [34]
213     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00", # [35]
214     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00", # [36]
215     'recursion'         => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00", # [18]
216     'redefine'          => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00", # [19]
217     'regexp'            => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00", # [20]
218     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00", # [37]
219     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00", # [38]
220     'severe'            => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00", # [21..25]
221     'signal'            => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00", # [26]
222     'substr'            => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00", # [27]
223     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00", # [28..38]
224     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00", # [39]
225     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00", # [40]
226     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00", # [41]
227     'unopened'          => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
228     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00", # [42]
229     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00", # [43]
230     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01", # [44]
231     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04", # [45]
232     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10", # [46]
233   );
234
235 %DeadBits = (
236     'all'               => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a", # [0..46]
237     'ambiguous'         => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00", # [29]
238     'bareword'          => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00", # [30]
239     'closed'            => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [6]
240     'closure'           => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [1]
241     'debugging'         => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00", # [22]
242     'deprecated'        => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [2]
243     'digit'             => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00", # [31]
244     'exec'              => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [7]
245     'exiting'           => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [3]
246     'glob'              => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [4]
247     'inplace'           => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00", # [23]
248     'internal'          => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00", # [24]
249     'io'                => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [5..11]
250     'layer'             => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [8]
251     'malloc'            => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00", # [25]
252     'misc'              => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00", # [12]
253     'newline'           => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [9]
254     'numeric'           => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00", # [13]
255     'once'              => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00", # [14]
256     'overflow'          => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00", # [15]
257     'pack'              => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00", # [16]
258     'parenthesis'       => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00", # [32]
259     'pipe'              => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [10]
260     'portable'          => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00", # [17]
261     'precedence'        => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00", # [33]
262     'printf'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00", # [34]
263     'prototype'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00", # [35]
264     'qw'                => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00", # [36]
265     'recursion'         => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00", # [18]
266     'redefine'          => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00", # [19]
267     'regexp'            => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00", # [20]
268     'reserved'          => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00", # [37]
269     'semicolon'         => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00", # [38]
270     'severe'            => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00", # [21..25]
271     'signal'            => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00", # [26]
272     'substr'            => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00", # [27]
273     'syntax'            => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00", # [28..38]
274     'taint'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00", # [39]
275     'threads'           => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00", # [40]
276     'uninitialized'     => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00", # [41]
277     'unopened'          => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00", # [11]
278     'unpack'            => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00", # [42]
279     'untie'             => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00", # [43]
280     'utf8'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02", # [44]
281     'void'              => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08", # [45]
282     'y2k'               => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20", # [46]
283   );
284
285 $NONE     = "\0\0\0\0\0\0\0\0\0\0\0\0";
286 $LAST_BIT = 94 ;
287 $BYTES    = 12 ;
288
289 $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
290
291 sub Croaker
292 {
293     delete $Carp::CarpInternal{'warnings'};
294     croak @_ ;
295 }
296
297 sub bits {
298     my $mask ;
299     my $catmask ;
300     my $fatal = 0 ;
301     foreach my $word (@_) {
302         if  ($word eq 'FATAL') {
303             $fatal = 1;
304         }
305         elsif ($catmask = $Bits{$word}) {
306             $mask |= $catmask ;
307             $mask |= $DeadBits{$word} if $fatal ;
308         }
309         else
310           { Croaker("Unknown warnings category '$word'")}
311     }
312
313     return $mask ;
314 }
315
316 sub import {
317     shift;
318     my $mask = ${^WARNING_BITS} ;
319     if (vec($mask, $Offsets{'all'}, 1)) {
320         $mask |= $Bits{'all'} ;
321         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
322     }
323     ${^WARNING_BITS} = $mask | bits(@_ ? @_ : 'all') ;
324 }
325
326 sub unimport {
327     shift;
328     my $mask = ${^WARNING_BITS} ;
329     if (vec($mask, $Offsets{'all'}, 1)) {
330         $mask |= $Bits{'all'} ;
331         $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
332     }
333     ${^WARNING_BITS} = $mask & ~ (bits('FATAL' => (@_ ? @_ : 'all')) | $All) ;
334 }
335
336 sub __chk
337 {
338     my $category ;
339     my $offset ;
340     my $isobj = 0 ;
341
342     if (@_) {
343         # check the category supplied.
344         $category = shift ;
345         if (ref $category) {
346             Croaker ("not an object")
347                 if $category !~ /^([^=]+)=/ ;
348             $category = $1 ;
349             $isobj = 1 ;
350         }
351         $offset = $Offsets{$category};
352         Croaker("Unknown warnings category '$category'")
353             unless defined $offset;
354     }
355     else {
356         $category = (caller(1))[0] ;
357         $offset = $Offsets{$category};
358         Croaker("package '$category' not registered for warnings")
359             unless defined $offset ;
360     }
361
362     my $this_pkg = (caller(1))[0] ;
363     my $i = 2 ;
364     my $pkg ;
365
366     if ($isobj) {
367         while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
368             last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
369         }
370         $i -= 2 ;
371     }
372     else {
373         for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
374             last if $pkg ne $this_pkg ;
375         }
376         $i = 2
377             if !$pkg || $pkg eq $this_pkg ;
378     }
379
380     my $callers_bitmask = (caller($i))[9] ;
381     return ($callers_bitmask, $offset, $i) ;
382 }
383
384 sub enabled
385 {
386     Croaker("Usage: warnings::enabled([category])")
387         unless @_ == 1 || @_ == 0 ;
388
389     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
390
391     return 0 unless defined $callers_bitmask ;
392     return vec($callers_bitmask, $offset, 1) ||
393            vec($callers_bitmask, $Offsets{'all'}, 1) ;
394 }
395
396
397 sub warn
398 {
399     Croaker("Usage: warnings::warn([category,] 'message')")
400         unless @_ == 2 || @_ == 1 ;
401
402     my $message = pop ;
403     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
404     croak($message)
405         if vec($callers_bitmask, $offset+1, 1) ||
406            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
407     carp($message) ;
408 }
409
410 sub warnif
411 {
412     Croaker("Usage: warnings::warnif([category,] 'message')")
413         unless @_ == 2 || @_ == 1 ;
414
415     my $message = pop ;
416     my ($callers_bitmask, $offset, $i) = __chk(@_) ;
417
418     return
419         unless defined $callers_bitmask &&
420                 (vec($callers_bitmask, $offset, 1) ||
421                 vec($callers_bitmask, $Offsets{'all'}, 1)) ;
422
423     croak($message)
424         if vec($callers_bitmask, $offset+1, 1) ||
425            vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
426
427     carp($message) ;
428 }
429
430 1;