1:
2:
3:
4:
5:
6:
7: package warnings;
8:
9: our $VERSION = '1.05_01';
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134: use Carp ();
135:
136: our %Offsets = (
137:
138:
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:
189: our %Bits = (
190: 'all' => "\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x55\x15",
191: 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00",
192: 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00",
193: 'closed' => "\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
194: 'closure' => "\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
195: 'debugging' => "\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00",
196: 'deprecated' => "\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
197: 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00",
198: 'exec' => "\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
199: 'exiting' => "\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
200: 'glob' => "\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
201: 'inplace' => "\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00",
202: 'internal' => "\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00",
203: 'io' => "\x00\x54\x55\x00\x00\x00\x00\x00\x00\x00\x00\x00",
204: 'layer' => "\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00",
205: 'malloc' => "\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00",
206: 'misc' => "\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00\x00",
207: 'newline' => "\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00",
208: 'numeric' => "\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00\x00",
209: 'once' => "\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00",
210: 'overflow' => "\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00",
211: 'pack' => "\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00\x00",
212: 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00\x00",
213: 'pipe' => "\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00\x00\x00",
214: 'portable' => "\x00\x00\x00\x00\x04\x00\x00\x00\x00\x00\x00\x00",
215: 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00\x00",
216: 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00",
217: 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00",
218: 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00\x00",
219: 'recursion' => "\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00\x00\x00",
220: 'redefine' => "\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00",
221: 'regexp' => "\x00\x00\x00\x00\x00\x01\x00\x00\x00\x00\x00\x00",
222: 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00\x00",
223: 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00\x00",
224: 'severe' => "\x00\x00\x00\x00\x00\x54\x05\x00\x00\x00\x00\x00",
225: 'signal' => "\x00\x00\x00\x00\x00\x00\x10\x00\x00\x00\x00\x00",
226: 'substr' => "\x00\x00\x00\x00\x00\x00\x40\x00\x00\x00\x00\x00",
227: 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\x55\x55\x15\x00\x00",
228: 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00\x00",
229: 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01\x00",
230: 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04\x00",
231: 'unopened' => "\x00\x00\x40\x00\x00\x00\x00\x00\x00\x00\x00\x00",
232: 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10\x00",
233: 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x40\x00",
234: 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x01",
235: 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x04",
236: 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x10",
237: );
238:
239: our %DeadBits = (
240: 'all' => "\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\xaa\x2a",
241: 'ambiguous' => "\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00",
242: 'bareword' => "\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00",
243: 'closed' => "\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
244: 'closure' => "\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
245: 'debugging' => "\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00",
246: 'deprecated' => "\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
247: 'digit' => "\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00",
248: 'exec' => "\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
249: 'exiting' => "\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
250: 'glob' => "\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",
251: 'inplace' => "\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00",
252: 'internal' => "\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00",
253: 'io' => "\x00\xa8\xaa\x00\x00\x00\x00\x00\x00\x00\x00\x00",
254: 'layer' => "\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00\x00",
255: 'malloc' => "\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00",
256: 'misc' => "\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00\x00",
257: 'newline' => "\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00\x00",
258: 'numeric' => "\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00\x00",
259: 'once' => "\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00",
260: 'overflow' => "\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00",
261: 'pack' => "\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00\x00",
262: 'parenthesis' => "\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00\x00",
263: 'pipe' => "\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00\x00\x00",
264: 'portable' => "\x00\x00\x00\x00\x08\x00\x00\x00\x00\x00\x00\x00",
265: 'precedence' => "\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00\x00",
266: 'printf' => "\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00",
267: 'prototype' => "\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00",
268: 'qw' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00\x00",
269: 'recursion' => "\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00\x00\x00",
270: 'redefine' => "\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00",
271: 'regexp' => "\x00\x00\x00\x00\x00\x02\x00\x00\x00\x00\x00\x00",
272: 'reserved' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00\x00",
273: 'semicolon' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00\x00",
274: 'severe' => "\x00\x00\x00\x00\x00\xa8\x0a\x00\x00\x00\x00\x00",
275: 'signal' => "\x00\x00\x00\x00\x00\x00\x20\x00\x00\x00\x00\x00",
276: 'substr' => "\x00\x00\x00\x00\x00\x00\x80\x00\x00\x00\x00\x00",
277: 'syntax' => "\x00\x00\x00\x00\x00\x00\x00\xaa\xaa\x2a\x00\x00",
278: 'taint' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00\x00",
279: 'threads' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02\x00",
280: 'uninitialized' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08\x00",
281: 'unopened' => "\x00\x00\x80\x00\x00\x00\x00\x00\x00\x00\x00\x00",
282: 'unpack' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20\x00",
283: 'untie' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x80\x00",
284: 'utf8' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x02",
285: 'void' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x08",
286: 'y2k' => "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x20",
287: );
288:
289: $NONE = "\0\0\0\0\0\0\0\0\0\0\0\0";
290: $LAST_BIT = 94 ;
291: $BYTES = 12 ;
292:
293: $All = "" ; vec($All, $Offsets{'all'}, 2) = 3 ;
294:
295: sub Croaker
296: {
297: require Carp::Heavy;
298: delete $Carp::CarpInternal{'warnings'};
299: Carp::croak(@_);
300: }
301:
302: sub bits
303: {
304:
305:
306: push @_, 'all' unless @_;
307:
308: my $mask;
309: my $catmask ;
310: my $fatal = 0 ;
311: my $no_fatal = 0 ;
312:
313: foreach my $word ( @_ ) {
314: if ($word eq 'FATAL') {
315: $fatal = 1;
316: $no_fatal = 0;
317: }
318: elsif ($word eq 'NONFATAL') {
319: $fatal = 0;
320: $no_fatal = 1;
321: }
322: elsif ($catmask = $Bits{$word}) {
323: $mask |= $catmask ;
324: $mask |= $DeadBits{$word} if $fatal ;
325: $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
326: }
327: else
328: { Croaker("Unknown warnings category '$word'")}
329: }
330:
331: return $mask ;
332: }
333:
334: sub import
335: {
336: shift;
337:
338: my $catmask ;
339: my $fatal = 0 ;
340: my $no_fatal = 0 ;
341:
342: my $mask = ${^WARNING_BITS} ;
343:
344: if (vec($mask, $Offsets{'all'}, 1)) {
345: $mask |= $Bits{'all'} ;
346: $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
347: }
348:
349: push @_, 'all' unless @_;
350:
351: foreach my $word ( @_ ) {
352: if ($word eq 'FATAL') {
353: $fatal = 1;
354: $no_fatal = 0;
355: }
356: elsif ($word eq 'NONFATAL') {
357: $fatal = 0;
358: $no_fatal = 1;
359: }
360: elsif ($catmask = $Bits{$word}) {
361: $mask |= $catmask ;
362: $mask |= $DeadBits{$word} if $fatal ;
363: $mask &= ~($DeadBits{$word}|$All) if $no_fatal ;
364: }
365: else
366: { Croaker("Unknown warnings category '$word'")}
367: }
368:
369: ${^WARNING_BITS} = $mask ;
370: }
371:
372: sub unimport
373: {
374: shift;
375:
376: my $catmask ;
377: my $mask = ${^WARNING_BITS} ;
378:
379: if (vec($mask, $Offsets{'all'}, 1)) {
380: $mask |= $Bits{'all'} ;
381: $mask |= $DeadBits{'all'} if vec($mask, $Offsets{'all'}+1, 1);
382: }
383:
384: push @_, 'all' unless @_;
385:
386: foreach my $word ( @_ ) {
387: if ($word eq 'FATAL') {
388: next;
389: }
390: elsif ($catmask = $Bits{$word}) {
391: $mask &= ~($catmask | $DeadBits{$word} | $All);
392: }
393: else
394: { Croaker("Unknown warnings category '$word'")}
395: }
396:
397: ${^WARNING_BITS} = $mask ;
398: }
399:
400: my %builtin_type; @builtin_type{qw(SCALAR ARRAY HASH CODE REF GLOB LVALUE Regexp)} = ();
401:
402: sub __chk
403: {
404: my $category ;
405: my $offset ;
406: my $isobj = 0 ;
407:
408: if (@_) {
409:
410: $category = shift ;
411: if (my $type = ref $category) {
412: Croaker("not an object")
413: if exists $builtin_type{$type};
414: $category = $type;
415: $isobj = 1 ;
416: }
417: $offset = $Offsets{$category};
418: Croaker("Unknown warnings category '$category'")
419: unless defined $offset;
420: }
421: else {
422: $category = (caller(1))[0] ;
423: $offset = $Offsets{$category};
424: Croaker("package '$category' not registered for warnings")
425: unless defined $offset ;
426: }
427:
428: my $this_pkg = (caller(1))[0] ;
429: my $i = 2 ;
430: my $pkg ;
431:
432: if ($isobj) {
433: while (do { { package DB; $pkg = (caller($i++))[0] } } ) {
434: last unless @DB::args && $DB::args[0] =~ /^$category=/ ;
435: }
436: $i -= 2 ;
437: }
438: else {
439: for ($i = 2 ; $pkg = (caller($i))[0] ; ++ $i) {
440: last if $pkg ne $this_pkg ;
441: }
442: $i = 2
443: if !$pkg || $pkg eq $this_pkg ;
444: }
445:
446: my $callers_bitmask = (caller($i))[9] ;
447: return ($callers_bitmask, $offset, $i) ;
448: }
449:
450: sub enabled
451: {
452: Croaker("Usage: warnings::enabled([category])")
453: unless @_ == 1 || @_ == 0 ;
454:
455: my ($callers_bitmask, $offset, $i) = __chk(@_) ;
456:
457: return 0 unless defined $callers_bitmask ;
458: return vec($callers_bitmask, $offset, 1) ||
459: vec($callers_bitmask, $Offsets{'all'}, 1) ;
460: }
461:
462:
463: sub warn
464: {
465: Croaker("Usage: warnings::warn([category,] 'message')")
466: unless @_ == 2 || @_ == 1 ;
467:
468: my $message = pop ;
469: my ($callers_bitmask, $offset, $i) = __chk(@_) ;
470: Carp::croak($message)
471: if vec($callers_bitmask, $offset+1, 1) ||
472: vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
473: Carp::carp($message) ;
474: }
475:
476: sub warnif
477: {
478: Croaker("Usage: warnings::warnif([category,] 'message')")
479: unless @_ == 2 || @_ == 1 ;
480:
481: my $message = pop ;
482: my ($callers_bitmask, $offset, $i) = __chk(@_) ;
483:
484: return
485: unless defined $callers_bitmask &&
486: (vec($callers_bitmask, $offset, 1) ||
487: vec($callers_bitmask, $Offsets{'all'}, 1)) ;
488:
489: Carp::croak($message)
490: if vec($callers_bitmask, $offset+1, 1) ||
491: vec($callers_bitmask, $Offsets{'all'}+1, 1) ;
492:
493: Carp::carp($message) ;
494: }
495:
496: 1;
497: