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/06/10 14:50:11 UTC
svn commit: r1491441 - in /qpid/proton/trunk/proton-c/bindings/perl: ./ lib/
lib/qpid/proton/ tests/
Author: mcpierce
Date: Mon Jun 10 12:50:10 2013
New Revision: 1491441
URL: http://svn.apache.org/r1491441
Log:
PROTON-324: Refactor Perl support for working with arrays and Data objects
Renamed the TypeHelper class to Mapping to be more like the Ruby
language. Deleted the previous qpid::proton::Array class since it
tightly coupled the developer's code to Proton where it should not do
so.
Provides three new methods:
qpid::proton::put_array_into - put an array into a Data object
qpid::proton::get_array_from - gets an array out of a Data object
qpid::proton::get_list_from - gets a list out of a Data object
Added:
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Mapping.pm
- copied, changed from r1490429, qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/TypeHelper.pm
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/array_helper.pm
qpid/proton/trunk/proton-c/bindings/perl/tests/array_helper.t
Removed:
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Array.pm
qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/TypeHelper.pm
qpid/proton/trunk/proton-c/bindings/perl/tests/array.t
Modified:
qpid/proton/trunk/proton-c/bindings/perl/ChangeLog
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/lib/qpid_proton.pm
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=1491441&r1=1491440&r2=1491441&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/ChangeLog (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/ChangeLog Mon Jun 10 12:50:10 2013
@@ -1,5 +1,8 @@
version 0.5:
* Added the qpid::proton::Data type.
+ * Added the qpid::proton::put_array_into method.
+ * Added the qpid::proton::get_array_from method.
+ * Added the qpid::proton::put_list_into method.
version 0.4:
* Unit tests for qpid::proton::Message.
Modified: 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=1491441&r1=1491440&r2=1491441&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Constants.pm Mon Jun 10 12:50:10 2013
@@ -21,86 +21,116 @@ package qpid::proton;
use constant {
NULL => $cproton_perl::PN_NULL,
- BOOL => qpid::proton::TypeHelper->new(
+ BOOL => qpid::proton::Mapping->new(
+ "bool",
$cproton_perl::PN_BOOL,
"put_bool",
"get_bool"),
- UBYTE => qpid::proton::TypeHelper->new(
+ UBYTE => qpid::proton::Mapping->new(
+ "ubyte",
$cproton_perl::PN_UBYTE,
"put_ubyte",
"get_ubyte"),
- BYTE => qpid::proton::TypeHelper->new(
+ BYTE => qpid::proton::Mapping->new(
+ "byte",
$cproton_perl::PN_BYTE,
"put_byte",
"get_byte"),
- USHORT => qpid::proton::TypeHelper->new(
+ USHORT => qpid::proton::Mapping->new(
+ "ushort",
$cproton_perl::PN_USHORT,
"put_ushort",
"get_ushort"),
- SHORT => qpid::proton::TypeHelper->new(
+ SHORT => qpid::proton::Mapping->new(
+ "short",
$cproton_perl::PN_SHORT,
"put_short",
"get_short"),
- UINT => qpid::proton::TypeHelper->new(
+ UINT => qpid::proton::Mapping->new(
+ "uint",
$cproton_perl::PN_UINT,
"put_uint",
"get_uint"),
- INT => qpid::proton::TypeHelper->new(
+ INT => qpid::proton::Mapping->new(
+ "int",
$cproton_perl::PN_INT,
"put_int",
"get_int"),
- CHAR => qpid::proton::TypeHelper->new(
+ CHAR => qpid::proton::Mapping->new(
+ "char",
$cproton_perl::PN_CHAR,
"put_char",
"get_char"),
- ULONG => qpid::proton::TypeHelper->new(
+ ULONG => qpid::proton::Mapping->new(
+ "ulong",
$cproton_perl::PN_ULONG,
"put_ulong",
"get_ulong"),
- LONG => qpid::proton::TypeHelper->new(
+ LONG => qpid::proton::Mapping->new(
+ "long",
$cproton_perl::PN_LONG,
"put_long",
"get_long"),
- TIMESTAMP => qpid::proton::TypeHelper->new(
+ TIMESTAMP => qpid::proton::Mapping->new(
+ "timestamp",
$cproton_perl::PN_TIMESTAMP,
"put_timestamp",
"get_timestamp"),
- FLOAT => qpid::proton::TypeHelper->new(
+ FLOAT => qpid::proton::Mapping->new(
+ "float",
$cproton_perl::PN_FLOAT,
"put_float",
"get_float"),
- DOUBLE => qpid::proton::TypeHelper->new(
+ DOUBLE => qpid::proton::Mapping->new(
+ "double",
$cproton_perl::PN_DOUBLE,
"put_double",
"get_double"),
- DECIMAL32 => qpid::proton::TypeHelper->new(
+ DECIMAL32 => qpid::proton::Mapping->new(
+ "decimal32",
$cproton_perl::PN_DECIMAL32,
"put_decimal32",
"get_decimal32"),
- DECIMAL64 => qpid::proton::TypeHelper->new(
+ DECIMAL64 => qpid::proton::Mapping->new(
+ "decimal64",
$cproton_perl::PN_DECIMAL64,
"put_decimal64",
"get_decimal64"),
- DECIMAL128 => qpid::proton::TypeHelper->new(
+ DECIMAL128 => qpid::proton::Mapping->new(
+ "decimal128",
$cproton_perl::PN_DECIMAL128,
"put_decimal128",
"get_decimal128"),
- UUID => qpid::proton::TypeHelper->new(
+ UUID => qpid::proton::Mapping->new(
+ "uuid",
$cproton_perl::PN_UUID,
"put_uuid",
"get_uuid"),
- BINARY => qpid::proton::TypeHelper->new(
+ BINARY => qpid::proton::Mapping->new(
+ "binary",
$cproton_perl::PN_BINARY,
"put_binary",
"get_binary"),
- STRING => qpid::proton::TypeHelper->new(
+ STRING => qpid::proton::Mapping->new(
+ "string",
$cproton_perl::PN_STRING,
"put_string",
"get_string"),
- SYMBOL => qpid::proton::TypeHelper->new(
+ SYMBOL => qpid::proton::Mapping->new(
+ "symbol",
$cproton_perl::PN_SYMBOL,
"put_symbol",
- "get_symbol")
+ "get_symbol"),
+ ARRAY => qpid::proton::Mapping->new(
+ "array",
+ $cproton_perl::PN_ARRAY,
+ "put_array",
+ "get_array"),
+ LIST => qpid::proton::Mapping->new(
+ "list",
+ $cproton_perl::PN_LIST,
+ "put_list",
+ "get_list"),
};
1;
Modified: 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=1491441&r1=1491440&r2=1491441&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Data.pm Mon Jun 10 12:50:10 2013
@@ -110,6 +110,17 @@ Clearing the current node sets it I<befo
Sets the current node to the parent node, and the parent node to its own parent.
+=item $doc->next;
+
+=item $doc->prev;
+
+Moves to the next/previous sibling and returns its type. If there is no next or
+previous sibling then the current node remains unchanged.
+
+=item $doc->rewind;
+
+Clears the current node and sets the parent to the root node.
+
=back
=cut
@@ -128,6 +139,13 @@ sub exit {
cproton_perl::pn_data_exit($impl);
}
+sub rewind {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+
+ cproton_perl::pn_data_rewind($impl);
+}
+
=pod
@@ -159,14 +177,16 @@ sub next {
my ($self) = @_;
my $impl = $self->{_impl};
- cproton_perl::pn_data_next($impl);
+ my $type = cproton_perl::pn_data_next($impl);
+ return qpid::proton::Mapping->find_by_type_value($type);
}
sub prev {
my ($self) = @_;
my $impl = $self->{_impl};
- cproton_perl::pn_data_prev($impl);
+ my $type = cproton_perl::pn_data_prev($impl);
+ return qpid::proton::Mapping->find_by_type_value($type);
}
@@ -177,9 +197,28 @@ sub prev {
The following methods allow for inserting the various node types into the
tree.
+=head2 NODE TYPE
+
+You can retrieve the type of the current node.
+
+=over
+
+=item $type = $doc->get_type;
+
+=back
+
=cut
+sub get_type {
+ my ($self) = @_;
+ my $impl = $self->{_impl};
+ my $type = cproton_perl::pn_data_type($impl);
+
+ return qpid::proton::Mapping->find_by_type_value($type);
+}
+
+
=pod
=head2 SCALAR TYPES
@@ -1000,22 +1039,20 @@ sub put_array {
die "array type must be defined" if !defined($array_type);
- my $type_value = $array_type->get_type_value;
-
check(cproton_perl::pn_data_put_array($impl,
$described,
- $type_value));
+ $array_type->get_type_value));
}
sub get_array {
my ($self) = @_;
my $impl = $self->{_impl};
- my $count = check(cproton_perl::pn_data_get_array($impl));
+ my $count = cproton_perl::pn_data_get_array($impl);
my $described = cproton_perl::pn_data_is_array_described($impl);
my $type_value = cproton_perl::pn_data_get_array_type($impl);
- $type_value = qpid::proton::TypeHelper->find_by_type_value($type_value);
+ $type_value = qpid::proton::Mapping->find_by_type_value($type_value);
return ($count, $described, $type_value);
}
Copied: qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Mapping.pm (from r1490429, qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/TypeHelper.pm)
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Mapping.pm?p2=qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Mapping.pm&p1=qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/TypeHelper.pm&r1=1490429&r2=1491441&rev=1491441&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/TypeHelper.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/Mapping.pm Mon Jun 10 12:50:10 2013
@@ -17,7 +17,7 @@
# under the License.
#
-package qpid::proton::TypeHelper;
+package qpid::proton::Mapping;
our %by_type_value = ();
@@ -25,19 +25,40 @@ sub new {
my ($class) = @_;
my ($self) = {};
- my $type_value = $_[1];
- my $set_method = $_[2];
- my $get_method = $_[3];
+ my $name = $_[1];
+ my $type_value = $_[2];
+ my $set_method = $_[3];
+ my $get_method = $_[4];
+ $self->{_name} = $name;
$self->{_type_value} = $type_value;
$self->{_set_method} = $set_method;
$self->{_get_method} = $get_method;
bless $self, $class;
- $qpid::proton::TypeHelper::by_type_value{$type_value} = $self;
+ $qpid::proton::Mapping::by_type_value{$type_value} = $self;
+
+ return $self;
+}
+
+use overload (
+ '""' => \& stringify,
+ '==' => \& equals,
+ );
+
+sub stringify {
+ my ($self) = @_;
+ return $self->{_name};
+}
+
+sub equals {
+ my ($self) = @_;
+ my $that = $_[1];
+
+ return 0 if !defined($that);
- return $self;
+ return ($self->get_type_value == $that->get_type_value);
}
sub getter_method {
@@ -53,36 +74,37 @@ sub get_type_value {
return $self->{_type_value};
}
+=pod
+
+=head1 MARSHALLING DATA
+
+I<Mapping> can move data automatically into and out of a I<Data> object.
+
+=over
+
+=item $mapping->put( [DATA], [VALUE] );
+
+=item $mapping->get( [DATA] );
+
+=back
+
+=cut
+
sub put {
my ($self) = @_;
my $data = $_[1];
- my $described = $_[2];
- my $elements = $_[3];
- my $array_type = $self->{_type_value};
+ my $value = $_[2];
my $setter_method = $self->{_set_method};
- $data->put_array($described,
- qpid::proton::TypeHelper->find_by_type_value($array_type));
- $data->enter;
- foreach $value (@${elements}) {
- $data->$setter_method($value);
- }
- $data->exit;
+ $data->$setter_method($value);
}
sub get {
+ my ($self) = @_;
my $data = $_[1];
+ my $getter_method = $self->{_get_method};
- my ($size, $described, $type_value) = $data->get_array;
- my $get_method = $type_value->getter_method;
- my $result = qpid::proton::Array->new($described, $type_value);
-
- $data->enter;
- while($data->next) {
- my $next_value = $data->$get_method();
- $result->push($next_value);
- }
- $data->exit;
+ my $result = $data->$getter_method;
return $result;
}
@@ -92,7 +114,7 @@ sub find_by_type_value {
return undef if !defined($type_value);
- return $qpid::proton::TypeHelper::by_type_value{$type_value};
+ return $qpid::proton::Mapping::by_type_value{$type_value};
}
1;
Added: qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/array_helper.pm
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/array_helper.pm?rev=1491441&view=auto
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/array_helper.pm (added)
+++ qpid/proton/trunk/proton-c/bindings/perl/lib/qpid/proton/array_helper.pm Mon Jun 10 12:50:10 2013
@@ -0,0 +1,147 @@
+#
+# 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;
+
+=head1 DESCRIPTION
+
+=cut
+
+package qpid::proton;
+
+=pod
+
+=head1 MOVING DATA OUT OF A DATA OBJECT
+
+=over
+
+=item qpid::proton::put_array_into( [DATA], [TYPE], [ELEMENTS], [DESCRIBED], [DESCRIPTOR] );
+
+Puts the specified elements into the I<qpid::proton::Data> object specified
+using the specified B<type> value. If the array is described (def. undescribed)
+then the supplied B<descriptor> is used.
+
+=item ($described, $type, @elements) = qpid::proton::get_array_from( [DATA] );
+
+=item ($described, $descriptor, $type, @elements) = qpid::proton::get_array_from( [DATA] );
+
+Retrieves the descriptor, size, type and elements for an array from the
+specified instance of I<qpid::proton::Data>.
+
+If the array is B<described> then the I<descriptor> for the array is returned as well.
+
+=item @elements = qpid::proton::get_list_from( [DATA] );
+
+Retrieves the elements for a list from the specified instance of
+I<qpid::proton::Data>.
+
+=back
+
+=cut
+
+sub put_array_into {
+ my $data = $_[0];
+ my $type = $_[1];
+ my ($values) = $_[2];
+ my $described = $_[3] || 0;
+ my $descriptor = $_[4];
+
+ die "data cannot be nil" if !defined($data);
+ die "type cannot be nil" if !defined($type);
+ die "values cannot be nil" if !defined($values);
+ die "descriptor cannot be nil" if $described && !defined($descriptor);
+
+ $data->put_array($described, $type);
+ $data->enter;
+
+ if ($described && defined($descriptor)) {
+ $data->put_symbol($descriptor);
+ }
+
+ foreach $value (@{$values}) {
+ $type->put($data, $value);
+ }
+ $data->exit;
+}
+
+sub get_array_from {
+ my $data = $_[0];
+
+ die "data cannot be nil" if !defined($data);
+
+ # ensure we're actually on an array
+ my $type = $data->get_type;
+
+ die "current node is not an array" if !defined($type) ||
+ !($type == qpid::proton::ARRAY);
+
+ my ($count, $described, $rtype) = $data->get_array;
+ my @elements = ();
+
+ $data->enter;
+
+ if (defined($described) && $described) {
+ $data->next;
+ $descriptor = $data->get_symbol;
+ }
+
+ for ($i = 0; $i < $count; $i++) {
+ $data->next;
+ my $type = $data->get_type;
+ my $element = $type->get($data);
+ push(@elements, $element);
+ }
+
+ $data->exit;
+
+ if (defined($described) && $described) {
+ return ($described, $descriptor, $rtype, @elements) if $described;
+ } else {
+ return ($described, $rtype, @elements);
+ }
+}
+
+sub get_list_from {
+ my $data = $_[0];
+
+ die "data can not be nil" if !defined($data);
+
+ # ensure we're actually on a list
+ my $type = $data->get_type;
+
+ die "current node is not a list" if !defined($type) ||
+ !($type == qpid::proton::LIST);
+
+ my $count = $data->get_list;
+ $data->enter;
+ for($i = 0; $i < $count; $i++) {
+ $data->next;
+ my $type = $data->get_type;
+ my $element = $type->get($data);
+ push(@elements, $element);
+ }
+
+ return @elements;
+}
+
+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=1491441&r1=1491440&r2=1491441&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 Mon Jun 10 12:50:10 2013
@@ -22,9 +22,9 @@ use warnings;
use cproton_perl;
use qpid::proton::Data;
-use qpid::proton::TypeHelper;
-use qpid::proton::Array;
+use qpid::proton::Mapping;
use qpid::proton::Constants;
+use qpid::proton::array_helper;
use qpid::proton::Messenger;
use qpid::proton::Message;
Added: qpid/proton/trunk/proton-c/bindings/perl/tests/array_helper.t
URL: http://svn.apache.org/viewvc/qpid/proton/trunk/proton-c/bindings/perl/tests/array_helper.t?rev=1491441&view=auto
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/tests/array_helper.t (added)
+++ qpid/proton/trunk/proton-c/bindings/perl/tests/array_helper.t Mon Jun 10 12:50:10 2013
@@ -0,0 +1,232 @@
+#!/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::Exception;
+
+require 'utils.pm';
+
+BEGIN {use_ok('qpid_proton');}
+require_ok('qpid_proton');
+
+my $data;
+my @values;
+my $result;
+my $length;
+my $descriptor;
+
+#=============================================================================
+# Getting an array from a nil Data instance raises an error.
+#=============================================================================
+$data = qpid::proton::Data->new;
+dies_ok(sub {qpid::proton::get_array_from(undef);},
+ "Raise an exception when getting from a nil Data object");
+
+
+#=============================================================================
+# Getting an array fails if the current node is not an array or a list.
+#=============================================================================
+$data = qpid::proton::Data->new;
+$data->put_string("foo");
+$data->rewind;
+$data->next;
+dies_ok(sub {qpid::proton::proton_get_array_from($data, undef);},
+ "Raise an exception when getting from a non-list and non-array");
+
+
+#=============================================================================
+# Can get an undescribed array.
+#=============================================================================
+$length = int(rand(256) + 64);
+$data = qpid::proton::Data->new;
+@values= random_integers($length);
+$data->put_array(0, qpid::proton::INT);
+$data->enter;
+foreach $value (@values) {
+ $data->put_int($value);
+}
+$data->exit;
+$data->rewind;
+
+{
+ $data->next;
+ my ($described, $type, @results) = qpid::proton::get_array_from($data);
+
+ ok(!$described, "Returned an undescribed array");
+ ok($type == qpid::proton::INT, "Returned the correct array type");
+ ok(scalar(@results) == $length, "Returns the correct number of elements");
+
+ is_deeply([sort @results], [sort @values],
+ "Returned the correct set of values");
+}
+
+
+#=============================================================================
+# Raises an error when putting into a null Data object.
+#=============================================================================
+dies_ok(sub {qpid::proton::put_array_into(undef, qpid::proton::INT, @values);},
+ "Raises an error when putting into a null Data object");
+
+
+#=============================================================================
+# Raises an error when putting a null type into a Data object.
+#=============================================================================
+$data = qpid::proton::Data->new;
+dies_ok(sub {qpid::proton::put_array_into($data, undef, @values);},
+ "Raises an error when putting into a null Data object");
+
+
+#=============================================================================
+# Raises an error when putting a null array into a Data object.
+#=============================================================================
+$data = qpid::proton::Data->new;
+dies_ok(sub {qpid::proton::put_array_into($data, qpid::proton::INT);},
+ "Raises an error when putting into a null Data object");
+
+
+#=============================================================================
+# Raises an error when putting a described array with no descriptor.
+#=============================================================================
+$data = qpid::proton::Data->new;
+dies_ok(sub {qpid::proton::put_array_into($data, qpid::proton::INT, \@values, 1);},
+ "Raises an error when putting a described array with no descriptor");
+
+
+#=============================================================================
+# Can put an undescribed array into a Data object.
+#=============================================================================
+$length = int(rand(256) + 64);
+$data = qpid::proton::Data->new;
+@values= random_integers($length);
+qpid::proton::put_array_into($data, qpid::proton::INT, \@values, 0);
+$data->rewind;
+
+{
+ $data->next;
+ my ($described, $type, @results) = qpid::proton::get_array_from($data);
+
+ ok(!$described, "Put an undescribed array");
+ ok($type == qpid::proton::INT, "Put the correct array type");
+ ok(scalar(@results) == $length, "Put the correct number of elements");
+
+ is_deeply([sort @results], [sort @values],
+ "Returned the correct set of values");
+}
+
+
+#=============================================================================
+# Can get an described array.
+#=============================================================================
+$length = int(rand(256) + 64);
+$data = qpid::proton::Data->new;
+@values= random_strings($length);
+$descriptor = random_string(64);
+$data->put_array(1, qpid::proton::STRING);
+$data->enter;
+$data->put_symbol($descriptor);
+foreach $value (@values) {
+ $data->put_string($value);
+}
+
+$data->exit;
+$data->rewind;
+
+{
+ $data->next;
+ my ($described, $dtor, $type, @results) = qpid::proton::get_array_from($data);
+
+ ok($described, "Returned a described array");
+ ok($dtor eq $descriptor, "Returned the correct descriptor");
+ ok($type == qpid::proton::STRING, "Returned the correct array type");
+ ok(scalar(@results) == $length, "Returns the correct number of elements");
+
+ is_deeply([sort @results], [sort @values],
+ "Returned the correct set of values");
+}
+
+
+#=============================================================================
+# Can put a described array into a Data object.
+#=============================================================================
+$length = int(rand(256) + 64);
+$data = qpid::proton::Data->new;
+@values= random_integers($length);
+$descriptor = random_string(128);
+qpid::proton::put_array_into($data, qpid::proton::INT, \@values, 1, $descriptor);
+$data->rewind;
+
+{
+ $data->next;
+ my ($described, $dtor, $type, @results) = qpid::proton::get_array_from($data);
+
+ ok($described, "Put a described array");
+ ok($dtor eq $descriptor, "Put the correct descriptor");
+ ok($type == qpid::proton::INT, "Put the correct array type");
+ ok(scalar(@results) == $length, "Put the correct number of elements");
+
+ is_deeply([sort @results], [sort @values],
+ "Returned the correct set of values");
+}
+
+
+#=============================================================================
+# Raises an error when getting a list from a null Data instance
+#=============================================================================
+$data = qpid::proton::Data->new;
+dies_ok(sub {qpid::proton::get_list_from(undef);},
+ "Raises error when getting list from null Data object");
+
+
+#=============================================================================
+# Raises an error when the current node is not a list.
+#=============================================================================
+$data = qpid::proton::Data->new;
+$data->put_string(random_string(64));
+$data->rewind;
+$data->next;
+
+dies_ok(sub {qpid::proton::get_list_from($data);},
+ "Raises an error when getting a list and it's not currently a list.");
+
+
+#=============================================================================
+# Can get an array
+#=============================================================================
+$length = int(rand(256) + 64);
+$data = qpid::proton::Data->new;
+@values = random_strings($length);
+$data->put_list;
+$data->enter;
+foreach $value (@values) {
+ $data->put_string($value);
+}
+$data->exit;
+$data->rewind;
+
+{
+ my $result = $data->next;
+
+ my @results = qpid::proton::get_list_from($data);
+
+ ok(scalar(@results) == $length, "Returned the correct number of elements");
+
+ is_deeply([sort @results], [sort @values],
+ "Returned the correct list of values");
+}
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=1491441&r1=1491440&r2=1491441&view=diff
==============================================================================
--- qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm (original)
+++ qpid/proton/trunk/proton-c/bindings/perl/tests/utils.pm Mon Jun 10 12:50:10 2013
@@ -37,6 +37,19 @@ sub random_string
return $result;
}
+sub random_strings
+{
+ my $len = $_[0];
+ my @result = ();
+
+ foreach (1..$len) {
+ my $strlen = rand(64) + 32;
+ push(@result, random_string($strlen));
+ }
+
+ return @result;
+}
+
sub random_timestamp
{
my $result = rand(2**63) + 1;
---------------------------------------------------------------------
To unsubscribe, e-mail: commits-unsubscribe@qpid.apache.org
For additional commands, e-mail: commits-help@qpid.apache.org