perl5.git.perl.org Git - perl5.git/blame_incremental

... / ...

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