proton-c/bindings/perl/lib/qpid/proton/Message.pm

#
# 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::Message;

our $DATA_FORMAT = $cproton_perl::PN_DATA;
our $TEXT_FORMAT = $cproton_perl::PN_TEXT;
our $AMQP_FORMAT = $cproton_perl::PN_AMQP;
our $JSON_FORMAT = $cproton_perl::PN_JSON;

sub new {
    my ($class) = @_;
    my ($self) = {};

    my $impl = cproton_perl::pn_message();
    $self->{_impl} = $impl;
    $self->{_properties} = {};
    $self->{_instructions} = {};
    $self->{_annotations} = {};
    $self->{_body} = undef;
    $self->{_body_type} = undef;

    bless $self, $class;
    return $self;
}

use overload fallback => 1,
    '""' => sub {
        my ($self) = @_;
        my $tmp = cproton_perl::pn_string("");
        cproton_perl::pn_inspect($self->{_impl}, $tmp);
        my $result = cproton_perl::pn_string_get($tmp);
        cproton_perl::pn_free($tmp);
        return $result;
};

sub DESTROY {
    my ($self) = @_;
    my $impl = $self->{_impl};

    cproton_perl::pn_message_free($impl);
}

sub get_impl {
    my ($self) = @_;
    my $impl = $self->{_impl};
    return $impl;
}

sub clear {
    my ($self) = @_;
    my $impl = $self->{_impl};

    cproton_perl::pn_message_clear($impl);

    $self->{_body} = undef;
    $self->{_properties} = {};
    $self->{_instructions} = {};
    $self->{_annotations} = {};
}

sub errno {
    my ($self) = @_;
    return cproton_perl::pn_message_errno($self->{_impl});
}

sub error {
    my ($self) = @_;
    return cproton_perl::pn_message_error($self->{_impl});
}

sub set_durable {
    my ($self) = @_;
    cproton_perl::pn_message_set_durable($self->{_impl}, $_[1]);
}

sub get_durable {
    my ($self) = @_;
    return cproton_perl::pn_message_is_durable($self->{_impl});
}

sub set_priority {
    my ($self) = @_;
    cproton_perl::pn_message_set_priority($self->{_impl}, $_[1]);
}

sub get_priority {
    my ($self) = @_;
    return cproton_perl::pn_message_get_priority($self->{_impl});
}

sub set_ttl {
    my ($self) = @_;
    cproton_perl::pn_message_set_ttl($self->{_impl}, $_[1]);
}

sub get_ttl {
    my ($self) = @_;
    return cproton_perl::pn_message_get_ttl($self->{_impl});
}

sub set_first_acquirer {
    my ($self) = @_;
    cproton_perl::pn_message_set_first_acquirer($self->{_impl}, $_[1]);
}

sub get_first_acquirer {
    my ($self) = @_;
    return cproton_perl::pn_message_is_first_acquirer($self->{_impl});
}

sub set_delivery_count {
    my ($self) = @_;
    cproton_perl::pn_message_set_delivery_count($self->{_impl}, $_[1]);
}

sub get_delivery_count {
    my ($self) = @_;
    return cproton_perl::pn_message_get_delivery_count($self->{_impl});
}

sub set_id {
    my ($self) = @_;
    my $id = $_[1];

    die "Message id must be defined" if !defined($id);

    cproton_perl::pn_message_set_id($self->{_impl}, $id);
}

sub get_id {
    my ($self) = @_;
    my $id = cproton_perl::pn_message_get_id($self->{_impl});

    return $id;
}

sub set_user_id {
    my ($self) = @_;
    my $user_id = $_[1];

    die "User id must be defined" if !defined($user_id);

    cproton_perl::pn_message_set_user_id($self->{_impl}, $user_id);
}

sub get_user_id {
    my ($self) = @_;
    my $user_id = cproton_perl::pn_message_get_user_id($self->{_impl});

    return $user_id;
}

sub set_address {
    my ($self) = @_;
    cproton_perl::pn_message_set_address($self->{_impl}, $_[1]);
}

sub get_address {
    my ($self) = @_;
    return cproton_perl::pn_message_get_address($self->{_impl});
}

sub set_subject {
    my ($self) = @_;
    cproton_perl::pn_message_set_subject($self->{_impl}, $_[1]);
}

sub get_subject {
    my ($self) = @_;
    return cproton_perl::pn_message_get_subject($self->{_impl});
}

sub set_reply_to {
    my ($self) = @_;
    cproton_perl::pn_message_set_reply_to($self->{_impl}, $_[1]);
}

sub get_reply_to {
    my ($self) = @_;
    return cproton_perl::pn_message_get_reply_to($self->{_impl});
}

sub set_correlation_id {
    my ($self) = @_;
    cproton_perl::pn_message_set_correlation_id($self->{_impl}, $_[1]);
}

sub get_correlation_id {
    my ($self) = @_;
    return cproton_perl::pn_message_get_correlation_id($self->{_impl});
}

sub set_format {
    my ($self) = @_;
    my $format = $_[1];

    die "Format must be defined" if !defined($format);

    cproton_perl::pn_message_set_format($self->{_impl}, $format);
}

sub get_format {
    my ($self) = @_;
    return cproton_perl::pn_message_get_format($self->{_impl});
}

sub set_content_type {
    my ($self) = @_;
    cproton_perl::pn_message_set_content_type($self->{_impl}, $_[1]);
}

sub get_content_type {
    my ($self) = @_;
    return cproton_perl::pn_message_get_content_type($self->{_impl});
}

sub set_content_encoding {
    my ($self) = @_;
    cproton_perl::pn_message_set_content_encoding($self->{_impl}, $_[1]);
}

sub get_content_encoding {
    my ($self) = @_;
    return cproton_perl::pn_message_get_content_encoding($self->{_impl});
}

sub set_expiry_time {
    my ($self) = @_;
    my $expiry_time = $_[1];

    die "Expiry time must be defined" if !defined($expiry_time);

    $expiry_time = int($expiry_time);

    die "Expiry time must be non-negative" if $expiry_time < 0;

    cproton_perl::pn_message_set_expiry_time($self->{_impl}, $expiry_time);
}

sub get_expiry_time {
    my ($self) = @_;
    return cproton_perl::pn_message_get_expiry_time($self->{_impl});
}

sub set_creation_time {
    my ($self) = @_;
    my $creation_time = $_[1];

    die "Creation time must be defined" if !defined($creation_time);

    $creation_time = int($creation_time);

    die "Creation time must be non-negative" if $creation_time < 0;

    cproton_perl::pn_message_set_creation_time($self->{_impl}, $creation_time);
}

sub get_creation_time {
    my ($self) = @_;
    return cproton_perl::pn_message_get_creation_time($self->{_impl});
}

sub set_group_id {
    my ($self) = @_;
    cproton_perl::pn_message_set_group_id($self->{_impl}, $_[1]);
}

sub get_group_id {
    my ($self) = @_;
    return cproton_perl::pn_message_get_group_id($self->{_impl});
}

sub set_group_sequence {
    my ($self) = @_;
    my $group_sequence = $_[1];

    die "Group sequence must be defined" if !defined($group_sequence);

    cproton_perl::pn_message_set_group_sequence($self->{_impl}, int($_[1]));
}

sub get_group_sequence {
    my ($self) = @_;
    return cproton_perl::pn_message_get_group_sequence($self->{_impl});
}

sub set_reply_to_group_id {
    my ($self) = @_;
    cproton_perl::pn_message_set_reply_to_group_id($self->{_impl}, $_[1]);
}

sub get_reply_to_group_id {
    my ($self) = @_;
    return cproton_perl::pn_message_get_reply_to_group_id($self->{_impl});
}

=pod

=head2 PROPERTIES

Allows for accessing and updating the set of properties associated with the
message.

=over

=item my $props = $msg->get_properties;

=item $msg->set_properties( [VAL] );

=item my $value = $msg->get_property( [KEY] );

=item $msg->set_propert( [KEY], [VALUE] );

=back

=cut

sub get_properties {
    my ($self) = @_;

    return $self->{_properties};
}

sub set_properties {
    my ($self) = @_;
    my ($properties) = $_[1];

    $self->{_properties} = $properties;
}

sub get_property {
    my ($self) = @_;
    my $name = $_[1];
    my $properties = $self->{_properties};

    return $properties{$name};
}

sub set_property {
    my ($self) = @_;
    my $name = $_[1];
    my $value = $_[2];
    my $properties = $self->{_properties};

    $properties->{"$name"} = $value;
}

=pod

=head2 ANNOTATIONS

Allows for accessing and updatin ghte set of annotations associated with the
message.

=over

=item my $annotations = $msg->get_annotations;

=item $msg->get_annotations->{ [KEY] } = [VALUE];

=item $msg->set_annotations( [VALUE ]);

=back

=cut

sub get_annotations {
    my ($self) = @_;
    return $self->{_annotations};
}

sub set_annotations {
    my ($self) = @_;
    my $annotations = $_[1];

    $self->{_annotations} = $annotations;
}

=pod

=cut

sub get_instructions {
    my ($self) = @_;
    return $self->{_instructions};
}

sub set_instructions {
    my ($self) = @_;
    my $instructions = $_[1];

    $self->{_instructions} = $instructions;
}

=pod

=head2 BODY

The body of the message. When setting the body value a type must be specified,
such as I<qpid::proton::INT>. If unspecified, the body type will default to
B<qpid::proton::STRING>.

=over

=item $msg->set_body( [VALUE], [TYPE] );

=item $msg->get_body();

=item $msg->get_body_type();

=back

=cut

sub set_body {
    my ($self) = @_;
    my $body = $_[1];
    my $body_type = $_[2] || undef;

    # if no body type was defined, then attempt to infer what it should
    # be, which is going to be a best guess
    if (!defined($body_type)) {
        if (qpid::proton::utils::is_num($body)) {
            if (qpid::proton::utils::is_float($body)) {
                $body_type = qpid::proton::FLOAT;
            } else {
                $body_type = qpid::proton::INT;
            }
        } elsif (!defined($body)) {
            $body_type =  qpid::proton::NULL;
        } elsif ($body eq '') {
            $body_type =  qpid::proton::STRING;
        } elsif (ref($body) eq 'HASH') {
            $body_type =  qpid::proton::MAP;
        } elsif (ref($body) eq 'ARRAY') {
            $body_type =  qpid::proton::LIST;
        } else {
            $body_type =  qpid::proton::STRING;
        }
    }

    $self->{_body} = $body;
    $self->{_body_type} = $body_type;
}

sub get_body {
    my ($self) = @_;
    my $body = $self->{_body};

    return $body;
}

sub get_body_type {
    my ($self) = @_;

    return $self->{_body_type};
}

sub preencode() {
    my ($self) = @_;
    my $impl = $self->{_impl};
    my $my_body = $self->{_body};
    my $body_type = $self->{_body_type};
    my $body = new qpid::proton::Data(cproton_perl::pn_message_body($impl));

    $body->clear();
    $body_type->put($body, $my_body) if(defined($my_body) && $body_type);

    my $my_props = $self->{_properties};
    my $props = new qpid::proton::Data(cproton_perl::pn_message_properties($impl));
    $props->clear();
    qpid::proton::MAP->put($props, $my_props) if $my_props;

    my $my_insts = $self->{_instructions};
    my $insts = new qpid::proton::Data(cproton_perl::pn_message_instructions($impl));
    $insts->clear;
    qpid::proton::MAP->put($insts, $my_insts) if $my_insts;

    my $my_annots = $self->{_annotations};
    my $annotations = new qpid::proton::Data(cproton_perl::pn_message_annotations($impl));
    $annotations->clear();
    qpid::proton::MAP->put($annotations, $my_annots);
}

sub postdecode() {
    my ($self) = @_;
    my $impl = $self->{_impl};

    $self->{_body} = undef;
    $self->{_body_type} = undef;
    my $body = new qpid::proton::Data(cproton_perl::pn_message_body($impl));
    if ($body->next()) {
        $self->{_body_type} = $body->get_type();
        $self->{_body} = $body->get_type()->get($body);
    }

    my $props = new qpid::proton::Data(cproton_perl::pn_message_properties($impl));
    $props->rewind;
    if ($props->next) {
        my $properties = $props->get_type->get($props);
        $self->{_properties} = $props->get_type->get($props);
    }

    my $insts = new qpid::proton::Data(cproton_perl::pn_message_instructions($impl));
    $insts->rewind;
    if ($insts->next) {
        $self->{_instructions} = $insts->get_type->get($insts);
    }

    my $annotations = new qpid::proton::Data(cproton_perl::pn_message_annotations($impl));
    $annotations->rewind;
    if ($annotations->next) {
        my $annots = $annotations->get_type->get($annotations);
        $self->{_annotations} = $annots;
    } else {
        $self->{_annotations} = {};
    }
}

1;