File Coverage

blib/lib/Devel/WarnGlobal/Scalar.pm

Criterion	Covered	Total	%
statement	54	55	98.1
branch	21	22	95.4
condition	4	6	66.6
subroutine	12	13	92.3
pod	0	2	0.0
total	91	98	92.8

package Devel::WarnGlobal::Scalar;

# ABSTRACT: Track down and eliminate scalar globals

use strict;
use warnings;

our $VERSION = '0.09'; # VERSION

use Carp;


# Items to export into callers namespace by default. Note: do not export
# names by default without a very good reason. Use EXPORT_OK instead.
# Do not simply export all your public functions/methods/constants.

################################# Methods ###############################

sub TIESCALAR {
    my $type = shift;
    my ($in) = @_;

    exists $in->{'get'} or croak "Improper use of 'tie' on $type: Field 'get' required; stopped";

    no strict 'refs';
    my Devel::WarnGlobal::Scalar $self = bless {}, $type;
    $self->{'get'} = $in->{'get'};
    $self->{'set'} = $in->{'set'} if defined $in->{'set'};
    $self->{'name'} = $in->{'name'} if defined $in->{'name'};
    $self->{'die_on_write'} = $type->_get_boolean($in, 'die_on_write', 0);
    $self->{'warn'} = $type->_get_boolean($in, 'warn', 1);

    return $self;
}

sub _get_boolean {
    my $type = shift;
    my ($hash, $member, $default) = @_;

    if ( defined $hash->{$member} ) {
	return $hash->{$member};
    }
    else {
	return $default;
    }
}

sub FETCH {
    my Devel::WarnGlobal::Scalar $self = shift;

    $self->{'warn'} and do {
	warn(ucfirst($self->_get_identifier()), " was read-accessed ", $self->_get_caller_info());
    };

    return $self->{'get'}->();
}

sub _get_caller_info {
    my Devel::WarnGlobal::Scalar $self = shift;

    my ($package, $filename, $line, $subroutine) = caller(1);
    return "at $filename line $line.\n";
}



sub _get_identifier {
    my Devel::WarnGlobal::Scalar $self = shift;

    if (defined $self->{'name'}) {
	return "global '$self->{'name'}'";
    }
    else {
	return "a global";
    }
}

sub STORE {
    my Devel::WarnGlobal::Scalar $self = shift;
    my ($new_value) = @_;

    if ( $self->{'warn'} && (! $self->{'die_on_write'} ) ) {
	warn(ucfirst( $self->_get_identifier() ), " was write-accessed ", $self->_get_caller_info());
    }

    if (! defined($self->{'set'}) ) {

	if ( defined($self->{'die_on_write'}) && $self->{'die_on_write'} ) {
	    die "Attempt to write-access ", $self->_get_identifier(), "(read-only) ", $self->_get_caller_info();
	}
    }
    else {
	$self->{'set'}->($new_value);
    }
}

sub DESTROY { }

sub warn {
    my Devel::WarnGlobal::Scalar $self = shift;
    my ($warn_val) = @_;

    defined $warn_val or return $self->{'warn'};

    $self->{'warn'} = $warn_val;
}

sub die_on_write {
    my Devel::WarnGlobal::Scalar $self = shift;
    my ($die_val) = @_;

    defined $die_val or return $self->{'die_on_write'};

    $self->{'die_on_write'} = $die_val;
}

1;

__END__