Troglodyne-Internet-Widgets · troglodyne-bot · Jun 3, 2026
diff --git a/CLAUDE.md 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
@@ -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
@@ -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
@@ -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 '<html><body>hi</body></html>';
+    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;