The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
use Test::More;
use strict;
use warnings;
use Data::Dumper;

require HTTP::Server::Simple;

BEGIN { unshift @INC, "../lib"; }


# -------------
package TestHelper;
use Data::Dumper;

our($PID, $PORT, $RECEIVED_METHOD);

sub setup {
    
    $PORT = 7657;
    $PID  = REST::Client::TestServer->new($PORT)->background();
    $Bio::Cellucidate::CONFIG = { host => "http://localhost:$PORT" };
}

sub teardown {
    kill 15, $PID;
    exit;
}

sub last_request {
  my $client = REST::Client->new( { host => "http://localhost:$PORT" } );
  eval $client->request('GET', "/test")->responseContent;
}


# -------------
package REST::Client::TestServer;

use base qw(HTTP::Server::Simple::CGI);
use File::Basename;
use Data::Dumper;

our ($LAST_METHOD, $LAST_PATH, $LAST_QUERY, @LAST_KEYWORDS);

sub handle_request {
    my ( $self, $cgi ) = @_;

    my $path = $cgi->path_info;
    my $fixture_filename = dirname(__FILE__) . "/fixtures$path";
    $fixture_filename =~ s/\/$//;
    $fixture_filename .= '.http';
    
    if ($path eq '/test') {
        my $info = { 
            method => $LAST_METHOD,
            path => $LAST_PATH,
            query => $LAST_QUERY,
            keywords => join "", @LAST_KEYWORDS
        };
        $Data::Dumper::Purity = 1;
        $Data::Dumper::Terse = 1;
        print "HTTP/1.1 200 OK\r\n";
        print "\n";
        print Dumper $info;
    } else {
        $LAST_METHOD = $ENV{'REQUEST_METHOD'};
        $LAST_PATH = $path;
        $LAST_QUERY = $cgi->Vars;
        if ($LAST_QUERY->{PUTDATA}) {
            $LAST_QUERY = $LAST_QUERY->{PUTDATA};
        } elsif ($LAST_QUERY->{'XForms:Model'}) {
            $LAST_QUERY = $LAST_QUERY->{'XForms:Model'};
        }
        @LAST_KEYWORDS = $cgi->keywords;
    }

    if ($ENV{'REQUEST_METHOD'} eq 'DELETE') {
        print "HTTP/1.1 200 OK\r\n";
    } elsif ($path ne '/test') {
        if (-e $fixture_filename) {
            open FH, $fixture_filename;
            print <FH>;
            close FH;
        } else {
            print "HTTP/1.1 500\r\n";
            die "Can't open $fixture_filename";
        }
    }
}


sub valid_http_method {
    my $self = shift;
    my $method = shift or return 0;
    return $method =~ /^(?:GET|POST|HEAD|PUT|DELETE|OPTIONS)$/;
}

1;