The London Perl and Raku Workshop takes place on 26th Oct 2024. If your company depends on Perl, please consider sponsoring and/or attending.
package TestServer;
use Data::Dump qw( dump );
use HTTP::Date;
use base ( 'Test::HTTP::Server::Simple', 'HTTP::Server::Simple::CGI' );

my %dispatch = (
    '/'                  => \&resp_root,
    '/hello'             => \&resp_hello,
    '/robots.txt'        => \&resp_robots,
    '/redirect/local'    => [ 307, '/target' ],
    '/redirect/loopback' => [ 307, 'http://127.0.0.1/hello' ],
    '/old/page'          => \&resp_old_page,
    '/size/big'          => \&resp_big_page,
    '/img/test'          => \&resp_img,
);

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

    #dump \%ENV;
    my $path = $cgi->path_info();

    #warn "path=$path";

    my $handler = $dispatch{$path};
    if ( ref $handler eq 'CODE' ) {
        print "HTTP/1.0 200 OK\r\n";
        $handler->($cgi);

    }
    elsif ( ref $handler eq 'ARRAY' ) {
        print "HTTP/1.0 $handler->[0]\r\n";
        print "Location: $handler->[1]\r\n";
    }
    elsif ( ref $handler eq 'HASH' ) {
        $handler->{code}->( $self, $cgi, $handler );
    }
    else {
        print "HTTP/1.0 404 Not found\r\n";
        print $cgi->header,
            $cgi->start_html('Not found'),
            $cgi->h1('Not found'),
            $cgi->end_html;
    }

}

sub resp_root {
    my $cgi = shift;
    print $cgi->header, $cgi->start_html,
        qq(<a href="#">recursive anchor</a>),
        qq(<a href="/">root</a>),
        qq(<a href="hello">follow me</a>),
        qq(<a href="nosuchlink">404</a>),
        qq(<a href="redirect/local">redirect local</a>),
        qq(<a href="redirect/loopback">redirect loopback</a>),
        qq(<a href="old/page">old and in the way</a>),
        qq(<a href="size/big">big file</a>),
        qq(<img src="img/test" />),
        $cgi->end_html;
}

sub resp_big_page {
    my $cgi = shift;
    print "Content-Length: 8192\r\n";
    print $cgi->header;
    print 'i am a really big file';

}

sub resp_img {
    my $cgi = shift;
    print $cgi->header('image/jpeg');
    print 'thisisanimage.heh';
}

sub resp_old_page {
    my $cgi = shift;
    printf( "Last-Modified: %s\r\n", time2str( time() - 86400 ) ); # yesterday
    print $cgi->header, $cgi->start_html, 'this page is old', $cgi->end_html;
}

sub resp_hello {
    my $cgi = shift;
    return if !ref $cgi;
    print $cgi->header, $cgi->h1('hello');
}

sub resp_robots {
    my $cgi = shift;
    print $cgi->header('text/plain'), '';                          # TODO
}

1;