| 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 = " |
||||
| 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 | |
||||||
| 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 | |||||||
| 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/</g; | ||||||
| 659 | $val =~ s/>/>/g; | ||||||
| 660 | $key =~ s/&/&/g; | ||||||
| 661 | $key =~ s/</g; | ||||||
| 662 | $params_html .= " | ||||||
| $key | $val | ||||||
| 663 | } | ||||||
| 664 | $params_html ||= ' | ||||||
| (no parameters) | |||||||
| 665 | |||||||
| 666 | my $html = <<"HTML"; | ||||||
| 667 | |||||||
| 668 | |
||||||
| 669 | |||||||
| 672 | |||||||
| 673 | Echo: $method $path |
||||||
| 674 | |
||||||
| 675 | |||||||
| 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/</g; | ||||||
| 690 | $env_html .= " | ||||||
$key | $val | ||||||
| 691 | } | ||||||
| 692 | my $html = <<"HTML"; | ||||||
| 693 | |||||||
| 694 | |
||||||
| 695 | |||||||
| 699 | |||||||
| 700 | PSGI Environment |
||||||
| 701 | |
||||||
| 702 | |||||||
| 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__ | ||||||