From dd0ded7719717446b49581584381bc292ccc5ca8 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Sat, 16 May 2026 01:58:55 +0000 Subject: [PATCH 1/3] Add precious lint config, CI job, and pre-commit hook precious.toml defines the canonical lint/tidy command set (perltidy, perlvars, omegasort). The lint CI job runs `precious lint --all`. scripts/pre-commit runs `precious lint --staged` on commit and blocks direct commits to master; contributors run `scripts/pre-commit --init` once per clone to symlink it into .git/hooks/pre-commit. Co-Authored-By: Claude Opus 4.7 --- .github/workflows/lint.yml | 34 ++++++++++++++++++++++++++++++++ precious.toml | 23 ++++++++++++++++++++++ scripts/pre-commit | 40 ++++++++++++++++++++++++++++++++++++++ 3 files changed, 97 insertions(+) create mode 100644 .github/workflows/lint.yml create mode 100644 precious.toml create mode 100755 scripts/pre-commit diff --git a/.github/workflows/lint.yml b/.github/workflows/lint.yml new file mode 100644 index 0000000..7119e38 --- /dev/null +++ b/.github/workflows/lint.yml @@ -0,0 +1,34 @@ +name: lint + +on: + push: + branches: + - master + pull_request: + workflow_dispatch: + +concurrency: + group: ${{ github.workflow }}-${{ github.ref }} + cancel-in-progress: true + +jobs: + precious: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v6 + - uses: shogo82148/actions-setup-perl@v1 + with: + perl-version: "5.42" + - uses: oalders/install-ubi-action@v0.0.6 + with: + GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }} + projects: | + houseabsolute/precious + houseabsolute/omegasort + - uses: perl-actions/install-with-cpm@v2 + with: + install: | + App::perlvars + Perl::Tidy + sudo: false + - run: precious lint --all diff --git a/precious.toml b/precious.toml new file mode 100644 index 0000000..5aa8978 --- /dev/null +++ b/precious.toml @@ -0,0 +1,23 @@ +[commands.perltidy] +type = "both" +include = ["**/*.{pl,pm,t,psgi}"] +cmd = ["perltidy", "--profile=$PRECIOUS_ROOT/.perltidyrc"] +lint-flags = ["--assert-tidy", "--no-standard-output", "--outfile=/dev/null"] +tidy-flags = ["--backup-and-modify-in-place", "--backup-file-extension=/"] +ok-exit-codes = [0] +lint-failure-exit-codes = [2] + +[commands.perlvars] +type = "lint" +include = ["**/*.pm"] +cmd = ["perlvars"] +ok-exit-codes = [0] +lint-failure-exit-codes = [1] + +[commands.omegasort-gitignore] +type = "both" +include = [".gitignore"] +cmd = ["omegasort", "--sort", "path", "--unique"] +lint-flags = ["--check"] +ok-exit-codes = [0] +lint-failure-exit-codes = [1] diff --git a/scripts/pre-commit b/scripts/pre-commit new file mode 100755 index 0000000..cd7b07a --- /dev/null +++ b/scripts/pre-commit @@ -0,0 +1,40 @@ +#!/bin/sh +# Pre-commit hook: enforce `precious lint` on staged files and +# block direct commits to the default branch. +# +# Install (run once per clone): +# scripts/pre-commit --init + +set -eu + +if [ "${1:-}" = "--init" ]; then + repo_root=$(git rev-parse --show-toplevel) + hook_path="$repo_root/.git/hooks/pre-commit" + target="../../scripts/pre-commit" + if [ -e "$hook_path" ] && [ ! -L "$hook_path" ]; then + echo "ERROR: $hook_path exists and is not a symlink." >&2 + echo "Move or remove it, then re-run scripts/pre-commit --init." >&2 + exit 1 + fi + chmod +x "$repo_root/scripts/pre-commit" + ln -sf "$target" "$hook_path" + echo "Installed pre-commit hook: $hook_path -> $target" + exit 0 +fi + +# Block direct commits to the default branch. +default_branch="master" +branch=$(git symbolic-ref --short HEAD 2>/dev/null || true) +if [ "$branch" = "$default_branch" ]; then + echo "ERROR: Direct commits to '$default_branch' branch are not allowed." >&2 + echo "Please create a feature branch instead:" >&2 + echo " git checkout -b feature/your-feature-name" >&2 + exit 1 +fi + +# Run precious lint on staged files +if ! precious lint -q --staged; then + echo "pre-commit hook failed: precious lint found issues with staged files" >&2 + echo "Please run 'precious tidy -q --staged' and try again" >&2 + exit 1 +fi From 6d2658adf6f0324fc49efb4e62ea6c4bd3807b60 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Sat, 16 May 2026 02:00:45 +0000 Subject: [PATCH 2/3] Tidy entire codebase with `precious tidy --all` Whitespace and formatting only, applied by `precious tidy --all` using the .perltidyrc profile. No functional changes. Co-Authored-By: Claude Opus 4.7 --- lib/HTTP/Daemon.pm | 30 +++++++++------ t/basic.t | 41 ++++++++++---------- t/chunked.t | 10 ++--- t/content_length.t | 68 +++++++++++++++++----------------- t/encoding.t | 4 +- t/lib/TestServer.pm | 31 ++++++++-------- t/lib/TestServer/BasicTests.pm | 6 +-- 7 files changed, 97 insertions(+), 93 deletions(-) diff --git a/lib/HTTP/Daemon.pm b/lib/HTTP/Daemon.pm index 501be02..f7f6cf2 100644 --- a/lib/HTTP/Daemon.pm +++ b/lib/HTTP/Daemon.pm @@ -52,7 +52,7 @@ sub url { $host = "::1" if $host eq "::"; $host = "[$host]" if $self->sockdomain == Socket::AF_INET6; - my $url = $self->_default_scheme . "://" . $host; + my $url = $self->_default_scheme . "://" . $host; my $port = $self->sockport; $url .= ":$port" if $port != $self->_default_port; $url .= "/"; @@ -85,9 +85,9 @@ our $DEBUG; use HTTP::Request (); use HTTP::Response (); use HTTP::Status; -use HTTP::Date qw(time2str); +use HTTP::Date qw(time2str); use LWP::MediaTypes qw(guess_media_type); -use Carp (); +use Carp (); # "\r\n" is not portable my $CRLF = "\015\012"; @@ -141,7 +141,7 @@ READ_HEADER: } if ($buf !~ s/^(\S+)[ \t]+(\S+)(?:[ \t]+(HTTP\/\d+\.\d+))?[^\012]*\012//) { ${*$self}{'httpd_client_proto'} = _http_version("HTTP/1.0"); - $self->send_error(400); # BAD_REQUEST + $self->send_error(400); # BAD_REQUEST $self->reason("Bad request line: $buf"); return; } @@ -153,7 +153,7 @@ READ_HEADER: my $r = HTTP::Request->new($method, $uri); $r->protocol($proto); ${*$self}{'httpd_client_proto'} = $proto = _http_version($proto); - ${*$self}{'httpd_head'} = ($method eq "HEAD"); + ${*$self}{'httpd_head'} = ($method eq "HEAD"); if ($proto >= $HTTP_1_0) { @@ -227,7 +227,7 @@ READ_HEADER: last CHUNK if $size == 0; my $missing = $size - length($buf) + 2; # 2=CRLF at chunk end - # must read until we have a complete chunk + # must read until we have a complete chunk while ($missing > 0) { print STDERR "Need $missing more bytes\n" if $DEBUG; my $n = $self->_need_more($buf, $timeout, $fdset); @@ -294,16 +294,19 @@ READ_HEADER: # section 3.3.3 -- Message Body Length # split and clean up Content-Length ', ' separated string - my @vals = map {my $str = $_; $str =~ s/^\s+//; $str =~ s/\s+$//; $str } + my @vals + = map { my $str = $_; $str =~ s/^\s+//; $str =~ s/\s+$//; $str } split ',', $ct_len; + # check that they are all numbers (RFC: Content-Length = 1*DIGIT) - my @nums = grep { /^[0-9]+$/} @vals; + my @nums = grep {/^[0-9]+$/} @vals; unless (@vals == @nums) { my $reason = "Content-Length value must be an unsigned integer"; $self->send_error(400, $reason); $self->reason($reason); return; } + # check they are all the same my $ct_len = shift @nums; foreach (@nums) { @@ -313,6 +316,7 @@ READ_HEADER: $self->reason($reason); return; } + # ensure we have now a fixed header, with only 1 value $r->header('Content-Length' => $ct_len); @@ -333,7 +337,9 @@ READ_HEADER: $buf = ''; } } - elsif ($ct_type && $ct_type =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) { + elsif ($ct_type + && $ct_type =~ m/^multipart\/\w+\s*;.*boundary\s*=\s*("?)(\w+)\1/i) + { # Handle multipart content type my $boundary = "$CRLF--$2--"; @@ -424,7 +430,7 @@ sub send_status_line { return if $self->antique_client; $status ||= RC_OK; $message ||= status_message($status) || ""; - $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; + $proto ||= $HTTP::Daemon::PROTO || "HTTP/1.1"; print $self "$proto $status $message$CRLF"; } @@ -566,12 +572,12 @@ sub send_file_response { sysopen(F, $file, 0) or return $self->send_error(RC_FORBIDDEN); binmode(F); my ($mime_type, $file_enc) = guess_media_type($file); - my ($size, $mtime) = (stat _)[7, 9]; + my ($size, $mtime) = (stat _)[7, 9]; unless ($self->antique_client) { $self->send_basic_header; print $self "Content-Type: $mime_type$CRLF"; print $self "Content-Encoding: $file_enc$CRLF" if $file_enc; - print $self "Content-Length: $size$CRLF" if $size; + print $self "Content-Length: $size$CRLF" if $size; print $self "Last-Modified: ", time2str($mtime), "$CRLF" if $mtime; print $self $CRLF; } diff --git a/t/basic.t b/t/basic.t index 533ac3e..96349d5 100644 --- a/t/basic.t +++ b/t/basic.t @@ -1,6 +1,6 @@ use strict; use warnings; -use Test::Needs { 'LWP::UserAgent' => '6.37' }; +use Test::Needs {'LWP::UserAgent' => '6.37'}; use Test::More tests => 45; use lib 't/lib'; @@ -12,7 +12,7 @@ use File::Temp qw(tempfile); use MIME::Base64; my $daemon = TestServer::BasicTests->new; -my $base = $daemon->start; +my $base = $daemon->start; note "Will access HTTP server at $base\n"; @@ -30,7 +30,7 @@ $req->header(X_Foo => "Bar"); $res = $ua->request($req); ok($res->is_error); -is($res->code, 404); +is($res->code, 404); like($res->message, qr/not\s+found/i); # we also expect a few headers @@ -61,20 +61,20 @@ ok($res->is_success); is($res->code, 200); is($res->message, "OK"); -$_ = $res->content; +$_ = $res->content; my @accept = /^Accept:\s*(.*)/mg; -like($_, qr/^From:\s*gisle\@aas\.no\n/m); -like($_, qr/^Host:/m); +like($_, qr/^From:\s*gisle\@aas\.no\n/m); +like($_, qr/^Host:/m); is(scalar @accept, 3); -like($_, qr/^Accept:\s*text\/html/m); -like($_, qr/^Accept:\s*text\/plain/m); -like($_, qr/^Accept:\s*image\/\*/m); -like($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m); -like($_, qr/^Long-Text:\s*This.*broken between/m); -like($_, qr/^Foo-Bar:\s*1\n/m); -like($_, qr/^X-Foo:\s*Bar\n/m); -like($_, qr/^User-Agent:\s*Mozilla\/0.01/m); +like($_, qr/^Accept:\s*text\/html/m); +like($_, qr/^Accept:\s*text\/plain/m); +like($_, qr/^Accept:\s*image\/\*/m); +like($_, qr/^If-Modified-Since:\s*\w{3},\s+\d+/m); +like($_, qr/^Long-Text:\s*This.*broken between/m); +like($_, qr/^Foo-Bar:\s*1\n/m); +like($_, qr/^X-Foo:\s*Bar\n/m); +like($_, qr/^User-Agent:\s*Mozilla\/0.01/m); # Try it with the higher level 'get' interface $res = $ua->get( @@ -86,14 +86,15 @@ $res = $ua->get( ); #$res->dump; -is($res->code, 200); +is($res->code, 200); like($res->content, qr/^From: gisle\@aas.no$/m); #---------------------------------------------------------------- note "Send file...\n"; { - my ($fh, $filename) = tempfile( 'http-daemon-test-XXXXXX', TMPDIR => 1, SUFFIX => '.html' ); + my ($fh, $filename) + = tempfile('http-daemon-test-XXXXXX', TMPDIR => 1, SUFFIX => '.html'); binmode $fh; print $fh <<"EOT"; En pr\xF8ve @@ -103,7 +104,8 @@ er sikkert nok i massevis. EOT close $fh; - $req = HTTP::Request->new(GET => $daemon->url("/file", { file => $filename })); + $req + = HTTP::Request->new(GET => $daemon->url("/file", {file => $filename})); $res = $ua->request($req); #print $res->as_string; @@ -112,7 +114,7 @@ EOT is($res->content_type, 'text/html'); is($res->content_length, 147); is($res->title, "En pr\xF8ve"); - like($res->content, qr/\xE5 v\xE6re/); + like($res->content, qr/\xE5 v\xE6re/); unlink $filename; @@ -162,6 +164,7 @@ is($res->code, 401); $auth = MIME::Base64::encode("user:passwd"); $req->header(Authorization => 'Basic ' . $auth); + # Then illegal credentials $res = $ua->request($req); is($res->code, 401); @@ -211,5 +214,5 @@ note "Terminating server...\n"; $req = HTTP::Request->new(GET => $daemon->url("/quit")); $res = $ua->request($req); -is($res->code, 503); +is($res->code, 503); like($res->content, qr/Bye, bye/); diff --git a/t/chunked.t b/t/chunked.t index 03a4edb..b1a4ffe 100644 --- a/t/chunked.t +++ b/t/chunked.t @@ -94,19 +94,17 @@ use IO::Socket::IP; plan tests => scalar @TESTS; my $daemon = TestServer::Reflect->new; -my $url = $daemon->start; +my $url = $daemon->start; my $addr = $url->host; my $port = $url->port; for my $test (@TESTS) { - my $raw = $test->{raw}; + my $raw = $test->{raw}; $raw =~ s/\r?\n/$CRLF/mg; - my $sock = IO::Socket::IP->new( - PeerAddr => $addr, - PeerPort => $port, - ) or die; + my $sock = IO::Socket::IP->new(PeerAddr => $addr, PeerPort => $port,) + or die; print $sock $raw; diff --git a/t/content_length.t b/t/content_length.t index e80cb69..3db7350 100644 --- a/t/content_length.t +++ b/t/content_length.t @@ -12,83 +12,83 @@ use TestServer::Reflect (); my @TESTS = ( { - title => "Positive Content Length", - raw => <<'END_RAW', + title => "Positive Content Length", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: +1 END_RAW - status => 400, - like => qr/value must be an unsigned integer/, + status => 400, + like => qr/value must be an unsigned integer/, }, { - title => "Negative Content Length", - raw => <<'END_RAW', + title => "Negative Content Length", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: -1 END_RAW - status => 400, - like => qr/value must be an unsigned integer/, + status => 400, + like => qr/value must be an unsigned integer/, }, { - title => "Non Integer Content Length", - raw => <<'END_RAW', + title => "Non Integer Content Length", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: 3.14 END_RAW - status => 400, - like => qr/value must be an unsigned integer/, + status => 400, + like => qr/value must be an unsigned integer/, }, { - title => "Explicit Content Length ... with exact length", - raw => <<'END_RAW', + title => "Explicit Content Length ... with exact length", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: 8 ABCDEFGH END_RAW - status => 200, - like => qr/^ABCDEFGH$/, + status => 200, + like => qr/^ABCDEFGH$/, }, { - title => "No Content Length with body ... will be ignored", - raw => <<'END_RAW', + title => "No Content Length with body ... will be ignored", + raw => <<'END_RAW', POST /echo HTTP/1.1 ABCDEFGH END_RAW - status => 200, - like => qr/^$/, + status => 200, + like => qr/^$/, }, { - title => "Shorter Content Length ... gets truncated", - raw => <<'END_RAW', + title => "Shorter Content Length ... gets truncated", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: 4 ABCDEFGH END_RAW - status => 200, - like => qr/^ABCD$/, + status => 200, + like => qr/^ABCD$/, }, { - title => "Different Content Length ... must fail", - raw => <<'END_RAW', + title => "Different Content Length ... must fail", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: 8 Content-Length: 4 ABCDEFGH END_RAW - status => 400, - like => qr/values are not the same/, + status => 400, + like => qr/values are not the same/, }, { - title => "Longer Content Length ... gets timeout", - raw => <<'END_RAW', + title => "Longer Content Length ... gets timeout", + raw => <<'END_RAW', POST /echo HTTP/1.1 Content-Length: 9 @@ -99,7 +99,7 @@ END_RAW ); my $daemon = TestServer::Reflect->new; -my $url = $daemon->start; +my $url = $daemon->start; my $addr = $url->host; my $port = $url->port; @@ -132,11 +132,9 @@ for my $test (@TESTS) { ok $raw_res, $test->{title}; - is $res->code, $test->{status}, - "... and has expected status"; + is $res->code, $test->{status}, "... and has expected status"; - like $res->content, $test->{like}, - "... and body does match" + like $res->content, $test->{like}, "... and body does match" if $test->{like}; } diff --git a/t/encoding.t b/t/encoding.t index 41dd996..d1dcbbf 100644 --- a/t/encoding.t +++ b/t/encoding.t @@ -4,7 +4,7 @@ use warnings; use Test::More; use HTTP::Daemon (); -use Socket qw( AF_INET6 ); +use Socket qw( AF_INET6 ); { no warnings 'redefine'; @@ -13,7 +13,7 @@ use Socket qw( AF_INET6 ); = sub { return q{fe80::250:54ff:fe00:f01%ens3} }; my $d = HTTP::Daemon->new; - is($d->sockhost, q{fe80::250:54ff:fe00:f01%ens3}, 'we overrode sockhost'); + is($d->sockhost, q{fe80::250:54ff:fe00:f01%ens3}, 'we overrode sockhost'); is($d->sockdomain, Socket::AF_INET6, 'we overrode sockdomain'); like( diff --git a/t/lib/TestServer.pm b/t/lib/TestServer.pm index 2d20db8..27cbb63 100644 --- a/t/lib/TestServer.pm +++ b/t/lib/TestServer.pm @@ -6,7 +6,7 @@ use File::Spec; sub new { my $class = shift; - my $self = bless {}, $class; + my $self = bless {}, $class; } sub perl { @@ -17,8 +17,7 @@ sub perl { sub lib_dirs { my $self = shift; my $perl = $self->perl; - $perl = qq["$perl"] - if $perl =~ /\s/; + $perl = qq["$perl"] if $perl =~ /\s/; my @inc = `$perl -l -e"print for \@INC"`; chomp @inc; @@ -33,8 +32,7 @@ sub lib_dirs { sub perl_cmd { my $self = shift; my $perl = $self->perl; - $perl = qq["$perl"] - if $perl =~ /\s/; + $perl = qq["$perl"] if $perl =~ /\s/; for my $lib ($self->lib_dirs) { my $quoted = $lib =~ /\s/ ? qq["$lib"] : $lib; @@ -45,7 +43,7 @@ sub perl_cmd { } sub start { - my $self = shift; + my $self = shift; my $class = ref $self; my $perl = $self->perl_cmd; @@ -60,15 +58,15 @@ sub start { $self->{url} = $base; $self->{pid} = $pid; - $self->{io} = $DAEMON; + $self->{io} = $DAEMON; return $base; } sub stop { my $self = shift; - my $pid = delete $self->{pid} or return; - my $io = delete $self->{io}; + my $pid = delete $self->{pid} or return; + my $io = delete $self->{io}; kill 'KILL', $pid; close $io; @@ -79,8 +77,7 @@ sub stop { sub DESTROY { my $self = shift; - $self->stop - if $self->{pid}; + $self->stop if $self->{pid}; } sub url { @@ -114,11 +111,13 @@ sub run { require Socket; require IO::Socket::IP; - my ($err, @res) = Socket::getaddrinfo("localhost", "http", { - protocol => Socket::IPPROTO_TCP(), - } ); + my ($err, @res) + = Socket::getaddrinfo("localhost", "http", + {protocol => Socket::IPPROTO_TCP(),}); - my @local_hosts = map +(Socket::getnameinfo($_->{addr}, Socket::NI_NUMERICHOST()))[1], @res; + my @local_hosts + = map +(Socket::getnameinfo($_->{addr}, Socket::NI_NUMERICHOST()))[1], + @res; push @local_hosts, '127.0.0.1'; for my $host (@local_hosts) { @@ -133,7 +132,7 @@ sub run { require HTTP::Daemon; my $d = HTTP::Daemon->new( Timeout => 10, - $listen_host ? ( LocalHost => $listen_host ) : (), + $listen_host ? (LocalHost => $listen_host) : (), ); print "HTTP::Daemon running at url, ">\n"; diff --git a/t/lib/TestServer/BasicTests.pm b/t/lib/TestServer/BasicTests.pm index a972776..cfdd9fa 100644 --- a/t/lib/TestServer/BasicTests.pm +++ b/t/lib/TestServer/BasicTests.pm @@ -12,8 +12,8 @@ sub dispatch { my ($c, $request) = @_; my $method = $request->method; my $uri = $request->uri; - my $p = ($uri->path_segments)[1]; - my $call = lc("httpd_" . $method . "_$p"); + my $p = ($uri->path_segments)[1]; + my $call = lc("httpd_" . $method . "_$p"); if ($self->can($call)) { return $self->$call($c, $request); } @@ -103,7 +103,7 @@ sub httpd_get_partial { sub httpd_get_quit { my ($self, $c) = @_; $c->send_error(503, "Bye, bye"); - exit; # terminate HTTP server + exit; # terminate HTTP server } 1; From 3e49e68c4676c8fb0cf358300384ee7c06f83079 Mon Sep 17 00:00:00 2001 From: Olaf Alders Date: Sat, 16 May 2026 03:38:07 +0000 Subject: [PATCH 3/3] CI: drop pre-5.24 Perl builds on macOS and Windows macOS no longer tests Perl 5.14-5.22. On Windows those versions were already commented out (shogo82148/actions-setup-perl#223); drop the dead entries along with the now-stale note. Co-Authored-By: Claude Opus 4.7 --- .github/workflows/build-and-test.yml | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/.github/workflows/build-and-test.yml b/.github/workflows/build-and-test.yml index 8ccc9ef..8f7281f 100644 --- a/.github/workflows/build-and-test.yml +++ b/.github/workflows/build-and-test.yml @@ -98,11 +98,6 @@ jobs: matrix: os: ["macos-latest"] perl-version: - - "5.14" - - "5.16" - - "5.18" - - "5.20" - - "5.22" - "5.24" - "5.26" - "5.28" @@ -146,14 +141,6 @@ jobs: matrix: os: ["windows-latest"] perl-version: - # https://github.com/shogo82148/actions-setup-perl/issues/223 - #- "5.10" - #- "5.12" - #- "5.14" - #- "5.16" - #- "5.18" - #- "5.20" - #- "5.22" - "5.24" - "5.26" - "5.28"