File Coverage

blib/lib/Perinci/AccessUtil.pm

Criterion	Covered	Total	%
statement	48	48	100.0
branch	28	30	93.3
condition	21	25	84.0
subroutine	7	7	100.0
pod	3	3	100.0
total	107	113	94.6

package Perinci::AccessUtil;

our $DATE = '2014-10-24'; # DATE
our $VERSION = '0.05'; # VERSION

use 5.010001;
use strict;
use warnings;

use MIME::Base64;

require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(insert_riap_stuffs_to_res
                    strip_riap_stuffs_from_res
                    decode_args_in_riap_req);

sub insert_riap_stuffs_to_res {
    my ($res, $def_ver, $nmeta, $encode) = @_;

    $res->[3]{'riap.v'} //= $def_ver // 1.1;
    if ($res->[3]{'riap.v'} >= 1.2) {
        # do we need to base64-encode?
        {
            last unless $encode // 1;
            last if $res->[3]{'riap.result_encoding'};
            if ($nmeta) {
                last unless $nmeta->{result}{schema} &&
                    $nmeta->{result}{schema}[0] eq 'buf';
            }
            last unless defined($res->[2]) && !ref($res->[2]) &&
                $res->[2] =~ /[^\x20-\x7f]/;
            $res->[2] = encode_base64($res->[2]);
            $res->[3]{'riap.result_encoding'} = 'base64';
        }
    }
    $res;
}

sub strip_riap_stuffs_from_res {
    my $res = shift;

    my $ver = $res->[3]{'riap.v'} // 1.1;
    return [501, "Riap version returned by server ($ver) is not supported, ".
                "only recognize v1.1 and v1.2"]
        unless $ver == 1.1 || $ver == 1.2;

    if ($ver >= 1.2) {
        # check and strip riap.*
        for my $k (keys %{$res->[3]}) {
            next unless $k =~ /\Ariap\./;
            my $val = $res->[3]{$k};
            if ($k eq 'riap.v') {
            } elsif ($k eq 'riap.result_encoding') {
                return [501, "Unknown result_encoding returned by server ".
                            "($val), only base64 is supported"]
                    unless $val eq 'base64';
                $res->[2] = decode_base64($res->[2]//'');
            } else {
                return [501, "Unknown Riap attribute in result metadata ".
                            "returned by server ($k)"];
            }
            delete $res->[3]{$k};
        }
    }

    $res;
}

sub decode_args_in_riap_req {
    my $req = shift;

    my $v = $req->{v} // 1.1;
    if ($v >= 1.2) {
        if ($req->{args}) {
            my $args = $req->{args};
            for (keys %$args) {
                next unless /\A(.+):base64\z/;
                $args->{$1} = decode_base64($args->{$_});
                delete $args->{$_};
            }
        }
    }
    $req;
}

1;
# ABSTRACT: Utility module for Riap client/server

__END__