The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use strict;
use warnings;

use Test::More tests => 3;

{
    package MyTest::Process;
    use base qw/CouchDB::ExternalProcess/;

    sub foo :Action {
        return {
            json => {
                foo => "bar"
            }
        };
    }

    # Getter/setter for file handle destroy will log to
    sub destroyLoggerFh {
        my ($self, $loggerFh) = @_;
        $self->{destroyLoggerFh} = $loggerFh if $loggerFh;
        return ($self->{destroyLoggerFh} || *STDERR);
    }

    sub _destroy {
        my $self = shift;
        my $fh = $self->destroyLoggerFh();
        print $fh "Destroy called!$/";
    }

    1;
}

my $testProcess = MyTest::Process->new;

isa_ok($testProcess,'MyTest::Process');

my $goodRequestJson = '{"path":["database","process","foo"]}';

pipe(PROC_READ, PROC_WRITE);
pipe(TEST_READ, TEST_WRITE);
pipe(DESTROY_READ, DESTROY_WRITE);

$testProcess->destroyLoggerFh(*DESTROY_WRITE);

my $pid = fork();

$| = 1;
if($pid) {
    # Only for the child to write to us (the parent)
    close(TEST_WRITE);
    close(DESTROY_WRITE);

    # Write some data to the child
    print PROC_WRITE $goodRequestJson.$/;

    # And close the stream
    close(PROC_WRITE);

    # Wait for the child to exit
    wait();
} else {
    # Only for the parent to write to us (the child)
    close(PROC_WRITE);

    # Run until our input stream is closed (by the parent)
    $testProcess->run(in_fh => *PROC_READ, out_fh => *TEST_WRITE);

    # Don't keep running the parent's code as the child!
    exit();
}

my $processOutputJson;
my $destroyOutput;
my $ret = read(TEST_READ, $processOutputJson, 100);
$ret = read(DESTROY_READ, $destroyOutput, 100);

is($destroyOutput, "Destroy called!$/", "_destroy output");

my $processOutput = $testProcess->jsonParser->jsonToObj($processOutputJson);
is($processOutput->{json}->{foo}, "bar","Good Response Data");