package Tibco::Rv::Msg::Field;
use vars qw/ $VERSION @CARP_NOT /;
$VERSION = '1.12';
use Tibco::Rv::Msg::DateTime;
@CARP_NOT = qw/ Tibco::Rv::Msg::DateTime /;
my ( %defaults );
BEGIN
{
%defaults = ( name => '', id => 0,
size => undef, count => undef, type => undef, data => undef );
}
sub new
{
my ( $proto ) = shift;
my ( %params ) = ( name => '', id => 0 );
my ( %args ) = @_;
map { Tibco::Rv::die( Tibco::Rv::INVALID_ARG )
unless ( exists $params{$_} ) } keys %args;
%params = ( %params, %args );
my ( $class ) = ref( $proto ) || $proto;
my ( $self ) = $class->_new;
$params{name} = '' unless ( defined $params{name} );
@$self{ qw/ name id / } = @params{ qw/ name id / };
my ( $status ) =
Tibco::Rv::Msg::MsgField_Create( @$self{ qw/ ptr name id / } );
Tibco::Rv::die( $status ) unless ( $status == Tibco::Rv::OK );
$self->bool( Tibco::Rv::FALSE );
return $self;
}
sub _new
{
my ( $class, $ptr ) = @_;
return bless { ptr => $ptr, %defaults }, $class;
}
sub _adopt
{
my ( $proto, $ptr ) = @_;
my ( $self );
my ( $class ) = ref( $proto );
if ( $class )
{
$self = $proto;
$self->DESTROY;
@$self{ 'ptr', keys %defaults } = ( $ptr, values %defaults );
} else {
$self = bless $proto->_new( $ptr ), $proto;
}
$self->_getValues;
return $self;
}
sub _getValues
{
my ( $self ) = @_;
Tibco::Rv::Msg::MsgField_GetValues(
@$self{ qw/ ptr name id size count type data / } );
if ( $self->{type} == Tibco::Rv::Msg::MSG )
{
$self->{data} = Tibco::Rv::Msg->_adopt( $self->{data} );
} elsif ( $self->{type} == Tibco::Rv::Msg::DATETIME ) {
$self->{data} = Tibco::Rv::Msg::DateTime->_adopt( $self->{data} );
} elsif ( $self->{type} == Tibco::Rv::Msg::IPADDR32 ) {
my ( $a, $b, $c, $d );
my ( $ipaddr32 ) = $self->{data};
$a = $ipaddr32; $a >>= 24; $ipaddr32 -= $a << 24;
$b = $ipaddr32; $b >>= 16; $ipaddr32 -= $b << 16;
$c = $ipaddr32; $c >>= 8; $ipaddr32 -= $c << 8;
$d = $ipaddr32;
$self->{data} = "$a.$b.$c.$d";
}
}
sub name
{
my ( $self ) = shift;
return @_ ? $self->_setName( @_ ) : $self->{name};
}
sub _setName
{
my ( $self, $name ) = @_;
$name = '' unless ( defined $name );
Tibco::Rv::Msg::MsgField_SetName( $self->{ptr}, $name );
return $self->{name} = $name;
}
sub id
{
my ( $self ) = shift;
return @_ ? $self->_setId( @_ ) : $self->{id};
}
sub _setId
{
my ( $self, $id ) = @_;
Tibco::Rv::Msg::MsgField_SetId( $self->{ptr}, $id );
return $self->{id} = $id;
}
sub count { return shift->{count} }
sub size { return shift->{size} }
sub type { return shift->{type} }
sub msg
{
my ( $self ) = shift;
return @_ ? $self->_setMsg( @_ ) : $self->_get( Tibco::Rv::Msg::MSG );
}
sub str { return shift->_bufAccessor( Tibco::Rv::Msg::STRING, @_ ) }
sub opaque { return shift->_bufAccessor( Tibco::Rv::Msg::OPAQUE, @_ ) }
sub xml { return shift->_bufAccessor( Tibco::Rv::Msg::XML, @_ ) }
sub bool { return shift->_eltAccessor( Tibco::Rv::Msg::BOOL, @_ ) }
sub i8 { return shift->_eltAccessor( Tibco::Rv::Msg::I8, @_ ) }
sub u8 { return shift->_eltAccessor( Tibco::Rv::Msg::U8, @_ ) }
sub i16 { return shift->_eltAccessor( Tibco::Rv::Msg::I16, @_ ) }
sub u16 { return shift->_eltAccessor( Tibco::Rv::Msg::U16, @_ ) }
sub i32 { return shift->_eltAccessor( Tibco::Rv::Msg::I32, @_ ) }
sub u32 { return shift->_eltAccessor( Tibco::Rv::Msg::U32, @_ ) }
sub i64 { return shift->_eltAccessor( Tibco::Rv::Msg::I64, @_ ) }
sub u64 { return shift->_eltAccessor( Tibco::Rv::Msg::U64, @_ ) }
sub f32 { return shift->_eltAccessor( Tibco::Rv::Msg::F32, @_ ) }
sub f64 { return shift->_eltAccessor( Tibco::Rv::Msg::F64, @_ ) }
sub ipport16 { return shift->_eltAccessor( Tibco::Rv::Msg::IPPORT16, @_ ) }
sub ipaddr32
{
my ( $self ) = shift;
return @_ ? $self->_setIPAddr32( @_ )
: $self->_get( Tibco::Rv::Msg::IPADDR32, $ipaddr32 );
}
sub date
{
my ( $self ) = shift;
return @_ ? $self->_setDate( @_ ) : $self->_get( Tibco::Rv::Msg::DATETIME );
}
sub i8array { return shift->_aryAccessor( Tibco::Rv::Msg::I8ARRAY, @_ ) }
sub u8array { return shift->_aryAccessor( Tibco::Rv::Msg::U8ARRAY, @_ ) }
sub i16array { return shift->_aryAccessor( Tibco::Rv::Msg::I16ARRAY, @_ ) }
sub u16array { return shift->_aryAccessor( Tibco::Rv::Msg::U16ARRAY, @_ ) }
sub i32array { return shift->_aryAccessor( Tibco::Rv::Msg::I32ARRAY, @_ ) }
sub u32array { return shift->_aryAccessor( Tibco::Rv::Msg::U32ARRAY, @_ ) }
sub i64array { return shift->_aryAccessor( Tibco::Rv::Msg::I64ARRAY, @_ ) }
sub u64array { return shift->_aryAccessor( Tibco::Rv::Msg::U64ARRAY, @_ ) }
sub f32array { return shift->_aryAccessor( Tibco::Rv::Msg::F32ARRAY, @_ ) }
sub f64array { return shift->_aryAccessor( Tibco::Rv::Msg::F64ARRAY, @_ ) }
sub _bufAccessor
{
my ( $self ) = shift;
my ( $type ) = shift;
return @_ ? $self->_setBuf( $type, @_ ) : $self->_get( $type );
}
sub _eltAccessor
{
my ( $self ) = shift;
my ( $type ) = shift;
return @_ ? $self->_setElt( $type, @_ ) : $self->_get( $type );
}
sub _aryAccessor
{
my ( $self ) = shift;
my ( $type ) = shift;
return @_ ? $self->_setAry( $type, @_ ) : $self->_get( $type );
}
sub _setIPAddr32
{
my ( $self, $ipaddr32 ) = @_;
@$self{ qw/ data type count / } = ( $ipaddr32, Tibco::Rv::Msg::IPADDR32, 1 );
my ( $a, $b, $c, $d ) = split( /\./, $ipaddr32 );
$ipaddr32 = $d + ( $c << 8 ) + ( $b << 16 ) + ( $a << 24 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetElt( @$self{ qw/ ptr type / }, $ipaddr32 );
return $self->{data};
}
sub _setDate
{
my ( $self, $date ) = @_;
@$self{ qw/ data type count / } = ( $date, Tibco::Rv::Msg::DATETIME, 1 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetDateTime( $self->{ptr}, $self->{data}{ptr} );
return $self->{data};
}
sub _get
{
my ( $self, $type ) = @_;
Tibco::Rv::die( Tibco::Rv::ARG_CONFLICT ) unless ( $self->{type} == $type );
return $self->{data};
}
sub _setMsg
{
my ( $self, $msg ) = @_;
@$self{ qw/ data type count / } = ( $msg, Tibco::Rv::Msg::MSG, 1 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetMsg( $self->{ptr}, $self->{data}{id} );
return $self->{data};
}
sub _setBuf
{
my ( $self, $type, $buf ) = @_;
@$self{ qw/ data type count / } = ( $buf, $type, 1 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetBuf( $self->{ptr}, $type, $self->{data} );
$self->{data} = substr( $self->{data}, 0, $self->{size} - 1 )
if ( $type == Tibco::Rv::Msg::STRING );
return $self->{data};
}
sub _setElt
{
my ( $self, $type, $elt ) = @_;
@$self{ qw/ data type count / } = ( $elt, $type, 1 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetElt( @$self{ qw/ ptr type data / } );
return $self->{data};
}
sub _setAry
{
my ( $self, $type, $ary ) = @_;
$ary = [ ] unless ( ref( $ary ) eq 'ARRAY' );
@$self{ qw/ data type count / } = ( $ary, $type, $#$ary + 1 );
$self->{size} =
Tibco::Rv::Msg::MsgField_SetAry( @$self{ qw/ ptr type data / } );
return $self->{data};
}
sub DESTROY
{
my ( $self ) = @_;
return unless ( exists $self->{ptr} );
my ( $status ) = Tibco::Rv::Msg::MsgField_Destroy( $self->{ptr} );
delete @$self{ keys %$self };
Tibco::Rv::die( $status ) unless ( $status == Tibco::Rv::OK );
}
1;
=pod
=head1 NAME
Tibco::Rv::Msg::Field - Manipulate a Tibco message field
=head1 SYNOPSIS
my ( $field ) = $msg->createField( name => 'myField' );
$field->i8( 123 );
$field->opaque( "abc\0abc" );
$field->ipaddr32( '66.35.250.150' );
$field->u64array( [ 1, 123, 3030 ] );
print "U64Array\n" if ( $field->type == Tibco::Rv::Msg::U64ARRAY );
print "Count: ", $field->count, "; size: ", $field->size, "\n";
=head1 DESCRIPTION
Message Field-manipulating class. Holds a single value, like a C enum,
along with a name and an id.
=head1 CONSTRUCTOR
=over 4
=item $field = new Tibco::Rv::Msg::Field( %args )
%args:
name => $name,
id => $id
Creates a C<Tibco::Rv::Msg::Field>, with name and id as given in %args
(name defaults '' and id defaults to 0, if not specified).
C<$field> is initialized with boolean value C<Tibco::Rv::FALSE>.
=back
=head1 METHODS
=over 4
=item $name = $field->name
Returns C<$field>'s name.
=item $field->name( $name )
Sets C<$field>'s name to C<$name>. If C<$name> is C<undef>, sets name to ''.
=item $id = $field->id
Returns C<$field>'s id.
=item $field->id( $id )
Sets C<$field>'s id.
=item $count = $field->count
Returns C<$field>'s count. For array types, C<$count> is the number of
elements in the array. For all other types, C<$count> is 1.
=item $size = $field->size
Returns C<$field>'s size. For array types, C<$size> is the size in bytes
of one element of the array. For all other types, C<$size> is the size in
bytes of the data (for strings, this includes the NULL terminator, and for
xml or opaque fields, this is the total number of bytes).
=item $type = $field->type
Returns the
L<Tibco::Rv::Msg Message Type Constant|Tibco::Rv::Msg/"MESSAGE TYPE CONSTANTS">
representing the type of data contained in the field.
=item $value = $field-><type>
Gets the C<$value> currently held in C<$field>. Dies with a
Tibco::Rv::ARG_CONFLICT Status message if E<lt>typeE<gt> does not match
the type of data currently held by C<$field>.
=item $field-><type>( $value )
<type> can be:
bool, str, opaque, xml,
f32, f64, i8, i16, i32, i64, u8, u16, u32, u64,
ipaddr32, ipport16, date, or msg
Sets the value of C<$field> to C<$value>, changing C<$field> to type
E<lt>typeE<gt> if it is not already.
=item $valueAryRef = $field-><type>array
Same as E<lt>typeE<gt>, except it returns an array reference of values.
=item $field-><type>array( [ $val1, $val2, ... ] )
<type> can be:
f32, f64, i8, i16, i32, i64, u8, u16, u32, u64
Some as E<lt>typeE<gt>, except it must be given an array reference of values.
=back
=head1 AUTHOR
Paul Sturm E<lt>I<sturm@branewave.com>E<gt>
=cut