File Coverage

lib/HTTP/Handy.pm

Criterion	Covered	Total	%
statement	210	350	60.0
branch	45	138	32.6
condition	25	75	33.3
subroutine	40	44	90.9
pod	10	10	100.0
total	330	617	53.4

package HTTP::Handy;
######################################################################
#
# HTTP::Handy - A tiny HTTP/1.0 server for Perl 5.5.3+
#
# https://metacpan.org/dist/HTTP-Handy
#
# Copyright (c) 2026 INABA Hitoshi
######################################################################
#
# Compatible : Perl 5.005_03 and later
# Platform   : Windows and UNIX/Linux
#
######################################################################

use 5.00503;    # Universal Consensus 1998 for primetools
                # Perl 5.005_03 compatibility for historical toolchains
# use 5.008001; # Lancaster Consensus 2013 for toolchains

use strict;
BEGIN { if ($] < 5.006 && !defined(&warnings::import)) { $INC{'warnings.pm'} = 'stub'; eval 'package warnings; sub import {}' } }
use warnings; local $^W = 1;
BEGIN { pop @INC if $INC[-1] eq '.' }

use IO::Socket;
use Carp qw(croak);
use vars qw($VERSION $ACCESS_LOG_FH $CURRENT_LOG_FILE $_fh_seq);
$VERSION = '1.05';
$VERSION = $VERSION;
$_fh_seq = 0;
# $VERSION self-assignment suppresses "used only once" warning under strict.

###############################################################################
# Status text map
###############################################################################
my %STATUS_TEXT = (
    200 => 'OK',
    201 => 'Created',
    204 => 'No Content',
    301 => 'Moved Permanently',
    302 => 'Found',
    304 => 'Not Modified',
    400 => 'Bad Request',
    403 => 'Forbidden',
    404 => 'Not Found',
    405 => 'Method Not Allowed',
    413 => 'Request Entity Too Large',
    500 => 'Internal Server Error',
);

###############################################################################
# MIME type map
###############################################################################
my %MIME = (
    'html'  => 'text/html; charset=utf-8',
    'htm'   => 'text/html; charset=utf-8',
    'txt'   => 'text/plain; charset=utf-8',
    'text'  => 'text/plain; charset=utf-8',
    'css'   => 'text/css',
    'js'    => 'application/javascript',
    'json'  => 'application/json',
    'xml'   => 'application/xml',
    'png'   => 'image/png',
    'jpg'   => 'image/jpeg',
    'jpeg'  => 'image/jpeg',
    'gif'   => 'image/gif',
    'ico'   => 'image/x-icon',
    'svg'   => 'image/svg+xml',
    'pdf'   => 'application/pdf',
    'zip'   => 'application/zip',
    'gz'    => 'application/gzip',
    'ltsv'  => 'text/plain; charset=utf-8',
    'csv'   => 'text/csv; charset=utf-8',
    'tsv'   => 'text/tab-separated-values; charset=utf-8',
);

# Default max POST body size: 10MB
my $DEFAULT_MAX_POST_SIZE = 10 * 1024 * 1024;

# Access log variables (package variables for testability; declared via use vars above)
$ACCESS_LOG_FH    = undef;
$CURRENT_LOG_FILE = '';

###############################################################################
# run - Start the server (blocking)
###############################################################################
sub run {
    my ($class, %args) = @_;

    my $app           = $args{app}           or croak "HTTP::Handy->run: 'app' is required";
    my $host          = defined $args{host}          ? $args{host}          : '0.0.0.0';
    my $port          = defined $args{port}          ? $args{port}          : 8080;
    my $log           = defined $args{log}           ? $args{log}           : 1;
    my $max_post_size = defined $args{max_post_size} ? $args{max_post_size} : $DEFAULT_MAX_POST_SIZE;

    ref($app) eq 'CODE' or croak "HTTP::Handy->run: 'app' must be a code reference";
    $port =~ /^\d+$/ or croak "HTTP::Handy->run: 'port' must be a number";
    $max_post_size =~ /^\d+$/ or croak "HTTP::Handy->run: 'max_post_size' must be a number";

    my $server = IO::Socket::INET->new(
        LocalAddr => $host,
        LocalPort => $port,
        Proto     => 'tcp',
        Listen    => 10,
        ReuseAddr => 1,
    );
    unless ($server) {
        croak "HTTP::Handy: Cannot bind to $host:$port - $@";
    }

    # Create Apache-like directories
    _init_directories();

    _log_message("HTTP::Handy $HTTP::Handy::VERSION started on http://$host:$port/") if $log;
    _log_message("Press Ctrl+C to stop.") if $log;

    while (1) {
        my $client = $server->accept;
        unless ($client) {
            _log_message("Accept failed: $!") if $log;
            next;
        }

        # Disable CRLF translation on Windows
        binmode $client;

        eval {
            _handle_connection($client, $app, $log, $max_post_size, $port);
        };
        if ($@) {
            _log_message("Error handling connection: $@") if $log;
        }

        close $client;
    }
}

###############################################################################
# _handle_connection - Parse request and dispatch to app
###############################################################################
sub _handle_connection {
    my ($client, $app, $log, $max_post_size, $server_port) = @_;

    # Read request line
    my $request_line = _read_line($client);
    return unless defined $request_line && $request_line ne '';

    $request_line =~ s/\r?\n$//;

    my ($method, $request_uri, $http_version) = split /\s+/, $request_line, 3;

    # Only allow GET and POST
    unless (defined $method && ($method eq 'GET' || $method eq 'POST')) {
        _send_error($client, 405, 'Method Not Allowed');
        return;
    }

    # Parse URI into path and query
    my ($path, $query_string) = ('/', '');
    if (defined $request_uri) {
        if ($request_uri =~ /^([^?]*)\?(.*)$/) {
            $path         = $1;
            $query_string = $2;
        }
        else {
            $path = $request_uri;
        }
    }
    $path = '/' unless defined $path && $path ne '';

    # Read headers
    my %headers;
    while (1) {
        my $line = _read_line($client);
        last unless defined $line;
        $line =~ s/\r?\n$//;
        last if $line eq '';

        if ($line =~ /^([^:]+):\s*(.*)$/) {
            my ($name, $value) = ($1, $2);
            # Normalize: lowercase, then convert to HTTP_* style
            $name = lc $name;
            $headers{$name} = $value;
        }
    }

    # Build $env
    my $server_name = $headers{'host'} || 'localhost';
    $server_name =~ s/:\d+$//;  # strip port from Host header

    # SERVER_PORT: prefer the port from Host header if present,
    # otherwise use the actual bound port passed from run().
    my $env_port = ($headers{'host'} && $headers{'host'} =~ /:(\d+)$/)
        ? int($1)
        : $server_port;

    my $content_length = $headers{'content-length'} || 0;
    $content_length = int($content_length);

    if ($content_length > $max_post_size) {
        _send_error($client, 413, 'Request Entity Too Large');
        return;
    }

    # Read POST body
    my $post_body = '';
    if ($method eq 'POST' && $content_length > 0) {
        read($client, $post_body, $content_length);
    }

    # Build psgi.input as an in-memory filehandle
    # For 5.5.3 compatibility, use a temp file approach via a simple object
    my $input = HTTP::Handy::Input->new($post_body);

    my %env = (
        'REQUEST_METHOD'  => $method,
        'PATH_INFO'       => $path,
        'QUERY_STRING'    => $query_string,
        'SERVER_NAME'     => $server_name,
        'SERVER_PORT'     => $env_port,
        'CONTENT_TYPE'    => $headers{'content-type'}   || '',
        'CONTENT_LENGTH'  => $content_length,
        'psgi.input'      => $input,
        'psgi.errors'     => \*STDERR,
        'psgi.url_scheme' => 'http',
    );

    # Add HTTP_* headers
    for my $name (keys %headers) {
        my $key = 'HTTP_' . uc($name);
        $key =~ s/-/_/g;
        $env{$key} = $headers{$name};
    }

    # Dispatch to app
    my $response;
    eval {
        $response = $app->(\%env);
    };
    if ($@) {
        my $err = $@;
        _log_message("App error: $err") if $log;
        _send_error($client, 500, 'Internal Server Error');
        return;
    }

    # Validate response
    unless (ref($response) eq 'ARRAY' && scalar(@$response) == 3) {
        _send_error($client, 500, 'Internal Server Error');
        return;
    }

    my ($status, $resp_headers, $body) = @$response;

    # Send response
    my $status_text = $STATUS_TEXT{$status} || 'Unknown';
    my $response_str = "HTTP/1.0 $status $status_text\r\n";
    $response_str .= "Connection: close\r\n";

    # Process response headers (flat array: key, value, key, value, ...)
    my @header_list;
    if (ref($resp_headers) eq 'ARRAY') {
        my @h = @$resp_headers;
        while (@h) {
            my $k = shift(@h) || '';
            my $v = shift(@h) || '';
            push @header_list, "$k: $v";
        }
    }
    $response_str .= join("\r\n", @header_list) . "\r\n" if @header_list;
    $response_str .= "\r\n";

    # Build body
    my $body_str = '';
    if (ref($body) eq 'ARRAY') {
        $body_str = join('', @$body) if @$body;
    }

    my $body_length = length($body_str);
    $response_str .= $body_str;

    print $client $response_str;

    # Access log in LTSV format.
    # Sanitize field values: LTSV forbids tab and newline characters in values.
    if ($log) {
        my $ts      = _iso_time();
        my $ua      = $headers{'user-agent'} || '';
        my $referer = $headers{'referer'}    || '';
        $ua      =~ s/[\t\n\r]/ /g;
        $referer =~ s/[\t\n\r]/ /g;
        my $line = join("\t",
            "time:$ts",
            "method:$method",
            "path:$path",
            "status:$status",
            "size:$body_length",
            "ua:$ua",
            "referer:$referer",
        ) . "\n";
        print STDERR $line;

        _open_access_log();
        if ($ACCESS_LOG_FH) { no strict 'refs'; print {*{$ACCESS_LOG_FH}} $line }
    }
}

###############################################################################
# _read_line - Read one line from socket (CR+LF or LF terminated)
###############################################################################
sub _read_line {
    my ($fh) = @_;
    my $line = '';
    my $char;
    while (read($fh, $char, 1)) {
        $line .= $char;
        last if $char eq "\n";
        # Safety limit: no header line should exceed 8KB
        return undef if length($line) > 8192;
    }
    return $line eq '' ? undef : $line;
}

###############################################################################
# _send_error - Send a simple HTTP error response
###############################################################################
sub _send_error {
    my ($client, $code, $message) = @_;
    my $text = $STATUS_TEXT{$code} || $message;
    my $body = "$code $text"
             . "$code $text$message"
             . "HTTP::Handy/$HTTP::Handy::VERSION";
    print $client "HTTP/1.0 $code $text\r\n";
    print $client "Content-Type: text/html\r\n";
    print $client "Content-Length: " . length($body) . "\r\n";
    print $client "Connection: close\r\n";
    print $client "\r\n";
    print $client $body;
}

###############################################################################
# _log_message - Print timestamped log to STDERR
###############################################################################
sub _log_message {
    my ($msg) = @_;

    my $ts = _iso_time();
    print STDERR "[$ts] $msg\n";

    $_fh_seq++;
    my $fhn = "HTTP::Handy::FH::H${_fh_seq}";
    { no strict 'refs'; open($fhn, ">> logs/error/error.log") or do { warn "HTTP::Handy: cannot open logs/error/error.log: $!"; return } }
    { no strict 'refs'; binmode(*{$fhn}) }
    { no strict 'refs'; print {*{$fhn}} "[$ts] $msg\n" }
    { no strict 'refs'; close($fhn) }
}

###############################################################################
# serve_static - Serve files from a document root
###############################################################################
sub serve_static {
    my ($class, $env, $docroot, %opts) = @_;

    $docroot ||= '.';
    # Remove trailing slash
    $docroot =~ s{[/\\]$}{};

    my $path = $env->{PATH_INFO} || '/';

    # Prevent path traversal via ".."
    if ($path =~ /\.\./) {
        return [403, ['Content-Type', 'text/plain'], ['Forbidden']];
    }

    # Normalize separators on Windows
    $path =~ s{\\}{/}g;

    # Strip leading slashes to prevent absolute path injection
    $path =~ s{^/+}{/};

    my $file = $docroot . $path;

    # Directory: strip trailing slash before -d check (Windows robustness),
    # then append index.html
    (my $file_check = $file) =~ s{/+$}{};
    if (-d $file_check) {
        $file = $file_check . '/index.html';
    }

    # Reject file names with unsafe characters (NUL, leading/trailing spaces,
    # or shell-special sequences that 2-arg open could misinterpret)
    if ($file =~ /\x00/ || $file =~ m{(?:^|\s)[|<>]|[|<>](?:\s|$)}) {
        return [403, ['Content-Type', 'text/plain'], ['Forbidden']];
    }

    unless (-f $file) {
        return [404, ['Content-Type', 'text/plain'], ['Not Found']];
    }

    # Determine MIME type from extension
    my $ext = '';
    if ($file =~ /\.([^.]+)$/) {
        $ext = lc $1;
    }
    my $mime = $MIME{$ext} || 'application/octet-stream';

    # Read file
    $_fh_seq++;
    my $fhn = "HTTP::Handy::FH::H${_fh_seq}";
    { no strict 'refs'; open($fhn, "< $file") or return [403, ['Content-Type', 'text/plain'], ['Forbidden']] }
    { no strict 'refs'; binmode(*{$fhn}) }
    local $/;
    my $content;
    { no strict 'refs'; $content = readline(*{$fhn}) }
    { no strict 'refs'; close($fhn) }

    # Cache-Control header
    my @cache_headers;
    if (exists $opts{cache_max_age}) {
        my $age = int($opts{cache_max_age});
        if ($age > 0) {
            push @cache_headers, 'Cache-Control', "public, max-age=$age";
        }
        else {
            push @cache_headers, 'Cache-Control', 'no-cache';
        }
    }
    else {
        # Default: no-cache (safe for development use)
        push @cache_headers, 'Cache-Control', 'no-cache';
    }

    return [200,
        ['Content-Type',   $mime,
         'Content-Length', length($content),
         @cache_headers],
        [$content]];
}

###############################################################################
# url_decode - Decode percent-encoded string
###############################################################################
sub url_decode {
    my ($class, $str) = @_;
    return '' unless defined $str;
    $str =~ s/\+/ /g;
    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    return $str;
}

###############################################################################
# parse_query - Parse query string into hash
###############################################################################
sub parse_query {
    my ($class, $query) = @_;
    return () unless defined $query && $query ne '';
    my %params;
    for my $pair (split /&/, $query) {
        my ($key, $val) = split /=/, $pair, 2;
        next unless defined $key;
        $key = $class->url_decode($key);
        $val = defined $val ? $class->url_decode($val) : '';
        if (exists $params{$key}) {
            if (ref $params{$key} eq 'ARRAY') {
                push @{$params{$key}}, $val;
            }
            else {
                $params{$key} = [$params{$key}, $val];
            }
        }
        else {
            $params{$key} = $val;
        }
    }
    return %params;
}

###############################################################################
# mime_type - Return MIME type for a file extension
###############################################################################
sub mime_type {
    my ($class, $ext) = @_;
    $ext = lc $ext;
    $ext =~ s/^\.//;
    return $MIME{$ext} || 'application/octet-stream';
}

###############################################################################
# is_htmx - Return true if the request was made by htmx
###############################################################################
sub is_htmx {
    my ($class, $env) = @_;
    return (defined $env->{HTTP_HX_REQUEST} && $env->{HTTP_HX_REQUEST} eq 'true') ? 1 : 0;
}

###############################################################################
# response_redirect - Build a redirect response
###############################################################################
sub response_redirect {
    my ($class, $location, $code) = @_;
    $code ||= 302;
    return [$code,
        ['Location',     $location,
         'Content-Type', 'text/plain'],
        ["Redirect to $location"]];
}

###############################################################################
# response_json - Build a JSON response (no JSON encoding, caller provides)
###############################################################################
sub response_json {
    my ($class, $json_str, $code) = @_;
    $code ||= 200;
    return [$code,
        ['Content-Type',   'application/json',
         'Content-Length', length($json_str)],
        [$json_str]];
}

###############################################################################
# response_html - Build an HTML response
###############################################################################
sub response_html {
    my ($class, $html, $code) = @_;
    $code ||= 200;
    return [$code,
        ['Content-Type',   'text/html; charset=utf-8',
         'Content-Length', length($html)],
        [$html]];
}

###############################################################################
# response_text - Build a plain text response
###############################################################################
sub response_text {
    my ($class, $text, $code) = @_;
    $code ||= 200;
    return [$code,
        ['Content-Type',   'text/plain; charset=utf-8',
         'Content-Length', length($text)],
        [$text]];
}

###############################################################################
# _init_directories - Create Apache-like directories
###############################################################################
sub _init_directories {
    for my $dir (qw(
        logs
        logs/access
        logs/error
        run
        htdocs
        conf
    )) {
        mkdir($dir, 0777) unless -d $dir;
    }
}

###############################################################################
# _open_access_log - Opens the access log file (YYYYMMDDHHm0.log.ltsv format)
###############################################################################
sub _open_access_log {
    my ($year, $month, $day, $hour, $min) = (localtime)[5, 4, 3, 2, 1];
    my $current_log_filename = sprintf("logs/access/%04d%02d%02d%02d%02d.log.ltsv",
        1900 + $year,
        $month + 1,
        $day,
        $hour,
        int($min / 10) * 10,
    );

    return if defined $ACCESS_LOG_FH && $current_log_filename eq $CURRENT_LOG_FILE;

    if ($ACCESS_LOG_FH) {
        no strict 'refs'; close($ACCESS_LOG_FH);
    }

    my $fh;
    $_fh_seq++;
    my $fhn = "HTTP::Handy::FH::H${_fh_seq}";
    { no strict 'refs'; open($fhn, ">> $current_log_filename") or do {
        warn "Cannot open access log: $current_log_filename: $!";
        return;
    } }
    { no strict 'refs'; binmode(*{$fhn}) }
    $fh = $fhn;

    { no strict 'refs'; select((select(*{$fhn}), $| = 1)[0]) } # autoflush

    $ACCESS_LOG_FH     = $fh;
    $CURRENT_LOG_FILE  = $current_log_filename;
}

###############################################################################
# _iso_time - Returns localtime as ISO style (YYYY-MM-DDTHH:mm:SS)
###############################################################################
sub _iso_time {
    my ($year, $month, $day, $hour, $min, $sec) = (localtime)[5, 4, 3, 2, 1, 0];
    return sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
        1900 + $year,
        $month + 1,
        $day,
        $hour,
        $min,
        $sec,
    );
}

# ----------------------------------------------------------------
# HTTP::Handy::Input - Minimal in-memory filehandle for psgi.input
# Compatible with Perl 5.5.3 (no open with scalar ref)
# ----------------------------------------------------------------
package HTTP::Handy::Input;

sub new {
    my ($class, $data) = @_;
    $data = '' unless defined $data;
    return bless { data => $data, pos => 0 }, $class;
}

sub read {
    # Note: $_[1] is the caller's buffer variable -- modified in place.
    # We do NOT include it in the my() list because:
    #   (a) we must write back via $_[1], not a copy, and
    #   (b) "my ($self, undef, $length)" requires Perl 5.10+.
    my $self   = $_[0];
    my $length = $_[2];
    my $offset = $_[3] || 0;
    my $remaining = length($self->{data}) - $self->{pos};
    $length = $remaining if $length > $remaining;
    return 0 if $length <= 0;
    my $chunk = substr($self->{data}, $self->{pos}, $length);
    $self->{pos} += $length;
    # Write into $_[1] at $offset (like POSIX read)
    substr($_[1], $offset) = $chunk;
    return $length;
}

sub seek {
    my ($self, $pos, $whence) = @_;
    $whence ||= 0;
    if ($whence == 0) {
        $self->{pos} = $pos;
    }
    elsif ($whence == 1) {
        $self->{pos} += $pos;
    }
    elsif ($whence == 2) {
        $self->{pos} = length($self->{data}) + $pos;
    }
    $self->{pos} = 0 if $self->{pos} < 0;
    return 1;
}

sub tell {
    my ($self) = @_;
    return $self->{pos};
}

sub getline {
    my ($self) = @_;
    return undef if $self->{pos} >= length($self->{data});
    my $nl = index($self->{data}, "\n", $self->{pos});
    my $line;
    if ($nl < 0) {
        $line = substr($self->{data}, $self->{pos});
        $self->{pos} = length($self->{data});
    }
    else {
        $line = substr($self->{data}, $self->{pos}, $nl - $self->{pos} + 1);
        $self->{pos} = $nl + 1;
    }
    return $line;
}

sub getlines {
    my ($self) = @_;
    my @lines;
    while (defined(my $line = $self->getline)) {
        push @lines, $line;
    }
    return @lines;
}

###############################################################################
# Back to main package -- demo/self-test when run directly
###############################################################################
package HTTP::Handy;

# Run as script: perl lib/HTTP/Handy.pm [port]
unless (caller) {
    my $port = $ARGV[0] || 8080;

    my $demo_app = sub {
        my $env = shift;
        my $method = $env->{REQUEST_METHOD};
        my $path   = $env->{PATH_INFO};
        my $query  = $env->{QUERY_STRING};

        # Route: GET /
        if ($method eq 'GET' && $path eq '/') {
            my $html = <<'HTML';


HTTP::Handy Demo
 </td>
</tr>

<tr>
<td  class="h" >
<a name="708">708</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   body { font-family: sans-serif; max-width: 600px; margin: 40px auto; padding: 0 20px; } </td>
</tr>

<tr>
<td  class="h" >
<a name="709">709</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   h1 { color: #336699; } </td>
</tr>

<tr>
<td  class="h" >
<a name="710">710</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   code { background: #f0f0f0; padding: 2px 6px; border-radius: 3px; } </td>
</tr>

<tr>
<td  class="h" >
<a name="711">711</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   form { margin: 20px 0; } </td>
</tr>

<tr>
<td  class="h" >
<a name="712">712</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   input, textarea { display: block; margin: 8px 0; padding: 6px; width: 100%; box-sizing: border-box; } </td>
</tr>

<tr>
<td  class="h" >
<a name="713">713</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">   button { padding: 8px 20px; background: #336699; color: white; border: none; cursor: pointer; } </td>
</tr>

<tr>
<td  class="h" >
<a name="714">714</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">


HTTP::Handy Demo
A tiny HTTP/1.0 server running on Perl 5.5.3+.
GET with query string


  Send GET

POST form



  Send POST

Server info


HTML
            return HTTP::Handy->response_html($html);
        }

        # Route: GET or POST /echo
        if ($path eq '/echo') {
            my %params;
            if ($method eq 'GET') {
                %params = HTTP::Handy->parse_query($query);
            }
            elsif ($method eq 'POST') {
                my $body = '';
                $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH} || 0);
                %params = HTTP::Handy->parse_query($body);
            }

            my $params_html = '';
            for my $key (sort keys %params) {
                my $val = $params{$key};
                $val = ref($val) eq 'ARRAY' ? join(', ', @$val) : $val;
                # simple HTML escape
                $val =~ s/&/&/g;
                $val =~ s/
                $val =~ s/>/>/g;
                $key =~ s/&/&/g;
                $key =~ s/
                $params_html .= "
            }
            $params_html ||= '

            my $html = <<"HTML";

Echo
body{font-family:sans-serif;max-width:600px;margin:40px auto;padding:0 20px} </td>
</tr>

<tr>
<td  class="h" >
<a name="767">767</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> table{border-collapse:collapse;width:100%}td{padding:6px 10px;border:1px solid #ccc} </td>
</tr>

<tr>
<td  class="h" >
<a name="768">768</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">

Echo: $method $path
$params_html
Back

HTML
            return HTTP::Handy->response_html($html);
        }

        # Route: GET /info
        if ($method eq 'GET' && $path eq '/info') {
            my $env_html = '';
            for my $key (sort keys %$env) {
                next if $key eq 'psgi.input' || $key eq 'psgi.errors';
                my $val = $env->{$key};
                $val = '' unless defined $val;
                $val =~ s/&/&/g;
                $val =~ s/
                $env_html .= "
            }
            my $html = <<"HTML";

Server Info
body{font-family:sans-serif;max-width:700px;margin:40px auto;padding:0 20px} </td>
</tr>

<tr>
<td  class="h" >
<a name="793">793</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> table{border-collapse:collapse;width:100%}td{padding:4px 8px;border:1px solid #ddd;font-size:13px} </td>
</tr>

<tr>
<td  class="h" >
<a name="794">794</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s"> tr:nth-child(even){background:#f8f8f8}code{font-size:12px} </td>
</tr>

<tr>
<td  class="h" >
<a name="795">795</a>
</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td >

&nbsp;

</td>

<td class="s">

PSGI Environment
$env_html
Back

HTML
            return HTTP::Handy->response_html($html);
        }

        # 404 fallback
        return [404,
            ['Content-Type', 'text/html'],
            ["404 Not Found$pathHome"]];
    };

    HTTP::Handy->run(app => $demo_app, port => $port);
}

1;

__END__