You are viewing a plain text version of this content. The canonical link for it is here.
Posted to commits@qpid.apache.org by mc...@apache.org on 2013/04/11 15:56:59 UTC
svn commit: r1466891 - in /qpid/proton/trunk/proton-c/bindings/perl:
ChangeLog lib/qpid/proton/Constants.pm lib/qpid/proton/Data.pm
lib/qpid_proton.pm perl.i tests/data.t tests/utils.pm
Author: mcpierce
Date: Thu Apr 11 13:56:59 2013
New Revision: 1466891
URL: http://svn.apache.org/r1466891
Log:
PROTON-228: Provides the qpid::proton::Data class for Perl.
Added:
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm
qpid/proton/trunk/proton-c/bindings/perl/tests/data.t
Modified:
qpid/proton/trunk/proton-c/bindings/perl/ChangeLog
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid_proton.pm
qpid/proton/trunk/proton-c/bindings/perl/perl.i
qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm
Modified: qpid/proton/trunk/proton-c/bindings/perl/ChangeLog
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/ChangeLog?rev=1466891&r1=1466890&r2=1466891&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/ChangeLog (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/ChangeLog Thu Apr 11 13:56:59 2013
@@ -1,3 +1,6 @@
+version 0.5:
+ * Added the qpid::proton::Data type.
+
version 0.4:
* Unit tests for qpid::proton::Message.
* Unit tests for qpid::proton::Messenger.
Added: qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm?rev=1466891&view=auto
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm (added)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm Thu Apr 11 13:56:59 2013
@@ -0,0 +1,52 @@
+#
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you under the Apache License, Version 2.0 (the
+# "License"); you may not use this file except in compliance
+# with the License. You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing,
+# software distributed under the License is distributed on an
+# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+# KIND, either express or implied. See the License for the
+# specific language governing permissions and limitations
+# under the License.
+#
+
+package qpid::proton;
+
+use constant {
+ NULL => $cproton_perl::PN_NULL,
+ BOOL => $cproton_perl::PN_BOOL,
+ UBYTE => $cproton_perl::PN_UBYTE,
+ BYTE => $cproton_perl::PN_BYTE,
+ USHORT => $cproton_perl::PN_USHORT,
+ SHORT => $cproton_perl::PN_SHORT,
+ UINT => $cproton_perl::PN_UINT,
+ INT => $cproton_perl::PN_INT,
+ CHAR => $cproton_perl::PN_CHAR,
+ ULONG => $cproton_perl::PN_ULONG,
+ LONG => $cproton_perl::PN_LONG,
+ TIMESTAMP => $cproton_perl::PN_TIMESTAMP,
+ FLOAT => $cproton_perl::PN_FLOAT,
+ DOUBLE => $cproton_perl::PN_DOUBLE,
+ DECIMAL32 => $cproton_perl::PN_DECIMAL32,
+ DECIMAL64 => $cproton_perl::PN_DECIMAL64,
+ DECIMAL128 => $cproton_perl::PN_DECIMAL128,
+ UUID => $cproton_perl::PN_UUID,
+ BINARY => $cproton_perl::PN_BINARY,
+ STRING => $cproton_perl::PN_STRING,
+ SYMBOL => $cproton_perl::PN_SYMBOL,
+ DESCRIBED => $cproton_perl::PN_DESCRIBED,
+ ARRAY => $cproton_perl::PN_ARRAY,
+ LIST => $cproton_perl::PN_LIST,
+ MAP => $cproton_perl::PN_MAP,
+};
+
+
+
+1;
Added: qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm?rev=1466891&view=auto
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm (added)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm Thu Apr 11 13:56:59 2013
@@ -0,0 +1,1051 @@
+#
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you under the Apache License, Version 2.0 (the
+# "License"); you may not use this file except in compliance
+# with the License. You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing,
+# software distributed under the License is distributed on an
+# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+# KIND, either express or implied. See the License for the
+# specific language governing permissions and limitations
+# under the License.
+#
+
+=pod
+
+=head1 NAME
+
+qpid::proton::Data
+
+=head1 DESCRIPTION
+
+The B<Data> class provides an interface for decoding, extract, creating and
+encoding arbitrary AMQP data. A B<Data> object contains a tree of AMQP values.
+Leaf nodes in this tree correspond to scalars in the AMQP type system such as
+B<INT> or B<STRING>. Integerior nodes in this tree correspond to compound values
+in the AMQP type system such as B<LIST>, B<MAP>, B<ARRAY> or B<DESCRIBED>. The
+root node of the tree is the B<Data> object itself and can have an arbitrary
+number of children.
+
+A B<Data> object maintains the notion of the current sibling node and a current
+parent node. Siblings are ordered within their parent. Values are accessed
+and/or added by using the B<next>, B<prev>, B<enter> and B<exit> methods to
+navigate to the desired location in the tree and using the supplied variety of
+mutator and accessor methods to access or add a value of the desired type.
+
+The mutator methods will always add a vlaue I<after> the current node in the
+tree. If the current node has a next sibling the mutaor method will overwrite
+the value on this node. If there is no current node or the current node has no
+next sibling then one will be added. The accessor methods always set the
+add/modified node to the current node. The accessor methods read the value of
+the current node and do not change which node is current.
+
+=cut
+
+package qpid::proton::Data;
+
+=pod
+
+=head1 CONSTRUCTOR
+
+Creates a new instance with the specified capacity.
+
+=over
+
+=item my $data = qpid::proton::Data->new( CAPACITY );
+
+=back
+
+=cut
+
+sub new {
+ my ($class) = @_;
+ my ($self) = {};
+ my $capacity = $_[1] || 16;
+
+ my $impl = cproton_perl::pn_data($capacity);
+ $self->{_impl} = $impl;
+
+ bless $self, $class;
+ return $self;
+}
+
+sub DESTROY {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_free($impl);
+}
+
+=pod
+
+=head1 NAVIGATION
+
+The following methods allow for navigating through the nodes in the tree.
+
+=cut
+
+
+=pod
+
+=over
+
+=item $doc->enter;
+
+=item if ($doc->enter()) { do_something_with_children; }
+
+Sets the parent node to the current node and clears the current node.
+
+Clearing the current node sets it I<before> the first child.
+
+=item $doc->exit;
+
+=item if ($doc->exit()) { do_something_with_parent; }
+
+Sets the current node to the parent node, and the parent node to its own parent.
+
+=back
+
+=cut
+
+sub enter {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_enter($impl);
+}
+
+sub exit {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_exit($impl);
+}
+
+
+=pod
+
+=over
+
+=item $doc->next;
+
+=item if ($doc->next()) { do_something; }
+
+Advances the current node to its next sibling and returns its type.
+
+If there is no next sibling then the current node remains unchanged and
+B<undef> is returned.
+
+=item $doc->prev;
+
+=item if ($doc->prev()) { do_something; }
+
+Advances the current node to its previous sibling and returns its type.
+
+If there is no previous sibling then the current node remains unchanged and
+undef is returned.
+
+=back
+
+=cut
+
+sub next {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_next($impl);
+}
+
+sub prev {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_prev($impl);
+}
+
+
+=pod
+
+=head1 SUPPORTED TYPES
+
+The following methods allow for inserting the various node types into the
+tree.
+
+=cut
+
+
+=pod
+
+=head2 SCALAR TYPES
+
+=cut
+
+=pod
+
+=head3 NULL
+
+=over
+
+=item $doc->put_null;
+
+Inserts a null node.
+
+=item $doc->is_null;
+
+Returns true if the current node is null.
+
+=back
+
+=cut
+
+sub put_null() {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_put_null($impl);
+}
+
+sub is_null {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_is_null($impl);
+}
+
+sub check {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $err = $_[1];
+
+ # if we got a null then just exit
+ return $err if !defined($err);
+
+ if($err < 0) {
+ die DataException->new("[$err]: " . cproton_perl::pn_data_error($impl));
+ } else {
+ return $err;
+ }
+}
+
+=pod
+
+=head3 BOOL
+
+Handles a boolean (B<true>/B<false>) node.
+
+=over
+
+=item $doc->put_bool( VALUE );
+
+=item $doc->get_bool;
+
+=back
+
+=cut
+
+sub put_bool {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "bool must be defined" if !defined($value);
+
+ cproton_perl::pn_data_put_bool($impl, $value);
+}
+
+sub get_bool {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_bool($impl);
+}
+
+=pod
+
+=head3 UBYTE
+
+Handles an unsigned byte node.
+
+=over
+
+=item $data->put_ubyte( VALUE );
+
+=item $data->get_ubyte;
+
+=back
+
+=cut
+
+sub put_ubyte {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "ubyte must be defined" if !defined($value);
+ die "ubyte must be non-negative" if $value < 0;
+
+ check(cproton_perl::pn_data_put_ubyte($impl, int($value)));
+}
+
+sub get_ubyte {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_ubyte($impl);
+}
+
+=pod
+
+=head3 BYTE
+
+Handles a signed byte node.
+
+=over
+
+=item $data->put_byte( VALUE );
+
+=item $data->get_byte;
+
+=back
+
+=cut
+
+sub put_byte {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "byte must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_byte($impl, int($value)));
+}
+
+sub get_byte {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_byte($impl);
+}
+
+=pod
+
+=head3 USHORT
+
+Handles an unsigned short node.
+
+=over
+
+=item $data->put_ushort( VALUE );
+
+=item $data->get_ushort;
+
+=back
+
+=cut
+
+sub put_ushort {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "ushort must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_ushort($impl, int($value)));
+}
+
+sub get_ushort {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_ushort($impl);
+}
+
+=pod
+
+=head3 SHORT
+
+Handles a signed short node.
+
+=over
+
+=item $data->put_short( VALUE );
+
+=item $data->get_short;
+
+=back
+
+=cut
+
+sub put_short {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "short must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_short($impl, int($value)));
+}
+
+sub get_short {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_short($impl);
+}
+
+=pod
+
+=head3 UINT
+
+Handles an unsigned integer node.
+
+=over
+
+=item $data->put_uint( VALUE );
+
+=item $data->get_uint;
+
+=back
+
+=cut
+
+sub put_uint {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "uint must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_uint($impl, int($value)));
+}
+
+sub get_uint {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_uint($impl);
+}
+
+=pod
+
+=head3 INT
+
+Handles an integer node.
+
+=over
+
+=item $data->put_int( VALUE );
+
+=item $data->get_int;
+
+=back
+
+=cut
+
+sub put_int {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "int must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_int($impl, int($value)));
+}
+
+sub get_int {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_int($impl);
+}
+
+=pod
+
+=head3 CHAR
+
+Handles a character node.
+
+=over
+
+=item $data->put_char( VALUE );
+
+=item $data->get_char;
+
+=back
+
+=cut
+
+sub put_char {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "char must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_char($impl, int($value)));
+}
+
+sub get_char {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_char($impl);
+}
+
+=pod
+
+=head3 ULONG
+
+Handles an unsigned long node.
+
+=over
+
+=item $data->set_ulong( VALUE );
+
+=item $data->get_ulong;
+
+=back
+
+=cut
+
+sub put_ulong {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "ulong must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_ulong($impl, $value));
+}
+
+sub get_ulong {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_ulong($impl);
+}
+
+=pod
+
+=head3 LONG
+
+Handles a signed long node.
+
+=over
+
+=item $data->put_long( VALUE );
+
+=item $data->get_long;
+
+=back
+
+=cut
+
+sub put_long {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "long must be defined" if !defined($value);
+
+ cproton_perl::pn_data_put_long($impl, int($value));
+}
+
+sub get_long {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_long($impl);
+}
+
+=pod
+
+=head3 TIMESTAMP
+
+Handles a timestamp node.
+
+=over
+
+=item $data->put_timestamp( VALUE );
+
+=item $data->get_timestamp;
+
+=back
+
+=cut
+
+sub put_timestamp {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "timestamp must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_timestamp($impl, int($value)));
+}
+
+sub get_timestamp {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_timestamp($impl);
+}
+
+=pod
+
+=head3 FLOAT
+
+Handles a floating point node.
+
+=over
+
+=item $data->put_float( VALUE );
+
+=item $data->get_float;
+
+=back
+
+=cut
+
+sub put_float {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "float must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_float($impl, $value));
+}
+
+sub get_float {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ my $value = cproton_perl::pn_data_get_float($impl);
+
+ cproton_perl::pn_data_get_float($impl);
+}
+
+=pod
+
+=head3 DOUBLE
+
+Handles a double node.
+
+=over
+
+=item $data->put_double( VALUE );
+
+=item $data->get_double;
+
+=back
+
+=cut
+
+sub put_double {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "double must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_double($impl, $value));
+}
+
+sub get_double {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_double($impl);
+}
+
+=pod
+
+=head3 DECIMAL32
+
+Handles a decimal32 node.
+
+=over
+
+=item $data->put_decimal32( VALUE );
+
+=item $data->get_decimal32;
+
+=back
+
+=cut
+
+sub put_decimal32 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "decimal32 must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_decimal32($impl, $value));
+}
+
+sub get_decimal32 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_decimal32($impl);
+}
+
+=pod
+
+=head3 DECIMAL64
+
+Handles a decimal64 node.
+
+=over
+
+=item $data->put_decimal64( VALUE );
+
+=item $data->get_decimal64;
+
+=back
+
+=cut
+
+sub put_decimal64 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "decimal64 must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_decimal64($impl, $value));
+}
+
+sub get_decimal64 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_decimal64($impl);
+}
+
+=pod
+
+=head3 DECIMAL128
+
+Handles a decimal128 node.
+
+=over
+
+=item $data->put_decimal128( VALUE );
+
+=item $data->get_decimal128;
+
+=back
+
+=cut
+
+sub put_decimal128 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "decimal128 must be defined" if !defined($value);
+
+ my @binary = split //, pack("H[32]", sprintf("%032x", $value));
+ my @bytes = ();
+
+ foreach $char (@binary) {
+ push(@bytes, ord($char));
+ }
+ check(cproton_perl::pn_data_put_decimal128($impl, \@bytes));
+}
+
+sub get_decimal128 {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ my $bytes = cproton_perl::pn_data_get_decimal128($impl);
+ my $value = hex(unpack("H[32]", $bytes));
+
+ return $value;
+}
+
+=pod
+
+=head3 UUID
+
+Handles setting a UUID value. UUID values can be set using a 128-bit integer
+value or else a well-formed string.
+
+=over
+
+=item $data->put_uuid( VALUE );
+
+=item $data->get_uuid;
+
+=back
+
+=cut
+
+use Data::Dumper;
+
+sub put_uuid {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "uuid must be defined" if !defined($value);
+
+ if($value =~ /[a-fA-F0-9]{8}-[a-fA-F0-9]{4}-[a-fA-F0-9]{4}-[a-fA-F0-9]{4}-[a-fA-F0-9]{12}/) {
+ $value =~ s/-//g;
+ my @binary = split //, pack("H[32]", $value);
+ my @bytes = ();
+
+ foreach $char (@binary) {
+ push(@bytes, ord($char));
+ }
+
+ check(cproton_perl::pn_data_put_uuid($impl, \@bytes));
+ } else {
+ die "uuid is malformed: $value";
+ }
+}
+
+sub get_uuid {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ my $bytes = cproton_perl::pn_data_get_uuid($impl);
+
+ my $value = unpack("H[32]", $bytes);
+ $value = substr($value, 0, 8) . "-" .
+ substr($value, 8, 4) . "-" .
+ substr($value, 12, 4) . "-" .
+ substr($value, 16, 4) . "-" .
+ substr($value, 20);
+
+ return $value;
+}
+
+=pod
+
+=head3 BINARY
+
+Handles a binary data node.
+
+=over
+
+=item $data->put_binary( VALUE );
+
+=item $data->get_binary;
+
+=back
+
+=cut
+
+sub put_binary {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "binary must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_binary($impl, $value)) if defined($value);
+}
+
+sub get_binary {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_binary($impl);
+}
+
+=pod
+
+=head3 STRING
+
+Handles a string node.
+
+=over
+
+=item $data->put_string( VALUE );
+
+=item $data->get_string;
+
+=back
+
+=cut
+
+sub put_string {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "string must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_string($impl, $value));
+}
+
+sub get_string {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_string($impl);
+}
+
+=pod
+
+=head3 SYMBOL
+
+Handles a symbol value.
+
+=over
+
+=item $data->put_symbol( VALUE );
+
+=item $data->get_symbol;
+
+=back
+
+=cut
+
+sub put_symbol {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $value = $_[1];
+
+ die "symbol must be defined" if !defined($value);
+
+ check(cproton_perl::pn_data_put_symbol($impl, $value));
+}
+
+sub get_symbol {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_get_symbol($impl);
+}
+
+=pod
+
+=head3 DESCRIBED VALUE
+
+A described node has two children: the descriptor and the value.
+
+These are specified by entering the node and putting the
+described values.
+
+=over
+
+=item $data->put_described;
+
+=item $data->is_described;
+
+=back
+
+=cut
+
+sub put_described {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_put_described($impl);
+}
+
+sub is_described {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_is_described($impl);
+}
+
+=pod
+
+=head3 ARRAYS
+
+Puts an array value.
+
+Elements may be filled by entering the array node and putting the element values.
+The values must all be of the specified array element type.
+
+If an array is B<described> then the first child value of the array is the
+descriptor and may be of any type.
+
+=over
+
+B<DESCRIBED> specifies whether the array is described or not.
+
+B<TYPE> specifies the type of elements in the array.
+
+=back
+
+=over
+
+=item $data->put_array( DESCRIBED, TYPE )
+
+=back
+
+=cut
+
+sub put_array {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $described = $_[1] || 0;
+ my $type = $_[2];
+
+ die "array type must be defined" if !defined($type);
+
+ check(cproton_perl::pn_data_put_array($impl, $described, $type));
+}
+
+=pod
+
+=head3 LIST
+
+Puts a list value.
+
+Elements may be filled in by entering the list and putting element values.
+
+=over
+
+=item $data->put_list;
+
+=back
+
+=cut
+
+sub put_list {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ check(cproton_perl::pn_data_put_list($impl));
+}
+
+=pod
+
+head3 MAP
+
+Puts a map value.
+
+Elements may be filled by entering the map node and putting alternating
+key/value pairs.
+
+=over
+
+=item $data->put_map;
+
+=back
+
+=cut
+
+sub put_map {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ check(cproton_perl::pn_data_put_map($impl));
+}
+
+1;
Modified: qpid/proton/trunk/proton-c/bindings/perl/lib/qpid_proton.pm
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/lib/qpid_proton.pm?rev=1466891&r1=1466890&r2=1466891&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid_proton.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid_proton.pm Thu Apr 11 13:56:59 2013
@@ -21,6 +21,8 @@ use strict;
use warnings;
use cproton_perl;
+use qpid::proton::Constants;
+use qpid::proton::Data;
use qpid::proton::Messenger;
use qpid::proton::Message;
Modified: qpid/proton/trunk/proton-c/bindings/perl/perl.i
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/perl.i?rev=1466891&r1=1466890&r2=1466891&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/perl.i (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/perl.i Thu Apr 11 13:56:59 2013
@@ -105,16 +105,51 @@ typedef int int32_t;
{
SV* obj = sv_newmortal();
- if($1.size > 0)
+ if($1.start != NULL)
{
- sv_setpvn(obj, $1.start, $1.size);
+ $result = newSVpvn($1.start, $1.size);
}
else
{
- sv_setsv(obj, &PL_sv_undef);
+ $result = &PL_sv_undef;
}
- $result = obj;
+ argvi++;
+}
+
+%typemap(in) pn_decimal128_t
+{
+ AV *tmpav = (AV*)SvRV($input);
+ int index = 0;
+
+ for(index = 0; index < 16; index++)
+ {
+ $1.bytes[index] = SvIV(*av_fetch(tmpav, index, 0));
+ $1.bytes[index] = $1.bytes[index] & 0xff;
+ }
+}
+
+%typemap(out) pn_decimal128_t
+{
+ $result = newSVpvn($1.bytes, 16);
+ argvi++;
+}
+
+%typemap(in) pn_uuid_t
+{
+ AV* tmpav = SvRV($input);
+ int index = 0;
+
+ for(index = 0; index < 16; index++)
+ {
+ $1.bytes[index] = SvIV(*av_fetch(tmpav, index, 0));
+ $1.bytes[index] = $1.bytes[index] & 0xff;
+ }
+}
+
+%typemap(out) pn_uuid_t
+{
+ $result = newSVpvn($1.bytes, 16);
argvi++;
}
Added: qpid/proton/trunk/proton-c/bindings/perl/tests/data.t
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/tests/data.t?rev=1466891&view=auto
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/tests/data.t (added)
+++ qpid/proton/trunk/proton-c/bindings/perl/tests/data.t Thu Apr 11 13:56:59 2013
@@ -0,0 +1,536 @@
+#!/bin/env perl -w
+#
+# Licensed to the Apache Software Foundation (ASF) under one
+# or more contributor license agreements. See the NOTICE file
+# distributed with this work for additional information
+# regarding copyright ownership. The ASF licenses this file
+# to you under the Apache License, Version 2.0 (the
+# "License"); you may not use this file except in compliance
+# with the License. You may obtain a copy of the License at
+#
+# http://www.apache.org/licenses/LICENSE-2.0
+#
+# Unless required by applicable law or agreed to in writing,
+# software distributed under the License is distributed on an
+# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+# KIND, either express or implied. See the License for the
+# specific language governing permissions and limitations
+# under the License.
+#
+
+use Test::More qw(no_plan);
+use Test::Number::Delta within => 1e-3;
+use Test::Exception;
+
+require 'utils.pm';
+
+BEGIN {use_ok('qpid_proton');}
+require_ok('qpid_proton');
+
+my $data;
+my $value;
+
+# Create without capacity
+$data = qpid::proton::Data->new();
+isa_ok($data, 'qpid::proton::Data');
+
+# Create with capacity
+$data = qpid::proton::Data->new(24);
+isa_ok($data, 'qpid::proton::Data');
+
+# can put a null
+$data = qpid::proton::Data->new();
+$data->put_null();
+ok($data->is_null(), "Data can put a null");
+
+# raises an error on a null boolean
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_bool;}, "Cannot put a null bool");
+
+# can put a true boolean
+$data = qpid::proton::Data->new();
+$data->put_bool(1);
+ok($data->get_bool(), "Data can put a true bool");
+
+# can put a false boolean
+$data = qpid::proton::Data->new();
+$data->put_bool(0);
+ok(!$data->get_bool(), "Data can put a false bool");
+
+# raises an error on a negative ubyte
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_ubyte(0 - (rand(2**7) + 1));},
+ "Cannot have a negative ubyte");
+
+# raises an error on a null ubyte
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_ubyte;}, "Cannot put a null ubyte");
+
+# can put a zero ubyte
+$data = qpid::proton::Data->new();
+$data->put_ubyte(0);
+ok($data->get_ubyte() == 0, "Can put a zero ubyte");
+
+# will convert a float to an int ubyte
+$data = qpid::proton::Data->new();
+$value = rand(2**7) + 1;
+$data->put_ubyte($value);
+ok ($data->get_ubyte() == int($value), "Can put a float ubyte");
+
+# can put a ubyte
+$data = qpid::proton::Data->new();
+$value = int(rand(2**7) + 1);
+$data->put_ubyte($value);
+ok($data->get_ubyte() == $value, "Can put a ubyte");
+
+# raises an error on a null byte
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_byte;}, "Cannot put a null byte");
+
+# can put a negative byte
+$data = qpid::proton::Data->new();
+$value = int(0 - (1 + rand(2**7)));
+$data->put_byte($value);
+ok($data->get_byte() == $value, "Can put a negative byte");
+
+# can put a zero byte
+$data = qpid::proton::Data->new();
+$data->put_byte(0);
+ok($data->get_byte() == 0, "Can put a zero byte");
+
+# can put a float as a byte
+$data = qpid::proton::Data->new();
+$value = rand(2**7) + 1;
+$data->put_byte($value);
+ok($data->get_byte() == int($value), "Can put a float as a byte");
+
+# can put a byte
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**7));
+$data->put_byte($value);
+ok($data->get_byte() == $value, "Can put a byte");
+
+# raise an error on a null ushort
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_ushort;}, "Cannot put a null ushort");
+
+# raises an error on a negative ushort
+$data = qpid::proton::Data->new();
+$value = 0 - (1 + rand((2**15)));
+dies_ok(sub {$data->put_ushort($value);}, "Cannot put a negative ushort");
+
+# can put a zero ushort
+$data = qpid::proton::Data->new();
+$data->put_ushort(0);
+ok($data->get_ushort() == 0, "Can put a zero ushort");
+
+# can handle a float ushort value
+$data = qpid::proton::Data->new();
+$value = 1 + rand((2**15));
+$data->put_ushort($value);
+ok($data->get_ushort() == int($value), "Can put a float ushort");
+
+# can put a ushort
+$data = qpid::proton::Data->new();
+$value = int(1 + rand((2**15)));
+$data->put_ushort($value);
+ok($data->get_ushort() == $value, "Can put a ushort");
+
+# raises an error on a null short
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_short;}, "Cannot put a null short");
+
+# can put a negative short
+$data = qpid::proton::Data->new();
+$value = int(0 - (1 + rand((2**15))));
+$data->put_short($value);
+ok($data->get_short() == $value, "Can put a negative short");
+
+# can put a zero short
+$data = qpid::proton::Data->new();
+$data->put_short(0);
+ok($data->get_short() == 0, "Can put a zero short");
+
+# can put a float as a short
+$data = qpid::proton::Data->new();
+$value = 1 + rand(2**15);
+$data->put_short($value);
+ok($data->get_short() == int($value), "Can put a float as a short");
+
+# can put a short
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**15));
+$data->put_short($value);
+ok($data->get_short() == $value, "Can put a short");
+
+# raises an error on a null uint
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_uint;}, "Cannot set a null uint");
+
+# raises an error on a negative uint
+$data = qpid::proton::Data->new();
+$value = 0 - (1 + rand(2**31));
+dies_ok(sub {$data->put_uint($value);}, "Cannot set a negative uint");
+
+# can put a zero uint
+$data = qpid::proton::Data->new();
+$data->put_uint(0);
+ok($data->get_uint() == 0, "Can put a zero uint");
+
+# can put a float as a uint
+$data = qpid::proton::Data->new();
+$value = 1 + rand(2**31);
+$data->put_uint($value);
+ok($data->get_uint() == int($value), "Can put a float as a uint");
+
+# can put a uint
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**31));
+$data->put_uint($value);
+ok($data->get_uint() == $value, "Can put a uint");
+
+# raise an error on a null integer
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_int;}, "Cannot put a null int");
+
+# can put a negative integer
+$data = qpid::proton::Data->new();
+$value = int(0 - (1 + rand(2**31)));
+$data->put_int($value);
+ok($data->get_int() == $value, "Can put a negative int");
+
+# can put a zero integer
+$data = qpid::proton::Data->new();
+$data->put_int(0);
+ok($data->get_int() == 0, "Can put a zero int");
+
+# can put a float as an integer
+$data = qpid::proton::Data->new();
+$value = 1 + (rand(2**31));
+$data->put_int($value);
+ok($data->get_int() == int($value), "Can put a float as an int");
+
+# can put an integer
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**31));
+$data->put_int($value);
+ok($data->get_int() == $value, "Can put an int");
+
+# raises an error on a null character
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_char;}, "Cannot put a null char");
+
+# can put a float as a char
+$data = qpid::proton::Data->new();
+$value = 1 + rand(255);
+$data->put_char($value);
+ok($data->get_char() == int($value), "Can put a float as a char");
+
+# can put a character
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(255));
+$data->put_char($value);
+ok($data->get_char() == $value, "Can put a char");
+
+# raise an error on a null ulong
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_ulong;}, "Cannot put a null ulong");
+
+# raises an error on a negative ulong
+$data = qpid::proton::Data->new();
+$value = 0 - (1 + rand(2**63));
+dies_ok(sub {$data->put_ulong($value);}, "Cannot put a negative ulong");
+
+# can put a zero ulong
+$data = qpid::proton::Data->new();
+$data->put_ulong(0);
+ok($data->get_ulong() == 0, "Can put a zero ulong");
+
+# can put a float as a ulong
+$data = qpid::proton::Data->new();
+$value = 1 + rand(2**63);
+$data->put_ulong($value);
+ok($data->get_ulong() == int($value), "Can put a float as a ulong");
+
+# can put a ulong
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**63));
+$data->put_ulong($value);
+ok($data->get_ulong() == $value, "Can put a ulong");
+
+# raises an error on a null long
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_long;}, "Cannot put a null long");
+
+# can put a negative long
+$data = qpid::proton::Data->new();
+$value = int(0 - (1 + rand(2**63)));
+$data->put_long($value);
+ok($data->get_long() == $value, "Can put a negative long");
+
+# can put a zero long
+$data = qpid::proton::Data->new();
+$data->put_long(0);
+ok($data->get_long() == 0, "Can put a zero long");
+
+# can put a float as a long
+$data = qpid::proton::Data->new();
+$value = 1 + rand(2**63);
+$data->put_long($value);
+ok($data->get_long() == int($value), "Can put a float as a long");
+
+# can put a long
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**63));
+$data->put_long($value);
+ok($data->get_long() == $value, "Can put a long value");
+
+# raises an error on a null timestamp
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_timestamp;}, "Cannot put a null timestamp");
+
+# can put a negative timestamp
+$data = qpid::proton::Data->new();
+$value = int(0 - (1 + rand(2**32)));
+$data->put_timestamp($value);
+ok($data->get_timestamp() == $value, "Can put a negative timestamp");
+
+# can put a zero timestamp
+$data = qpid::proton::Data->new();
+$data->put_timestamp(0);
+ok($data->get_timestamp() == 0, "Can put a zero timestamp");
+
+# can put a float as a timestamp
+$data = qpid::proton::Data->new();
+$value = 1 + (rand(2**32));
+$data->put_timestamp($value);
+ok($data->get_timestamp() == int($value), "Can put a float as a timestamp");
+
+# can put a timestamp
+$data = qpid::proton::Data->new();
+$value = int(1 + rand(2**32));
+$data->put_timestamp($value);
+ok($data->get_timestamp() == $value, "Can put a timestamp");
+
+# raises an error on a null float
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_float;}, "Cannot put a null float");
+
+# can put a negative float
+$data = qpid::proton::Data->new();
+$value = 0 - (1 + rand(2**15));
+$data->put_float($value);
+delta_ok($data->get_float(), $value, "Can put a negative float");
+
+# can put a zero float
+$data = qpid::proton::Data->new();
+$data->put_float(0.0);
+delta_ok($data->get_float(), 0.0, "Can put a zero float");
+
+# can put a float
+$data = qpid::proton::Data->new();
+$value = 1.0 + rand(2**15);
+$data->put_float($value);
+delta_ok($data->get_float(), $value, "Can put a float");
+
+# raises an error on a null double
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_double;}, "Cannot set a null double");
+
+# can put a negative double
+$data = qpid::proton::Data->new();
+$value = 0 - (1 + rand(2**31));
+$data->put_double($value);
+delta_ok($data->get_double(), $value, "Can put a double value");
+
+# can put a zero double
+$data = qpid::proton::Data->new();
+$data->put_double(0.0);
+delta_ok($data->get_double(), 0.0, "Can put a zero double");
+
+# can put a double
+$data = qpid::proton::Data->new();
+$value = 1.0 + rand(2**15);
+$data->put_double($value);
+delta_ok($data->get_double(), $value, "Can put a double");
+
+# raises an error on a null decimal32
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_decimal32;}, "Cannot put a null decimal32");
+
+# can put a decimal32
+$data = qpid::proton::Data->new();
+$value = int(rand(2**32));
+$data->put_decimal32($value);
+ok($data->get_decimal32() == $value, "Can put a decimal32 value");
+
+# raises an error on a null decimal64
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_decimal64();}, "Cannot put a null decimal64");
+
+# can put a decimal64
+$data = qpid::proton::Data->new();
+$value = int(rand(2**64));
+$data->put_decimal64($value);
+ok($data->get_decimal64() == $value, "Can put a decimal64 value");
+
+# raises an error on a null decimal128
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_decimal128;}, "Cannot put a null decimal128");
+
+# can put a decimal128
+$data = qpid::proton::Data->new();
+$value = int(rand(2**31));
+$data->put_decimal128($value);
+ok($data->get_decimal128() == $value, "Can put a decimal128 value");
+
+# raises an error on a null UUID
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_uuid;}, "Cannot put a null UUID");
+
+# raises an error on a malformed UUID
+$data = qpid::proton::Data->new();
+$value = random_string(36);
+dies_ok(sub {$data->put_uuid($value);}, "Cannot put a malformed UUID");
+
+# can put a UUID
+$data = qpid::proton::Data->new();
+$data->put_uuid("fd0289a5-8eec-4a08-9283-81d02c9d2fff");
+ok($data->get_uuid() eq "fd0289a5-8eec-4a08-9283-81d02c9d2fff",
+ "Can store a string UUID");
+
+# cannot put a null binary
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_binary;}, "Cannot put a null binary");
+
+# can put an empty binary string
+$data = qpid::proton::Data->new();
+$data->put_binary("");
+ok($data->get_binary() eq "", "Can put an empty binary");
+
+# can put a binary
+$data = qpid::proton::Data->new();
+$value = random_string(128);
+$data->put_binary($value);
+ok($data->get_binary() eq $value, "Can put a binary value");
+
+# cannot put a null string
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_string;}, "Cannot put a null string");
+
+# can put an empty string
+$data = qpid::proton::Data->new();
+$data->put_string("");
+ok($data->get_string() eq "", "Can put an empty string");
+
+# can put a string
+$data = qpid::proton::Data->new();
+$value = random_string(128);
+$data->put_string($value);
+ok($data->get_string() eq $value, "Can put an arbitrary string");
+
+# cannot put a null symbol
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_symbol;}, "Cannot put a null symbol");
+
+# can put a symbol
+$data = qpid::proton::Data->new();
+$value = random_string(64);
+$data->put_symbol($value);
+ok($data->get_symbol eq $value, "Can put a symbol");
+
+# can hold a described value
+$data = qpid::proton::Data->new();
+$data->put_described;
+ok($data->is_described, "Can hold a described value");
+
+# can put an array with undef as described flag
+$data = qpid::proton::Data->new();
+my @values = map { rand } (1..100, );
+lives_ok(sub {$data->put_array(undef, qpid::proton::INT);},
+ "Array can have null for described flag");
+
+# arrays must have a specified type
+$data = qpid::proton::Data->new();
+dies_ok(sub {$data->put_array;},
+ "Array type cannot be null");
+
+# can put an array
+$data = qpid::proton::Data->new();
+@values = random_integers(100);
+$data->put_array(0, qpid::proton::INT);
+$data->enter;
+foreach $value (@values) {
+ $data->put_int($value);
+}
+$data->exit;
+
+@result = ();
+$data->enter;
+foreach $value (@values) {
+ $data->next;
+ push @result, $data->get_int;
+}
+$data->exit;
+is_deeply((\@result, \@values), "Array was populated correctly");
+
+# can put a described array
+$data = qpid::proton::Data->new();
+@values = random_integers(100);
+$data->put_array(1, qpid::proton::INT);
+$data->enter;
+foreach $value (@values) {
+ $data->put_int($value);
+}
+$data->exit;
+
+@result = ();
+$data->enter;
+foreach $value (@values) {
+ $data->next;
+ push @result, $data->get_int;
+}
+is_deeply((\@result, \@values), "Array was populated correctly");
+
+# can put a list
+$data = qpid::proton::Data->new();
+@values = random_integers(100);
+$data->put_list;
+$data->enter;
+foreach $value (@values) {
+ $data->put_int($value);
+}
+$data->exit;
+
+@result = ();
+$data->enter;
+foreach $value (@values) {
+ $data->next;
+ push @result, $data->get_int;
+}
+$data->exit;
+is_deeply((\@result, \@values), "List was populated correctly");
+
+
+# can put a map
+$data = qpid::proton::Data->new();
+my %map = random_hash(100);
+$data->put_map;
+$data->enter;
+foreach my $key (keys %map) {
+ $data->put_string($key);
+ $data->put_string($map{$key});
+}
+$data->exit;
+
+my $result = {};
+$data->enter;
+foreach my $key (keys %map) {
+ $data->next;
+ my $rkey = $data->get_string;
+ $data->next;
+ my $rval = $data->get_string;
+ $result{$rkey} = $rval;
+}
+$data->exit;
+ok(eq_hash(\%result, \%map), "Map was populated correctly");
Modified: qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm?rev=1466891&r1=1466890&r2=1466891&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm Thu Apr 11 13:56:59 2013
@@ -1,3 +1,29 @@
+sub random_integers
+{
+ my $len = shift;
+ my @result;
+
+ foreach (1..$len) {
+ my $value = int(rand(100));
+ push @result, $value;
+ }
+
+ return @result;
+}
+
+sub random_hash
+{
+ my $len = shift;
+ my %result;
+
+ foreach (1..$len) {
+ my $key = random_string(32);
+ my $val = random_string(128);
+ $result{$key} = $val;
+ }
+
+ return %result;
+}
sub random_string
{
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscribe@qpid.apache.org
For additional commands, e-mail: commits-help@qpid.apache.org