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: