File Coverage

blib/lib/HTTP/Handy.pm
Criterion Covered Total %
statement 123 254 48.4
branch 37 120 30.8
condition 21 62 33.8
subroutine 23 28 82.1
pod 10 10 100.0
total 214 474 45.1


"; '; ";
line stmt bran cond sub pod time code
1             package HTTP::Handy;
2             ######################################################################
3             #
4             # HTTP::Handy - A tiny HTTP/1.0 server for Perl 5.5.3+
5             #
6             # https://metacpan.org/dist/HTTP-Handy
7             #
8             # Copyright (c) 2026 INABA Hitoshi
9             ######################################################################
10              
11 5     5   292900 use 5.00503; # Universal Consensus 1998 for primetools
  5         22  
12             # Perl 5.005_03 compatibility for historical toolchains
13             # use 5.008001; # Lancaster Consensus 2013 for toolchains
14              
15             $VERSION = '1.00';
16             $VERSION = $VERSION;
17             # VERSION policy: avoid `our` for 5.005_03 compatibility.
18             # Self-assignment prevents "used only once" warning under `use strict`.
19              
20 5 50   5   167 BEGIN { pop @INC if $INC[-1] eq '.' } # CVE-2016-1238: Important unsafe module load path flaw
21 5     5   37 use strict;
  5         14  
  5         369  
22 5 50   5   182 BEGIN { if ($] < 5.006) { $INC{'warnings.pm'} = 'stub'; eval 'package warnings; sub import {}' } } use warnings; local $^W=1;
  0     5   0  
  0         0  
  5         30  
  5         8  
  5         448  
23             # warnings.pm compatibility: stub with import() for Perl < 5.6
24              
25 5     5   3198 use IO::Socket;
  5         148537  
  5         29  
26 5     5   7752 use POSIX qw(strftime);
  5         43864  
  5         31  
27 5     5   9487 use Carp qw(croak);
  5         13  
  5         28478  
28              
29             # ----------------------------------------------------------------
30             # Status text map
31             # ----------------------------------------------------------------
32             my %STATUS_TEXT = (
33             200 => 'OK',
34             201 => 'Created',
35             204 => 'No Content',
36             301 => 'Moved Permanently',
37             302 => 'Found',
38             304 => 'Not Modified',
39             400 => 'Bad Request',
40             403 => 'Forbidden',
41             404 => 'Not Found',
42             405 => 'Method Not Allowed',
43             413 => 'Request Entity Too Large',
44             500 => 'Internal Server Error',
45             );
46              
47             # ----------------------------------------------------------------
48             # MIME type map
49             # ----------------------------------------------------------------
50             my %MIME = (
51             'html' => 'text/html; charset=utf-8',
52             'htm' => 'text/html; charset=utf-8',
53             'txt' => 'text/plain; charset=utf-8',
54             'text' => 'text/plain; charset=utf-8',
55             'css' => 'text/css',
56             'js' => 'application/javascript',
57             'json' => 'application/json',
58             'xml' => 'application/xml',
59             'png' => 'image/png',
60             'jpg' => 'image/jpeg',
61             'jpeg' => 'image/jpeg',
62             'gif' => 'image/gif',
63             'ico' => 'image/x-icon',
64             'svg' => 'image/svg+xml',
65             'pdf' => 'application/pdf',
66             'zip' => 'application/zip',
67             'gz' => 'application/gzip',
68             'ltsv' => 'text/plain; charset=utf-8',
69             'csv' => 'text/csv; charset=utf-8',
70             'tsv' => 'text/tab-separated-values; charset=utf-8',
71             );
72              
73             # Default max POST body size: 10MB
74             my $DEFAULT_MAX_POST_SIZE = 10 * 1024 * 1024;
75              
76             # ----------------------------------------------------------------
77             # run - Start the server (blocking)
78             # ----------------------------------------------------------------
79             sub run {
80 0     0 1 0 my ($class, %args) = @_;
81              
82 0 0       0 my $app = $args{app} or croak "HTTP::Handy->run: 'app' is required";
83 0 0       0 my $host = defined $args{host} ? $args{host} : '0.0.0.0';
84 0 0       0 my $port = defined $args{port} ? $args{port} : 8080;
85 0 0       0 my $log = defined $args{log} ? $args{log} : 1;
86 0 0       0 my $max_post_size = defined $args{max_post_size} ? $args{max_post_size} : $DEFAULT_MAX_POST_SIZE;
87              
88 0 0       0 ref($app) eq 'CODE' or croak "HTTP::Handy->run: 'app' must be a code reference";
89 0 0       0 $port =~ /^\d+$/ or croak "HTTP::Handy->run: 'port' must be a number";
90 0 0       0 $max_post_size =~ /^\d+$/ or croak "HTTP::Handy->run: 'max_post_size' must be a number";
91              
92 0         0 my $server = IO::Socket::INET->new(
93             LocalAddr => $host,
94             LocalPort => $port,
95             Proto => 'tcp',
96             Listen => 10,
97             ReuseAddr => 1,
98             );
99 0 0       0 unless ($server) {
100 0         0 croak "HTTP::Handy: Cannot bind to $host:$port - $@";
101             }
102              
103 0 0       0 _log_message("HTTP::Handy $HTTP::Handy::VERSION started on http://$host:$port/") if $log;
104 0 0       0 _log_message("Press Ctrl+C to stop.") if $log;
105              
106 0         0 while (1) {
107 0         0 my $client = $server->accept;
108 0 0       0 unless ($client) {
109 0 0       0 _log_message("Accept failed: $!") if $log;
110 0         0 next;
111             }
112              
113             # Disable CRLF translation on Windows
114 0         0 binmode $client;
115              
116 0         0 eval {
117 0         0 _handle_connection($client, $app, $log, $max_post_size, $port);
118             };
119 0 0       0 if ($@) {
120 0 0       0 _log_message("Error handling connection: $@") if $log;
121             }
122              
123 0         0 close $client;
124             }
125             }
126              
127             # ----------------------------------------------------------------
128             # _handle_connection - Parse request and dispatch to app
129             # ----------------------------------------------------------------
130             sub _handle_connection {
131 0     0   0 my ($client, $app, $log, $max_post_size, $server_port) = @_;
132              
133             # Read request line
134 0         0 my $request_line = _read_line($client);
135 0 0 0     0 return unless defined $request_line && $request_line ne '';
136              
137 0         0 $request_line =~ s/\r?\n$//;
138              
139 0         0 my ($method, $request_uri, $http_version) = split /\s+/, $request_line, 3;
140              
141             # Only allow GET and POST
142 0 0 0     0 unless (defined $method && ($method eq 'GET' || $method eq 'POST')) {
      0        
143 0         0 _send_error($client, 405, 'Method Not Allowed');
144 0         0 return;
145             }
146              
147             # Parse URI into path and query
148 0         0 my ($path, $query_string) = ('/', '');
149 0 0       0 if (defined $request_uri) {
150 0 0       0 if ($request_uri =~ /^([^?]*)\?(.*)$/) {
151 0         0 $path = $1;
152 0         0 $query_string = $2;
153             }
154             else {
155 0         0 $path = $request_uri;
156             }
157             }
158 0 0 0     0 $path = '/' unless defined $path && $path ne '';
159              
160             # Read headers
161 0         0 my %headers;
162 0         0 while (1) {
163 0         0 my $line = _read_line($client);
164 0 0       0 last unless defined $line;
165 0         0 $line =~ s/\r?\n$//;
166 0 0       0 last if $line eq '';
167              
168 0 0       0 if ($line =~ /^([^:]+):\s*(.*)$/) {
169 0         0 my ($name, $value) = ($1, $2);
170             # Normalize: lowercase, then convert to HTTP_* style
171 0         0 $name = lc $name;
172 0         0 $headers{$name} = $value;
173             }
174             }
175              
176             # Build $env
177 0   0     0 my $server_name = $headers{'host'} || 'localhost';
178 0         0 $server_name =~ s/:\d+$//; # strip port from Host header
179              
180             # SERVER_PORT: prefer the port from Host header if present,
181             # otherwise use the actual bound port passed from run().
182 0 0 0     0 my $env_port = ($headers{'host'} && $headers{'host'} =~ /:(\d+)$/)
183             ? int($1)
184             : $server_port;
185              
186 0   0     0 my $content_length = $headers{'content-length'} || 0;
187 0         0 $content_length = int($content_length);
188              
189 0 0       0 if ($content_length > $max_post_size) {
190 0         0 _send_error($client, 413, 'Request Entity Too Large');
191 0         0 return;
192             }
193              
194             # Read POST body
195 0         0 my $post_body = '';
196 0 0 0     0 if ($method eq 'POST' && $content_length > 0) {
197 0         0 read($client, $post_body, $content_length);
198             }
199              
200             # Build psgi.input as an in-memory filehandle
201             # For 5.5.3 compatibility, use a temp file approach via a simple object
202 0         0 my $input = HTTP::Handy::Input->new($post_body);
203              
204             my %env = (
205             'REQUEST_METHOD' => $method,
206             'PATH_INFO' => $path,
207             'QUERY_STRING' => $query_string,
208             'SERVER_NAME' => $server_name,
209             'SERVER_PORT' => $env_port,
210 0   0     0 'CONTENT_TYPE' => $headers{'content-type'} || '',
211             'CONTENT_LENGTH' => $content_length,
212             'psgi.input' => $input,
213             'psgi.errors' => \*STDERR,
214             'psgi.url_scheme' => 'http',
215             );
216              
217             # Add HTTP_* headers
218 0         0 for my $name (keys %headers) {
219 0         0 my $key = 'HTTP_' . uc($name);
220 0         0 $key =~ s/-/_/g;
221 0         0 $env{$key} = $headers{$name};
222             }
223              
224             # Dispatch to app
225 0         0 my $response;
226 0         0 eval {
227 0         0 $response = $app->(\%env);
228             };
229 0 0       0 if ($@) {
230 0         0 my $err = $@;
231 0         0 _log_message("App error: $err");
232 0         0 _send_error($client, 500, 'Internal Server Error');
233 0         0 return;
234             }
235              
236             # Validate response
237 0 0 0     0 unless (ref($response) eq 'ARRAY' && scalar(@$response) == 3) {
238 0         0 _send_error($client, 500, 'Internal Server Error');
239 0         0 return;
240             }
241              
242 0         0 my ($status, $resp_headers, $body) = @$response;
243              
244             # Send response
245 0   0     0 my $status_text = $STATUS_TEXT{$status} || 'Unknown';
246 0         0 my $response_str = "HTTP/1.0 $status $status_text\r\n";
247 0         0 $response_str .= "Connection: close\r\n";
248              
249             # Process response headers (flat array: key, value, key, value, ...)
250 0         0 my @header_list;
251 0 0       0 if (ref($resp_headers) eq 'ARRAY') {
252 0         0 my @h = @$resp_headers;
253 0         0 while (@h) {
254 0         0 my $k = shift @h;
255 0         0 my $v = shift @h;
256 0         0 push @header_list, "$k: $v";
257             }
258             }
259 0 0       0 $response_str .= join("\r\n", @header_list) . "\r\n" if @header_list;
260 0         0 $response_str .= "\r\n";
261              
262             # Build body
263 0         0 my $body_str = '';
264 0 0       0 if (ref($body) eq 'ARRAY') {
265 0         0 $body_str = join('', @$body);
266             }
267              
268 0         0 my $body_length = length($body_str);
269 0         0 $response_str .= $body_str;
270              
271 0         0 print $client $response_str;
272              
273             # Access log in LTSV format.
274             # Sanitize field values: LTSV forbids tab and newline characters in values.
275 0 0       0 if ($log) {
276 0         0 my $ts = strftime('%Y-%m-%dT%H:%M:%S', localtime);
277 0   0     0 my $ua = $headers{'user-agent'} || '';
278 0   0     0 my $referer = $headers{'referer'} || '';
279 0         0 $ua =~ s/[\t\n\r]/ /g;
280 0         0 $referer =~ s/[\t\n\r]/ /g;
281 0         0 print STDERR join("\t",
282             "time:$ts",
283             "method:$method",
284             "path:$path",
285             "status:$status",
286             "size:$body_length",
287             "ua:$ua",
288             "referer:$referer",
289             ) . "\n";
290             }
291             }
292              
293             # ----------------------------------------------------------------
294             # _read_line - Read one line from socket (CR+LF or LF terminated)
295             # ----------------------------------------------------------------
296             sub _read_line {
297 0     0   0 my ($fh) = @_;
298 0         0 my $line = '';
299 0         0 my $char;
300 0         0 while (read($fh, $char, 1)) {
301 0         0 $line .= $char;
302 0 0       0 last if $char eq "\n";
303             # Safety limit: no header line should exceed 8KB
304 0 0       0 return undef if length($line) > 8192;
305             }
306 0 0       0 return $line eq '' ? undef : $line;
307             }
308              
309             # ----------------------------------------------------------------
310             # _send_error - Send a simple HTTP error response
311             # ----------------------------------------------------------------
312             sub _send_error {
313 0     0   0 my ($client, $code, $message) = @_;
314 0   0     0 my $text = $STATUS_TEXT{$code} || $message;
315 0         0 my $body = "$code $text"
316             . "

$code $text

$message

"
317             . "
HTTP::Handy/$HTTP::Handy::VERSION";
318 0         0 print $client "HTTP/1.0 $code $text\r\n";
319 0         0 print $client "Content-Type: text/html\r\n";
320 0         0 print $client "Content-Length: " . length($body) . "\r\n";
321 0         0 print $client "Connection: close\r\n";
322 0         0 print $client "\r\n";
323 0         0 print $client $body;
324             }
325              
326             # ----------------------------------------------------------------
327             # _log_message - Print timestamped log to STDERR
328             # ----------------------------------------------------------------
329             sub _log_message {
330 0     0   0 my ($msg) = @_;
331 0         0 my $ts = strftime('%Y-%m-%d %H:%M:%S', localtime);
332 0         0 print STDERR "[$ts] $msg\n";
333             }
334              
335             # ----------------------------------------------------------------
336             # serve_static - Serve files from a document root
337             # ----------------------------------------------------------------
338             sub serve_static {
339 20     20 1 244826 my ($class, $env, $docroot, %opts) = @_;
340              
341 20   100     82 $docroot ||= '.';
342             # Remove trailing slash
343 20         139 $docroot =~ s{[/\\]$}{};
344              
345 20   50     114 my $path = $env->{PATH_INFO} || '/';
346              
347             # Prevent path traversal via ".."
348 20 100       87 if ($path =~ /\.\./) {
349 3         22 return [403, ['Content-Type', 'text/plain'], ['Forbidden']];
350             }
351              
352             # Normalize separators on Windows
353 17         51 $path =~ s{\\}{/}g;
354              
355             # Strip leading slashes to prevent absolute path injection
356 17         102 $path =~ s{^/+}{/};
357              
358 17         44 my $file = $docroot . $path;
359              
360             # Directory: try index.html
361 17 100       418 if (-d $file) {
362 2         12 $file =~ s{/?$}{/index.html};
363             }
364              
365 17 100       331 unless (-f $file) {
366 2         20 return [404, ['Content-Type', 'text/plain'], ['Not Found']];
367             }
368              
369             # Determine MIME type from extension
370 15         55 my $ext = '';
371 15 50       110 if ($file =~ /\.([^.]+)$/) {
372 15         81 $ext = lc $1;
373             }
374 15   100     57 my $mime = $MIME{$ext} || 'application/octet-stream';
375              
376             # Read file
377 15         69 local *FH;
378 15 50       1193 unless (open FH, "<$file") {
379 0         0 return [403, ['Content-Type', 'text/plain'], ['Forbidden']];
380             }
381 15         65 binmode FH;
382 15         82 local $/;
383 15         547 my $content = ;
384 15         227 close FH;
385              
386             # Cache-Control header
387 15         65 my @cache_headers;
388 15 100       54 if (exists $opts{cache_max_age}) {
389 3         26 my $age = int($opts{cache_max_age});
390 3 100       20 if ($age > 0) {
391 2         17 push @cache_headers, 'Cache-Control', "public, max-age=$age";
392             }
393             else {
394 1         14 push @cache_headers, 'Cache-Control', 'no-cache';
395             }
396             }
397             else {
398             # Default: no-cache (safe for development use)
399 12         50 push @cache_headers, 'Cache-Control', 'no-cache';
400             }
401              
402 15         251 return [200,
403             ['Content-Type', $mime,
404             'Content-Length', length($content),
405             @cache_headers],
406             [$content]];
407             }
408              
409             # ----------------------------------------------------------------
410             # url_decode - Decode percent-encoded string
411             # ----------------------------------------------------------------
412             sub url_decode {
413 29     29 1 134869 my ($class, $str) = @_;
414 29 100       38 return '' unless defined $str;
415 28         32 $str =~ s/\+/ /g;
416 28         35 $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
  10         18  
417 28         47 return $str;
418             }
419              
420             # ----------------------------------------------------------------
421             # parse_query - Parse query string into hash
422             # ----------------------------------------------------------------
423             sub parse_query {
424 8     8 1 104 my ($class, $query) = @_;
425 8 100 100     22 return () unless defined $query && $query ne '';
426 6         5 my %params;
427 6         24 for my $pair (split /&/, $query) {
428 10         15 my ($key, $val) = split /=/, $pair, 2;
429 10 50       14 next unless defined $key;
430 10         11 $key = $class->url_decode($key);
431 10 100       14 $val = defined $val ? $class->url_decode($val) : '';
432 10 100       11 if (exists $params{$key}) {
433 2 100       4 if (ref $params{$key} eq 'ARRAY') {
434 1         2 push @{$params{$key}}, $val;
  1         3  
435             }
436             else {
437 1         3 $params{$key} = [$params{$key}, $val];
438             }
439             }
440             else {
441 8         14 $params{$key} = $val;
442             }
443             }
444 6         31 return %params;
445             }
446              
447             # ----------------------------------------------------------------
448             # mime_type - Return MIME type for a file extension
449             # ----------------------------------------------------------------
450             sub mime_type {
451 11     11 1 21 my ($class, $ext) = @_;
452 11         8 $ext = lc $ext;
453 11         12 $ext =~ s/^\.//;
454 11   100     35 return $MIME{$ext} || 'application/octet-stream';
455             }
456              
457             # ----------------------------------------------------------------
458             # is_htmx - Return true if the request was made by htmx
459             # ----------------------------------------------------------------
460             sub is_htmx {
461 5     5 1 12 my ($class, $env) = @_;
462 5 100 100     16 return (defined $env->{HTTP_HX_REQUEST} && $env->{HTTP_HX_REQUEST} eq 'true') ? 1 : 0;
463             }
464              
465             # ----------------------------------------------------------------
466             # response_redirect - Build a redirect response
467             # ----------------------------------------------------------------
468             sub response_redirect {
469 2     2 1 33 my ($class, $location, $code) = @_;
470 2   100     12 $code ||= 302;
471 2         8 return [$code,
472             ['Location', $location,
473             'Content-Type', 'text/plain'],
474             ["Redirect to $location"]];
475             }
476              
477             # ----------------------------------------------------------------
478             # response_json - Build a JSON response (no JSON encoding, caller provides)
479             # ----------------------------------------------------------------
480             sub response_json {
481 1     1 1 27 my ($class, $json_str, $code) = @_;
482 1   50     3 $code ||= 200;
483 1         3 return [$code,
484             ['Content-Type', 'application/json',
485             'Content-Length', length($json_str)],
486             [$json_str]];
487             }
488              
489             # ----------------------------------------------------------------
490             # response_html - Build an HTML response
491             # ----------------------------------------------------------------
492             sub response_html {
493 2     2 1 38 my ($class, $html, $code) = @_;
494 2   100     6 $code ||= 200;
495 2         7 return [$code,
496             ['Content-Type', 'text/html; charset=utf-8',
497             'Content-Length', length($html)],
498             [$html]];
499             }
500              
501             # ----------------------------------------------------------------
502             # response_text - Build a plain text response
503             # ----------------------------------------------------------------
504             sub response_text {
505 1     1 1 9 my ($class, $text, $code) = @_;
506 1   50     4 $code ||= 200;
507 1         3 return [$code,
508             ['Content-Type', 'text/plain; charset=utf-8',
509             'Content-Length', length($text)],
510             [$text]];
511             }
512              
513             # ----------------------------------------------------------------
514             # HTTP::Handy::Input - Minimal in-memory filehandle for psgi.input
515             # Compatible with Perl 5.5.3 (no open with scalar ref)
516             # ----------------------------------------------------------------
517             package HTTP::Handy::Input;
518              
519             sub new {
520 2     2   30 my ($class, $data) = @_;
521 2 50       5 $data = '' unless defined $data;
522 2         7 return bless { data => $data, pos => 0 }, $class;
523             }
524              
525             sub read {
526             # Note: $_[1] is the caller's buffer variable -- modified in place.
527             # We do NOT include it in the my() list because:
528             # (a) we must write back via $_[1], not a copy, and
529             # (b) "my ($self, undef, $length)" requires Perl 5.10+.
530 2     2   8 my $self = $_[0];
531 2         2 my $length = $_[2];
532 2   50     4 my $offset = $_[3] || 0;
533 2         8 my $remaining = length($self->{data}) - $self->{pos};
534 2 100       3 $length = $remaining if $length > $remaining;
535 2 100       5 return 0 if $length <= 0;
536 1         2 my $chunk = substr($self->{data}, $self->{pos}, $length);
537 1         2 $self->{pos} += $length;
538             # Write into $_[1] at $offset (like POSIX read)
539 1         2 substr($_[1], $offset) = $chunk;
540 1         2 return $length;
541             }
542              
543             sub seek {
544 2     2   8 my ($self, $pos, $whence) = @_;
545 2   50     6 $whence ||= 0;
546 2 50       5 if ($whence == 0) {
    0          
    0          
547 2         3 $self->{pos} = $pos;
548             }
549             elsif ($whence == 1) {
550 0         0 $self->{pos} += $pos;
551             }
552             elsif ($whence == 2) {
553 0         0 $self->{pos} = length($self->{data}) + $pos;
554             }
555 2 50       4 $self->{pos} = 0 if $self->{pos} < 0;
556 2         13 return 1;
557             }
558              
559             sub tell {
560 2     2   17 my ($self) = @_;
561 2         5 return $self->{pos};
562             }
563              
564             sub getline {
565 7     7   31 my ($self) = @_;
566 7 100       16 return undef if $self->{pos} >= length($self->{data});
567 4         13 my $nl = index($self->{data}, "\n", $self->{pos});
568 4         4 my $line;
569 4 50       6 if ($nl < 0) {
570 0         0 $line = substr($self->{data}, $self->{pos});
571 0         0 $self->{pos} = length($self->{data});
572             }
573             else {
574 4         8 $line = substr($self->{data}, $self->{pos}, $nl - $self->{pos} + 1);
575 4         5 $self->{pos} = $nl + 1;
576             }
577 4         7 return $line;
578             }
579              
580             sub getlines {
581 1     1   4 my ($self) = @_;
582 1         1 my @lines;
583 1         2 while (defined(my $line = $self->getline)) {
584 2         5 push @lines, $line;
585             }
586 1         4 return @lines;
587             }
588              
589             # ----------------------------------------------------------------
590             # Back to main package -- demo/self-test when run directly
591             # ----------------------------------------------------------------
592             package HTTP::Handy;
593              
594             # Run as script: perl HTTP::Handy.pm [port]
595             unless (caller) {
596             my $port = $ARGV[0] || 8080;
597              
598             my $demo_app = sub {
599             my $env = shift;
600             my $method = $env->{REQUEST_METHOD};
601             my $path = $env->{PATH_INFO};
602             my $query = $env->{QUERY_STRING};
603              
604             # Route: GET /
605             if ($method eq 'GET' && $path eq '/') {
606             my $html = <<'HTML';
607            
608            
609             HTTP::Handy Demo
610            
618            
619            
620            

HTTP::Handy Demo

621            

A tiny HTTP/1.0 server running on Perl 5.5.3+.

622            

GET with query string

623            
624            
625            
626            
627            

POST form

628            
629            
630            
631            
632            
633            

Server info

634            
635            
636             HTML
637             return HTTP::Handy->response_html($html);
638             }
639              
640             # Route: GET or POST /echo
641             if ($path eq '/echo') {
642             my %params;
643             if ($method eq 'GET') {
644             %params = HTTP::Handy->parse_query($query);
645             }
646             elsif ($method eq 'POST') {
647             my $body = '';
648             $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH} || 0);
649             %params = HTTP::Handy->parse_query($body);
650             }
651              
652             my $params_html = '';
653             for my $key (sort keys %params) {
654             my $val = $params{$key};
655             $val = ref($val) eq 'ARRAY' ? join(', ', @$val) : $val;
656             # simple HTML escape
657             $val =~ s/&/&/g;
658             $val =~ s/
659             $val =~ s/>/>/g;
660             $key =~ s/&/&/g;
661             $key =~ s/
662             $params_html .= "
$key$val
663             }
664             $params_html ||= '
(no parameters)
665              
666             my $html = <<"HTML";
667            
668             Echo
669            
672            
673            

Echo: $method $path

674             $params_html
675            

Back

676            
677             HTML
678             return HTTP::Handy->response_html($html);
679             }
680              
681             # Route: GET /info
682             if ($method eq 'GET' && $path eq '/info') {
683             my $env_html = '';
684             for my $key (sort keys %$env) {
685             next if $key eq 'psgi.input' || $key eq 'psgi.errors';
686             my $val = $env->{$key};
687             $val = '' unless defined $val;
688             $val =~ s/&/&/g;
689             $val =~ s/
690             $env_html .= "
$key$val
691             }
692             my $html = <<"HTML";
693            
694             Server Info
695            
699            
700            

PSGI Environment

701             $env_html
702            

Back

703            
704             HTML
705             return HTTP::Handy->response_html($html);
706             }
707              
708             # 404 fallback
709             return [404,
710             ['Content-Type', 'text/html'],
711             ["

404 Not Found

$path

Home"]];
712             };
713              
714             HTTP::Handy->run(app => $demo_app, port => $port);
715             }
716              
717             1;
718              
719             __END__