File Coverage

blib/lib/warnings/DynamicScope.pm

Criterion	Covered	Total	%
statement	113	128	88.2
branch	37	52	71.1
condition	3	3	100.0
subroutine	23	27	85.1
pod	0	2	0.0
total	176	212	83.0

#!perl -w
# -*- coding: utf-8-unix; tab-width: 4; -*-
package warnings::DynamicScope;

# DynamicScope.pm
# ------------------------------------------------------------------------
# Revision: $Id: DynamicScope.pm,v 1.14 2005/08/15 15:53:59 kay Exp $
# Written by Keitaro Miyazaki
# Copyright 2005 Keitaro Miyazaki All Rights Reserved.

# HISTORY
# ------------------------------------------------------------------------
# 2005-08-15 Version 1.04
# 2005-08-10 Version 1.03
#            - Fixed a bug the value of $^W was not set properly in
#              BEGIN block.
# 2005-08-07 Version 1.02
#            - Defined new package variable named "$DYNAMIC_W_BITS".
#              The tied hash "%^W" no longer accesses to the variable
#              "${^WARNING_BITS}" unless it is accessed in BEGIN block.
#            - Now the variable "%^W" accepts keyword "FATAL" as value.
#              If the value is set to "FATAL", it returns 2 as value.
#            - Added "DEAD BIT", "BEGIN BLOCK", and "$^W AND %W" item
#              in POD document.
#            - Improved handling of the variable "$^W". It's value is
#              always synchronized with the value of "$^W{all}".
#            - Made "%^W" realize "-W" and "-X" command line switches.
# 2005-08-04 Version 1.01
#            - Modified POD document.
#            - Added a few tests.
# 2005-08-04 Version 1.00
#            - Initial version.

use 5.008;
use strict;
use warnings;

our $VERSION  = '1.04';
our $REVISION = '$Id: DynamicScope.pm,v 1.14 2005/08/15 15:53:59 kay Exp $';
our $DEBUG    = 0;

use Symbol::Values 'symbol';

#-------------------------------------------------------------------------
# Functions
#
sub in_begin_block {
	my($func, $i);

 	for ($i=2; $func = (caller($i))[3]; ++$i) {
		return 1 if $func =~ /^(?:.*::)?BEGIN$/o;
		next if $func eq '(eval)';
		return 0;
	}
	0
}


#-------------------------------------------------------------------------
# Base module(Tied Hash)
#-------------------------------------------------------------------------
package warnings::DynamicScope::WARNINGS_HASH;
use Tie::Hash;
use base "Tie::Hash";
use Symbol::Values 'symbol';

#-------------------------------------------------------------------------
# Variables
#
our (
	 $r_WARNINGS,		# original value of $^W
	 $LEXICAL_W_BITS,	# alias of ${^WARNING_BITS}
	 $DYNAMIC_W_BITS,	# Warning bits in dynamic scope.
	 %Bits,				# bitmask on/off
	 %DeadBits,			# bitmask if fatal or not.
	 %Offsets,			# bit offset beggining from the string.
	 $W_FLAG,			# if command line switch "-W" is on
	 $X_FLAG,			# if command line switch "-X" is on
	);

#-------------------------------------------------------------------------
# Some aliases
#
BEGIN {
	no warnings 'Symbol::Values';
	symbol('LEXICAL_W_BITS')->glob	= *{^WARNING_BITS};		# $LEXICAL_W_BITS
	symbol('bits')->code			= *warnings::bits;		# bits()
	symbol('in_begin_block')->code	= *warnings::DynamicScope::in_begin_block;
	symbol('Bits')->hash_ref		= *warnings::Bits;		# %Bits
	symbol('DeadBits')->hash_ref	= *warnings::DeadBits;	# %DeadBits # Fatal?
	symbol('Offsets')->hash_ref		= *warnings::Offsets;	# %Offsets
	$DYNAMIC_W_BITS = "";
}

#-------------------------------------------------------------------------
# Code
#
sub TIEHASH {
	my $self;
	my $init_val = $_[1];
	__PACKAGE__->STORE('all', $init_val);
	bless \$self
}

sub FETCH {
	my ($self, $key) = @_;
	return undef unless exists $Bits{$key};

	my $mask;
	if (in_begin_block) {
		$mask = (caller(0))[9];
	} else {
		$mask = $DYNAMIC_W_BITS;
	}

	my $flag  = vec($mask, $Offsets{$key}, 1);
    my $fatal = vec($mask, $Offsets{$key}+1, 1);

	$DEBUG && printf(STDERR "FETCH(%s): %s = %s (FATAL = %s)\n",
					 in_begin_block() ? 'lex' : 'dyn',
					 $key, $flag, $fatal);

	$flag = 0 if $X_FLAG; # Always false if "-X" switch is on.
	$flag = 1 if $W_FLAG; # Always true  if "-W" switch is on.
                          # NOTE: "-W" switch have a priority.

	$flag
		? $fatal ? 2 : 1
		: 0
}

sub STORE {
	my ($self, $key, $value) = @_;

	unless (exists $Bits{$key})
		{ warnings::Croaker("Unknown warning category '$key'")}

	my $is_pragma = in_begin_block();
	my $mask      = $is_pragma ? $LEXICAL_W_BITS : $DYNAMIC_W_BITS;
	my $fatal     = 0;
	my $no_fatal  = 0;

	$DEBUG && printf(STDERR "STORE(%s): %s = %s\n",
					 in_begin_block() ? 'lex' : 'dyn',
					 $key, $value);

	# Check if category will be set FATAL error.
	#
	if ($value && $value eq 'FATAL') {
		$fatal = 1;
	}

	# Set value
	#
	if ($value) {
		$mask |= $Bits{$key};

		# Set DeadBits
		if ($fatal) {
			$mask |= $DeadBits{$key};
		} else {
			$mask &= ~$DeadBits{$key};
		}

	# Unet value
	#
	} else {
		if ($is_pragma) {
			# this is just for compatibility...
			$mask &= ~($Bits{$key} | $DeadBits{$key} | $warnings::All);
		} else {
			$mask &= ~($Bits{$key} | $DeadBits{$key});
		}
	}

	# Set value of $^W if necessary.
	#
	if ($key eq 'all') {
		${$r_WARNINGS} = $value ? 1 : 0;
	}

	if ($is_pragma) {
		$LEXICAL_W_BITS = $mask;
	} else {
		$DYNAMIC_W_BITS = $mask;
	}

	return vec($mask, $Offsets{$key}, 2)
}

sub FIRSTKEY {
	my $self = shift;
	scalar each %Bits
}

sub NEXTKEY {
	my($self, $lastkey) = @_;
	scalar each %Bits
}

sub EXISTS {
	my($self, $key) = @_;
	exists $Bits{$key}
}

sub DELETE {
	my($self, $key) = @_;

	unless (exists $Bits{$key})
		{ warnings::Croaker("Unknown warning category '$key'")}

	# currently, delete $^W{key} will only disables the value.
	vec($LEXICAL_W_BITS, $Offsets{$key}, 1) = 0
}

sub CLEAR {
	my $self = shift;

	# set all bits and dead bets to 0
	$LEXICAL_W_BITS = $warnings::NONE;

	undef
}

sub SCALAR {
	my $self = shift;

	# this value has no meaning,
	# exists only for compatibility...
	scalar %Bits
}

#-------------------------------------------------------------------------
# $^W
#-------------------------------------------------------------------------
package warnings::DynamicScope::WARNINGS_SCALAR;
use Tie::Scalar ();
use Symbol::Values 'symbol';
use base "Tie::Scalar";

sub TIESCALAR {
	my $dummy;
	bless \$dummy;
}

sub FETCH {
	push(@_, 'all');
	goto &warnings::DynamicScope::WARNINGS_HASH::FETCH;
}

sub STORE {
	splice(@_, 1, 0, 'all');
	goto &warnings::DynamicScope::WARNINGS_HASH::STORE;
}

#-------------------------------------------------------------------------
# Initialize
#-------------------------------------------------------------------------
package warnings::DynamicScope;

my $loaded = 0;

BEGIN {
	unless ($loaded) {
		my $init_value = $^W;

		# Test if "-W" or "-X" flag was passed.
		#
		$W_FLAG = $X_FLAG = 0;

		$^W = 0; $^W && ($W_FLAG = 1);
		$^W = 1; $^W || ($X_FLAG = 1);

		$^W = $init_value;

		# Save original $^W
		#
		$r_WARNINGS = symbol('^W')->scalar_ref;
		my $new_val;
		symbol('^W')->scalar_ref = \$new_val;

		# Tie $^W and %^W
		#
		tie %^W, "warnings::DynamicScope::WARNINGS_HASH", $init_value;
		tie $^W, "warnings::DynamicScope::WARNINGS_SCALAR";

		$loaded = 1;
	}
}


# This is private function
sub report {
	my $pkg = shift;
	printf("ALL: %d, ^W: %d\n",
		   length($Bits{all}),
		   length(${^WARNING_BITS})
		  );
	if ($pkg) {
		printf("Value for \"%s\" = %d(in Bits: %d, %d/in all: %d, %d)\n",
			   $pkg,
			   $^W{$pkg},
			   vec($Bits{$pkg}, $Offsets{$pkg}, 1),
			   vec($DeadBits{$pkg}, $Offsets{$pkg}+1, 1),
			   vec($Bits{all}, $Offsets{$pkg}, 1),
			   vec($DeadBits{all}, $Offsets{$pkg}+1, 1)
			  );

	}
	foreach my $package (keys %Offsets) {
		printf("%15s[%3d] = %d, bits(%d, %d), bitsin all(%d, %d)\n",
			   $package,
			   $Offsets{$package},
			   $^W{$package},
			   vec($Bits{$package}, $Offsets{$package}, 1),
			   vec($DeadBits{$package}, $Offsets{$package}+1, 1),
			   vec($Bits{all}, $Offsets{$package}, 1),
			   vec($DeadBits{all}, $Offsets{$package}+1, 1)
			  );
	}
}

1;
__END__