pbot/applets/compiler_vm/host/bin/vm-exec

#!/usr/bin/env perl

# File: vm-exec
#
# Purpose: Process and send commands to the PBot Guest server (guest-server) on
# the default serial TCP port (5555). Use the PBOTVM_SERIAL environment variable
# to override the port. E.g., to use port 7777 instead:
#
# $ PBOTVM_SERIAL=7777 vm-exec -lang=sh echo test

# SPDX-FileCopyrightText: 2021 Pragmatic Software <pragma78@gmail.com>
# SPDX-License-Identifier: MIT

use 5.020;

use warnings;
use strict;

use feature qw(signatures);
no warnings qw(experimental::signatures);

use constant {
    SERIAL => $ENV{PBOTVM_SERIAL} // 5555,
    CID    => $ENV{PBOTVM_CID}    // 7,
    VPORT  => $ENV{PBOTVM_VPORT}  // 5555,
};

use File::Basename;
use JSON::XS;
use IPC::Open2;
use IO::Socket;

use FindBin qw($RealBin);
use lib "$RealBin/../lib";

sub connect_vsock($context) {
    return undef if not $context->{'vm-cid'};

    print STDERR "Connecting to remote VM socket CID $context->{'vm-cid'} port $context->{'vm-vport'}\n";

    my $command = "socat - VSOCK-CONNECT:$context->{'vm-cid'}:$context->{'vm-vport'}";

    my ($pid, $input, $output) = eval {
        my $pid = open2(my $output, my $input, $command);
        return ($pid, $input, $output);
    };

    if ($@) {
        print STDERR "Failed to connect to VM socket: $@\n";
        return undef;
    }

    if (not defined $pid) {
        print STDERR "Failed to connect to VM socket: $!\n";
        return undef;
    }

    return ($input, $output);
}

sub connect_serial($context) {
    print STDERR "Connecting to remote VM serial port $context->{'vm-serial'}\n";

    my $vm = IO::Socket::INET->new(
        PeerAddr => '127.0.0.1',
        PeerPort => $context->{'vm-serial'},
        Proto => 'tcp',
        Type => SOCK_STREAM
    );

    # return same $vm handle for ($input, $output)
    return ($vm, $vm);
}

sub connect_vm($context) {
    my ($input, $output);

    # attempt preferred VSOCK connection
    ($input, $output) = connect_vsock($context);

    # fallback to serial
    if (not defined $input) {
        ($input, $output) = connect_serial($context);
    }

    if (not defined $input) {
        die "Could not create connection to VM: $!";
    }

    print STDERR "Connected to VM.\n";
    return ($input, $output);
}

sub main() {
    my $args = join ' ', @ARGV;

    my $context = eval { decode_json $args };

    if ($@) {
        # wasn't JSON; make structure manually
        if ($args =~ s/^-lang=([^ ]+)\s+//) {
            $context = { lang => $1, code => $args };
        } else {
            $context = { code => $args };
        }
    }

    if (not exists $context->{code}) {
        die "Usage: $0 <code>\n";
    }

    # set any missing fields to default values
    $context->{nick}        //= 'vm';
    $context->{channel}     //= 'vm';
    $context->{lang}        //= 'c11';
    $context->{'vm-serial'} //= SERIAL;
    $context->{'vm-cid'}    //= CID;
    $context->{'vm-vport'}  //= VPORT;

    # parse -lang option
    if ($context->{code} =~ s/^-lang=([^ ]+)\s+//) {
        $context->{lang} = $1;
    }

    my $language = lc $context->{lang};

    eval {
        require "Languages/$language.pm";
    } or do {
        my $found = 0;
        my ($languages, $comma) = ('', '');

        foreach my $module (sort glob "$RealBin/../lib/Languages/*.pm") {
            $module = basename $module;
            $module =~ s/.pm$//;
            next if $module =~ m/^_/;

            require "Languages/$module.pm" or die $!;
            my $mod = "Languages::$module"->new;

            if (exists $mod->{name} and $mod->{name} eq $language) {
                $language = $module;
                $found = 1;
                last;
            }

            $module = $mod->{name} if exists $mod->{name};
            $languages .= "$comma$module";
            $comma = ', ';
        }

        if (not $found) {
            print "Language '$language' is not supported.\nSupported languages are: $languages\n";
            exit;
        }
    };

    if (not length $context->{code}) {
        if (exists $context->{usage}) {
            print "$context->{usage}\n";
        } else {
            print "Usage: cc [-lang=<language>] [-info] [-paste] [-args \"command-line arguments\"] [compiler/language options] <code> [-stdin <stdin input>]\n";
        }
        exit;
    }

    my $lang = "Languages::$language"->new(%$context);

    $lang->process_interactive_edit;
    $lang->process_standard_options;
    $lang->process_custom_options;
    $lang->process_cmdline_options;
    $lang->preprocess_code;

    ($lang->{'vm-input'}, $lang->{'vm-output'}) = connect_vm($context);
    $lang->execute;

    $lang->postprocess_output;
    $lang->show_output;
}

main();