rabx.sql

CREATE EXTENSION plperlu;

CREATE OR REPLACE FUNCTION read_rabx(text, text) RETURNS boolean LANGUAGE plperlu IMMUTABLE AS $$
    use IO::String;
    use utf8;

    my ($extra, $key) = @_;

    sub netstring_rd ($) {
        my ($h) = @_;
        my $len = 0;
        my $c;
        while (defined($c = $h->getc())) {
            last if ($c eq ':');
            die qq#bad character '$c' in netstring length# if ($c !~ m#\d#);
            $len = ($len * 10) + ord($c) - ord('0');
        }

        if (!defined($c)) {
            die "$! reading netstring length" if ($h->error());
            die "EOF reading netstring length";
        }

        my $string = '';
        while (length($string) < $len) {
            my $n = $h->read($string, $len - length($string), length($string));
            die "$! reading netstring content"
                if (!defined($n));
            die "EOF reading netstring content"
                if ($n == 0);
        }

        if (!defined($c = $h->getc())) {
            die "$! reading netstring trailer" if ($h->error());
            die "EOF reading netstring trailer";
        }

        die "bad netstring trailer character '$c'"
            if ($c ne ',');

        return $string;
    }

    sub wire_rd ($) {
        my ($h) = @_;

        my $type = $h->getc();
        if (!defined($type)) {
            die "$! reading type indicator character" if $h->error();
                return undef;
            # die "EOF reading type indicator character";
            return undef;
        }

        if ($type eq 'N') {
            return undef;
        } elsif ($type =~ m#^[IRB]$#) {
            return netstring_rd($h); # XXX type checks
        } elsif ($type eq 'T') {
            my $t = netstring_rd($h);
            die "data in 'T' string are not valid UTF-8 octets: '$t'" if (!utf8::decode($t));
            return $t;
        } elsif ($type eq 'L') {
            my $len = netstring_rd($h);
            die "bad list length '$len'" unless ($len =~ m#^(0|[1-9]\d*)$#);
            my @r = ( );
            for (my $i = 0; $i < $len; ++$i) {
                push(@r, wire_rd($h));
            }
            return \@r;
        } elsif ($type eq 'A') {
            my $len = netstring_rd($h);
            die "bad associative array length '$len'" unless ($len =~ m#^(0|[1-9]\d*)$#);
            my %r = ( );
            for (my $i = 0; $i < $len; ++$i) {
                my $k = wire_rd($h);
                die "repeated element '$k' in associative array" if (exists($r{$k}));
                my $v = wire_rd($h);
                $r{$k} = $v;
            }
            return \%r;
        } else {
            # die "bad type indicator character '$type'";
            return undef;
        }
    }


    my $h = new IO::String($extra);
    my $decoded = wire_rd($h);
    return ref($decoded) eq 'HASH' ? $decoded->{$key} : 0;
$$;