File Coverage

blib/lib/Type/Tie/Aggregate/Scalar.pm

Criterion	Covered	Total	%
statement	26	26	100.0
branch	3	4	75.0
condition			n/a
subroutine	9	9	100.0
pod			n/a
total	38	39	97.4

# ABSTRACT: class to tie arrays for Type::Tie::Aggregate

######################################################################
# Copyright (C) 2021 Asher Gordon                 #
#                                                                    #
# This program is free software: you can redistribute it and/or      #
# modify it under the terms of the GNU General Public License as     #
# published by the Free Software Foundation, either version 3 of     #
# the License, or (at your option) any later version.                #
#                                                                    #
# This program is distributed in the hope that it will be useful,    #
# but WITHOUT ANY WARRANTY; without even the implied warranty of     #
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU   #
# General Public License for more details.                           #
#                                                                    #
# You should have received a copy of the GNU General Public License  #
# along with this program. If not, see                               #
# .                                    #
######################################################################

package Type::Tie::Aggregate::Scalar;
$Type::Tie::Aggregate::Scalar::VERSION = '0.001';
#pod =head1 DESCRIPTION
#pod
#pod This class is used to tie arrays. This class is internal to
#pod L.
#pod
#pod The C<_value> method is overloaded to return and set the referenced
#pod scalar, rather than the reference itself. C<< $obj->_value >> is like
#pod C<< ${$obj->_ref} >>.
#pod
#pod =cut

use v5.6.0;
use strict;
use warnings;
use namespace::autoclean;
use Carp;
use parent 'Type::Tie::Aggregate::Base';

sub _create_ref {
    shift;
    carp 'More than one value given for scalar; using first value'
	if @_ > 1;
    \$_[0];
}

sub _value {
    my $self = shift;
    my $ref = $self->_ref;
    return $$ref unless @_;
    ($$ref) = @_;
}

sub TIESCALAR { my $class = shift; $class->_new(@_) }

__PACKAGE__->_install_methods(
    { mutates => 1 },
    STORE	=> '$$ref = $_[0]',
);

__PACKAGE__->_install_methods(
    { mutates => 0 },
    FETCH	=> '$$ref',
);

#pod =head1 SEE ALSO
#pod
#pod =for :list
#pod * L
#pod
#pod =cut

1;

__END__