File Coverage

blib/lib/Type/Tie/Aggregate.pm

Criterion	Covered	Total	%
statement	33	33	100.0
branch	2	4	50.0
condition	2	6	33.3
subroutine	10	10	100.0
pod	1	1	100.0
total	48	54	88.8

# ABSTRACT: like Type::Tie, but slower and more flexible

######################################################################
# 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;
$Type::Tie::Aggregate::VERSION = '0.001';
#pod =head1 SYNOPSIS
#pod
#pod     use Type::Tie::Aggregate;
#pod     use Types::Standard qw(Dict Optional Num Str);
#pod
#pod     ttie my %hash, Dict[name => Str, age => Optional[Num]], (
#pod         name	=> 'John Doe',
#pod 	age	=> 42,
#pod     );
#pod
#pod     $hash{name} = 'Jane Doe';	# ok
#pod     $hash{age}++;		# ok
#pod     $hash{age} = 'forty-two;	# dies
#pod     delete $hash{name};		# dies ('name' is mandatory)
#pod
#pod     # Unfortunately this does not work, because the hash is
#pod     # momentarily cleared and will no longer pass the type constraint
#pod     # (which requires a 'name' key).
#pod     %hash = (name => 'J. Random Hacker');
#pod
#pod     # Use this instead (also more efficient).
#pod     (tied %hash)->initialize(name => 'J. Random Hacker');
#pod
#pod =head1 DESCRIPTION
#pod
#pod Like L, this module exports a single function:
#pod C. Also like L, C ties a variable to
#pod a type constraint (coercions will be honored).
#pod
#pod However, unlike L, when an assignment happens on
#pod a variable tied with C, the I variable will be
#pod re-checked, not just the value that was added. This is much more
#pod expensive, of course, but can be very useful for structured types such
#pod as C from L as show in the
#pod L.
#pod
#pod Any type constraints supporting the L interface
#pod should work, not just L types. However, in the
#pod examples that follow, all type constraints are from
#pod L unless specified otherwise.
#pod
#pod =head2 Initialization and Re-initialization
#pod
#pod Since some types don't allow empty values (see the L),
#pod values may need to be given when initializing the type. For example,
#pod this is invalid:
#pod
#pod     ttie my %hash, Dict[name => Str]; # dies
#pod
#pod No values were given to initialize C<%hash>, so C<%hash> failed the
#pod type constraint C Str]> (which requires a C
#pod key). Instead, this should be done:
#pod
#pod     ttie my %hash, Dict[name => Str], (name => 'My Name');
#pod
#pod This initializes C<%hash> with the value C<< (name => 'My Name') >>
#pod before any type checking is performed, so, at the end of the day,
#pod C<%hash> passes the type constraint.
#pod
#pod Another important thing to note is that when a variable is
#pod re-initialized, it is temporarily emptied. So the following is
#pod invalid:
#pod
#pod     ttie my %hash, Dict[name => Str], (name => 'My Name');
#pod     %hash = (name => 'Other Name'); # dies
#pod
#pod Instead, the C method should be used on the tied object,
#pod like so:
#pod
#pod     ttie my %hash, Dict[name => Str], (name => 'My Name');
#pod     (tied %hash)->initialize(name => 'Other Name'); # ok
#pod
#pod This is also more efficient than the previous method.
#pod
#pod =head2 Deep Tying
#pod
#pod C ties variables deeply, meaning that if any references
#pod contained within the variable are changed, the entire variable is
#pod rechecked against the type constraint. Blessed objects are not deeply
#pod tied, but tied references are and the functionality of these tied
#pod references is preserved.
#pod
#pod For example, the following Does The Right Thing(TM):
#pod
#pod     ttie my %hash, HashRef[ArrayRef[Int]];
#pod     $hash{foo} = [1, 2, 3];	# ok
#pod     $hash{foo}[0] = 'one';	# dies
#pod     $hash{bar} = [3, 2, 1];	# ok
#pod     push @{$hash{bar}}, 'zero';	# dies
#pod
#pod This also works:
#pod
#pod     use List::Util qw(all);
#pod     use Tie::RefHash;
#pod
#pod     ttie my @array, ArrayRef[HashRef[Int]];
#pod
#pod     my $scalar_key = 'scalar';
#pod     my @array_key = (1, 2, 3);
#pod     tie my %refhash, 'Tie::RefHash', (
#pod         \$scalar_key    => 1,
#pod         \@array_key     => 2,
#pod     );
#pod
#pod     push @array, \%refhash;
#pod
#pod     $array[0]{\$scalar_key} = 'foo';	# dies
#pod     $array[0]{\@array_key} = 42;	# ok
#pod     all { ref ne '' } keys %{$array[0]}; # true
#pod
#pod Currently, circular references are not handled correctly (see
#pod L).
#pod
#pod =head1 CAVEATS
#pod
#pod =head2 Re-initialization
#pod
#pod Re-initialization of tied variables using C<@array = @init> or
#pod C<%hash = %init> does not always work. Use
#pod C<< (tied @array)->initialize(@init) >> and
#pod C<< (tied %hash)->initialize(%init) >> instead. See
#pod L for more information.
#pod
#pod =head2 Retying References
#pod
#pod If a variable tied to a type contains a reference, then that reference
#pod cannot be contained by any other variable tied to a type. For example,
#pod the following will die:
#pod
#pod     my $arrayref = [42];
#pod     ttie my @num_array, ArrayRef[ArrayRef[Num]], ($arrayref);
#pod     ttie my @str_array, ArrayRef[ArrayRef[Str]], ($arrayref);
#pod
#pod If this were allowed, it would not be clear whether
#pod C should die or not. This behavior may be
#pod changed in a later release, but you probably should not be doing this
#pod regardless.
#pod
#pod =head2 Circular References
#pod
#pod Circular references are not handled correctly. Hopefully this will be
#pod fixed in a future release.
#pod
#pod =cut

use v5.13.2;
use strict;
use warnings;
use namespace::autoclean;
use Carp;
use Scalar::Util qw(reftype);
use parent 'Exporter';

our @EXPORT = qw(ttie);

# Used by Type::Tie::Aggregate::Deep;
sub _tied_types { qw(SCALAR ARRAY HASH) }

{
    my %tied_types = map { $_ => 1 } _tied_types;

    # Used also by Type::Tie::Aggregate::Deep. Returns the type of the
    # reference.
    sub _check_ref_type {
	my ($class, $ref) = @_;
	my $type = reftype $ref // croak 'Not a reference';
	$type = 'SCALAR' if $type eq 'REF';
	return unless $tied_types{$type};
	return $type;
    }
}

#pod =func ttie
#pod
#pod     ttie my $scalar, TYPE, $init_val;
#pod     ttie my @array, TYPE, @init_val;
#pod     ttie my %hash, TYPE, %init_val;
#pod
#pod Tie C<$scalar>, C<@array>, or C<%hash> to C and initialize with
#pod C<$init_val>, C<@init_val>, or C<%init_val>.
#pod
#pod =cut

sub ttie (\[$@%]@) {
    my ($ref, $type, @args) = @_;

    my $ref_type;
    $ref_type = __PACKAGE__->_check_ref_type($ref) //
	croak "Cannot tie variable of type $ref_type";

    my $pkg = __PACKAGE__ . '::' . ucfirst lc $ref_type;
    require $pkg =~ s|::|/|gr . '.pm';

    &CORE::tie($ref, $pkg, $type, @args);
    return $ref;
}

#pod =method initialize
#pod
#pod     (tied $scalar)->initialize($init_val);
#pod     (tied @array)->initialize(@init_val);
#pod     (tied %hash)->initialize(%init_val);
#pod
#pod Re-initialize C<$scalar>, C<@array>, or C<%hash>. This is necessary
#pod because some types don't allow an empty value, and the variable will
#pod temporarily be emptied (except for scalars) if initialized the usual
#pod way (e.g., C<@array = qw(foo bar baz)>). This is also more efficient
#pod than conventional initialization.
#pod
#pod See L for more info.
#pod
#pod =method type
#pod
#pod     my $type = (tied VAR)->type;
#pod
#pod Return the type constraint for C. Note that the type cannot
#pod currently be set, only read.
#pod
#pod =cut

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

1;

__END__