# You may distribute under the terms of either the GNU General Public License
# or the Artistic License (the same terms as Perl itself)
#
# (C) Paul Evans, 2013-2014 -- leonerd@leonerd.org.uk
package Tangence::Type;
use strict;
use warnings;
use base qw( Tangence::Meta::Type );
require Tangence::Type::Primitive;
=head1 NAME
C<Tangence::Type> - represent a C<Tangence> value type
=head1 DESCRIPTION
Objects in this class represent individual types that are sent over the wire
in L<Tangence> messages. This is a subclass of L<Tangence::Meta::Type> which
provides additional methods that may be useful in server or client
implementations.
=cut
=head1 CONSTRUCTOR
=head2 $type = Tangence::Type->new( $primitive_sig )
Returns an instance to represent a primitive type of the given signature.
=head2 $type = Tangence::Type->new( list => $member_type )
=head2 $type = Tangence::Type->new( dict => $member_type )
Returns an instance to represent a list or dict aggregation containing members
of the given type.
=cut
sub new
{
# Subtle trickery is at work here
# Invoke our own superclass constructor, but pretend to be some higher
# subclass that's appropriate
shift;
if( @_ == 1 ) {
my ( $type ) = @_;
my $class = "Tangence::Type::Primitive::$type";
$class->can( "new" ) or die "TODO: Need $class";
return $class->SUPER::new( $type );
}
elsif( $_[0] eq "list" ) {
shift;
return Tangence::Type::List->SUPER::new( list => @_ );
}
elsif( $_[0] eq "dict" ) {
shift;
return Tangence::Type::Dict->SUPER::new( dict => @_ );
}
else {
die "TODO: Not sure how to make a Tangence::Type->new( @_ )";
}
}
=head1 METHODS
=head2 $value = $type->default_value
Returns a value suitable to use as an initial value for object properties.
=head2 $type->pack_value( $message, $value )
Appends a value of this type to the end of a L<Tangence::Message>.
=head2 $value = $type->unpack_value( $message )
Removes a value of this type from the start of a L<Tangence::Message>.
=cut
package
Tangence::Type::List;
use base qw( Tangence::Type );
use Carp;
use Tangence::Constants;
sub default_value { [] }
sub pack_value
{
my $self = shift;
my ( $message, $value ) = @_;
ref $value eq "ARRAY" or croak "Cannot pack a list from non-ARRAY reference";
$message->_pack_leader( DATA_LIST, scalar @$value );
my $member_type = $self->member_type;
$member_type->pack_value( $message, $_ ) for @$value;
}
sub unpack_value
{
my $self = shift;
my ( $message ) = @_;
my ( $type, $num ) = $message->_unpack_leader();
$type == DATA_LIST or croak "Expected to unpack a list but did not find one";
my $member_type = $self->member_type;
my @values;
foreach ( 1 .. $num ) {
push @values, $member_type->unpack_value( $message );
}
return \@values;
}
package
Tangence::Type::Dict;
use base qw( Tangence::Type );
use Carp;
use Tangence::Constants;
sub default_value { {} }
sub pack_value
{
my $self = shift;
my ( $message, $value ) = @_;
ref $value eq "HASH" or croak "Cannot pack a dict from non-HASH reference";
my @keys = keys %$value;
@keys = sort @keys if $Tangence::Message::SORT_HASH_KEYS;
$message->_pack_leader( DATA_DICT, scalar @keys );
my $member_type = $self->member_type;
$message->pack_str( $_ ), $member_type->pack_value( $message, $value->{$_} ) for @keys;
}
sub unpack_value
{
my $self = shift;
my ( $message ) = @_;
my ( $type, $num ) = $message->_unpack_leader();
$type == DATA_DICT or croak "Expected to unpack a dict but did not find one";
my $member_type = $self->member_type;
my %values;
foreach ( 1 .. $num ) {
my $key = $message->unpack_str();
$values{$key} = $member_type->unpack_value( $message );
}
return \%values;
}
=head1 AUTHOR
Paul Evans <leonerd@leonerd.org.uk>
=cut
0x55AA;