view release on metacpan or  search on metacpan

lib/Fixed.pm  view on Meta::CPAN

package Fixed;

use 5.012;
use strict;
use warnings;

BEGIN {
	$Fixed::AUTHORITY = 'cpan:TOBYINK';
	$Fixed::VERSION   = '0.003';
}

use Readonly;
use Text::Balanced;

BEGIN {
	package Fixed::Scalar;
	sub TIESCALAR {
		my $class = shift;
		bless \@_, $class;
	}
	sub FETCH {
		$_[0][0];
	}
	sub STORE {
		my $self = shift;
		Readonly::croak $Readonly::MODIFY if @$self;
		push @$self, $_[0];
	}
};

my $KEYWORD  = 'fix';
my $CLASS    = __PACKAGE__;

my $PERLSVAR = qr{\$[^\W0-9]\w*};
my $SPACE    = qr{(?:\s|\#.*?\n)*}s;

sub import
{
	require Keyword::Simple;
	Keyword::Simple::define($KEYWORD, sub
	{
		my $ref = shift;
		$$ref =~ s/^$SPACE//;

		# set $foo = 1;
		if (my ($vname, $assignment, $rest) = ($$ref =~ /^($PERLSVAR)($SPACE=)(.*)$/s))
		{
			$$ref = "$CLASS\::Scalar my $vname => $rest";
		}

		# set ($foo) = 1;
		elsif (my ($vname4, $assignment4, $rest4) = ($$ref =~ /^\($SPACE($PERLSVAR)$SPACE\)($SPACE=)(.*)$/s))
		{
			$$ref = "$CLASS\::Scalar my $vname4 => $rest4";
		}

		# set $foo;
		elsif (my ($vname2, $rest2) = ($$ref =~ /^($PERLSVAR)$SPACE;(.*)$/s))
		{
			$$ref = "$CLASS\::Scalar my $vname2; $rest2";
		}
		
		# set ($foo, $bar)
		# set ($foo, $bar) = (1, 2);
		elsif ($$ref =~ /^$SPACE\(/s)
		{
			my $extracted = Text::Balanced::extract_bracketed($$ref)
				or Readonly::croak "usage: $KEYWORD (\$scalar, ...);";
			$extracted =~ s/(^\(|\)$)//gs;
			my @E = split /$SPACE,$SPACE/, $extracted;
			for (@E)
			{
				Readonly::croak "$KEYWORD used for non scalar variable '$_'"
					unless /^$PERLSVAR$/;
			}
			# If declaration includes an assignent, then ensure we have something to assign to!
			my $extra = ''; $extra = "($extracted)" if $$ref =~ /^$SPACE=/;
			$$ref = "$CLASS\::Scalar(\$_) for my ($extracted); $extra $$ref";
		}
		
		elsif (
			my ($vname3) = ($$ref =~ /^$SPACE([\@\%\*][^\W0-9]\w*)/s)
		) {
			Readonly::croak "$KEYWORD used with non scalar variable '$vname3'";
		}
		
		else {
			Readonly::croak "usage: $KEYWORD \$variable = \$value;";
		}
	});
}

sub unimport
{