view release on metacpan or  search on metacpan

lib/AmberDB/Base/Encoder.pm  view on Meta::CPAN

package AmberDB::Base::Encoder;

use 5.016;
use warnings;
use Carp qw(croak cluck);
use MIME::Base64 qw(encode_base64 decode_base64);

our $VERSION = '5.25.1';

my $CREATED = '2026-09-06';

# =====================================================================
# RECORD ENCODING / DECODING — ABR v5 (Amber Binary Record)
# Native Pure Perl Binary Format with Zero CPAN Dependencies
# Format Specification:
#   Header:      \x00 A B R \x05  (5 bytes: NUL + Magic "ABR" + Version 5)
#   Mode:        1 byte (0x00 = multiple fields, 0x01 = single root reference)
#   Payload:
#     Mode 0x00: 2 bytes unsigned short "n" (field count) + field nodes
#     Mode 0x01: single root node
#   Node Types (1 byte tag):
#     0x00 -> UNDEF
#     0x01 -> SCALAR_RAW  (4-byte "N" length + raw octets, numbers/ASCII/binary)
#     0x02 -> SCALAR_UTF8 (4-byte "N" length + UTF-8 octets, decoded with utf8::decode)
#     0x03 -> ARRAY       (2-byte "n" count + child nodes)
#     0x04 -> HASH        (2-byte "n" pair count + 2-byte "n" key len + UTF-8 key + child value node)
# =====================================================================

sub _abr_encode_node {
    my ( $self, $node, $depth ) = @_;
    die "AmberDB ABR: Max nesting depth exceeded (>32)\n" if ( $depth // 0 ) > 32;

    if ( !defined $node ) {
        return "\x00";
    }

    my $ref = ref($node);
    if ( !$ref ) {
        my $is_utf8 = utf8::is_utf8($node);
        my $bytes   = "$node";
        utf8::encode($bytes) if $is_utf8;
        return ( $is_utf8 ? "\x02" : "\x01" ) . pack( "N", length($bytes) ) . $bytes;
    }
    elsif ( $ref eq 'ARRAY' ) {
        my $cnt = scalar @$node;
        my $out = "\x03" . pack( "n", $cnt );
        for my $item (@$node) {
            $out .= $self->_abr_encode_node( $item, ( $depth // 0 ) + 1 );
        }
        return $out;
    }
    elsif ( $ref eq 'HASH' ) {
        my @keys = sort keys %$node;
        my $cnt  = scalar @keys;
        my $out  = "\x04" . pack( "n", $cnt );
        for my $k (@keys) {
            my $k_bytes = "$k";
            my $k_utf8  = utf8::is_utf8($k_bytes);
            utf8::encode($k_bytes) if $k_utf8;
            $out .= pack( "n", length($k_bytes) ) . $k_bytes;
            $out .= $self->_abr_encode_node( $node->{$k}, ( $depth // 0 ) + 1 );
        }
        return $out;
    }
    else {
        my $str = "$node";
        return "\x01" . pack( "N", length($str) ) . $str;
    }
}

sub _abr_decode_node {
    my ( $self, $dref, $pref, $depth ) = @_;
    die "AmberDB ABR: Max nesting depth exceeded (>32)\n" if ( $depth // 0 ) > 32;

    return undef if $$pref >= length($$dref);
    my $tag = substr( $$dref, $$pref++, 1 );
    return undef if !defined $tag || $tag eq "\x00";

    if ( $tag eq "\x01" || $tag eq "\x02" ) {
        # SCALAR_RAW / SCALAR_UTF8
        return undef if $$pref + 4 > length($$dref);
        my $len = unpack( "N", substr( $$dref, $$pref, 4 ) );
        $$pref += 4;
        return undef unless defined $len;
        return undef if $$pref + $len > length($$dref);
        my $val = substr( $$dref, $$pref, $len );
        $$pref += $len;
        utf8::decode($val) if $tag eq "\x02";
        return $val;
    }
    elsif ( $tag eq "\x03" ) {
        # ARRAY
        return undef if $$pref + 2 > length($$dref);
        my $cnt = unpack( "n", substr( $$dref, $$pref, 2 ) );
        $$pref += 2;
        return undef unless defined $cnt;
        my @arr;
        for ( 1 .. $cnt ) {
            push @arr, $self->_abr_decode_node( $dref, $pref, ( $depth // 0 ) + 1 );
        }
        return \@arr;
    }
    elsif ( $tag eq "\x04" ) {
        # HASH
        return undef if $$pref + 2 > length($$dref);
        my $cnt = unpack( "n", substr( $$dref, $$pref, 2 ) );
        $$pref += 2;
        return undef unless defined $cnt;
        my %h;
        for ( 1 .. $cnt ) {
            return undef if $$pref + 2 > length($$dref);
            my $klen = unpack( "n", substr( $$dref, $$pref, 2 ) );
            $$pref += 2;
            return undef unless defined $klen;
            return undef if $$pref + $klen > length($$dref);
            my $k = substr( $$dref, $$pref, $klen );
            $$pref += $klen;
            utf8::decode($k);
            $h{$k} = $self->_abr_decode_node( $dref, $pref, ( $depth // 0 ) + 1 );
        }
        return \%h;
    }
    return undef;
}

# my $record  = $adb->db_encode(@fields);
# my $record  = $adb->db_encode(\%hash_data);
# ------------------------------------------------
sub db_encode {
    my ( $self, @fields ) = @_;
    return unless @fields;

    # ROOT CHECK: If single item passed and it is a reference
    if ( @fields == 1 && ref( $fields[0] ) ) {
        return "\x00ABR\x05\x01" . $self->_abr_encode_node( $fields[0], 0 );
    }

    my $out = "\x00ABR\x05\x00" . pack( "n", scalar @fields );
    for my $f (@fields) {
        $out .= $self->_abr_encode_node( $f, 0 );
    }
    return $out;
}

# my @fields   = $adb->db_decode($record);
# my $hash_ref = $adb->db_decode($record);
# ------------------------------------------------
sub db_decode {
    my ( $self, $record ) = @_;
    return unless defined $record && length $record;

    # ABR Binary Check (5-byte magic signature \x00ABR\x05 or \x00ABR\x01)
    if ( length($record) >= 7 && substr( $record, 0, 4 ) eq "\x00ABR" && ( substr( $record, 4, 1 ) eq "\x05" || substr( $record, 4, 1 ) eq "\x01" ) ) {
        my $mode = substr( $record, 5, 1 );
        my $pos  = 6;

        if ( $mode eq "\x01" ) {
            # Single root reference
            return $self->_abr_decode_node( \$record, \$pos, 0 );
        }
        elsif ( $mode eq "\x00" ) {
            # Multiple fields
            my $fcnt = unpack( "n", substr( $record, $pos, 2 ) );
            $pos += 2;
            my @fields;
            for ( 1 .. $fcnt ) {
                push @fields, $self->_abr_decode_node( \$record, \$pos, 0 );
            }
            return wantarray ? @fields : ( @fields == 1 ? $fields[0] : \@fields );
        }
    }

    # TRANSPARENT FALLBACK: Legacy Text Format Decoding
    return $self->tsv_decode($record);
}

# ------------------------------------------------
# tsv_decode: Multi-era decoder for historical and text-based records (v1 - v4)