File Coverage

lib/SIRTX/VM/Disassembler.pm

Criterion	Covered	Total	%
statement	23	134	17.1
branch	0	54	0.0
condition	0	22	0.0
subroutine	8	13	61.5
pod	2	2	100.0
total	33	225	14.6

# Copyright (c) 2025 Philipp Schafft

# licensed under Artistic License 2.0 (see LICENSE file)

# ABSTRACT: module for assembling SIRTX VM code


package SIRTX::VM::Disassembler;

use v5.16;
use strict;
use warnings;

use Carp;
use Fcntl qw(SEEK_SET SEEK_END SEEK_CUR);
use SIRTX::VM::RegisterFile;
use SIRTX::VM::Opcode;

use parent 'Data::Identifier::Interface::Userdata';

our $VERSION = v0.12;


sub new {
    my ($pkg, %opts) = @_;
    my $self = bless({
            max_data => delete($opts{max_data}),
        }, $pkg);

    {
        my $fh = delete $opts{in};
        croak 'No input given' unless defined $fh;

        unless (ref $fh) {
            open(my $x, '<', $fh) or die $!;
            $fh = $x;
        }

        $fh->binmode;
        $self->{in} = $fh;
    }

    {
        my $fh = delete $opts{out};
        croak 'No output given' unless defined $fh;

        unless (ref $fh) {
            open(my $x, '>', $fh) or die $!;
            $fh = $x;
        }

        $fh->binmode;
        $fh->binmode(':utf8');
        $self->{out} = $fh;
    }

    croak 'Stray options passed' if scalar keys %opts;

    return $self;
}


sub run {
    my ($self, @opts) = @_;
    my $in = $self->{in};
    my $out = $self->{out};
    my $in_length = $self->_in_length;

    $self->{starts} = {0 => undef};

    croak 'Stray options passed' if scalar @opts;

    while (1) {
        my $pos = $in->tell // croak 'Cannot tell on input';

        last if $pos >= $in_length;

        if (exists $self->{starts}{$pos}) {
            $self->_run_text;
        } else {
            $self->_run_data;
        }
    }
}

# ---- Private helpers ----

sub _in_length {
    my ($self) = @_;

    return $self->{in_length} //= do {
        my $fh = $self->{in};
        my $l;

        $fh->seek(0, SEEK_END);

        $l = $fh->tell;

        $fh->seek(0, SEEK_SET);

        $l;
    };
}

sub _run_text {
    my ($self) = @_;
    my $in = $self->{in};
    my $out = $self->{out};
    my $in_length = $self->_in_length;

    while ($in->tell < $in_length && defined(my $opcode = SIRTX::VM::Opcode->read($in))) {
        my %extra = $opcode->_extra;

        $self->{starts}{$_} //= undef for @{$extra{start_offsets}//[]};


        if ($extra{type} eq 'chunk') {
            my $length = $extra{length};

            if ($length >= 4) {
                my $command = '.chunk';
                my $data_length = $length - 4;
                my ($flags, $type);
                my $chunk_identifier;
                my $raw;

                $in->read($raw, 4) == 4 or croak 'Cannot read input';

                ($flags, $type) = unpack('nn', $raw);

                {
                    my $identifier_type = $flags & ((1<<15)|(1<<14));
                    if ($identifier_type == ((1<<15)|(1<<14))) {
                        croak 'Unsupported identifier type: user defined';
                    } elsif ($identifier_type == ((1<<15)|(0<<14))) {
                        $command .= ' of ~'.$type;
                    } elsif ($identifier_type == ((0<<15)|(1<<14))) {
                        $command .= ' of sid:'.$type;
                    } elsif ($identifier_type == ((0<<15)|(0<<14))) {
                        $command .= ' of sni:'.$type;
                    }
                }

                if ($flags & (1<<7)) {
                    $command .= ' standalone';
                }

                if ($flags & (1<<1)) {
                    $in->read($raw, 2) == 2 or croak 'Cannot read input';
                    $chunk_identifier = unpack('n', $raw);
                    $data_length -= 2;
                    $command .= ' as ~'.$chunk_identifier;
                }

                if ($flags & (1<<0)) {
                    $data_length -= 1;
                }

                #warn sprintf('; ### flags: %04x type: %04x, chunk identifier: %s, data_length: %u', $flags, $type, $chunk_identifier // '', $data_length);
                $out->say($command);
                $self->_run_data($data_length);

                if ($flags & (1<<0)) {
                    my $pos = $in->tell;
                    $in->read($raw, 1) == 1 or croak 'Cannot read input';
                    $out->say(sprintf('                                                 ; at 0x%04x: Padding: 0x%02x', $pos, ord $raw));
                }
                $out->say('.endchunk');
            }
        } else {
            $out->say($opcode->as_text);
            if ($opcode->is_end_of_text) {
                $out->say('; End of text');
                last;
            }
        }
    }
}

sub _run_data {
    my ($self, $todo) = @_;
    my $in = $self->{in};
    my $out = $self->{out};
    my $pos = $in->tell // croak 'Cannot tell on input';
    my ($next_code) = sort { $a <=> $b } grep { $_ >= $pos } keys(%{$self->{starts}}), $self->_in_length;

    $todo //= $next_code - $pos;

    if (defined($self->{max_data}) && $todo > $self->{max_data}) {
        $out->say(sprintf('; %u bytes of data skipped', $todo));
        $in->seek($todo, SEEK_CUR);
        return;
    }

    $out->say(sprintf('; %u bytes of data follow', $todo));

    while ($todo > 0) {
        my $step = $todo > 8 ? 8 : $todo;
        my $line = '.byte';
        my $rendered;

        $in->read(my $raw, $step) == $step or croak 'Error reading data';

        $line .= sprintf(' 0x%02x', ord) foreach split //, $raw;

        $rendered = $raw =~ tr/\x21-\x7E/./rc;

        $line = sprintf('%-48s ; at 0x%04x: | %-8s |',
            $line, $pos,
            $rendered,
        );

        $out->say($line);

        $todo -= $step;
        $pos  += $step;
    }
}

1;

__END__