The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package xt::Server;
use strict;
use warnings;
use Net::Drizzle ':constants';
use IO::Socket::INET;
use Exporter 'import';

# usage: xt::Server->run(4443);

sub true  () { 1 }
sub false () { 0 }
our $rows = [['a', 'b'], ['c', 'd']];

our @EXPORT = 'server_rows';

sub server_rows { $rows }

sub run {
    my ($class, $port) = @_;

    $SIG{PIPE} = "IGNORE";
    my $sock = IO::Socket::INET->new(
        LocalAddr => "0.0.0.0:$port",
        Proto     => 'tcp',
        ReuseAddr => 1,
        Listen    => 10,
    );
    die $! unless $sock;
    my $drizzle = Net::Drizzle->new();
    while (1) {
        my $csock = $sock->accept or die "cannot accept";
        my $con = $drizzle->con_create()
                        ->set_fd($csock->fileno)
                        ->add_options(Net::Drizzle::DRIZZLE_CON_MYSQL);
        _handle($con);
    }
}

sub _handle {
    my $con = shift;

    # Handshake packets.
    $con->set_protocol_version(10)
        ->set_server_version("Net::Drizzle example 1.2.3")
        ->set_thread_id(1)
        ->set_scramble("ABCDEFGHIJKLMNOPQRST")
        ->set_capabilities(Net::Drizzle::DRIZZLE_CAPABILITIES_NONE)
        ->set_charset(8)
        ->set_status(DRIZZLE_CON_STATUS_NONE)
        ->set_max_packet_size(DRIZZLE_MAX_PACKET_SIZE);

    $con->server_handshake_write();
    my $ret = $con->client_handshake_read();
    if ($ret == DRIZZLE_RETURN_LOST_CONNECTION) {
        # warn "LOST CONNECTION";
        return;
    }

    $con->result_create()
        ->write(true);

    while (1) {
        my ($data, $command, $total, $ret) = $con->command_buffer();
        if ($ret == DRIZZLE_RETURN_LOST_CONNECTION) {
            # warn "LOST CONNECTION, $ret";
            return;
        }
        if ($ret == DRIZZLE_RETURN_OK && $command == DRIZZLE_COMMAND_QUIT) {
            # warn "USER QUIT";
            return;
        }
        #use Data::Dumper; warn Dumper([$data, $command, $total, $ret]);
        # printf("got query %u '%s'\n", $command, defined($data) ? $data : '(undef)');

        my $res = $con->result_create();
        if ($command != DRIZZLE_COMMAND_QUERY) {
            $res->write(true);
            #warn "not a query, skipped, $command";
            next;
        }


        $res->set_column_count(2)
            ->write(false);

        $res->column_create()
            ->set_catalog("default")
            ->set_db("drizzle_test_db")
            ->set_table("drizzle_set_table")
            ->set_orig_table("drizzle_test_table")
            ->set_name("test_column_1")
            ->set_orig_name("test_column_1")
            ->set_charset(8)
            ->set_size(scalar(@$rows))
            ->set_type(DRIZZLE_COLUMN_TYPE_VARCHAR)
            ->write()
            ->set_name("test_column_2")
            ->set_orig_name("test_column_2")
            ->write();

        $res->set_eof(true)
            ->write(false);

        for my $fields (@$rows) {
            $res->calc_row_size(@$fields) # This is needed for MySQL and old Drizzle protocol.
                ->row_write();
            $res->fields_write(@$fields);
        }
        $res->write(true);
    }
}

1;