File Coverage

blib/lib/variable.pm

Criterion	Covered	Total	%
statement	28	42	66.6
branch	5	24	20.8
condition	1	6	16.6
subroutine	7	8	87.5
pod	0	1	0.0
total	41	81	50.6

package variable;

require 5.006;

use strict;
use warnings::register;
use warnings;
no  warnings 'syntax';


our $VERSION = '2009110702';
our %declared;

sub croak {
    require Carp;
    goto &Carp::croak (@_);
}

my %keywords         = map {$_ => 1} qw /BEGIN INIT CHECK END DESTROY AUTOLOAD/;
my %forced_into_main = map {$_ => 1} qw /STDIN STDOUT STDERR ARGV ARGVOUT
                                         ENV INC SIG/;
my %forbidden        = (%keywords, %forced_into_main);

sub import {
    my $package = shift;
    return unless @_;         # Ignore 'use variable;'.
    my $caller  = caller;
    my $name    = shift;

    croak "Can't use undef as variable name" unless defined $name;

    if ($name =~ /^_?[^\W_\d]\w*\z/ && !$forbidden {$name}) {
        # Ok.
    }
    elsif ($forced_into_main {$name} and $caller ne 'main') {
        croak "Variable name '$name' is forced into main::";
    }
    elsif ($name =~ /^__/) {
        croak "Variable name '$name' begins with '__'";
    }
    elsif ($name =~ /^[A-Za-z_]\w*\z/) {
	# Perhaps give a warning.
        if (warnings::enabled ()) {
            if ($keywords {$name}) {
                warnings::warn ("Variable name '$name' is a Perl keyword");
            }
            elsif ($forced_into_main {$name}) {
                warnings::warn ("Variable name '$name' is forced into " .
                                "package main::");
            }
            else {
                warnings::warn ("Variable name '$name' has unknown problems");
            }
        }
    }
    elsif ($name =~ /^[01]?\z/) {
        if (@_) {
            croak "Variable name '$name' is invalid";
        }
        else {
            croak "Variable name looks like a boolean value";
        }
    }

    else {
        # Must have bad characters.
        croak "Variable name '$name' has invalid characters";
    }

    if (@_ > 1) {
        croak "Variables have to be scalar";
    }

    {
        no strict 'refs';
        my $value = shift;    # Might be undef, which is ok.
        my $full  = "${caller}::$name";
        $declared {$full} ++;
        *$full    = sub () : lvalue {$value};
    }
}

1;

__END__