# Copyright (c) 2024 Yuki Kimoto
# MIT License
class Packer {
version_from SPVM;
use Packer::Specifier;
use StringBuffer;
use Fn;
# Class Methods
static method new : Packer () {
my $self = new Packer;
return $self;
}
precompile method pack : string ($template : string, $objects : object[]) {
unless ($template) {
die "The template \$template must be defined.";
}
unless ($objects) {
die "The objects \$objects must be defined.";
}
my $specifiers = $self->_parse_template($template);
my $specifiers_length = @$specifiers;
my $objects_length = @$objects;
unless ($specifiers_length <= $objects_length) {
die "The length of the specifiers in the template \"$template\" must be less than or equal to the lenght of the objects \$objects.";
}
my $binary_buffer = StringBuffer->new;
for (my $i = 0; $i < $specifiers_length; $i++) {
my $specifier = $specifiers->[$i];
my $specifier_type = $specifier->{type};
my $is_numeric_object = $specifier->{is_numeric_object};
my $endian = $specifier->{endian};
my $length = $specifier->{length};
my $has_wildcard_length = $specifier->{has_wildcard_length};
my $object = $objects->[$i];
my $size = 0;
my $values = (object)undef;
switch ($specifier_type) {
case Packer::Specifier->TYPE_STRING : {
$size = 1;
$values = (string)$object;
}
case Packer::Specifier->TYPE_HEX_STRING_LOW :
case Packer::Specifier->TYPE_HEX_STRING_HIGH :
{
$size = 1;
my $hex_string = (string)$object;
my $hex_string_length = length $hex_string;
my $values_buffer = StringBuffer->new;
for (my $i = 0; $i < $hex_string_length; $i += 2) {
my $hex_char_high = $hex_string->[$i];
unless (Fn->is_hex_digit($hex_char_high)) {
die "Input contains non hex character.";
}
my $hex_char_low = '\x30'; # 0
if ($i + 1 < $hex_string_length) {
$hex_char_low = $hex_string->[$i + 1];
unless (Fn->is_hex_digit($hex_char_high)) {
die "Input contains non hex character.";
}
}
my $hex_char = (string)undef;
if ($specifier_type == Packer::Specifier->TYPE_HEX_STRING_HIGH) {
$hex_char = Fn->chr($hex_char_high) . Fn->chr($hex_char_low);
}
elsif ($specifier_type == Packer::Specifier->TYPE_HEX_STRING_LOW) {
$hex_char = Fn->chr($hex_char_low) . Fn->chr($hex_char_high);
}
else {
die "[Unexpected Error]Invalid specifier type";
}
my $byte_number = Fn->hex($hex_char);
$values_buffer->push_char($byte_number);
}
$values = $values_buffer->to_string;
}
case Packer::Specifier->TYPE_BYTE : {
if ($is_numeric_object) {
unless ($object is_type Byte) {
die "The type of the element in the objects \$objects at index $i must be Byte type.";
}
$values = [(byte)$object];
}
else {
unless ($object is_type byte[]) {
die "The type of the element in the objects \$objects at index $i must be byte[] type.";
}
$values = (byte[])$object;
}
$size = 1;
}
case Packer::Specifier->TYPE_SHORT : {
if ($is_numeric_object) {
unless ($object is_type Short) {
die "The type of the element in the objects \$objects at index $i must be Short type.";
}
$values = [(short)$object];
}
else {
unless ($object is_type short[]) {
die "The type of the element in the objects \$objects at index $i must be short[] type.";
}
$values = (short[])$object;
}
$size = 2;
}
case Packer::Specifier->TYPE_INT : {
if ($is_numeric_object) {
unless ($object is_type Int) {
die "The type of the element in the objects \$objects at index $i must be Int type.";
}
$values = [(int)$object];
}
else {
unless ($object is_type int[]) {
die "The type of the element in the objects \$objects at index $i must be int[] type.";
}
$values = (int[])$object;
}
$size = 4;
}
case Packer::Specifier->TYPE_LONG : {
if ($is_numeric_object) {
unless ($object is_type Long) {
die "The type of the element in the objects \$objects at index $i must be Long type.";
}
$values = [(long)$object];
}
else {
unless ($object is_type long[]) {
die "The type of the element in the objects \$objects at index $i must be long[] type.";
}
$values = (long[])$object;
}
$size = 8;
}
case Packer::Specifier->TYPE_FLOAT : {
if ($is_numeric_object) {
unless ($object is_type Float) {
die "The type of the element in the objects \$objects at index $i must be Float type.";
}
$values = [(float)$object];
}
else {
unless ($object is_type float[]) {
die "The type of the element in the objects \$objects at index $i must be float[] type.";
}
$values = (float[])$object;
}
$size = 4;
}
case Packer::Specifier->TYPE_DOUBLE : {
if ($is_numeric_object) {
unless ($object is_type Double) {
die "The type of the element in the objects \$objects at index $i must be Double type.";
}
$values = [(double)$object];
}
else {
unless ($object is_type double[]) {
die "The type of the element in the objects \$objects at index $i must be double[] type.";
}
$values = (double[])$object;
}
$size = 8;
}
default : {
die "[Unexpected Error]Invalid specifier type.";
}
}
my $process_length = 0;
if ($has_wildcard_length) {
$process_length = Fn->length($values);
}
else {
$process_length = $length;
}
if ($specifier_type == Packer::Specifier->TYPE_HEX_STRING_LOW || $specifier_type == Packer::Specifier->TYPE_HEX_STRING_HIGH) {
$process_length = ($process_length + 1) / 2;
}
my $binary_part_size = $size * $process_length;
my $copy_size = 0;
if (Fn->length($values) < $process_length) {
$copy_size = $size * Fn->length($values);
}
else {
$copy_size = $size * $process_length;
}
my $binary_part = (mutable string)new_string_len $binary_part_size;
Fn->memcpy($binary_part, 0, $values, 0, $copy_size);
if ($endian == Packer::Specifier->ENDIAN_BIG_ENDIAN || $endian == Packer::Specifier->ENDIAN_LITTLE_ENDIAN) {
for (my $i = 0; $i < $process_length; $i++) {
my $binary_part_offset = $size * $i;
if ($endian == Packer::Specifier->ENDIAN_BIG_ENDIAN) {
Fn->system_endian_to_big_endian($binary_part, $size);
}
elsif ($endian == Packer::Specifier->ENDIAN_LITTLE_ENDIAN) {
Fn->system_endian_to_little_endian($binary_part, $size);
}
}
}
$binary_buffer->push($binary_part);
}
my $binary = $binary_buffer->to_string;
return $binary;
}
precompile method unpack : object[] ($template : string, $binary : string) {
unless ($template) {
die "The template \$template must be defined.";
}
unless ($binary) {
die "The binary data \$binary must be defined.";
}
my $binary_length = length $binary;
my $specifiers = $self->_parse_template($template);
my $specifiers_length = @$specifiers;
my $binary_offset = 0;
my $objects_list = List->new(new object[0]);
for (my $i = 0; $i < $specifiers_length; $i++) {
my $specifier = $specifiers->[$i];
my $specifier_type = $specifier->{type};
my $endian = $specifier->{endian};
my $length = $specifier->{length};
my $has_wildcard_length = $specifier->{has_wildcard_length};
my $is_numeric_object = $specifier->{is_numeric_object};
my $size = 0;
switch ($specifier_type) {
case Packer::Specifier->TYPE_STRING : {
$size = 1;
}
case Packer::Specifier->TYPE_HEX_STRING_LOW :
case Packer::Specifier->TYPE_HEX_STRING_HIGH :
{
$size = 1;
}
case Packer::Specifier->TYPE_BYTE : {
$size = 1;
}
case Packer::Specifier->TYPE_SHORT : {
$size = 2;
}
case Packer::Specifier->TYPE_INT : {
$size = 4;
}
case Packer::Specifier->TYPE_LONG : {
$size = 8;
}
case Packer::Specifier->TYPE_FLOAT : {
$size = 4;
}
case Packer::Specifier->TYPE_DOUBLE : {
$size = 8;
}
default : {
die "[Unexpected Error]Invalid specifier type.";
}
}
my $process_length = $length;
if ($has_wildcard_length) {
$process_length = ($binary_length - $binary_offset) / $size;
}
if ($specifier_type == Packer::Specifier->TYPE_HEX_STRING_LOW || $specifier_type == Packer::Specifier->TYPE_HEX_STRING_HIGH) {
$process_length = ($process_length + 1) / 2;
}
unless ($binary_offset + $size * $process_length <= $binary_length) {
die "The current offset $binary_offset plus (the size $size * the process length culcuralted by $length of the specifier) must be less than the length($binary_length) of the binary data \$binary.";
}
my $binary_part_size = $size * $process_length;
my $binary_part = (mutable string)new_string_len $binary_part_size;
Fn->memcpy($binary_part, 0, $binary, $binary_offset, $binary_part_size);
if ($endian == Packer::Specifier->ENDIAN_BIG_ENDIAN || $endian == Packer::Specifier->ENDIAN_LITTLE_ENDIAN) {
for (my $i = 0; $i < $process_length; $i++) {
my $binary_part_offset = $size * $i;
if ($endian == Packer::Specifier->ENDIAN_BIG_ENDIAN) {
Fn->big_endian_to_system_endian($binary_part, $size);
}
elsif ($endian == Packer::Specifier->ENDIAN_LITTLE_ENDIAN) {
Fn->little_endian_to_system_endian($binary_part, $size);
}
}
}
my $object = (object)undef;
switch ($specifier_type) {
case Packer::Specifier->TYPE_STRING : {
$object = $binary_part;
}
case Packer::Specifier->TYPE_HEX_STRING_LOW :
case Packer::Specifier->TYPE_HEX_STRING_HIGH :
{
my $byte_numbers = (byte[])$binary_part;
my $int_object_array = new Int[$process_length];
for (my $i = 0; $i < length $binary_part; $i++) {
my $number = $binary_part->[$i];
$int_object_array->[$i] = Int->new($number & 0xFF);
}
my $format = Fn->repeat("%x", $process_length);
my $hex_string_part = (mutable string)Fn->sprintf($format, (object[])$int_object_array);
if ($specifier_type == Packer::Specifier->TYPE_HEX_STRING_LOW) {
for (my $i = 0; $i < $process_length; $i++) {
my $tmp = $hex_string_part->[$i * 2];
$hex_string_part->[$i * 2] = $hex_string_part->[$i * 2 + 1];
$hex_string_part->[$i * 2 + 1] = $tmp;
}
}
unless ($has_wildcard_length) {
Fn->shorten($hex_string_part, $length);
}
$object = $hex_string_part;
}
case Packer::Specifier->TYPE_BYTE : {
$object = new byte[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Byte->new($object->(byte[])->[0]);
}
}
case Packer::Specifier->TYPE_SHORT : {
$object = new short[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Short->new($object->(short[])->[0]);
}
}
case Packer::Specifier->TYPE_INT : {
$object = new int[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Int->new($object->(int[])->[0]);
}
}
case Packer::Specifier->TYPE_LONG : {
$object = new long[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Long->new($object->(long[])->[0]);
}
}
case Packer::Specifier->TYPE_FLOAT : {
$object = new float[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Float->new($object->(float[])->[0]);
}
}
case Packer::Specifier->TYPE_DOUBLE : {
$object = new double[$process_length];
Fn->memcpy($object, 0, $binary_part, 0, $binary_part_size);
if ($is_numeric_object) {
$object = Double->new($object->(double[])->[0]);
}
}
default : {
die "[Unexpected Error]Invalid specifier type.";
}
}
$objects_list->push($object);
$binary_offset += $binary_part_size;
}
my $objects = $objects_list->to_array;
return $objects;
}
private precompile method _parse_template : Packer::Specifier[] ($template : string) {
my $template_length = length $template;
my $template_index = 0;
my $specifiers_list = List->new(new Packer::Specifier[0]);
while (1) {
unless ($template_index < $template_length) {
last;
}
my $ch = $template->[$template_index];
# Parse a specifier
my $specifier_type = Packer::Specifier->TYPE_NONE;
switch ($ch) {
# String
case 'a' : {
$specifier_type = Packer::Specifier->TYPE_STRING;
}
# A hex string (low nybble first)
case 'h' : {
$specifier_type = Packer::Specifier->TYPE_HEX_STRING_LOW;
}
# A hex string (high nybble first)
case 'H' : {
$specifier_type = Packer::Specifier->TYPE_HEX_STRING_HIGH;
}
# Signed 8-bit integers
case 'c' : {
$specifier_type = Packer::Specifier->TYPE_BYTE;
}
# Unsigned 8-bit integers
case 'C' : {
$specifier_type = Packer::Specifier->TYPE_BYTE;
}
# Signed 16-bit integers
case 's' : {
$specifier_type = Packer::Specifier->TYPE_SHORT;
}
# Unsigned 16-bit integers
case 'S' : {
$specifier_type = Packer::Specifier->TYPE_SHORT;
}
# Signed 32-bit integers
case 'l' : {
$specifier_type = Packer::Specifier->TYPE_INT;
}
# Unsigned 32-bit integers
case 'L' : {
$specifier_type = Packer::Specifier->TYPE_INT;
}
# Signed 32-bit integers
case 'q' : {
$specifier_type = Packer::Specifier->TYPE_LONG;
}
# Unigned 32-bit integers
case 'Q' : {
$specifier_type = Packer::Specifier->TYPE_LONG;
}
# 16-bit floating point numbers
case 'f' : {
$specifier_type = Packer::Specifier->TYPE_FLOAT;
}
# 32-bit floating point numbers
case 'd' : {
$specifier_type = Packer::Specifier->TYPE_DOUBLE;
}
default : {
die "Invalid specifier " . Fn->chr($ch) . " in the template \"$template\".";
}
}
$template_index++;
# Prase endian
my $endian = Packer::Specifier->ENDIAN_NONE;
if ($template_index < $template_length) {
$ch = $template->[$template_index];
if ($ch == '>') {
$endian = Packer::Specifier->ENDIAN_BIG_ENDIAN;
$template_index++;
}
elsif ($ch == '<') {
$endian = Packer::Specifier->ENDIAN_LITTLE_ENDIAN;
$template_index++;
}
}
# Parse length
my $is_numeric_object = 0;
my $has_wildcard_length = 0;
my $length = 0;
if ($template_index < $template_length && $template->[$template_index] == '*') {
$has_wildcard_length = 1;
$template_index++;
}
else {
my $length_string = "";
while (1) {
unless ($template_index < $template_length) {
last;
}
$ch = $template->[$template_index];
if (Fn->is_digit($ch)) {
$length_string .= Fn->chr($ch);
$template_index++;
}
else {
last;
}
}
if (length $length_string) {
$length = Fn->to_int($length_string);
unless ($length > 0) {
die "The data length $length in the template in the template \"$template\" must be a positive value.";
}
}
else {
$length = 1;
$is_numeric_object = 1;
}
}
if ($specifier_type == Packer::Specifier->TYPE_STRING) {
if ($is_numeric_object) {
die "The data length $length for \"a\" in the template in the template \"$template\" must be specified.";
}
}
my $specifier = new Packer::Specifier;
$specifier->{type} = $specifier_type;
$specifier->{is_numeric_object} = $is_numeric_object;
$specifier->{endian} = $endian;
$specifier->{length} = $length;
$specifier->{has_wildcard_length} = (byte)$has_wildcard_length;
$specifiers_list->push($specifier);
}
my $specifiers = (Packer::Specifier[])$specifiers_list->to_array;
return $specifiers;
}
}