The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package Server::Base;

use Moo;
use Sub::Quote qw[ quote_sub ];
use IO::Handle;
use Carp;

has capabilities => (
    is      => 'lazy',
    builder => sub { return {} },
);


has input => (
    is       => 'ro',
    init_arg => undef,
    default  => quote_sub q{ \*STDIN },
);

has output => (
    is       => 'ro',
    init_arg => undef,
    default  => quote_sub q{ \*STDOUT },
);

has encoding => (
    is        => 'rw',
    predicate => 1,
    clearer   => 1,
    default   => quote_sub q{ $ENV{HGENCODING} // 'utf-8' }
);

sub read {

    my ( $self, $size ) = ( shift, shift );

    my $buf;

    if ( $size ) {

        my $r = $self->input->read( @_ ? $_[-1] : $buf, $size );
        croak( "EOF\n" ) unless defined $r && $size == $r;

    }

    else {

        ( @_ ? $_[-1] : $buf ) = '';

    }

    return $buf unless @_;
    return;
}

sub read_chunk {

    my $self = shift;

    my $buf;

    $self->read( 4, $buf );

    my $len = unpack( 'N', $buf );

    return $self->read( $len, @_ );
}

sub write {

    my $self = shift;
    return  defined $self->output->syswrite( @_ );
}

sub write_chunk {

    my $self = shift;

    # my ( $channel, $data ) = @_;

    return  defined $self->output->syswrite( pack( 'A[1] N/A*', @_ ) );
}

sub say_hello {

    my $self = shift;

    my @capabilities = keys %{ $self->capabilities };

    $self->write_chunk(
        'o',
        join( "\n",
            @capabilities
            ? ( join( ' ', 'capabilities:', @capabilities ) )
            : (),
            $self->has_encoding ? 'encoding: ' . $self->encoding : (),
        ) );
}

sub serve {

    my $self = shift;

    $self->say_hello;

    while ( my $cmd = $self->input->getline ) {

        chomp $cmd;

        if ( $self->capabilities->{$cmd} ) {

            my $mth = $self->can( $cmd )
              or croak(
                "internal error; should be able to perform capability: $cmd\n"
              );

            $self->$mth;

        }

        else {

            croak( "unknown command: $cmd\n" );

        }

    }

}

sub DEMOLISH { }

1;