File Coverage

blib/lib/Const/PP.pm

Criterion	Covered	Total	%
statement	17	78	21.7
branch	0	36	0.0
condition	0	29	0.0
subroutine	6	14	42.8
pod	0	5	0.0
total	23	162	14.2

package Const::PP;

use 5.006;
use strict;
use warnings;
no warnings 'recursion';

our $VERSION = '1.00';

use Scalar::Util qw/reftype/;

use base qw/Import::Export/;

our %EX = (
        const => [qw/all/],
	make_readonly => [qw/all/],
	make_readonly_ref => [qw/all/],
	unmake_readonly => [qw/all/],
	is_readonly => [qw/all/],
);

our $RECURSION_LIMIT = 10000;

sub _make_readonly {

        if (my $type = reftype $_[0] and not &Internals::SvREADONLY($_[0])) {
               	&Internals::SvREADONLY($_[0], 1);
	        if ($type eq 'ARRAY') {
                        _make_readonly($_) for @{ $_[0] };
                }
                elsif ($type eq 'HASH') {
                        &Internals::hv_clear_placeholders($_[0]);
                        _make_readonly($_) for values %{ $_[0] };
                }
        }

        Internals::SvREADONLY($_[0], 1);

        return;
}

sub _make_readwrite {
        if (my $type = reftype $_[0] and &Internals::SvREADONLY($_[0])) {
               	&Internals::SvREADONLY($_[0], 0);
	        if ($type eq 'ARRAY') {
                        _make_readwrite($_) for @{ $_[0] };
                }
                elsif ($type eq 'HASH') {
                        &Internals::hv_clear_placeholders($_[0]);
                        _make_readwrite($_) for values %{ $_[0] };
                }

        }
        Internals::SvREADONLY($_[0], 0);
}

sub _is_readonly {
        if (my $type = reftype $_[0]) {
		if ($type eq 'HASH' || $type eq 'ARRAY') {
			return &Internals::SvREADONLY($_[0]) ? 1 : 0;
		}
	}

	return Internals::SvREADONLY($_[0]) ? 1 : 0;
}

sub const (\[$@%]@) {
        my (undef, @args) = @_;

	if ( ! scalar @args ) {
		die "No value for readonly variable";
	}

        if ( ref $_[0] eq 'ARRAY') {
                @{ $_[0] } = @args;
        }
        elsif ( ref $_[0] eq 'HASH') {
                die 'Odd number of elements in hash assignment' if @args % 2;
                %{ $_[0] } = @args;
        }
        else {
		my $ref = reftype($args[0]) || "";
		if ($ref eq 'HASH' || $ref eq 'ARRAY') {
			${ $_[0] } = $args[0];
			$_[0] = ${$_[0]};
		} else {
        	        ${ $_[0] } = $args[0];
		}
        }

        _make_readonly($_[0]);

        return $_[0];
}

sub make_readonly (\[$@%]@) {
	my $ref= reftype($_[0]) || "";
	if ( $ref eq 'HASH' || $ref eq 'ARRAY' ) {
		_make_readonly($_[0]);
	} else {
		_make_readonly(${$_[0]});
	}
	$_[0];
}

sub make_readonly_ref {
	_make_readonly($_[0]);
	return $_[0];
}

sub unmake_readonly (\[$@%]@)  {
	my $ref= reftype($_[0]) || "";
	if ( $ref eq 'HASH' || $ref eq 'ARRAY' ) {
		_make_readwrite($_[0]);
	} else {
		_make_readwrite(${$_[0]});
	}
	$_[0];
}

sub is_readonly (\[$@%]@) {
	my $ref= reftype($_[0]) || "";
	if ($ref eq 'HASH' || $ref eq 'ARRAY' ) {
		return _is_readonly($_[0]);
	} else {
		return _is_readonly(${$_[0]});
	}
}

1;

__END__