view release on metacpan or  search on metacpan

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

    }

    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)
# ------------------------------------------------
sub tsv_decode {
    my ( $self, $record, $expected_rid ) = @_;
    return () unless defined $record && length($record);

    # If already ABR binary, decode directly via db_decode
    if ( length($record) >= 7 && substr( $record, 0, 4 ) eq "\x00ABR" ) {
        return $self->db_decode($record);
    }

    if ( $self && ref($self) ) {
        $record = $self->utf_decode($record);
    }

    # drop line endings: chomp
    $record =~ s/\R$//;

    # FAST-PATH: Plain TSV record without escapes, entities, or nested tags
    if ( index($record, "\\") == -1 && index($record, "<TAB") == -1 && index($record, "&#") == -1 && index($record, "ARRAY:") == -1 && index($record, "HASH:") == -1 ) {
        my @fields = split( /\t/, $record, -1 );
        return wantarray ? @fields : ( @fields == 1 ? $fields[0] : \@fields );
    }

    # 1. ERA 2019 - 2025: <TAB> Hierarchy (<TAB0>, <TAB1>, <TAB2>, <TAB3>)
    if ( $record =~ /<TAB[0-9]+>/ ) {
        my $white_decode = sub {
            return map {
                my $s = $_;
                if ( defined $s ) {
                    $s =~ s/\\(.)/$1 eq "t" ? "\t" : $1 eq "n" ? "\n" : $1 eq "r" ? "\r" : $1 eq "T" ? "\\T" : $1/eg;
                }
                $s;
            } @_;
        };

        my $rid_prefix;
        if ( $record =~ /^([a-zA-Z0-9_\-\.]+)(?:<TAB0>|\t)(.*)$/s ) {
            my ( $candidate_rid, $rest ) = ( $1, $2 );
            if ( !defined $expected_rid || $candidate_rid eq $expected_rid ) {
                $rid_prefix = $candidate_rid;
                $record     = $rest;
            }
        }

        my @fields = $record =~ /<TAB0>/ ? split( /<TAB0>/, $record, -1 ) : split( /\t/, $record, -1 );
        @fields = $white_decode->(@fields);

        for my $f1 (@fields) {
            if ( defined $f1 && $f1 =~ /<TAB1>/ ) {
                my @sub1 = map { $_ eq '-' ? '' : $_ } split( /<TAB1>/, $f1, -1 );
                @sub1 = $white_decode->(@sub1);
                for my $f2 (@sub1) {
                    if ( defined $f2 && $f2 =~ /<TAB2>/ ) {
                        my @sub2 = map { $_ eq '-' ? '' : $_ } split( /<TAB2>/, $f2, -1 );
                        @sub2 = $white_decode->(@sub2);
                        for my $f3 (@sub2) {
                            if ( defined $f3 && $f3 =~ /<TAB3>/ ) {
                                my @sub3 = map { $_ eq '-' ? '' : $_ } split( /<TAB3>/, $f3, -1 );
                                $f3 = [ $white_decode->(@sub3) ];
                            }
                        }
                        $f2 = \@sub2;
                    }
                }
                $f1 = \@sub1;
            }
        }

        if ( defined $rid_prefix ) {
            unshift @fields, $rid_prefix;
        }
        return wantarray ? @fields : ( @fields == 1 ? $fields[0] : \@fields );
    }

    # 2. ERA 2026: HTML entities (&#38;, &#124;, &#61;) + ARRAY: / HASH:
    if ( $record =~ /(?:ARRAY:|HASH:|&#(?:38|61|124|92|30);)/ ) {
        my $unescape_chars = sub {
            my ($str) = @_;
            return "" unless defined $str;
            $str =~ s/\\\\/\\/g;
            $str =~ s/\\([nrt])/$1 eq 'n' ? "\n" : $1 eq 'r' ? "\r" : "\t"/eg;
            $str =~ s/&#61;/=/g;
            $str =~ s/&#124;/|/g;
            $str =~ s/&#30;/\x1e/g;
            $str =~ s/&#92;/\\/g;
            $str =~ s/&#38;/&/g;
            return $str;
        };

        my $decode_node;
        $decode_node = sub {
            my ($field) = @_;
            return "" unless defined $field;

            if ( $field =~ /^ARRAY:(.*)/s ) {
                my $payload = $1;
                return [] if $payload eq "";
                return [ map { $decode_node->( $unescape_chars->($_) ) } split( /\|/, $payload, -1 ) ];
            }
            elsif ( $field =~ /^HASH:(.*)/s ) {
                my $payload = $1;
                my %h;
                if ( $payload ne "" ) {
                    for my $pair ( split( /\|/, $payload, -1 ) ) {
                        my ( $k, $v ) = split( /=/, $pair, 2 );
                        $h{ $unescape_chars->($k) } = $decode_node->( $unescape_chars->( $v // '' ) );
                    }
                }
                return \%h;
            }
            elsif ( $field =~ /\\T/ ) {
                return [ map { $unescape_chars->($_) } split( /\\T/, $field, -1 ) ];
            }
            else {
                return $unescape_chars->($field);
            }
        };

        my @raw = split( /\t/, $record, -1 );
        if ( @raw == 1 && $raw[0] =~ /^(?:ARRAY|HASH):/ ) {
            my $res = $decode_node->( $raw[0] );
            return wantarray ? ($res) : $res;
        }
        my @res = map { $decode_node->( $unescape_chars->($_) ) } @raw;
        return wantarray ? @res : ( @res == 1 ? $res[0] : \@res );
    }

    # 3. ERA 2004 - 2006 & 2003: \t root, \T array delimiter, standard escapes
    my $unescape_basic = sub {
        my ($s) = @_;
        return "" unless defined $s;
        $s =~ s/\\(.)/$1 eq "t" ? "\t" : $1 eq "n" ? "\n" : $1 eq "r" ? "\r" : $1 eq "T" ? "\\T" : $1 eq "\\" ? "\\" : $1/eg;
        return $s;
    };

    my @raw_fields = split( /\t/, $record, -1 );
    @raw_fields = map { $unescape_basic->($_) } @raw_fields;

    for my $line (@raw_fields) {
        if ( defined $line && $line =~ /\\T/ ) {
            my @parts = split( /\\T/, $line, -1 );
            @parts = map { $unescape_basic->($_) } @parts;
            $line = \@parts;
        }
    }

    return wantarray ? @raw_fields : ( @raw_fields == 1 ? $raw_fields[0] : \@raw_fields );
}

# ------------------------------------------------
# tsv_encode: Legacy text encoder for CSV exports and text-mode pipelines
# ------------------------------------------------
sub tsv_encode {
    my ( $self, @fields ) = @_;
    return unless @fields;

    my $encode_node;
    $encode_node = sub {
        my ($node) = @_;

        if ( ref($node) eq "ARRAY" ) {
            my @escaped = map { ref($_) ? $encode_node->($_) : $self->char_escape($_) } @$node;
            return "ARRAY:" . join( "|", @escaped );
        }
        elsif ( ref($node) eq "HASH" ) {
            my @escaped_pairs;
            foreach my $k ( sort keys %$node ) {
                my $safe_k = $self->char_escape($k);
                my $safe_v = ref( $node->{$k} ) ? $encode_node->( $node->{$k} ) : $self->char_escape( $node->{$k} );
                push @escaped_pairs, "$safe_k=$safe_v";
            }
            return "HASH:" . join( "|", @escaped_pairs );
        }
        else {
            return $self->char_escape($node);
        }
    };

    if ( @fields == 1 && ref( $fields[0] ) ) {
        return $encode_node->( $fields[0] );
    }

    my @encoded = map { ref($_) ? $encode_node->($_) : $self->char_escape($_) } @fields;
    return join( "\t", @encoded );
}

# ------------------------------------------------
sub char_escape {
    my ( $self, $str ) = @_;
    return "" unless defined $str;

    # WARNING: Escape ampersand & first! (Double escaping logic)
    $str =~ s/&/&#38;/g;      # ampersand
    $str =~ s/\\/&#92;/g;     # backslash
    $str =~ s/\|/&#124;/g;    # pipe (Array/Hash delimiter)
    $str =~ s/=/&#61;/g;      # equals (Hash key-value delimiter)
    $str =~ s/\x1e/&#30;/g;   # record separator (Transaction journal delimiter)
    $str =~ s/\t/\\t/g;       # tab
    $str =~ s/\n/\\n/g;       # newline
    $str =~ s/\r/\\r/g;       # carriage return
    return $str;
}

# ------------------------------------------------
sub char_unescape {
    my ( $self, $str ) = @_;
    return "" unless defined $str;

    $str =~ s{ (\\\\) | \\([nrt]) | &\#(92|61|124|38|30); }{
        defined $1 ? "\\" :
        defined $2 ? ( $2 eq 'n' ? "\n" : $2 eq 'r' ? "\r" : "\t" ) :
        chr($3)
    }gex;

    return $str;
}

# encode like cgi escape
# my $sifresiz = $adb->uri_encode("sifreli");
# ------------------------------------------------
sub uri_encode {
    my ( $self, $str ) = @_;

    $str =~ s/([^A-Za-z0-9\-_.~])/sprintf("%%%02X", ord($1))/ge;

    return $str;
}

# decode like cgi unescape
# my $sifresiz = $adb->uri_decode("sifresiz");
# ------------------------------------------------
sub uri_decode {
    my ( $self, $str ) = @_;

    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/ge;

    return $str;
}

# my $key_escape = $adb->key_encode($key);
# ------------------------------------------------
sub key_encode {
    my ( $self, $key ) = @_;

    my $key_escape = "$key";

    if ( $key_escape =~ /[^\w]/ ) {
        if ( $self && ref($self) ) {
            $key_escape = $self->to_ascii($key_escape);
        }
        $key_escape =~ s/[^\w]//g;
    }

    return $key_escape;
}

# =====================================================================
# FORMAT DETECTION & LEGACY DECODING (2003-2026 formats)
# =====================================================================

sub detect_record_format {
    my ( $self, $record ) = @_;
    return 'v5' if !defined $record || $record eq '';

    if ( length($record) >= 7 && substr( $record, 0, 4 ) eq "\x00ABR" ) {
        return 'v5';
    }
    if ( $record =~ /(?:ARRAY:|HASH:|&#(?:38|61|124|92|30);)/ ) {
        return 'v4';
    }
    if ( $record =~ /<TAB[0-9]+>/ ) {
        return 'v3';
    }
    if ( $record =~ /\\T/ ) {
        return 'v2';
    }
    return 'v1';
}

# =====================================================================
# BINARY INDEX PACKING (64-bit Big-Endian Packed Identifiers)
# =====================================================================

# $adb->bin_encode(\@rids)
# Encodes list of record IDs into 8-byte packed binary format (64-bit uint Q>*).
# ------------------------------------------------
sub bin_encode {
    my ( $self, $rids ) = @_;

    return '' unless ref($rids) eq 'ARRAY' && @$rids;

    return pack( "(Q>)*", @$rids );
}

# $adb->bin_decode($binary_buffer, $offset, $limit, $dir)
# Decodes 8-byte binary buffer (64-bit uint Q>*) with O(1) substr slicing.
# Returns ($total_count, @sliced_ids)
# ------------------------------------------------
sub bin_decode {
    my ( $self, $buffer, $offset, $limit, $dir ) = @_;

    return ( 0, () ) unless defined $buffer && length($buffer) >= 8;

    my $rec_size = 8;
    my $total = int( length($buffer) / $rec_size );
    return ( 0, () ) unless $total;

    $offset ||= 0;
    $limit  ||= 0;
    $dir    = ( defined $dir && $dir =~ /^(asc|desc|reverse)$/i ) ? lc($dir) : 'desc';

    if ( lc($dir) eq 'desc' ) {
        my ( $real_start, $real_limit );
        if ($limit) {