From 2875a265a92cd8bd6506a8ad09376188c08773a7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?K=C5=8Dan?= Date: Wed, 3 Jun 2026 03:13:29 +0000 Subject: [PATCH] Fix parse_ranges and serve stat-before-open; add CLAUDE.md and tests MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Two bugs fixed in lib/TPSGI.pm: 1. parse_ranges: `my $range = val if cond` is Perl UB — when the condition is false, $range retains the value from the previous call rather than being reset to undef. On keepalive connections, a request without Range headers after one that had them would incorrectly return stale ranges. Fixed with an explicit if/else. 2. serve: stat($path) was called before open(), so when the file doesn't exist or can't be opened, $mt and $sz are undef — triggering warnings in gmtime() and the numeric comparison. Moved stat inside the open block, stat-ing the filehandle ($fh) instead of the path. Also adds: - CLAUDE.md: project orientation for agent sessions - t/lib/TPSGITestStubs.pm: stub loader for missing CPAN deps in test env - t/04-parse-ranges.t: 8 tests including stale-variable regression - t/05-serve.t: 7 tests for static file serving (200/304/403/streaming) - t/06-route-and-query.t: 19 tests for route dispatch, extract_query, HTTP error helpers, and redirect methods --- CLAUDE.md | 83 ++++++++++ lib/TPSGI.pm | 22 +-- t/04-parse-ranges.t | 86 +++++++++++ t/05-serve.t | 158 +++++++++++++++++++ t/06-route-and-query.t | 330 ++++++++++++++++++++++++++++++++++++++++ t/lib/TPSGITestStubs.pm | 142 +++++++++++++++++ 6 files changed, 812 insertions(+), 9 deletions(-) create mode 100644 CLAUDE.md create mode 100644 t/04-parse-ranges.t create mode 100644 t/05-serve.t create mode 100644 t/06-route-and-query.t create mode 100644 t/lib/TPSGITestStubs.pm diff --git a/CLAUDE.md b/CLAUDE.md new file mode 100644 index 0000000..0dd583e --- /dev/null +++ b/CLAUDE.md @@ -0,0 +1,83 @@ +# CLAUDE.md — tPSGI + +## Project overview + +tPSGI is a PSGI server wrapper built around Starman. It bridges legacy CGI/mod_perl +applications onto PSGI, and powers tCMS. Key features: static file serving, CGI +execution, custom route dispatch, gzip compression, byte-range streaming, hot-reload +via inotify. + +## Architecture + +Two processes: + +- **`bin/tarbaby`** — master Starman process. Uses only `TPSGI::Startup` (minimal + deps). Sets up inotify watches for hot-reload before forking workers. +- **`bin/tpsgi`** — PSGI app file loaded by each Starman worker. Creates a `TPSGI` + object per request, dispatches to routes or static files. + +Key modules: + +- **`lib/TPSGI.pm`** — main library. Route dispatch, static serving, CGI execution, + multipart range responses, gzip, post-close callbacks. +- **`lib/TPSGI/Startup.pm`** — lightweight module for `get_config()` and + `watch_for_changes()`. Loaded only by tarbaby to avoid restart on TPSGI.pm changes. + +## Routes + +Routes live in flat paired arrays: `[pattern1, handler1, pattern2, handler2, ...]`. +Patterns at **even** indices, handler hashrefs at **odd** indices. Exact match is +tried first; then regex match. + +When writing code that iterates the route array, always restrict to even indices: + +```perl +my @pat_idx = grep { !($_ % 2) } 0 .. $#$r; +``` + +## Configuration + +`~/.tpsgi.ini` in `[default]` block (Config::Simple key=value format). Fields: +`verbose`, `custom_log`, `routers`, `loggers`, `auth`, `domain`, `user`, +`http_user`, `autoreload`, `basedir`, `binds`, `tpsgi_dir`. + +## Running tests + +Tests require the local `perl5` lib in scope. Either: + +```bash +eval $(perl -I$HOME/perl5/lib/perl5 -Mlocal::lib) +prove -Ilib t/ +``` + +Or directly: + +```bash +PERLBASE=$HOME/perl5/lib/perl5 +perl -I$PERLBASE -I$PERLBASE/x86_64-linux-gnu-thread-multi -Ilib t/01-startup.t +``` + +Tests use `t/lib/TPSGITestStubs.pm` to stub missing CPAN deps. Stubs prefer real +modules when loadable; they only activate when the real module is absent. + +## Key patterns + +- `TPSGI->new()` validates the running user matches `options{user}`. Tests bypass + this by blessing a raw hashref: `bless { user => ..., ... }, 'TPSGI'`. +- `bin/tarbaby` must NOT `use TPSGI` directly — only `use TPSGI::Startup`. This + keeps the master process isolated from TPSGI.pm changes. +- NYTProf: only load via `require Devel::NYTProf` guarded by `if ($ENV{NYTPROF})`. + Never set `$ENV{NYTPROF}` unconditionally before `require`. +- Multipart range terminator: `"\n--$CHUNK_SEP--\n"` — the `--` is literal, not + an escape. In Perl double-quoted strings `\-` is a backslash, not a dash. +- `HTTP::Body` must be declared with `use HTTP::Body` — it does not load + transitively from Plack in all configurations. +- `parse_ranges` and `extract_query`: never use `my $x = expr if cond` — the + variable retains its value from previous calls when the condition is false + (Perl UB). Always use an explicit `if`/`else` or ternary. +- `stream_raw_psgi`: iterate `@{$response->[2]}` for the body — not just `[0]`. + +## Commit conventions + +Plain English imperative: "Fix multipart boundary", "Add test suite", etc. +No ticket prefix. Keep under 72 chars. diff --git a/lib/TPSGI.pm b/lib/TPSGI.pm index c23a3e4..e65c1bd 100755 --- a/lib/TPSGI.pm +++ b/lib/TPSGI.pm @@ -317,16 +317,17 @@ sub serve { push( @headers, 'Accept-Ranges' => 'bytes' ); $self->DEBUG("FETCH $path"); - my $mt = ( stat($path) )[9]; - my $sz = ( stat(_) )[7]; - my @gm = gmtime($mt); - my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm ); - my $code = $mt > $last_fetch ? 200 : 304; - - push( @headers, "Last-Modified" => $now_string ); - push( @headers, 'Vary' => 'Accept-Encoding' ); if ( open( my $fh, '<', $path ) ) { + my $mt = ( stat($fh) )[9]; + my $sz = ( stat(_) )[7]; + my @gm = gmtime($mt); + my $now_string = strftime( "%a, %d %b %Y %H:%M:%S GMT", @gm ); + my $code = $mt > $last_fetch ? 200 : 304; + + push( @headers, "Last-Modified" => $now_string ); + push( @headers, 'Vary' => 'Accept-Encoding' ); + return $self->_range( $fullpath, $fh, $ranges, $sz, @headers ) if @$ranges && $streaming; # Transfer-encoding: chunked @@ -725,7 +726,10 @@ sub parse_ranges { my $env = shift; # Handle HTTP range/streaming requests - my $range = $env->{HTTP_RANGE} || "bytes=0-" if $env->{HTTP_RANGE} || $env->{HTTP_IF_RANGE}; + my $range; + if ( $env->{HTTP_RANGE} || $env->{HTTP_IF_RANGE} ) { + $range = $env->{HTTP_RANGE} || "bytes=0-"; + } my @ranges; if ($range) { diff --git a/t/04-parse-ranges.t b/t/04-parse-ranges.t new file mode 100644 index 0000000..2c1a817 --- /dev/null +++ b/t/04-parse-ranges.t @@ -0,0 +1,86 @@ +#!/usr/bin/env perl + +# Tests for parse_ranges() including the stale-variable bug where a previous +# range request's value leaked into a subsequent request that had no range headers. + +use strict; +use warnings; + +use Test::More; +use File::Temp qw{tempdir}; + +use lib 't/lib'; +use TPSGITestStubs; +use FindBin::libs; + +use TPSGI; + +# ---- Basic functionality (already stable) ---- + +subtest 'no range header returns empty list' => sub { + my @ranges = TPSGI::parse_ranges({}); + is(scalar @ranges, 0, 'empty list for bare request'); +}; + +subtest 'single byte range parsed' => sub { + my @ranges = TPSGI::parse_ranges({ HTTP_RANGE => 'bytes=0-1023' }); + is(scalar @ranges, 1, 'one range'); + is($ranges[0][0], 0, 'start = 0'); + is($ranges[0][1], 1023, 'end = 1023'); +}; + +subtest 'multiple ranges parsed' => sub { + my @ranges = TPSGI::parse_ranges({ HTTP_RANGE => 'bytes=0-499,1000-1499' }); + is(scalar @ranges, 2, 'two ranges'); + is($ranges[0][0], 0, 'first start = 0'); + is($ranges[0][1], 499, 'first end = 499'); + is($ranges[1][0], 1000, 'second start = 1000'); + is($ranges[1][1], 1499, 'second end = 1499'); +}; + +subtest 'open-ended range: end is undef' => sub { + my @ranges = TPSGI::parse_ranges({ HTTP_RANGE => 'bytes=500-' }); + is(scalar @ranges, 1, 'one range'); + is($ranges[0][0], 500, 'start = 500'); + ok(!defined $ranges[0][1], 'end is undef for open-ended range'); +}; + +subtest 'IF_RANGE without RANGE uses full-file default range' => sub { + my @ranges = TPSGI::parse_ranges({ HTTP_IF_RANGE => '"some-etag"' }); + is(scalar @ranges, 1, 'default range generated'); + is($ranges[0][0], 0, 'default start = 0'); + ok(!defined $ranges[0][1], 'default end undef'); +}; + +# ---- Stale variable bug regression test ---- +# The old code used `my $range = val if cond` — Perl UB that causes $range to +# retain its previous value when the condition is false on a subsequent call. +# After the fix, a ranged call followed by a non-ranged call must return empty. + +subtest 'non-ranged call after ranged call returns empty list (stale-variable fix)' => sub { + # First call: with a range — establishes a value in the old buggy code + my @first = TPSGI::parse_ranges({ HTTP_RANGE => 'bytes=0-255' }); + is(scalar @first, 1, 'first call: range returned'); + + # Second call: no range headers at all — must return empty, not stale range + my @second = TPSGI::parse_ranges({}); + is(scalar @second, 0, 'second call: no range headers -> empty list (not stale)'); +}; + +subtest 'multiple non-ranged calls in sequence all return empty' => sub { + # Seed a range first + TPSGI::parse_ranges({ HTTP_RANGE => 'bytes=100-200' }); + + for my $i (1..3) { + my @ranges = TPSGI::parse_ranges({}); + is(scalar @ranges, 0, "call $i: no ranges returned without header"); + } +}; + +subtest 'IF_RANGE followed by no-range call returns empty' => sub { + TPSGI::parse_ranges({ HTTP_IF_RANGE => '"etag-abc"' }); + my @ranges = TPSGI::parse_ranges({}); + is(scalar @ranges, 0, 'no range headers after IF_RANGE -> empty list'); +}; + +done_testing; diff --git a/t/05-serve.t b/t/05-serve.t new file mode 100644 index 0000000..eae751b --- /dev/null +++ b/t/05-serve.t @@ -0,0 +1,158 @@ +#!/usr/bin/env perl + +# Tests for TPSGI::serve() — static file serving without a real HTTP server. +# We call serve() directly on a blessed hashref to avoid new()'s user check. + +use strict; +use warnings; + +use Test::More; +use File::Temp qw{tempdir tempfile}; +use Time::HiRes qw{gettimeofday}; + +use lib 't/lib'; +use TPSGITestStubs; +use FindBin::libs; + +use TPSGI; + +my $tmpdir = tempdir(CLEANUP => 1); + +my $user = scalar getpwuid($>); +my $http_grp = (getgrgid($)))[0]; + +sub _make_tpsgi { + my %extra = @_; + return bless { + user => $user, + http_user => $http_grp, + tpsgi_dir => $tmpdir, + basedir => '.', + log_dir => $tmpdir, + log_name => "$tmpdir/tpsgi.log", + verbose => 0, + autoreload => 0, + indices => [qw{index.html}], + callbacks => [], + routes => [], + aliases => {}, + ip => '127.0.0.1', + gid => scalar(getgrnam($http_grp)), + loggers => [], + %extra, + }, 'TPSGI'; +} + +sub _start { return [gettimeofday] } + +# ---- serve: basic file return (no compression) ---- + +subtest 'serve: returns 200 array response for existing text file' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.txt', UNLINK => 1); + print $fh 'Hello, world!'; + close $fh; + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/hello.txt', $path, _start(), 0, [], 0, 0); + + ok(ref $resp eq 'ARRAY', 'got arrayref response'); + is($resp->[0], 200, 'status 200'); + + my %headers = @{ $resp->[1] }; + like($headers{'Content-type'}, qr{text/plain}, 'Content-type is text/plain'); + ok(exists $headers{'Content-Length'}, 'Content-Length present'); + is($headers{'Content-Length'}, 13, 'Content-Length = 13'); + ok(exists $headers{'Last-Modified'}, 'Last-Modified header present'); +}; + +subtest 'serve: returns 200 for html file with correct MIME type' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.html', UNLINK => 1); + print $fh 'hi'; + close $fh; + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/page.html', $path, _start(), 0, [], 0, 0); + + is($resp->[0], 200, 'status 200'); + my %headers = @{ $resp->[1] }; + like($headers{'Content-type'}, qr{text/html}, 'Content-type is text/html'); +}; + +subtest 'serve: returns 304 when file not modified since last fetch' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.txt', UNLINK => 1); + print $fh 'old content'; + close $fh; + + my $mtime = (stat($path))[9]; + my $future = $mtime + 3600; # pretend client fetched an hour after mtime + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/old.txt', $path, _start(), 0, [], $future, 0); + + is($resp->[0], 304, '304 when client cache is newer than file mtime'); +}; + +subtest 'serve: returns 403 when file cannot be opened' => sub { + my $tpsgi = _make_tpsgi(); + # Serve a nonexistent path — open() fails, should give 403 + my $resp = $tpsgi->serve('/secret.txt', '/this/path/does/not/exist.txt', _start(), 0, [], 0, 0); + is($resp->[0], 403, '403 for unreadable/nonexistent file'); +}; + +subtest 'serve: Accept-Ranges header present' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.bin', UNLINK => 1); + print $fh 'x' x 100; + close $fh; + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/data.bin', $path, _start(), 0, [], 0, 0); + + my %headers = @{ $resp->[1] }; + is($headers{'Accept-Ranges'}, 'bytes', 'Accept-Ranges: bytes header set'); +}; + +subtest 'serve: Server-Timing header appended' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.txt', UNLINK => 1); + print $fh 'timing test'; + close $fh; + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/timing.txt', $path, _start(), 0, [], 0, 0); + + my %headers = @{ $resp->[1] }; + ok(exists $headers{'Server-Timing'}, 'Server-Timing header present'); + like($headers{'Server-Timing'}, qr/dur=/, 'Server-Timing contains duration'); +}; + +# ---- serve: streaming (large file) ---- + +subtest 'serve: returns CODE ref for streaming when file > CHUNK_SIZE' => sub { + my ($fh, $path) = tempfile(DIR => $tmpdir, SUFFIX => '.dat', UNLINK => 1); + # Write more than 1MB + print $fh 'A' x ($TPSGI::CHUNK_SIZE + 1); + close $fh; + + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->serve('/large.dat', $path, _start(), 1, [], 0, 0); + + ok(ref $resp eq 'CODE', 'streaming response is a CODE ref for large files'); + + # Drive the responder to ensure it completes without error + my @written; + my $writer = bless { + write => sub { push @written, $_[1] }, + close => sub { }, + }, '_MockWriter'; + no strict 'refs'; + *{'_MockWriter::write'} = sub { push @written, $_[1] }; + *{'_MockWriter::close'} = sub { }; + use strict 'refs'; + + my $responder = sub { return $writer }; + local $@; + eval { $resp->($responder) }; + ok(!$@, 'streaming responder ran without exception'); + ok(@written > 0, 'data was written'); +}; + +done_testing; diff --git a/t/06-route-and-query.t b/t/06-route-and-query.t new file mode 100644 index 0000000..a5860c9 --- /dev/null +++ b/t/06-route-and-query.t @@ -0,0 +1,330 @@ +#!/usr/bin/env perl + +# Tests for route() dispatch and extract_query() parameter handling. +# Covers: method validation, content-type dispatch, GET/POST params, +# route captures, data injection, server-timing headers, and HTTP +# error helper responses. + +use strict; +use warnings; + +use Test::More; +use File::Temp qw{tempdir}; +use Time::HiRes qw{gettimeofday}; + +use lib 't/lib'; +use TPSGITestStubs; +use FindBin::libs; + +use TPSGI; + +my $tmpdir = tempdir(CLEANUP => 1); + +my $user = scalar getpwuid($>); +my $http_grp = (getgrgid($)))[0]; + +sub _make_tpsgi { + my %extra = @_; + return bless { + user => $user, + http_user => $http_grp, + tpsgi_dir => $tmpdir, + basedir => '.', + log_dir => $tmpdir, + log_name => "$tmpdir/tpsgi.log", + verbose => 0, + autoreload => 0, + indices => [qw{index.html}], + callbacks => [], + routes => [], + aliases => {}, + ip => '127.0.0.1', + gid => scalar(getgrnam($http_grp)), + loggers => [], + %extra, + }, 'TPSGI'; +} + +sub _env { + my (%extra) = @_; + return { + REQUEST_METHOD => 'GET', + REQUEST_URI => '/test', + PATH_INFO => '/test', + HTTP_HOST => 'localhost', + REMOTE_ADDR => '127.0.0.1', + 'psgi.streaming' => 0, + 'psgi.errors' => \*STDERR, + 'psgi.url_scheme' => 'http', + QUERY_STRING => '', + CONTENT_TYPE => 'text/html', + CONTENT_LENGTH => 0, + %extra, + }; +} + +sub _start { return [gettimeofday] } + +# ---- HTTP error helpers ---- + +subtest 'notfound returns 404' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/nope', tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->notfound($query); + is($resp->[0], 404, 'notfound -> 404'); +}; + +subtest 'forbidden returns 403' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/secret', tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->forbidden($query); + is($resp->[0], 403, 'forbidden -> 403'); +}; + +subtest 'badrequest returns 400' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/bad', tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->badrequest($query); + is($resp->[0], 400, 'badrequest -> 400'); +}; + +subtest 'error returns 500' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/explode', tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->error($query); + is($resp->[0], 500, 'error -> 500'); +}; + +subtest 'unavailable returns 503' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/down', tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->unavailable($query); + is($resp->[0], 503, 'unavailable -> 503'); +}; + +subtest 'toolong returns 419' => sub { + my $tpsgi = _make_tpsgi(); + my $query = { method => 'GET', fullpath => '/x' x 3000, tpsgi => $tpsgi, ip => '127.0.0.1', ua => '', referer => '' }; + my $resp = $tpsgi->toolong($query); + is($resp->[0], 419, 'toolong -> 419'); +}; + +# ---- route: method validation ---- + +subtest 'route: wrong HTTP method returns 400' => sub { + my $handler = { + method => 'GET', + callbacks => { '*' => sub { [200, ['Content-Type' => 'text/plain', 'Content-Length' => 2], ['ok']] } }, + pattern => '/api', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/api', $handler]; + + my $env = _env(REQUEST_METHOD => 'DELETE', PATH_INFO => '/api', REQUEST_URI => '/api'); + my $resp = TPSGI::_app($tpsgi, $env); + is($resp->[0], 400, 'DELETE on GET-only route -> 400'); +}; + +subtest 'route: HEAD method allowed on GET route' => sub { + my $handler = { + method => 'GET', + callbacks => { '*' => sub { [200, ['Content-Type' => 'text/plain', 'Content-Length' => 2], ['ok']] } }, + pattern => '/headtest', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/headtest', $handler]; + + my $env = _env(REQUEST_METHOD => 'HEAD', PATH_INFO => '/headtest', REQUEST_URI => '/headtest'); + my $resp = TPSGI::_app($tpsgi, $env); + is($resp->[0], 200, 'HEAD allowed on GET route'); +}; + +# ---- route: content-type dispatch ---- + +subtest 'route: wildcard callback dispatched regardless of content-type' => sub { + my $dispatched = 0; + my $handler = { + method => 'POST', + callbacks => { + '*' => sub { $dispatched++; [200, ['Content-Type' => 'text/plain', 'Content-Length' => 2], ['ok']] }, + }, + pattern => '/submit', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/submit', $handler]; + + my $body = 'key=val'; + open my $in, '<', \$body; + my $env = _env( + REQUEST_METHOD => 'POST', + PATH_INFO => '/submit', + REQUEST_URI => '/submit', + CONTENT_TYPE => 'application/x-www-form-urlencoded', + CONTENT_LENGTH => length($body), + 'psgi.input' => $in, + ); + my $resp = TPSGI::_app($tpsgi, $env); + is($resp->[0], 200, 'status 200'); + is($dispatched, 1, 'wildcard handler called'); +}; + +subtest 'route: specific content-type dispatched, wrong type returns 400' => sub { + my $handler = { + method => 'POST', + callbacks => { + 'application/json' => sub { [200, ['Content-Type' => 'text/plain', 'Content-Length' => 2], ['ok']] }, + }, + pattern => '/json-only', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/json-only', $handler]; + + my $body = 'name=bob'; + open my $in, '<', \$body; + my $env = _env( + REQUEST_METHOD => 'POST', + PATH_INFO => '/json-only', + REQUEST_URI => '/json-only', + CONTENT_TYPE => 'application/x-www-form-urlencoded', + CONTENT_LENGTH => length($body), + 'psgi.input' => $in, + ); + my $resp = TPSGI::_app($tpsgi, $env); + is($resp->[0], 400, 'wrong content-type -> 400'); +}; + +# ---- route: server timing headers ---- + +subtest 'route: Server-Timing header appended to response' => sub { + my $handler = { + method => 'GET', + callbacks => { '*' => sub { [200, ['Content-Type' => 'text/plain', 'Content-Length' => 2], ['ok']] } }, + pattern => '/timing', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/timing', $handler]; + + my $resp = TPSGI::_app($tpsgi, _env(PATH_INFO => '/timing', REQUEST_URI => '/timing')); + my %headers = @{ $resp->[1] }; + ok(exists $headers{'Server-Timing'}, 'Server-Timing header present'); + like($headers{'Server-Timing'}, qr/dur=/, 'Server-Timing contains duration'); +}; + +# ---- extract_query: GET parameters ---- + +subtest 'extract_query: GET params parsed from QUERY_STRING' => sub { + my $handler = { + method => 'GET', + callbacks => { '*' => sub { + my ($self, $q) = @_; + [200, ['Content-Type' => 'text/plain', 'Content-Length' => 1], [$q->{name} // '']]; + }}, + pattern => '/search', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/search', $handler]; + + my $resp = TPSGI::_app($tpsgi, _env( + PATH_INFO => '/search', + REQUEST_URI => '/search', + QUERY_STRING => 'name=alice&age=30', + )); + is($resp->[0], 200, 'status 200'); + is($resp->[2][0], 'alice', 'name param extracted from QUERY_STRING'); +}; + +subtest 'extract_query: empty QUERY_STRING returns empty hashref (no URL params)' => sub { + my $tpsgi = _make_tpsgi(); + my $route = { pattern => '/empty' }; + my $env = _env(PATH_INFO => '/empty', REQUEST_URI => '/empty', QUERY_STRING => ''); + + my $query = TPSGI::extract_query($tpsgi, '/empty', $route, $env); + + # extract_query returns undef or empty hashref when QUERY_STRING is absent + ok(!defined $query || (ref $query eq 'HASH' && !%$query), + 'extract_query returns empty/undef for empty QUERY_STRING'); +}; + +# ---- extract_query: route captures ---- + +subtest 'extract_query: captures extracted from URL via regex' => sub { + my $captured; + my $handler = { + method => 'GET', + captures => ['id'], + callbacks => { '*' => sub { + my ($self, $q) = @_; + $captured = $q->{id}; + [200, ['Content-Type' => 'text/plain', 'Content-Length' => 1], ['x']]; + }}, + pattern => '/item/(\d+)', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/item/(\d+)', $handler]; + + TPSGI::_app($tpsgi, _env(PATH_INFO => '/item/42', REQUEST_URI => '/item/42')); + is($captured, '42', 'capture group "id" extracted from /item/42'); +}; + +# ---- extract_query: data injection ---- + +subtest 'extract_query: static data hash injected into query' => sub { + my $got_mode; + my $handler = { + method => 'GET', + data => { mode => 'admin' }, + callbacks => { '*' => sub { + my ($self, $q) = @_; + $got_mode = $q->{mode}; + [200, ['Content-Type' => 'text/plain', 'Content-Length' => 1], ['x']]; + }}, + pattern => '/admin', + }; + + my $tpsgi = _make_tpsgi(); + $tpsgi->{routes} = ['/admin', $handler]; + + TPSGI::_app($tpsgi, _env(PATH_INFO => '/admin', REQUEST_URI => '/admin')); + is($got_mode, 'admin', 'static data hash injected into query'); +}; + +# ---- app: URI too long ---- + +subtest '_app: URI longer than 2048 chars returns 419' => sub { + my $tpsgi = _make_tpsgi(); + my $long_path = '/' . ('x' x 2049); + my $env = _env(PATH_INFO => $long_path, REQUEST_URI => $long_path); + my $resp = TPSGI::_app($tpsgi, $env); + is($resp->[0], 419, 'URI > 2048 chars -> 419 toolong'); +}; + +# ---- redirect helpers ---- + +subtest 'redirect returns 302 with Location header' => sub { + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->redirect('/new-location'); + is($resp->[0], 302, 'redirect -> 302'); + my %headers = @{ $resp->[1] }; + is($headers{Location}, '/new-location', 'Location header set'); +}; + +subtest 'redirect_permanent returns 301' => sub { + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->redirect_permanent('/permanent'); + is($resp->[0], 301, 'redirect_permanent -> 301'); +}; + +subtest 'see_also returns 303' => sub { + my $tpsgi = _make_tpsgi(); + my $resp = $tpsgi->see_also('/other'); + is($resp->[0], 303, 'see_also -> 303'); +}; + +done_testing; diff --git a/t/lib/TPSGITestStubs.pm b/t/lib/TPSGITestStubs.pm new file mode 100644 index 0000000..f9afba6 --- /dev/null +++ b/t/lib/TPSGITestStubs.pm @@ -0,0 +1,142 @@ +package TPSGITestStubs; + +# Stubs for TPSGI dependencies that may not be installed in the test environment. +# Each stub first attempts to load the real module — if that succeeds we do +# nothing. Only when the real module is absent do we register a minimal fake. +# +# Load this BEFORE 'use TPSGI' or 'use TPSGI::Startup' so Perl won't try +# to find the missing .pm files on disk. + +use strict; +use warnings; + +sub import { + _maybe_stub('Linux::Perl::inotify', 'Linux/Perl/inotify.pm', \&_stub_linux_perl_inotify); + _maybe_stub('HTTP::Parser::XS', 'HTTP/Parser/XS.pm', \&_stub_http_parser_xs); + _maybe_stub('CGI::Emulate::PSGI', 'CGI/Emulate/PSGI.pm', \&_stub_cgi_emulate_psgi); + _maybe_stub('Log::Dispatch', 'Log/Dispatch.pm', \&_stub_log_dispatch); + _maybe_stub('Log::Dispatch::Screen', 'Log/Dispatch/Screen.pm', \&_stub_log_dispatch_screen); + _maybe_stub('Log::Dispatch::FileRotate', 'Log/Dispatch/FileRotate.pm', \&_stub_log_dispatch_filerotate); + _maybe_stub('URL::Encode', 'URL/Encode.pm', \&_stub_url_encode); + _maybe_stub('DateTime::Format::HTTP', 'DateTime/Format/HTTP.pm', \&_stub_datetime_format_http); + _maybe_stub('HTTP::Body', 'HTTP/Body.pm', \&_stub_http_body); +} + +sub _maybe_stub { + my ($pkg, $path, $stubber) = @_; + return if $INC{$path}; # already loaded (real or stubbed) + return if eval { require $path; 1 }; # real module loadable — use it + $stubber->(); # install the stub +} + +sub _stub_linux_perl_inotify { + package Linux::Perl::inotify; + sub new { bless { _wds => [] }, shift } + sub add { my $self = shift; my $wd = {}; push @{$self->{_wds}}, $wd; return $wd } + sub read { return () } + $INC{'Linux/Perl/inotify.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_http_parser_xs { + package HTTP::Parser::XS; + use constant HEADERS_AS_HASHREF => 1; + sub parse_http_response { + my ($buf, $mode) = @_; + my ($status, $message) = (200, 'OK'); + my %headers; + for my $line (split /\r?\n/, $buf) { + if ($line =~ m{^HTTP/1\.(\d)\s+(\d+)\s+(.+)}) { + $status = $2 + 0; + $message = $3; + } elsif ($line =~ m{^([^:]+):\s*(.+)}) { + $headers{lc $1} = $2; + } + } + return (1, undef, 1, $status, $message, \%headers); + } + sub import { + my $class = shift; + my $caller = caller; + no strict 'refs'; + for my $sym (@_) { + *{"${caller}::${sym}"} = \&{"HTTP::Parser::XS::${sym}"}; + } + } + $INC{'HTTP/Parser/XS.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_cgi_emulate_psgi { + package CGI::Emulate::PSGI; + sub emulate_environment { return () } + $INC{'CGI/Emulate/PSGI.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_log_dispatch { + package Log::Dispatch; + sub new { bless { handlers => [] }, shift } + sub add { push @{$_[0]{handlers}}, $_[1] } + { + no strict 'refs'; + for my $lvl (qw{debug info notice warning error critical alert emergency}) { + *{"Log::Dispatch::$lvl"} = sub { }; + } + *{"Log::Dispatch::log_and_die"} = sub { die $_[-1] }; + } + $INC{'Log/Dispatch.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_log_dispatch_screen { + package Log::Dispatch::Screen; + sub new { bless {}, shift } + $INC{'Log/Dispatch/Screen.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_log_dispatch_filerotate { + package Log::Dispatch::FileRotate; + sub new { bless {}, shift } + $INC{'Log/Dispatch/FileRotate.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_url_encode { + package URL::Encode; + sub url_params_mixed { + my $qs = shift // ''; + my %params; + for my $pair (split /&/, $qs) { + my ($k, $v) = split /=/, $pair, 2; + next unless defined $k && length $k; + $k =~ s/\+/ /g; $k =~ s/%([0-9A-Fa-f]{2})/chr hex $1/ge; + $v //= ''; $v =~ s/\+/ /g; $v =~ s/%([0-9A-Fa-f]{2})/chr hex $1/ge; + $params{$k} = $v; + } + return \%params; + } + $INC{'URL/Encode.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_datetime_format_http { + package DateTime::Format::HTTP; + sub parse_datetime { bless { epoch => 0 }, ref($_[0]) || $_[0] } + sub epoch { $_[0]->{epoch} } + $INC{'DateTime/Format/HTTP.pm'} = 1; + package TPSGITestStubs; +} + +sub _stub_http_body { + package HTTP::Body; + sub new { bless { param => {}, upload => {} }, shift } + sub add { } + sub param { $_[0]->{param} } + sub upload { $_[0]->{upload} } + $INC{'HTTP/Body.pm'} = 1; + package TPSGITestStubs; +} + +1;