DEV Community: LNATION

Time::Keeper: Time goes by so slowly

LNATION — Sun, 18 Oct 2026 17:14:59 +0000

Time goes by at one second at a time, and that is the last simple thing about it. A second is a count of caesium atoms, a day is a turn of the earth, a month is a turn of the moon or the decision of a committee, a year is a turn of the sun, and none of them fits inside the next. So we keep arrangements instead: zones that shift an hour twice a year, a leap day most years in four, a leap second when the earth runs slow, and a dozen calendars that cut the same days into different months. A date library is a place to keep those arrangements so that a program can ask what time it is and give an answer two people in two places will both recognise. Most of them manage the common case and make you pay for it on every call.

Time::Keeper is a new CPAN distribution for dates and times. A value is an instant and the zone it is read in, and that is the whole of it: no state to mutate, no locale object, no copy of the zone rules. It covers the ground Time::Piece and DateTime cover between them, and a method that would change a value hands back a new one and leaves the old one as it was.

use Time::Keeper;

my $t = Time::Keeper->new(year => 2026, month => 10, day => 15, hour => 9, zone => 'Europe/London');
print "$t\n";                          # 2026-10-15T09:00:00+01:00
print $t->in_zone('Asia/Tokyo'), "\n"; # 2026-10-15T17:00:00+09:00
print $t->plus(months => 1), "\n";     # 2026-11-15T09:00:00+00:00

I wrote it because every program I have that handles time pays a price for it. DateTime takes 54 ms to load and makes a 1.5 KB object for every value. Time::Piece is lighter but knows nothing of zones beyond the one the process runs in, and nothing of locales at all. Neither knows a leap second. So this post starts with the numbers, then walks through the ordinary work, then ends with what Time::Keeper does that nothing else on CPAN does.

The benchmark

Measured on an Apple M5 with perl 5.42, Time::Piece 1.36 and DateTime 1.66, by the bench/ scripts in the distribution. A rate is calls a second over half a second of CPU, the best of five, and each mark was set before any number was seen.

	Time::Keeper	Time::Piece	DateTime
`use`, in a fresh process	1.9 ms	3.9 ms	53.6 ms
`now`	12.98M/s	980k/s	171k/s
epoch to year, month and day	5.29M/s	827k/s	148k/s
new from fields in America/New_York	2.66M/s		73k/s
`strftime('%Y-%m-%d %H:%M:%S')`	9.09M/s	1.04M/s	362k/s
the same instant in another zone	7.86M/s		148k/s
plus one month	11.1M/s	894k/s	37k/s
the difference of two values	5.89M/s	1.89M/s	135k/s
parse an ISO 8601 string	9.27M/s	1.16M/s
`format('EEEE d MMMM y')` in French	9.62M/s		68k/s
round to the nearest 15 minutes	5.00M/s		114k/s
the next Monday	8.66M/s		10k/s
bytes a value costs	170	606	1,557
installed, with zones and locales	10.7 MB		20.5 MB

Adding a month is three hundred times faster than DateTime. Finding the next Monday is eight hundred times faster, because DateTime has no adjuster and the usual loop makes seven values to find it.

The reason is not cleverness. A value is one 72-byte C struct: the instant as seconds and nanoseconds, the offset, a zone id, a locale id, and a cache of the civil fields filled on the first read. Making one allocates nothing but the scalar it lives in. The zone rules for all 344 zones are compiled into Time::Keeper::Zone from the IANA database, and a program that works in UTC never loads them. The names and formats of 1,121 locales are compiled into one archive, English into the module itself, and a locale's section is read the first time that locale is asked for. There is no object for a zone and no object for a locale.

A quick tour

Making a value

my $now   = Time::Keeper->now;                               # UTC
my $there = Time::Keeper->now(zone => 'Asia/Tokyo');
my $here  = Time::Keeper->now(zone => 'local');
my $t     = Time::Keeper->new(year => 2026, month => 10, day => 15, hour => 9, zone => 'Europe/London');
my $e     = Time::Keeper->from_epoch('1760000000.123456789', zone => '+05:30');
my $p     = Time::Keeper->parse('2026-10-15T09:00:00+01:00[Europe/London]');

A zone is an IANA name, UTC, local, floating for a wall clock with no zone, or an offset. The epoch takes a string, so nine decimal places survive: $e->nanosecond is 123456789, not what a double made of it.

The accessors are the ones you expect, year through nanosecond, day_of_week, day_of_year, week, quarter, days_in_month, is_leap_year, epoch, offset, zone_name, zone_abbr, is_dst, and a value prints as ISO 8601.

Zones, and the two things that go wrong in them

Twice a year a wall-clock time either did not happen or happened twice. Time::Keeper refuses to guess about the first and tells you which it chose for the second:

Time::Keeper->new(year => 2026, month => 3, day => 8, hour => 2, minute => 30, zone => 'America/New_York');
# dies: 2026-03-08 02:30:00 did not happen in America/New_York: the clocks went
# forward over it (gap => 'forward' or 'backward' takes it anyway)

my $t = Time::Keeper->new(year => 2026, month => 11, day => 1, hour => 1, minute => 30,
                          zone => 'America/New_York');
print "$t\n";                       # 2026-11-01T01:30:00-04:00, the earlier of the two
print $t->is_ambiguous, "\n";       # 1
print $t->other_reading, "\n";      # 2026-11-01T01:30:00-05:00
print $t->next_transition, "\n";    # the next time the clocks change, as a value

overlap => 'later' takes the other reading at construction. DateTime takes the later one silently, which is why its default differs from Java's, Python's and Temporal's, and from this one.

Arithmetic that adds back

my $a = Time::Keeper->new(year => 2026, month => 1, day => 31, zone => 'UTC');
my $b = Time::Keeper->new(year => 2026, month => 3, day => 1, hour => 12, zone => 'UTC');

my $d = $b - $a;                    # P29DT12H
print $a + $d == $b ? "yes\n" : "no\n";   # yes, for every pair of values

$a->plus(months => 1);                              # 2026-03-03, Jan 31 wrapped past Feb
$a->plus(months => 1, end_of_month => 'limit');     # 2026-02-28
$a->until($b, largest => 'hours');                  # PT708H
$a->until($b, largest => 'hours')->total('hours');  # 708

Months are added before days, as Java, Python and Temporal do it, and the difference is defined as the duration that adds back to exactly the second value. DateTime adds days before months, and in a run of 9,000 random pairs 137 of them did not round-trip there. Here every pair does, and the test suite proves it on 20,000 fresh pairs each run.

The rest of the arithmetic you would otherwise write by hand:

$t->end_of(to => 'month');                   # 2026-10-31T23:59:59.999999999+00:00
$t->next(day_of_week => 1);                  # the Monday after, same time of day
$t->nth_in_month(day_of_week => 4, n => 3);  # the third Thursday
$t->round(to => 'minute', increment => 15);  # 09:37 becomes 09:30
$t->truncate(to => 'week');                  # the Monday
$t->range($end, by => 'day');                # every day to $end, inclusive

Formatting, in any locale

Both pattern languages are there, strftime's and CLDR's, plus the locale's own four date and time formats and its skeletons:

$t->strftime('%A %d %B %Y %H:%M %Z');        # Thursday 15 October 2026 09:00 BST
$t->format('EEEE d MMMM y HH:mm zzzz');      # Thursday 15 October 2026 09:00 British Summer Time
$t->in_locale('fr')->format_date('full');    # jeudi 15 octobre 2026
$t->in_locale('ja')->format_datetime('long');   # 2026年10月15日 9:00:00 GMT+1
$t->in_locale('ar-EG')->format_date('medium');  # ١٥‏/١٠‏/٢٠٢٦, in the locale's digits
$t->in_locale('de')->format_skeleton('yMMMEd'); # Do., 15. Okt. 2026
$t->rfc2822;  $t->http_date;  $t->rfc9557;  $t->iso8601(form => 'week');

Relative time and intervals come from the same data, so they are right in every locale rather than in English with a dictionary:

$t->format_relative(to => $now);                         # 3 hours ago
$t->in_locale('fr')->format_relative(to => $now);        # il y a 3 heures
$t->minus(days => 1)->format_relative(to => $now, unit => 'day');   # yesterday
$t->format_interval($t->plus(days => 2), skeleton => 'yMMMd');      # Oct 15 – 17, 2026
Time::Keeper::Duration->new(hours => 1, minutes => 30)->format;     # 1 hour, 30 minutes
Time::Keeper::Duration->new(hours => 1, minutes => 5, seconds => 9)->format(style => 'digital');   # 1:05:09

Parsing

parse reads ISO 8601 in all its forms, RFC 3339 and 9557, the mail and HTTP dates, and @epoch. strptime reads back everything strftime writes; parse_cldr reads back everything format writes, in the locale given; and each has a try_ form that gives undef instead of dying.

Time::Keeper->parse('Thu, 15 Oct 2026 09:00:00 +0100');
Time::Keeper->strptime('15/10/2026 09:00', '%d/%m/%Y %H:%M', zone => 'Europe/London');
Time::Keeper->parse_cldr('jeudi 15 octobre 2026', 'EEEE d MMMM y', locale => 'fr');
Time::Keeper->try_parse('yesterday');      # undef

Dates without times

A birthday is not a nanosecond at midnight. Four plain classes hold the parts on their own, each with the arithmetic that makes sense for it:

my $d  = Time::Keeper::Date->new(year => 2026, month => 10, day => 15);    # 2026-10-15
my $tm = Time::Keeper::Time->new(hour => 23, minute => 30);
$tm->plus(hours => 1);                                                     # 00:30:00, it wraps
Time::Keeper::YearMonth->new(year => 2026, month => 10)->last_day;        # 2026-10-31
Time::Keeper::MonthDay->new(month => 2, day => 29)->in_year(2027, end_of_month => 'limit');   # 2027-02-28
$d->at($tm, zone => 'Europe/London');                                      # a Time::Keeper
$d->plus(hours => 3);                                                      # dies: a date has no clock

Living with the others

Values compare with <=> and ==, stringify, serialise through Storable, through FREEZE and THAW for Sereal and CBOR::XS, and through TO_JSON. from_object takes a DateTime, a Time::Piece or anything with utc_rd_values or an epoch, and DateTime's from_object takes a Time::Keeper:

Time::Keeper->from_object(object => $datetime);
DateTime->from_object(object => $t);

What the others do not do

Leap seconds. 23:59:60 UTC existed 27 times between 1972 and 2016, and a log line from one of those seconds is a real time. Time::Keeper accepts second => 60 at exactly those seconds, in any zone (it was 08:59:60 in Tokyo), and refuses it at any other. The difference of two values counts them. The list comes from the IERS bulletin, and leap_seconds_expire says how far it is good for. DateTime and Time::Piece cannot represent the second at all.

Nanoseconds and a billion years. Nine decimal places in and out, exact, and a calendar that runs from the year -999,999,999 to 999,999,999 without a special case.

Every locale. The 1,121 locale codes of CLDR 48, with their month and day names, date and time formats, skeletons, relative-time words, duration words, interval formats, list patterns, plural rules, first day of the week, weekend, and their own digits. DateTime::Locale has the names and formats; the rest, from "3 hours ago" to "Oct 15 – 17, 2026" to whether Friday is a weekend in Cairo, is not on CPAN in any locale but English.

Every calendar. Seventeen calendar ids, the thirteen arithmetic ones and the Chinese, Dangi and two astronomical Hijri calendars read from tables of what ICU computes, each with its names and formats in every locale:

my $h = $t->in_calendar('hebrew');                 # the same instant, read in another calendar
$h->format('d MMMM y');                             # 4 Heshvan 5787
$h->in_locale('he')->format_date('long');           # ד׳ בחשוון תשפ״ז
$t->in_calendar('japanese')->in_locale('ja')->format_date('long');   # 令和8年10月15日
$t->in_calendar('chinese')->in_locale('zh')->format_date('full');    # 2026丙午年九月初六星期四
$t->in_calendar('islamic-umalqura')->format('d MMMM y G');           # 4 Jumada I 1448 AH
Time::Keeper->new(year => 5787, month => 1, day => 1, calendar => 'hebrew', zone => 'Asia/Jerusalem');
$h->plus(years => 1);                               # 4 Heshvan 5788, Adar I stays Adar I where there is one
$h->rfc9557;                                        # 2026-10-15T09:00:00+01:00[Europe/London][u-ca=hebrew]
Time::Keeper::Calendar->preferred('IL');            # gregory hebrew islamic islamic-civil islamic-tbla

Arithmetic, the round-trip guarantee, formatting and parsing all hold in every calendar, and a Hebrew date in Hebrew comes out in Hebrew letters because that is what CLDR says a Hebrew date in Hebrew should be.

The zone engine, exposed. Time::Keeper::Zone is its own distribution, with tzdata 2026e compiled in, and answers questions a value cannot: every transition of a zone between two instants, the standard offset, whether a zone has DST in a year, the zones of a country and the country of a zone, and the Windows name for a zone and back. A value can ask next_transition, previous_transition, is_ambiguous and other_reading.

A clock for tests. local $Time::Keeper::CLOCK = $fixed pins now and today for one block, with no global and no CORE::GLOBAL::time hack that XS code never sees.

A C ABI. Another extension's C can read the clock, find a zone, turn an instant into a wall clock in any zone or any calendar and back, format and parse, and make a Time::Keeper value or read one Perl made, through one installed header found with ExtUtils::Depends. Nothing is linked against, the table is versioned, and the two distributions upgrade independently.

One answer to a mistake. Every method either does the thing or dies with the reason: a date that does not exist, a time the clocks skipped, a pattern letter a date has no field for, a calendar year outside its table. Nothing is silently clamped, wrapped or guessed unless you asked for that by name.

Getting it

Time::Keeper 0.05 and Time::Keeper::Zone 0.04 are on CPAN. They need perl 5.10 or later and a C compiler.

cpanm Time::Keeper::Zone Time::Keeper

Context::Vars: Perl variables with context scope

LNATION — Wed, 14 Oct 2026 17:47:38 +0000

Context::Vars is another new CPAN distribution I've published which solves a familiar problem in Perl programs. Some values belong to one request or one job: a request id, the current user, a tracing span. Code far down the call stack needs to read them, and so do callbacks that run later. Sometimes they need to be overriden within specific context.

The usual answers each fail in a different way. A global gets overwritten as soon as two requests are in flight on one event loop. local is undone when the sub returns, which is before a callback registered in it ever runs. Passing a $c everywhere works, until the logger, the database layer or the tracing library you did not write needs it too.

Context::Vars gives you a variable that holds a value per context, and the context follows the work: into every sub called, into callbacks, and across await.

use Context::Vars qw($request_id);

Context::Vars

A variable, imported

Every package that imports a name shares the one variable. What it reads is the value in the context current at that moment:

package My::Log;
use Context::Vars qw($request_id);

sub info { printf "[%s] %s\n", $request_id // '-', shift }

package My::App;
use Context::Vars qw($request_id);

sub handle {
    my ($req) = @_;
    $request_id = $req->{id};
    My::Log::info('start');
    load_user($req);
    My::Log::info('done');
}

sub load_user { My::Log::info('loading user') }

handle({ id => 'a1' });
My::Log::info('between requests');
handle({ id => 'b2' });

[a1] start
[a1] loading user
[a1] done
[-] between requests
[b2] start
[b2] loading user
[b2] done

The logger never takes an argument for the request. Between requests it reads nothing, because handle's assignment ended when handle returned.

The rule: an assignment belongs to the sub it is written in

use Context::Vars q{$variable};

$variable = 'one';

sub change {
    $variable = 'two';
    print "$variable\n";    # two
}

change();

print "$variable\n";        # one

An assignment holds until the sub it is written in returns, however it returns: falling off the end, return from inside a loop, die, goto &other, last out of the caller's loop. A block inside the sub does not end it. Every sub it calls sees it. Code outside any sub keeps what it assigns for the program.

It is like local, with two differences that matter: you do not have to write it, and it survives into callbacks.

Callbacks see the values of the moment they were wrapped

An event loop, a queue or a future runs a callback later, after other work has changed things. Wrap the callback, and it runs with the values of the moment it was wrapped:

my @queue;
sub later { push @queue, Context::Vars->wrap(shift) }

sub handle {
    my ($id) = @_;
    $request_id = $id;
    later(sub { My::Log::info('callback ran') });
}

handle('a1');
handle('b2');
$_->() for reverse @queue;

[b2] callback ran
[a1] callback ran

Without wrap, the same two callbacks print [-] callback ran twice. They run outside any request, and they never see another request's value instead of their own. Nothing is the worst answer, but it is never a wrong one.

async subs

Under Future::AsyncAwait, an async sub keeps its own values across await, however the waits interleave:

use Future::AsyncAwait;

my %pending;

async sub handle {
    my ($id) = @_;
    $request_id = $id;
    My::Log::info('waiting');
    await($pending{$id} = Future->new);
    My::Log::info('resumed');
}

my @f = (handle('a1'), handle('b2'));
$pending{b2}->done;
$pending{a1}->done;

[a1] waiting
[b2] waiting
[b2] resumed
[a1] resumed

Context::Vars does not depend on Future::AsyncAwait. If it is loaded, before or after, Context::Vars hooks into its suspend and resume.

Holding a context yourself

capture keeps the values every variable has now. run runs code with them:

use Context::Vars qw($user);

my $ctx;
sub login {
    $user = 'alice';
    $ctx = Context::Vars->capture;
    $user = 'alice, later';
}
login();

$ctx->get('user');                  # alice
$ctx->names;                        # user
$ctx->run(sub { "hello $user" });   # hello alice
$user;                              # undef: login has returned

local works too

use Context::Vars qw($level);

$level = 'info';
sub show { print "$level\n" }

{
    local $level = 'debug';
    show();     # debug
}
show();         # info

Arrays, hashes and whole structures

Arrays and hashes are imported the same way and follow the same rule. A push, an element stored or deleted, a whole assignment: each holds until the sub it is written in returns.

use Context::Vars qw(@trail %seen);

sub step {
    my ($name) = @_;
    push @trail, $name;
    $seen{$name}++;
    return "@trail";
}

sub handle {
    push @trail, 'handle';
    print step('validate'), "\n";   # handle validate
    print "@trail\n";               # handle
}

The rule goes all the way down. A plain hash or array stored in a context variable, at any depth, belongs to the context:

use Context::Vars qw(%seen $config);

%seen = (user => { roles => ['reader'] });

sub elevate {
    push @{ $seen{user}{roles} }, 'admin';
    print join(',', @{ $seen{user}{roles} }), "\n";   # reader,admin
}

elevate();
print join(',', @{ $seen{user}{roles} }), "\n";       # reader

$config = { level => 'info', db => { host => 'localhost' } };
sub tweak { $config->{db}{host} = 'replica' }
tweak();
print "$config->{db}{host}\n";                        # localhost

Objects and code references stored anywhere in such a structure are kept as the references they are, and shared, as their classes expect.

One thing that surprises people

A sub that only assigns a variable for its caller changes nothing the caller can see:

sub set_user { $user = shift }

sub handle {
    set_user('alice');
    print $user // 'undef', "\n";   # undef
    $user = lookup_user();          # do this instead
}

The assignment belongs to set_user, and set_user has returned. Return the value and let the caller assign it.

How it works

1. A context is a persistent map

A context is a map from variable name to value, and it is a HAMT::Map from the HAMT distribution: a persistent map, where an update returns a new map and leaves the old one exactly as it was, sharing almost all of its memory with it.

That is what makes everything else cheap. Keeping a context for a callback is copying one small struct onto the same tree. A sub that assigns gets a fresh copy, and its store copies the four or five nodes on one path. Every other context still points at the nodes it had.

There is one current context for each interpreter. Code at the top level, before anything has been assigned, runs in a shared empty one that is never written to.

2. The variable is a scalar with magic

use Context::Vars qw($request_id) puts one scalar into your package, the same scalar in every package that imports the name. It holds no value of its own. Reading it fetches request_id from the current context; assigning it stores into the current context. use strict accepts it as it accepts a name from use vars.

3. The scope is decided when the sub is compiled

"The sub it is written in" is lexical, so it is settled at compile time. When perl finishes compiling a sub it hands it to its optimiser, and Context::Vars hooks that. The hook walks the sub's op tree looking for a write to one of its variables: an assignment, .=, ++, chomp, push, an element store at any depth, local.

A sub that has one is given a scope. Its first statement is changed to open one, every time the sub is entered: a fresh copy of the current context becomes current, and putting the previous one back goes onto perl's save stack. That is the same stack local uses. However the sub is left, by return, die, goto or anything else, the save stack is unwound and the caller's context comes back.

A sub that only reads is left exactly as perl built it, and costs nothing extra to call.

This runs the same on every perl from 5.10 to 5.44. Getting there meant learning, among other things, that perl 5.14 and older optimise a map block as soon as they parse it, and that @{ $h{list} } is really a little block whose value is its last statement.

4. A callback carries its context

wrap captures the current context, one struct copy, and returns a sub that, each time it is called, makes a fresh copy of that capture current, calls your code, and restores whatever was current before. Because each call starts from a fresh copy, nothing one call does is seen by the next.

5. async subs

An async sub leaves by an ordinary return when it suspends at await, so its scope closes, which is right. Nothing reopens it when it is resumed, which would be wrong. Future::AsyncAwait has hooks that run around every suspend and resume. Context::Vars uses them to keep what the sub could see when it first suspended, and to make that current again for each stretch it runs.

6. Arrays and hashes are proxies over persistent data

A plain hash in a context is held as a HAMT map, and a plain array as a HAMT vector, at every level. What you read back is a hash or array tied to a path: the variable's name, then each key or index. Each access resolves the path against the current context. A change at any depth copies the nodes on the path from the variable down to the element, and stores the new top under the variable's name, in the current context.

The visible difference from an ordinary hash is identity: two reads of $seen{a} are two references, and == between them is false. Copy one out, { %{ $seen{a} } }, when you want an ordinary hash.

A C ABI for event loops

An event loop written in C can capture a context when a callback is registered and enter it when the callback runs, with no Perl call in between. The interface is one installed header, context_vars_abi.h, found through ExtUtils::Depends, and a loop needs three calls per callback:

cb->ctx = (VARS->capture)(aTHX);                  /* when it is registered */

ENTER;                                             /* when it runs */
(VARS->enter_copy)(aTHX_ cb->ctx);
call_sv(cb->code, G_DISCARD | G_EVAL);
LEAVE;

(VARS->release)(aTHX_ cb->ctx);                    /* when it is dropped */

C code can also read and write any variable, or any element of an array or hash at any depth, by name. Nothing is linked against: the table is looked up once at load time and is versioned, so the two distributions upgrade independently.

What it costs

Measured on an Apple M5 with perl 5.42:

	cost
read a variable	about 3x a package scalar, some 30 to 40 ns
assign one	about 6x a package scalar
call a sub that assigns once	under 2x the same sub using `local`
a C loop's capture, enter and release per callback, nothing assigned	4 to 5 ns
100,000 captures of a context holding ten values	a fifth of the memory of 100,000 hash copies
read or write one element of a context hash	some hundreds of ns, against tens for a plain hash

Scalars are cheap. Containers pay for being persistent and tied on every element access, so keep the large working data in ordinary lexicals and put in the context what genuinely belongs to it.

Getting it

Context::Vars 0.03 is on CPAN. It needs perl 5.10 or later, a C compiler and HAMT.

cpanm Context::Vars

HAMT: persistent maps, sets and vectors for Perl

LNATION — Wed, 14 Oct 2026 11:05:35 +0000

HAMT is a new CPAN distribution that gives Perl three persistent containers: HAMT::Map, HAMT::Set and HAMT::Vector. "Persistent" here means an update never changes the container you call it on. It returns a new one, and the old one stays exactly as it was.

That sounds expensive. With a Perl hash it is: to keep the old version you copy/clone the whole hash, so one change to a 100,000 key hash costs 100,000 copies. HAMT makes the same change by building four or five small nodes, and the new version shares everything else with the old one.

This is useful anywhere a program copies a hash or array only so it can change it safely.

A quick tour

Every update method returns a new container. The receiver never changes.

use HAMT::Map;

my $m  = HAMT::Map->new(a => 1, b => 2);
my $m2 = $m->set(c => 3);
my $m3 = $m2->set(a => 10)->delete('b');

$m->get('a');        # 1: $m is what it always was
$m->exists('c');     # false
$m2->get('c');       # 3
$m3->get('a');       # 10, and $m2 still says 1

Sets have the usual algebra:

use HAMT::Set;

my $s  = HAMT::Set->new(qw(a b c));
my $s3 = $s->add('d')->remove('a');

my $both   = $s->intersect($s3);
my $either = $s->union($s3);
my $mine   = $s->difference($s3);
$both->is_subset($s);       # true

Vectors index from zero and also join and cut cheaply:

use HAMT::Vector;

my $v    = HAMT::Vector->new(qw(a b c));
my $v2   = $v->push('d')->set(0, 'A');
my $both = $v->concat($v2);          # a b c A b c d
my $mid  = $both->slice(2, 3);       # c A b
my $more = $both->insert(1, 'x');    # a x b c A b c d

Calling an update in void context is almost always a habit carried over from hashes, so it warns and does nothing:

$m->set(k => 1);    # Useless use of HAMT::Map::set in void context

Comparing versions

Two versions of one map can be merged, compared or diffed. The cost is proportional to what differs between them, not to their size:

my $n = $old->diff($new, sub {
    my ($key, $was, $now, $kind) = @_;   # kind: add, remove or change
    print "$kind $key\n";
});

my $sum = $m->merge($other, sub {
    my ($key, $mine, $theirs) = @_;
    return $mine + $theirs;
});

Batches of updates

When you build a large map in one go, a transient skips the per step copying. It is changed in place, then closed into an ordinary map:

my $t = $m->transient;
$t->set("key$_" => $_) for 1 .. 100_000;
my $m2 = $t->persistent;      # $m is unchanged

Values are shared and read-only

A stored value is copied once and made readonly, and every version shares that one scalar. This is shallow: a stored array ref cannot be replaced, but the array it points to can still be changed. Store data you do not intend to change, or a HAMT container, which is safe all the way down.

How it works: the hash array mapped trie

HAMT stands for hash array mapped trie, the structure Phil Bagwell described in 2001 and that Clojure and Scala later made the standard for persistent maps. HAMT::Map uses the CHAMP refinement of it. The idea fits in a few steps.

1. The hash is the path

Every key is hashed to 64 bits. Suppose the low bits of "apple" hash as below. The trie reads that hash five bits at a time, and each five-bit group is a number from 0 to 31: which of 32 branches to take at that level.

hash of "apple"  ...  00111  10010  01101
                      level 2 level 1 root
                        7      18     13

So "apple" lives at position 13 of the root, then position 18 of that child, and so on down. A key only goes as deep as it needs to: it stops at the first level where no other key shares its prefix. With 32 branches per level, 100,000 keys need about four levels, and a million need about five.

The hash is seeded per process. Without a seed, anyone feeding keys into a map could choose keys that all share one path.

2. Nodes store only what is there

A node with 32 pointer slots, most of them empty, would waste a lot of memory. Instead each node has a 32-bit bitmap with one bit per position, and an array holding only the occupied positions. To find the slot for position p, count the set bits below p:

slot(p) = popcount(bitmap & ((1 << p) - 1))

popcount is a single CPU instruction on modern hardware, so this is as fast as indexing a full array. A node holding three things is allocated with room for about three, not 32.

CHAMP splits that bitmap in two. datamap marks positions holding a key and value; nodemap marks positions holding a child node. Entries are packed at the front of the array and children at the back, which keeps a node's entries together for fast iteration and makes equality checks simpler.

3. Inserting

Follow the hash down until one of three things happens:

The position is empty. Set its bit in datamap and put the entry there.
The same key is there. Replace its value.
A different key is there. Both keys share the hash bits so far, so make a new child node, move the old entry into it, and insert the new key into that child at the next five bits. Repeat if they still share bits.

Twelve levels use 60 bits of the hash. Two keys whose hashes agree on all 60 bits go into a small collision node: a plain list, searched one by one. With a decent hash this almost never happens.

Deleting runs the other way. When a child is left holding a single entry, that entry moves back up into its parent and the child is freed. So a given set of keys always produces the same tree shape, however it was built. That property matters later.

4. Path copying

This is the step that makes the structure persistent. An update never writes into an existing node. It copies only the nodes on the path from the root to the key, changes the copies, and points the new root at them. Every node off that path is shared, by pointer, between the old version and the new one.

$m2 = $m->set(apple => 2)

$m                                $m2

root                              root *
 |-- A                             |-- A            (the same node)
 |-- P                             |-- P *
 |    |-- apple: 1                 |    |-- apple: 2 *
 |    `-- C                        |    `-- C       (the same node)
 `-- B                             `-- B            (the same node)

* = allocated by the set

The new root, the one node on the path, and the node holding "apple" are new. A, B and C each exist once in memory, and both versions point at them.

At four levels deep, a set on a 100,000 key map allocates four small nodes. The other several thousand nodes are shared. Both versions are complete, independent maps, and each node is reference counted, so a node is freed when the last version using it goes away.

5. Why comparing versions is cheap

Path copying gives merge, equals and diff a shortcut. When two maps came from the same ancestor, every subtree they did not both change is the same node, at the same address. Comparing two identical pointers answers "are these subtrees equal?" without looking inside.

So $old->diff($new) walks both trees together and skips every shared node. It only descends where the pointers differ, which is along the paths that were actually updated. The canonical shape from step 3 is what makes this safe: two maps with the same keys always have the same shape, so differing subtrees can be compared position by position.

6. Not copying when nobody is looking

Copying a node is only needed if someone else can see it. Each node carries a reference count, and a node whose count is one belongs to a single version. A transient uses this: it edits nodes it owns in place and copies only those still shared with the map it came from. Building 100,000 keys through a transient therefore copies each node at most once, not once per key.

The vector: the same tree, read by position

HAMT::Vector uses the same 32-wide tree, with path copying, but indexes it by position instead of by hash. Values sit in leaves of 32. To find index i, take five bits of i per level, highest level first:

index 1000 = 00000 11111 01000
             root  child  leaf
              0     31     8

There is no bitmap here. A vector that has only been pushed to is dense: every leaf is full except the last, so the five bits are the slot.

The tail

The last 1 to 32 values are kept outside the tree in a leaf of their own, called the tail. A push adds to the tail and a pop takes from it, so nearly every push and pop touches one small node and no path. Only when the tail fills is it moved into the tree as a full leaf, one path copy per 32 pushes.

Relaxed nodes, for concat and slice

Joining two vectors, or cutting a slice out of one, leaves some nodes along the join or the cut only part full. Now the index bits no longer give the slot directly. Those nodes become relaxed: each carries a small table of how many values lie under its first child, its first two, and so on. A lookup guesses the child from the index bits, then steps forward along the table a place or two.

This is the RRB tree (relaxed radix balanced), from Bagwell and Rompf, 2011. To keep lookups close to the dense case, concat and slice repack the nodes along each seam until only a few spare slots remain. That keeps the tree's height near what a dense vector would have.

With concat and slice cheap, insert and remove in the middle of a vector follow for free: cut at the point, then join the pieces with the new values between them. No values that stay put are copied.

A C ABI for other XS modules

Everything the classes do from Perl can also be done from another extension's C, with no Perl call in between. The interface is one installed header, hamt_abi.h, found through ExtUtils::Depends:

my $pkg = ExtUtils::Depends->new('My::Module', 'HAMT');

Nothing is linked against. The function table is looked up once at load time and is versioned, so the two distributions can be upgraded independently.

Getting it

HAMT 0.02 is on CPAN. It needs perl 5.10 or later and a C compiler, and has no other dependencies.

cpanm HAMT

It is released under the Artistic License 2.0. Bug reports and ideas are welcome.

Game::Terminal: Perl game implementations in a terminal

LNATION — Sun, 11 Oct 2026 14:31:44 +0000

Recently I have been building https://peer2peergames.com, a site where two or more people play a board or card game against each other in a browser, each moving when they get round to it. Every game on it needs an engine: the rules, the endings, a bot to stand in when nobody else is online. So I wrote them, one dist at a time, each with the same discipline, the engine does no input and no output, a game is a pure function of its moves, and a terminal front end sits on top so I could play the thing before it had a web page. Cribbage was the one that existed before the site, everything after it was built for it.

That is how I have ended up with twenty plus terminal games and little memory of which script wanted which params.

So now I have one command.

$ cpanm Game::Terminal
$ game

That gives you a menu. Arrow keys move, enter plays, q leaves, and a letter jumps to the next game starting with it. When the game you picked ends, win or lose or you ragequit, the menu is back with a line saying what happened.

Game                                                            21 games

 > backgammon  board  2    backgammon
   brandubh    board  2    the Irish 7 by 7 tafl game
   checkers    board  2    English draughts
   chess       board  2    chess
   cribbage    card   2    cribbage
   dominoes    tile   2-4  draw dominoes with All Fives scoring
   durak       card   2    Podkidnoy Durak, the Russian beating game
   fanorona    board  2    the board game of Madagascar
   floppy      arcade 1    a one-button bird through a field of tubes
   gin         card   2    gin rummy
   go          board  2    Go
   mahjong     tile   4    Mahjong, Chinese Official rules
   maze        puzzle 1    mazes in the terminal
   merrills    board  2    Nine Men's Morris
   oware       board  2    the African sow and capture game, Abapa rules
   reversi     board  2    Reversi, with its 1883 opening
   royalur     board  2    the Royal Game of Ur
   schnapsen   card   2    Schnapsen
   sixtysix    card   2    Sixty-Six, the German parent of Schnapsen
   snake       arcade 1    the classic snake game
   xiangqi     board  2    xiangqi, Chinese chess

backgammon: Game::Backgammon::Terminal 0.03, options: game backgammon --help
checkers finished with status 1 (lost)

up and down to choose, enter to play, a letter to jump, q to quit

Yes, that last line of status is real. The checkers bot is not kind at level 4.

How it works

The obvious way to build a launcher is to exec the installed scripts. I did not do that, and the reason is the menu: I wanted it to come back when a game ends, and I wanted that to work the same on every platform without a shell in the loop.

So every game now has a class method with one boring, binding promise:

my $status = Game::Checkers::Terminal->run(@ARGV);

It parses its own options from the array it is given, plays, and returns the exit status: 0 if you won, drew or quit, 1 if you lost, 2 for a bad option. It never calls exit. Each game's bin/ script is now two lines, use and exit ...->run(@ARGV), and the launcher just requires the class and calls the same method in its own process.

If you have a terminal game of your own and you want it in the menu, that run contract is the whole price of admission. Return the status, do not exit, take your arguments as a list. The roster is data; adding a row is a pull request though.

Where this is going

The terminal is one skin over these engines. The other as mentioned is the one they were written for https://peer2peergames.com.

A mobile app for peer2peergames is in development and coming soon. Same games, same engines.

Until then, cpanm Game::Terminal installs all twenty one games.

Template::Stencil - A Fast Template Engine

LNATION — Sun, 30 Aug 2026 07:09:58 +0000

A template engine spends its life doing the same job over and over. The task does not change between request one and request one million. The variables do. Yet most engines re-derive some part of the page on every render: they walk a tree of node objects, they build and throw away intermediate strings and they allocate a fresh buffer per fragment.

Template::Stencil takes the other route. A template is parsed once into packed bytecode in a single memory arena, and rendered by a threaded C interpreter that writes straight into an SV-backed buffer. The scalar you get back is that buffer. At steady state a render performs no heap allocation and no system calls at all.

use Template::Stencil;

my $stencil = Template::Stencil->new(
    template_dir => 'templates',
    wrapper      => 'wrapper.tmpl',
);

my $html = $stencil->render('index', {
    title => 'Hello',
    items => [ { name => 'one' }, { name => 'two' } ],
});

<h1>{% title | upper %}</h1>
<ul>
{% for item in items %}<li>{% item.name %}</li>
{% end %}</ul>

One delimiter, one closer

Everything is {% %}. Every block closes with {% end %}. Whitespace inside the delimiters is insignificant, so {%name%} and {% name %} are the same tag.

Output tags

{% name %}              variable, HTML-escaped
{% page.header %}       dotted path through hashrefs
{% page.number[0] %}    array index; mixes freely: a.b[0][1].c
{% raw name %}          same resolution, no escaping
{% name | upper %}      filters

Auto-escaping is on and replaces < > & " ' with entities. raw is the opt-out. A missing or undefined path renders as the empty string, or croaks if you asked for strict.

Paths resolve innermost scope first: loop variables and set bindings shadow outer scopes, and the hashref you pass to render is the outermost scope. Paths go up to eight segments deep, and traversing through a blessed reference is an error - templates render data, they do not call methods.

Filters

{% name | upper %}
{% price | default('0.00') %}
{% summary | trim | lower %}

Filters chain left to right. Escaping happens once, after the last filter, unless the tag is raw or the chain ends in html. Nothing is ever double-escaped, though a filter that runs after html re-escapes, because it changed the bytes.

The built-ins are all C:

filter	does
`upper`	uppercase (ASCII fast path, UTF-8 aware)
`lower`	lowercase
`trim`	strip leading and trailing whitespace
`html`	HTML-escape now, and mark the value escaped
`uri`	RFC 3986 percent-encoding of the component
`default(x)`	replace undef or `''` with the literal `x`
`fmt(f)`	sprintf with exactly one conversion

fmt is the number formatter:

{% price | fmt('$%.2f') %}      $1.50
{% id    | fmt('%08d')  %}      00000042
{% hash  | fmt('%x')    %}      deadbeef

The format is one sprintf conversion from diouxXeEfgGs, with the usual flags, width and precision, surrounded by any literal text. It is validated when the template compiles, so a second conversion, a *, a length modifier, %n or an oversized width is a compile-time error rather than a render-time surprise. Integer conversions cover the full IV/UV range on every platform, and %s with a precision counts bytes without leaving a broken UTF-8 sequence behind.

Your own filters are coderefs registered on the constructor:

filters => { money => sub { sprintf '%.2f', $_[0] } }

{% price | money %}
{% s | repeat(3) %}     # coderef called as ->($value, 3)

An argument is a single string or number literal. An unknown filter name is a compile-time error that lists what is registered, and a die inside a filter becomes a render error carrying the filter name and the template location.

User filters are the escape hatch, not the fast path. Crossing the Perl call boundary is roughly 100ns before the body of your sub runs, where a built-in is free. If the coderef is only a sprintf, use fmt.

Conditionals

{% if expr %} ... {% elsif expr %} ... {% else %} ... {% end %}
{% unless expr %} ... {% end %}

The expression grammar is deliberately small - no arithmetic, no concatenation:

operands     paths, numbers (42, 3.14, -2), strings ('a' or "a"), undef
numeric      ==  !=  <  >  <=  >=
string       eq  ne  lt  gt  le  ge
boolean      && / and,  || / or,  ! / not,  ( ... )
other        defined(path)

&& and || short-circuit and yield the deciding operand, exactly like Perl. Comparison operators are typed at compile time from how they are spelled: == compares numerically, eq compares strings, and the VM never has to guess.

Truthiness follows Perl - undef, 0, '' and '0' are false - with one deliberate extension: an unblessed empty arrayref or hashref is false too, so {% if items %} guards a loop the way you would expect it to.

Loops

{% for item in items %} ... {% end %}
{% for key, value in hash %} ... {% end %}

Arrays bind each element. Hashes bind key and value and iterate in sorted key order by default, so output is deterministic; sort_keys => 0 gives you raw hash order. Iterating undef or an empty aggregate renders nothing.

Inside a loop there is an implicit loop variable:

loop.index    0-based index          loop.first   true on first
loop.index1   1-based index          loop.last    true on last
loop.size     total iterations       loop.even    parity of index1
loop.key      current key (hash)     loop.odd     parity of index1

loop always means the innermost loop. To reach an outer one, capture it:

{% for item in items %}
  {% set item_loop = loop %}
  {% for x in item.list %}
    {% item_loop.index %} / {% loop.index %}
  {% end %}
{% end %}

Assignment

{% set name = expr %}

The value is any expression from the grammar above, and the binding lives in the current block scope. A set inside a for body is fresh each iteration and gone after the {% end %}; a set inside an if branch dies with the branch; a top-level set lasts to the end of the template. Bindings shadow your data without modifying it - the hashref you passed to render is never touched.

Includes

{% include header.tmpl %}
{% include header %}        # .tmpl appended when the name has no dot

The name is static and resolves against template_dir. An include shares the current scope, so it sees loop variables, set bindings and the root data exactly as the include site does. Includes are compiled once and linked, and revalidate independently: editing an include takes effect without recompiling everything that includes it. Cycles are a compile-time error naming the cycle, and absolute paths and .. segments are refused.

Wrapper

my $stencil = Template::Stencil->new(wrapper => 'wrapper.tmpl');

<html><body>{% content %}</body></html>

With a wrapper configured, render runs the wrapper and {% content %} renders the requested template at that point. This is one pass into one buffer, with no intermediate string for the inner page. The wrapper sees the same data. Override per render with { wrapper => 'other.tmpl' } or disable it with { wrapper => undef }.

A wrapper without a {% content %} is refused at compile time, rendering a template that contains {% content %} directly is a render error, and {% content %} runs exactly once.

Comments and literal braces

{%# anything, up to the first closing percent-brace %}

Comments are stripped at compile time and may span lines. A literal {% in output is written {%%}, the empty tag. A bare %} or } in text needs no escaping at all.

The Perl API

new

my $stencil = Template::Stencil->new(%options);
my $stencil = Template::Stencil->new(\%options);

Unknown option names croak, which is the theme: things that are knowable when you build the engine are checked when you build the engine.

option	default	meaning
`template_dir`	none	base directory for file templates and includes
`wrapper`	none	default layout template
`filters`	`{}`	user filter registry, every value a coderef
`auto_escape`	`1`	HTML-escape output tags
`strict`	`0`	croak on an undef or missing value, with the path and location
`cache`	`1`	cache compiled templates
`cache_size`	`256`	bound on cached string-keyed templates, LRU evicted
`stat_ttl`	`1`	seconds between mtime revalidations of cached files
`sort_keys`	`1`	deterministic sorted hash iteration
`chars`	`0`	return a character string instead of UTF-8 bytes
`pretty`	`0`	re-indent the rendered HTML through Eshu

stat_ttl is the production knob. 0 stats on every render, the default 1 stats at most once a second per template, and a negative value never re-checks at all, which is what gets you to zero syscalls at steady state. File templates are cached with mtime revalidation; string templates are cached by content hash in the bounded LRU.

pretty loads Eshu on first use. It is an optional dependency: asking for pretty without it is an error, and never asking for it costs nothing. Budget around 1.5 microseconds per KB when you do.

render

my $out = $stencil->render($template, \%data);
my $out = $stencil->render($template, \%data, \%opts);

$template is either source or a file name. The rule is mechanical: an argument with no newline and no {% that resolves to a file - under template_dir, or relative to cwd, with .tmpl inferred - renders that file, and anything else is treated as source. Rendering equal content as a string and as a file produces byte-identical output.

\%data is the root scope and is optional; anything that is not a hashref croaks. \%opts overrides wrapper, strict and pretty for this one render, and unknown keys croak.

The return value is the render buffer itself, a fresh scalar each call, which is exactly what you want to hand to a PSGI body arrayref.

One detail worth knowing: a statically resolved call, written Template::Stencil::render($s, ...), is rewritten at compile time by a call checker onto a direct C entry point, skipping the usual XSUB dispatch. Method calls take the ordinary path. Both produce identical results, and the benchmark below uses the static form because a hot loop in a real application would.

Template::Stencil::PSGI

The small conveniences that everyone writes anyway:

use Template::Stencil::PSGI;

my $view = Template::Stencil::PSGI->new(
    template_dir => 'templates',
    wrapper      => 'wrapper.tmpl',
);

# a finished PSGI response tuple, Content-Length included
my $res = $view->res('index', { title => 'Hi' });

# or a tiny routed app
my $app = $view->to_app({
    '/'      => [ 'index', sub { my $env = shift; { title => 'Hi' } } ],
    '/about' => 'about',
});

new takes exactly the Template::Stencil options, stencil hands back the underlying object, res($template, \%data, $status, \@headers) builds the tuple, and to_app(\%routes) gives you an app where a route value is either a template name or [$template, \%data | sub ($env) { ... }]. Unknown paths get a 404.

Encoding, errors, concurrency

Encoding is the engine's job. Callers never utf8::encode. By default render returns wire-ready UTF-8 bytes: UTF8-flagged values pass through, unflagged latin-1 values and templates containing high bytes are upgraded automatically, and uri percent-encodes UTF-8 bytes. length($out) is therefore the correct Content-Length, which is the entire point. Template files are expected to be UTF-8 or ASCII on disk. For non-web use, chars => 1 returns a flagged character string instead.

Errors croak with the template name, a line, a column for compile errors, and a message:

Template::Stencil: templates/page.tmpl:12:5: unclosed 'if' block
Template::Stencil: header.tmpl:2: undef value for 'user.name'

An error inside an include or a wrapper names the failing file, not the page that pulled it in. Unclosed blocks report the opener's position, and mismatched constructs name both ends.

Concurrency is one engine per interpreter. Nothing is shared, so nothing is locked, and there are no locks anywhere in the codebase. A preforking server constructs the object before or after fork and each child gets a private copy either way. Under ithreads a cloned object lazily rebuilds its own engine, with an empty cache, from its cloned options on first use.

What it will not do

The honest list.

Blessed references cannot be traversed in paths. No method calls in templates; the engine renders data.
Empty unblessed aggregates are false in conditions. This is a documented extension to Perl truthiness, not an accident.
Hash-loop key order is sorted bytewise by default.
The reserved words if unless elsif else end for set include raw content in cannot be used in the first position of a tag, or as a for or set binding name. They work fine as data keys.
Dynamic include names, wrapper chains, arithmetic in expressions, context-aware escaping for attributes/JS/URLs, i18n and streaming render are all reserved hook points, not shipped features.

The numbers

The distribution ships bench/compare.pl, which renders the same reference page in every engine it can find installed:

perl -Mblib bench/compare.pl

The page is about 1 KB - a title, a heading with characters that actually need escaping, a conditional, a paragraph of filler and a ten-item loop over hashrefs. Every engine gets its own idiomatic spelling of that page, with caching turned on and warmed, and HTML escaping on where the engine makes it optional. On my machine:

engine	ops/sec	ns/op	relative
Template::Stencil	1,442,829	693	1.00x
Text::Xslate	559,685	1,787	2.58x
hand-written perl	190,015	5,263	7.59x
Template::Toolkit	42,658	23,442	33.82x
Text::Template	35,213	28,398	40.97x
HTML::Template	22,984	43,509	62.78x

Where it is

Template::Stencil is on CPAN. It needs Perl 5.10.1 and a C compiler, builds on Linux, macOS, the BSDs and Windows (MSVC included), and has no runtime dependencies at all. Eshu is optional and only for pretty.

It is young. The syntax is settled and I do not intend to grow it much - the small grammar is the feature - but the edges are not. If you try it and something is wrong or missing, I would like to hear about it.

Punk: Fully Authed

LNATION — Sat, 22 Aug 2026 20:22:46 +0000

Authentication is where a web framework's promises get tested, because every entry point of it is a door. A password form, a verification link in a mail, a reset link, a "continue with GitHub" button and a six-digit code from a phone all end in the same sentence - "this session belongs to that user".

This guide builds one application with all of those doors on it, from punk new to a passing test suite, using four pieces of the Punk ecosystem: Punk::Auth for the identity and the single-use tokens, Punk::Plugin::Mailer to send the tokens through Resend, Punk::Plugin::TOTP for the second factor, and Punk::Plugin::OAuth2 for GitHub and Google.

What you are building

Twenty routes, and this is all of them:

METHOD  PATH                      TARGET
GET     /login/totp               native handler
POST    /login/totp               native handler
GET     /auth/:provider           sub {...} at OAuth2.pm:56
GET     /auth/:provider/callback  sub {...} at OAuth2.pm:56
GET     /                         AuthApp::Controller::Web::Root::index
GET     /register                 AuthApp::Controller::Web::Auth::register_form
POST    /register                 AuthApp::Controller::Web::Auth::register
GET     /verify/:token            AuthApp::Controller::Web::Auth::verify
GET     /login                    AuthApp::Controller::Web::Auth::login_form
POST    /login                    AuthApp::Controller::Web::Auth::login
POST    /logout                   AuthApp::Controller::Web::Auth::logout
GET     /forgot                   AuthApp::Controller::Web::Auth::forgot_form
POST    /forgot                   AuthApp::Controller::Web::Auth::forgot
GET     /reset/:token             AuthApp::Controller::Web::Auth::reset_form
POST    /reset/:token             AuthApp::Controller::Web::Auth::reset
GET     /account                  AuthApp::Controller::Web::Account::home  [1 guard]
POST    /account/totp             AuthApp::Controller::Web::Account::enrol  [1 guard]
POST    /account/recovery         AuthApp::Controller::Web::Account::recovery  [1 guard]
GET     /vault/secrets            AuthApp::Controller::Web::Vault::secrets  [1 guard]
ANY     /static/*                 static root/static

That is punk routes on the finished app. The first four are not yours: the TOTP plugin mounts the challenge, the OAuth2 plugin mounts the provider hop and its callback. The rest is the application, and it is small: sign up and prove the address, sign in, forget and reset a password, enrol a phone, and one page - the vault - that opens only for a session holding both a signed-in user and a second factor passed since sign-in.

punk new AuthApp

cpanm Punk Punk::TOTP Punk::OAuth2 Punk::Mailer DBD::SQLite
punk new AuthApp
cd AuthApp

punk new writes a running application: an app.psgi that changes to its own directory before loading the class, a config/punk.yml with the views and static mount set and everything else commented, a two-line application class, one controller, a layout and a welcome template, a stylesheet, a test and a README. The class is the whole routing table:

package AuthApp;
use strict; use warnings; use Punk;
our $VERSION = '0.01';
config 'config/punk.yml';
get '/' => 'Web::Root#index';
1;

punk dev boots it on port 5000 and restarts on change. Two more generator calls give us the models and controllers we are about to fill in - the files they write are skeletons, and every one of them is replaced below:

punk generate model User
punk generate model AuthToken --table auth_tokens
punk generate controller Auth
punk generate controller Account
punk generate controller Vault

Everything Punk does, it does at to_app: routes are resolved, guard chains flattened, 'Web::Auth#login' turned into a coderef, the configuration read and every keyword checked. The consequence for the rest of this guide is that wiring mistakes are boot errors. A typo in a plugin option, a template a mail names that does not exist, a missing environment variable - each stops the process from starting, which is the cheapest moment to find out.

The app.psgi the generator wrote is kept. The first BEGIN is the generator's: it changes to the application root so the relative paths in the configuration resolve wherever the server was started from. lib/AuthApp.pm is loaded last, after both.

app.psgi:

#!/usr/bin/env perl

use strict;
use warnings;
use FindBin ();
use lib "$FindBin::Bin/lib";

BEGIN {
    chdir $FindBin::Bin or die "cannot chdir to $FindBin::Bin: $!\n";
}

use AuthApp;

AuthApp->to_app;

Secrets before sessions

Everything here rides on the session, and a session needs a secret. Mint one next:

export AUTHAPP_SESSION_KEY=$(punk secret)

and reference it from the configuration rather than writing it there. This is the finished config/punk.yml - the oauth and plugins blocks at the bottom belong to sections further down, and are explained there:

config/punk.yml:

# AuthApp configuration. Safe to commit: secrets are referenced here,
# never written here.
#
# Layered - this file, then punk.$PUNK_ENV.yml, then punk.local.yml, each
# merged over the last. Put deployment differences in the environment file
# and machine-local ones in punk.local.yml, which is gitignored.

views:
  Stencil:
    template_dir: root/templates
    wrapper: layout.tmpl

static:
  /static: root/static

# The application's canonical origin, declared once. The OAuth2 redirect
# URIs and every link in an outbound mail derive from it. Never taken from
# a request's Host header, which is attacker-supplied.
host: http://localhost:5000

# The database. SQLite, in a file under var/ that lib/AuthApp/Schema.pm
# creates at boot - Punk ships no migrations, so the schema lives with the
# application.
database:
  dsn: dbi:SQLite:dbname=var/authapp.db

# Signed cookie sessions, and single-use CSRF tokens over them. The secret
# belongs outside this file, like any other secret: `punk secret` mints
# one, and a missing AUTHAPP_SESSION_KEY is a boot error, not a default.
# The auth battery is declared in lib/AuthApp.pm, right after this file
# is applied.
session:
  secret:   { $env: AUTHAPP_SESSION_KEY }
  expires:  7d
  samesite: Lax

csrf: true

# OAuth2 registrations, read with secret('oauth.github_id') and so on. The
# callback URLs registered with each provider are <host>/auth/github/callback
# and <host>/auth/google/callback.
oauth:
  github_id:     { $env: AUTHAPP_GITHUB_ID }
  github_secret: { $env: AUTHAPP_GITHUB_SECRET }
  google_id:     { $env: AUTHAPP_GOOGLE_ID }
  google_secret: { $env: AUTHAPP_GOOGLE_SECRET }

plugins:
  TOTP:
    issuer:         AuthApp          # names the account in the authenticator app
    login_path:     /login           # an unauthenticated step-up goes here
    render:         totp_page        # the challenge page, as a helper of ours
    recovery_model: AuthToken        # recovery codes share the token table

{ $env: NAME } is resolved at boot from outside the file; $app->config shows [redacted] in its place, so the configuration can be logged. There is no default syntax, and that is the point: an application that boots with an empty session key because nobody set the variable is an application whose sessions anyone can forge, so it does not boot.

csrf: true is the bare form of the keyword, the same as writing csrf; in the class; a mapping there carries its options (keep, exempt, the field and header names). One keyword does go in the class rather than the file, immediately after the file is applied, because it reads better beside the routes that use it: lib/AuthApp.pm

config 'config/punk.yml';

# The authentication battery: who the signed-in user is (User), where
# single-use tokens live (AuthToken - verification and reset links, and the
# TOTP plugin's recovery codes), and where a guard sends a stranger.
auth model       => 'User',
     token_model => 'AuthToken',
     login_path  => '/login';

With csrf on, every POST, PUT, PATCH and DELETE must carry a live token and using one spends it. The token is not injected into your templates - copying a hashref per render to add one key would tax every page for the sake of the ones with forms - so you pass $c->csrf_field to the view and print it with {% raw csrf %}. A helper further down does that once for every page. One consequence worth knowing before it surprises you: the default keeps one live token per session, so the same form open in two tabs submits once. csrf keep => 3 relaxes that.

A database and two models

Punk ships no migrations. The shipped model backend is plain DBI, and the schema is yours to create - here, at boot, so the application runs from a fresh checkout:

lib/AuthApp/Schema.pm:

package AuthApp::Schema;

use strict;
use warnings;
use DBI ();
use File::Basename ();

# The two tables the application needs, created on demand so it runs from a
# fresh checkout with nothing to set up first. Punk ships no migrations; a
# real application would keep them somewhere less casual than this.
#
# `users` is Punk::Auth's schema plus the three columns Punk::Plugin::TOTP
# reads and writes. `auth_tokens` is shared: verification and reset links
# (kinds `verify` and `reset`) and TOTP recovery codes (kind `totp_recovery`)
# are all rows in it, told apart by `kind`.

my @DDL = (
    <<'SQL',
CREATE TABLE IF NOT EXISTS users (
    id                INTEGER PRIMARY KEY AUTOINCREMENT,
    email             TEXT    NOT NULL,
    password_hash     TEXT,                          -- null: federated-only
    verified          INTEGER NOT NULL DEFAULT 0,
    totp_secret       TEXT,
    totp_last_counter INTEGER,
    totp_enabled      INTEGER NOT NULL DEFAULT 0,
    created           TEXT    NOT NULL
)
SQL
    'CREATE UNIQUE INDEX IF NOT EXISTS users_email ON users (lower(email))',
    <<'SQL',
CREATE TABLE IF NOT EXISTS auth_tokens (
    id      INTEGER PRIMARY KEY AUTOINCREMENT,
    user_id INTEGER NOT NULL,
    kind    TEXT    NOT NULL,
    digest  TEXT    NOT NULL,
    expires INTEGER NOT NULL
)
SQL
    'CREATE UNIQUE INDEX IF NOT EXISTS auth_tokens_digest ON auth_tokens (digest)',
);

sub ensure {
    my ($class, $dsn) = @_;
    die "AuthApp::Schema: no database dsn configured\n" unless $dsn;

    # dbi:SQLite:dbname=var/authapp.db - make sure var/ exists
    if ($dsn =~ /dbname=([^;]+)/) {
        my $dir = File::Basename::dirname($1);
        mkdir $dir unless -d $dir;
    }

    my $dbh = DBI->connect($dsn, undef, undef,
        { RaiseError => 1, AutoCommit => 1, PrintError => 0 });
    $dbh->do($_) for @DDL;
    $dbh->disconnect;
    return $dsn;
}

1;

password_hash is nullable on purpose. A user who arrives through GitHub has no password, and Punk::Auth's check_password is simply false for a null hash - it is a meaningful state, not a missing value. The token table holds only SHA-256 digests; the plaintext of a token exists in the link that was mailed and nowhere else.

The users row is Punk::Auth's four columns plus three the TOTP plugin owns, and the model declares every one of them, because the DBI backend writes only declared fields:

lib/AuthApp/Model/User.pm:

package AuthApp::Model::User;

use Punk::Model;

table 'users';

# Every column is declared, because the DBI backend writes only declared
# fields: a column left out here is a column that can never be written.
# Punk::Auth reads email, password_hash and verified; Punk::Plugin::TOTP
# reads and writes the three totp_ columns - the counter as a number,
# which is what the plugin hands back.
field id                => { type => 'integer', primary => 1 };
field email             => { type => 'string', required => 1 };
field password_hash     => { type => 'string' };
field verified          => { type => 'integer' };
field totp_secret       => { type => 'string' };
field totp_last_counter => { type => 'number' };
field totp_enabled      => { type => 'integer' };
field created           => { type => 'string' };

1;

The token model is the same shape over auth_tokens:

lib/AuthApp/Model/AuthToken.pm:

package AuthApp::Model::AuthToken;

use Punk::Model;

table 'auth_tokens';

# Punk::Auth's token table: only the SHA-256 digest of a token is stored,
# and a row is deleted the moment it is presented, valid or not. Verification
# and reset links live here, and so do the TOTP plugin's recovery codes.
field id      => { type => 'integer', primary => 1 };
field user_id => { type => 'integer' };
field kind    => { type => 'string' };
field digest  => { type => 'string' };
field expires => { type => 'integer' };

1;

Both are discovered automatically: anything under AuthApp::Model:: registers without a model line.

Wiring auth

The application class, after the keywords above, installs three helpers. The first draws every page through the layout with the same four things - who is signed in, the one-request notice the last action left in the flash, and the CSRF field:

helper page => sub {
    my ($c, $template, $vars, %opt) = @_;
    my $flash = $c->flash || {};
    return $c->render($template, {
        user   => $c->current_user,
        notice => $flash->{notice},
        kind   => $flash->{kind} // 'ok',
        csrf   => $c->csrf_field,
        %{ $vars || {} },
    }, %opt);
};

$c->current_user loads the row once per request and memoises it; $c->flash reads what the previous request set. The layout prints the nav from user and the notice when there is one, and every form in every template carries {% raw csrf %}.

Here is that layout, the welcome page it wraps, and the controller behind the front page:

root/templates/layout.tmpl:

<!doctype html>
<html lang="en">
<head>
<meta charset="utf-8">
<meta name="viewport" content="width=device-width, initial-scale=1">
<title>{% title | default('AuthApp') %}</title>
<link rel="stylesheet" href="/static/style.css">
</head>
<body>
<header>
  <h1><a href="/">AuthApp</a></h1>
  <nav>
{% if user %}
    <span>signed in as <code>{% user.email %}</code></span>
    <a href="/account">Account</a>
    <a href="/vault/secrets">Vault</a>
    <form method="post" action="/logout">{% raw csrf %}<button>Sign out</button></form>
{% else %}
    <a href="/login">Sign in</a>
    <a href="/register">Create an account</a>
{% end %}
  </nav>
</header>

{% if notice %}<p class="notice {% kind %}">{% raw notice %}</p>{% end %}

<main>
{% content %}
</main>
</body>
</html>

root/templates/welcome.tmpl:

<h2>Passwords, mail, a second factor and social login</h2>
<p>One Punk application with every door on it: create an account and prove
the address by mail, sign in with a password or with GitHub or Google,
enrol a phone as a second factor, and reach a page that only a session
holding both can open.</p>
{% if user %}
<p>You are signed in. The <a href="/account">account page</a> is where the
second factor is enrolled; <a href="/vault/secrets">the vault</a> is what
it protects.</p>
{% else %}
<p><a href="/register">Create an account</a> or <a href="/login">sign in</a>.</p>
{% end %}

lib/AuthApp/Controller/Web/Root.pm:

package AuthApp::Controller::Web::Root;

use strict;
use warnings;
use parent 'Punk::Controller';

our $VERSION = '0.01';

sub index {
    my ($c) = @_;
    return $c->page('welcome');
}

1;

__END__

=head1 NAME

AuthApp::Controller::Web::Root - the front page

=cut

The stylesheet is the demo's only one - system fonts, light and dark, nothing else:

root/static/style.css:

/* The demo's one stylesheet: system fonts, light and dark, nothing else. */
:root { color-scheme: light dark }
body { font: 16px/1.5 system-ui, sans-serif; max-width: 40rem;
       margin: 3rem auto; padding: 0 1rem }
header { display: flex; flex-wrap: wrap; justify-content: space-between;
         align-items: baseline; gap: 1rem; margin-bottom: 1.5rem }
header h1 { margin: 0 }
header h1 a { color: inherit; text-decoration: none }
nav { display: flex; gap: 1rem; align-items: center; font-size: .9rem }
nav form { margin: 0; display: inline }
h2 { margin-top: 2rem }
code { user-select: all }
form.stack { display: flex; flex-direction: column; gap: .75rem;
             max-width: 22rem; margin: 1rem 0 }
form.stack label { display: flex; flex-direction: column; gap: .25rem }
form.row { display: flex; gap: .5rem; margin: 1rem 0; align-items: center }
input { font: inherit; padding: .5rem .75rem }
button, a.button { font: inherit; padding: .5rem 1rem; border-radius: 6px;
                   border: 1px solid currentColor; background: none;
                   color: inherit; text-decoration: none; cursor: pointer }
p.row { display: flex; gap: .5rem; flex-wrap: wrap }
.qr { width: 16rem; max-width: 80vw; margin: 1rem 0 }
.qr svg { width: 100%; height: auto; display: block;
          background: #fff; border-radius: 8px }
ul.status { list-style: none; padding: 0 }
li, .notice { padding: .35rem .6rem; border-radius: 6px; margin: .25rem 0 }
.ok    { background: #1a7f3722 }
.bad   { background: #b3261e22 }
.quiet { opacity: .8 }
small  { opacity: .6 }

The password door is in lib/AuthApp/Controller/Web/Auth.pm:

sub login {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $pw    = $c->param('password') // '';
    my $user  = $c->model('User')->get(email => $email);

    # check_password burns the same work when there is no user, so the
    # response time does not say whether the address exists
    return $c->page('auth/login',
        { email => $email, error => 'Wrong email or password.' })
        unless $c->check_password($user, $pw);
    return $c->page('auth/login',
        { email => $email, error => 'Verify your address first - the link is in your mail.' })
        unless $user->{verified};

    if (Punk::Auth::Password::needs_rehash($user->{password_hash})) {
        $c->model('User')->update({ id => $user->{id},
            password_hash => Punk::Auth::Password::hash($pw) });
    }
    return $c->sign_in($user, to => $c->safe_path($c->param('to'), '/account'));
}

Three things here are the battery's, not ours. check_password takes undef for the user and burns a full PBKDF2 verification before saying no, so the timing of a wrong password and the timing of an unknown address are the same. needs_rehash is the opportunistic cost upgrade: when the hashing parameters are raised in a later release, each user's hash moves to the new cost on their next successful login, with no migration. And safe_path guards the ?to= that auth_guard writes when it redirects a stranger to the login: the value a login form reads back is whatever the browser sent, and someone else may have written that link, so anything that is not a same-origin relative path becomes /account.

The form it reads, with the social buttons and the hidden to that auth_guard filled in:

root/templates/auth/login.tmpl:

<h2>Sign in</h2>
{% if error %}<p class="notice bad">{% error %}</p>{% end %}
<form method="post" action="/login" class="stack">
  {% raw csrf %}
  <input type="hidden" name="to" value="{% to %}">
  <label>Email <input name="email" type="email" value="{% email %}" autofocus required></label>
  <label>Password <input name="password" type="password" required></label>
  <button>Sign in</button>
</form>
<p class="row">
  <a class="button" href="/auth/github">Continue with GitHub</a>
  <a class="button" href="/auth/google">Continue with Google</a>
</p>
<p><small><a href="/forgot">Forgotten your password?</a> -
<a href="/register">No account yet?</a></small></p>

The guard itself is one line in the class:

# Signed in: the account page, enrolment and recovery codes.
my $account = under '/account' => auth_guard;
$account->get ('/'         => 'Web::Account#home');
$account->post('/totp'     => 'Web::Account#enrol');
$account->post('/recovery' => 'Web::Account#recovery');

auth_guard negotiates on Accept: a browser is redirected to login_path with ?to= set, anything else gets a 401 in the house error shape. The common case - is anyone signed in - runs entirely in C, one session load and one hash fetch, and every route under the scope inherits it without a per-action check.

Mail through Resend

Verification and reset links need a way out of the process. The mailer plugin takes one transport and makes it the application's:

# Outbound mail. With RESEND_API_KEY in the environment every message goes
# through Resend; without it the capture transport keeps each one under
# var/mail/new/ as a .eml file - what `punk dev` and the tests read. Links
# in every mail are built on the `host` declared in punk.yml.
my $resend = $ENV{RESEND_API_KEY};
plugin 'Mailer' => {
    transport => $resend ? 'resend' : 'capture',
    from      => $ENV{AUTHAPP_MAIL_FROM} // 'AuthApp <no-reply@example.com>',
    mail_dir  => 'root/mail',                  # base defaults to `host`
    $resend ? (resend  => { api_key => $resend })
            : (capture => { dir => 'var/mail' }),
};

Resend needs two things from you: an API key, and a sending domain you have verified in its dashboard, with from on that domain. With both in the environment, every message is a POST to Resend's API through Fetch, and the Result the helpers return says what happened - accepted with Resend's message id, or deferred for a 429 and rejected for anything else the API refused. Nothing dies for what happened on the wire; a malformed message is the only croak.

Without the key, the capture transport keeps every message as a .eml file under var/mail/new/, which is what a development box wants: open it in a mail client, or read the link straight out of it. The tests read the same transport in memory. The third rung, transport => 'log', writes each message to STDERR and records it as unsent, for a box that should not keep mail on disk either.

The mail templates live under mail_dir, one message per name: verify.txt.tmpl for the text part, verify.html.tmpl beside it for an HTML alternative if you want one. The directory is read once when the plugin registers, so a template that names nothing there is a croak listing what does exist.

Verification links with mail_token

Sign-up creates the user unverified and mails a link:

sub register {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $pw    = $c->param('password') // '';

    return $c->page('auth/register',
        { email => $email, error => 'Enter a valid email address.' })
        unless _valid_email($email);
    return $c->page('auth/register',
        { email => $email, error => "Use at least $MIN_PASSWORD characters." })
        if length $pw < $MIN_PASSWORD;

    # An address that already has an account gets the same page and no
    # mail: the response must not say which addresses are registered.
    my $users = $c->model('User');
    my ($result, $link);
    unless ($users->get(email => $email)) {
        my $user = $users->create({
            email         => $email,
            password_hash => Punk::Auth::Password::hash($pw),
            verified      => 0,
            totp_enabled  => 0,
            created       => _now(),
        });
        ($result, $link) = $c->mail_token($user,
            kind     => 'verify',
            ttl      => 2 * 24 * 60 * 60,
            path     => '/verify/%s',
            template => 'verify',
            subject  => 'Verify your AuthApp account',
        );
    }
    return $c->page('auth/sent', {
        kind     => 'verify',
        email    => $email,
        sent     => ($result && $result->accepted) ? 1 : 0,
        dev_link => $c->app->env eq 'development' ? ($link // '') : '',
    });
}

mail_token is the composition the two batteries were built to meet at. It issues a single-use token through Punk::Auth's issue_token - storing the digest on the AuthToken model with the kind and an expiry - builds the link on the configured origin, renders the template with link, token and user, sends, and returns the Result and the link. The link comes back so a development page can show it when no mail is configured, which auth/sent.tmpl does under punk dev. The template is all text:

root/mail/verify.txt.tmpl:

One click and your AuthApp account is live:

    {% link %}

The link lasts 48 hours and works once. If you did not create an account
at {% base %}, ignore this mail - nothing happens without the click.

Redeeming it is take_token:

# The token is spent the moment it is presented, valid or not: a second
# click on the same link is a 410, not a second sign-in.
sub verify {
    my ($c) = @_;
    my $row = $c->take_token($c->param('token'), 'verify')
        or return $c->page('auth/verify', { ok => 0 }, status => 410);
    my $user = $c->model('User')->update({ id => $row->{user_id}, verified => 1 });
    $c->flash(kind => 'ok', notice => 'Your address is verified.');
    return $c->sign_in($user);
}

The order inside take_token is the feature: the row is deleted first and judged afterwards, so a token is spent whether or not it turns out to be the right kind or still in date. And issuing a new token of a kind invalidates the user's older ones, which is why a re-sent mail leaves exactly one live link rather than a trail of them.

The three pages around those two handlers - the form, the page after submit, and the one a spent link lands on (the reset flow reuses the last two):

root/templates/auth/register.tmpl:

<h2>Create an account</h2>
{% if error %}<p class="notice bad">{% error %}</p>{% end %}
<form method="post" action="/register" class="stack">
  {% raw csrf %}
  <label>Email <input name="email" type="email" value="{% email %}" autofocus required></label>
  <label>Password <input name="password" type="password" minlength="10" required></label>
  <button>Create account</button>
</form>
<p><small>A verification link is mailed to the address. Nothing works
until it is clicked.</small></p>

root/templates/auth/sent.tmpl:

<h2>Check your mail</h2>
{% if kind eq 'verify' %}
<p>If <code>{% email %}</code> is new here, a verification link is on its
way. It lasts 48 hours and works once.</p>
{% else %}
<p>If <code>{% email %}</code> has an account, a reset link is on its way.
It lasts 24 hours and works once.</p>
{% end %}
{% if dev_link %}
<p class="notice quiet">Development mode, so here is the link the mail
carries: <a href="{% dev_link %}">{% dev_link %}</a></p>
{% end %}

root/templates/auth/verify.tmpl:

<h2>That link has been used</h2>
<p>A link works once and for a limited time. This one is spent, or it was
never valid.
{% if kind eq 'reset' %}<a href="/forgot">Ask for a new reset link.</a>
{% else %}<a href="/login">Sign in</a>, or <a href="/register">create an account</a>.{% end %}</p>

Forgotten passwords

The reset flow is the same two halves with a different kind. The request side answers every address identically:

# The same page whatever the address: an answer that differed would be a
# way to list accounts one address at a time.
sub forgot {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $user  = _valid_email($email) ? $c->model('User')->get(email => $email) : undef;
    my ($result, $link);
    ($result, $link) = $c->mail_token($user,
        kind     => 'reset',
        ttl      => 24 * 60 * 60,
        path     => '/reset/%s',
        template => 'reset',
        subject  => 'Reset your AuthApp password',
    ) if $user;
    return $c->page('auth/sent', {
        kind     => 'reset',
        email    => $email,
        sent     => ($result && $result->accepted) ? 1 : 0,
        dev_link => $c->app->env eq 'development' ? ($link // '') : '',
    });
}

The redeeming side is split in two, and the split matters. GET /reset/:token renders the form and leaves the token alone; only the POST with a new password spends it. Mail clients and link scanners fetch URLs they find in messages, and a link that died on the first GET would die in the preview pane before the user ever saw it:

sub reset {
    my ($c) = @_;
    my $token = $c->param('token');
    my $pw    = $c->param('password') // '';
    return $c->page('auth/reset',
        { token => $token, error => "Use at least $MIN_PASSWORD characters." })
        if length $pw < $MIN_PASSWORD;

    my $row = $c->take_token($token, 'reset')
        or return $c->page('auth/verify', { ok => 0, kind => 'reset' }, status => 410);
    my $user = $c->model('User')->update({
        id            => $row->{user_id},
        password_hash => Punk::Auth::Password::hash($pw),
        verified      => 1,                 # the mail reached them
    });
    $c->flash(kind => 'ok', notice => 'Your password is changed.');
    return $c->sign_in($user);
}

The password is checked before the token is taken, for the same reason: a typo should cost a second attempt, not a second mail.

The mail, and the two forms:

root/mail/reset.txt.tmpl:

Somebody - hopefully you - asked to reset the AuthApp password for
{% user.email %}. Choose a new one here:

    {% link %}

The link lasts 24 hours and works once. If it was not you, ignore this
mail - your password does not change until the link is used.

root/templates/auth/forgot.tmpl:

<h2>Reset your password</h2>
<form method="post" action="/forgot" class="stack">
  {% raw csrf %}
  <label>Email <input name="email" type="email" autofocus required></label>
  <button>Send a reset link</button>
</form>

root/templates/auth/reset.tmpl:

<h2>Choose a new password</h2>
{% if error %}<p class="notice bad">{% error %}</p>{% end %}
<form method="post" action="/reset/{% token %}" class="stack">
  {% raw csrf %}
  <label>New password <input name="password" type="password" minlength="10" autofocus required></label>
  <button>Change password</button>
</form>

One chokepoint for signing in

Every handler above ends in $c->sign_in, not $c->login. That is the third helper, and it is the most important dozen lines in the application:

# THE chokepoint: the one place an identity becomes a session. Password
# login, a verification link, a reset link and a social login all return
# through here, so a user who enrolled a second factor meets it whichever
# door they came in by - a mailed link cannot bypass the factor.
helper sign_in => sub {
    my ($c, $user, %opt) = @_;
    my $to = $opt{to} // '/account';
    return $c->totp_challenge($user, to => $to) if $user->{totp_enabled};
    $c->login($user);
    return $c->redirect($to);
};

A second factor gated only on the password form is a second factor with a side entrance: a reset link, a verification link and a social login each produce a signed-in session too, and each is a way round the factor unless they all funnel through the same decision. The TOTP plugin's own documentation says exactly this, and the application's test proves it - a reset link presented by an enrolled user lands on the challenge, not the account.

A second factor

The plugin is configured in the file, since nothing about it is code:

plugins:
  TOTP:
    issuer:         AuthApp          # names the account in the authenticator app
    login_path:     /login           # an unauthenticated step-up goes here
    render:         totp_page        # the challenge page, as a helper of ours
    recovery_model: AuthToken        # recovery codes share the token table

Two of those lines are about the tables. recovery_model names where recovery codes go - the plugin defaults to a model called Token, and ours is AuthToken, so it is said. And the three totp_ columns on the user row are the plugin's: the secret, the last accepted counter, and the enabled flag.

render names the challenge page, and it has to. The plugin ships a self-contained form so it works out of the box, but that form carries no CSRF token, and with csrf on the plugin's POST /login/totp is checked like any other. So the page is ours, drawn through the same page helper as everything else:

helper totp_page => sub {
    my ($c, $error) = @_;
    return $c->page('auth/totp', { error => $error ? 1 : 0 });
};

Enrolment lives on the account page, which is one of two pages depending on state:

sub home {
    my ($c) = @_;
    my $user = $c->current_user;

    if (!$user->{totp_enabled}) {
        # the pending secret lives in the session until a code proves it
        my $secret = $c->session->{totp_enrolling} //= $c->totp_secret;
        return $c->page('account/enrol', {
            secret => $secret,
            qr     => $c->totp_qr($secret),
        });
    }
    return $c->page('account/home', {
        passed => $c->session->{totp_at} ? 1 : 0,
    });
}

totp_qr renders the otpauth:// URI as an SVG through QR::Code, at the highest error correction level - an enrolment QR is scanned once, from a screen, by every phone the user will ever own. The secret is not on the user row yet. It sits in the session until a code proves the phone has it:

sub enrol {
    my ($c) = @_;
    my $user   = $c->current_user;
    my $secret = $c->session->{totp_enrolling} or return $c->redirect('/account');
    my $code   = $c->param('code') // '';
    $code =~ s/\s+//g;

    unless ($c->totp_verify({ %$user, totp_secret => $secret }, $code)) {
        $c->flash(kind => 'bad', notice => 'That code did not match. Try the next one.');
        return $c->redirect('/account');
    }
    $c->model('User')->update({ id => $user->{id},
        totp_secret => $secret, totp_enabled => 1 });
    delete $c->session->{totp_enrolling};
    $c->flash(kind => 'ok', notice => 'Second factor enabled. Keep some recovery codes.');
    return $c->redirect('/account');
}

totp_verify is replay-safe by construction: on success it writes the matched counter back through the User model before returning true, so the code that just enrolled the phone is already spent when the challenge page sees it thirty seconds later. The test checks that too.

The vault is the page that needs both halves:

# Signed in AND this session passed the second factor. A session that has
# not is stepped up to the challenge and comes back here afterwards.
my $vault = under '/vault' => totp_guard();
$vault->get('/secrets' => 'Web::Vault#secrets');

totp_guard() - with parentheses, because the plugin installs the keyword when it registers, which is after the package has been parsed - passes when this session recorded a passed factor since it was signed in. A signed-in session that has not is sent to the challenge with the page it wanted remembered, and returns there afterwards. A session that enrolled a phone a moment ago has not passed the challenge either; it is stepped up like any other, which is how the test reaches the vault.

Recovery codes are five single-use codes shown once, issued by totp_recovery_codes into the same AuthToken table under their own kind. They are deliberately not issue_token: that keyword revokes a user's older tokens of the same kind when it issues a new one, which is right for a mailed link and wrong for a drawer of codes that must all stay good until each is used.

The account controller in full - home and enrol from above, plus the recovery action - the vault controller, and the four templates they render:

lib/AuthApp/Controller/Web/Account.pm:

package AuthApp::Controller::Web::Account;

use strict;
use warnings;
use parent 'Punk::Controller';

our $VERSION = '0.01';

# Behind auth_guard, so $c->current_user is always a row here.

# Two pages by state: enrolment until a phone has proved it holds the
# secret, the account page afterwards.
sub home {
    my ($c) = @_;
    my $user = $c->current_user;

    if (!$user->{totp_enabled}) {
        # the pending secret lives in the session until a code proves it
        my $secret = $c->session->{totp_enrolling} //= $c->totp_secret;
        return $c->page('account/enrol', {
            secret => $secret,
            qr     => $c->totp_qr($secret),
        });
    }
    return $c->page('account/home', {
        passed => $c->session->{totp_at} ? 1 : 0,
    });
}

# Verified against the pending secret. On success the plugin has already
# written the matched counter to the row - the replay floor - so storing
# the secret and flipping the flag completes the enrolment. Until then the
# account has no second factor, whatever the session holds.
sub enrol {
    my ($c) = @_;
    my $user   = $c->current_user;
    my $secret = $c->session->{totp_enrolling} or return $c->redirect('/account');
    my $code   = $c->param('code') // '';
    $code =~ s/\s+//g;

    unless ($c->totp_verify({ %$user, totp_secret => $secret }, $code)) {
        $c->flash(kind => 'bad', notice => 'That code did not match. Try the next one.');
        return $c->redirect('/account');
    }
    $c->model('User')->update({ id => $user->{id},
        totp_secret => $secret, totp_enabled => 1 });
    delete $c->session->{totp_enrolling};
    $c->flash(kind => 'ok', notice => 'Second factor enabled. Keep some recovery codes.');
    return $c->redirect('/account');
}

# Five single-use codes, shown once. A new set revokes the old one.
sub recovery {
    my ($c) = @_;
    my $user  = $c->current_user;
    my $codes = $c->totp_recovery_codes($user, count => 5);
    return $c->page('account/home', {
        passed => $c->session->{totp_at} ? 1 : 0,
        codes  => $codes,
        notice => 'Recovery codes issued - any older set is revoked.',
        kind   => 'ok',
    });
}

1;

__END__

=head1 NAME

AuthApp::Controller::Web::Account - the account page, enrolment, recovery codes

=cut

lib/AuthApp/Controller/Web/Vault.pm:

package AuthApp::Controller::Web::Vault;

use strict;
use warnings;
use parent 'Punk::Controller';

our $VERSION = '0.01';

# Reached only through totp_guard: this session passed the second factor.
sub secrets {
    my ($c) = @_;
    return $c->page('vault/secrets', { title => 'The vault' });
}

1;

__END__

=head1 NAME

AuthApp::Controller::Web::Vault - the page behind totp_guard

=cut

root/templates/auth/totp.tmpl - the challenge page render: totp_page names, with the CSRF field the plugin's own form lacks:

<h2>Second factor</h2>
<p>The password passed. Enter the code your authenticator shows, or one of
your recovery codes.</p>
{% if error %}
<p class="notice bad">That code did not work. Try again, or use a recovery
code - repeated misses drop you back to the password.</p>
{% end %}
<form method="post" action="/login/totp" class="row">
  {% raw csrf %}
  <input name="code" autofocus autocomplete="one-time-code"
         inputmode="numeric" pattern="[0-9A-Za-z -]*"
         placeholder="000000 or a recovery code" aria-label="code">
  <button>Verify</button>
</form>

root/templates/account/enrol.tmpl:

<h2>Enrol a phone</h2>
<p>No second factor yet. Scan with Google Authenticator, 1Password, Aegis -
anything. Or add the secret by hand: <code>{% secret %}</code></p>

<div class="qr">{% raw qr %}</div>

<form method="post" action="/account/totp" class="row">
  {% raw csrf %}
  <input name="code" autofocus autocomplete="one-time-code"
         inputmode="numeric" pattern="[0-9]*" placeholder="000000"
         aria-label="code">
  <button>Confirm</button>
</form>
<p><small>Enrolment is not complete until one code proves the phone has the
secret - the account's second factor switches on only then.</small></p>

root/templates/account/home.tmpl:

<h2>Your account</h2>
<p>Second factor on. Every sign-in - password, a mailed link, GitHub or
Google - now goes through the challenge.</p>

<ul class="status">
{% if passed %}
  <li class="ok">this session passed the factor - <a href="/vault/secrets">the
  vault</a> opens</li>
{% else %}
  <li class="quiet">this session has not passed the factor yet -
  <a href="/vault/secrets">the vault</a> will ask for a code first</li>
{% end %}
{% if codes %}
  <li class="ok">recovery codes, shown once - put them somewhere safe:<br>
  {% for code in codes %}<code>{% code %}</code> {% end %}</li>
{% end %}
</ul>

<form method="post" action="/account/recovery" class="row">
  {% raw csrf %}
  <button>Issue 5 recovery codes</button>
  <small>a new set revokes the old one</small>
</form>

root/templates/vault/secrets.tmpl:

<h2>The vault</h2>
<p>You are reading this because this session holds both halves: a signed-in
user, and a second factor passed since it was signed in.
<a href="/account">Back to the account.</a></p>

Sign in with GitHub and Google

The plugin installs two keywords at compile time, so the use line matters:

use Punk;
use Punk::Plugin::OAuth2;      # compile time: installs the oauth2 / oauth2_login keywords

and the declarations are the provider presets plus your credentials:

plugin 'OAuth2';

oauth2 github => {
    preset        => 'github',
    client_id     => secret('oauth.github_id'),
    client_secret => secret('oauth.github_secret'),
};
oauth2 google => {
    preset        => 'google',
    client_id     => secret('oauth.google_id'),
    client_secret => secret('oauth.google_secret'),
};

oauth2_login '/auth' => {
    on_login => 'Web::Auth#on_login',
    base_url => host(),
};

secret('oauth.github_id') reaches the oauth: block of punk.yml, where each value is an { $env: ... } reference like the session key. host() with no argument reads the origin declared in the file back, so the callback URLs the plugin registers - /auth/github/callback and /auth/google/callback on that origin - are built from the same value the mail links are, and a request's Host header is consulted for neither.

Both providers need an application registered on their side. At GitHub, an OAuth App under developer settings with the callback URL http://localhost:5000/auth/github/callback; at Google, an OAuth client in the Cloud console with http://localhost:5000/auth/google/callback as an authorised redirect URI. The presets already ask for the scopes the identity needs - GitHub's read:user user:email, Google's openid email profile - and GitHub's identity is read from the emails endpoint, because a private primary address is GitHub's default.

oauth2_login mounts the hop and the callback, runs the authorization code flow with PKCE and single-use signed state, verifies Google's id_token against its JWKS, and calls your handler with a normalised identity. The handler is where a stranger becomes a user:

# Called by the OAuth2 plugin with a verified identity. Only an address the
# provider has itself verified may claim an account here; a returned
# reference becomes the response, so the redirect decision is sign_in's.
sub on_login {
    my ($c, $identity, $tokens) = @_;
    return $c->redirect('/login?error=oauth')
        unless $identity->{email_verified} && $identity->{email};

    my $email = _clean_email($identity->{email});
    my $users = $c->model('User');
    my $user  = $users->get(email => $email) // $users->create({
        email        => $email,
        verified     => 1,
        totp_enabled => 0,
        created      => _now(),
    });
    return $c->sign_in($user);
}

Find-or-create by a verified email is the composition Punk::Auth documents for federated sign-in, and the email_verified check is what makes it safe: an address the provider has not verified is an address anyone could have typed into a profile. Returning $c->sign_in($user) - a reference - makes it the response, which is how an enrolled user arriving from GitHub still meets the challenge. The tokens are handed over and then discarded; nothing token-shaped is kept in the session.

The application class and the auth controller, complete

Every keyword in the class and every handler in the auth controller has now been explained in its own section; here are both files whole, in the order the lines run. The class reads top to bottom as the boot does: the file is applied, auth is declared, the tables are ensured, the two plugins register, the three helpers are installed, and the routes are listed last.

lib/AuthApp.pm:

package AuthApp;

use strict;
use warnings;

use Punk;
use Punk::Plugin::OAuth2;      # compile time: installs the oauth2 / oauth2_login keywords
use AuthApp::Schema ();

our $VERSION = '0.01';

# Views, the static mount, the origin, the database, sessions, CSRF and
# the TOTP plugin all come from config/punk.yml. This file is the routing
# table and the wiring that has to be code.
config 'config/punk.yml';

# The authentication battery: who the signed-in user is (User), where
# single-use tokens live (AuthToken - verification and reset links, and the
# TOTP plugin's recovery codes), and where a guard sends a stranger.
auth model       => 'User',
     token_model => 'AuthToken',
     login_path  => '/login';

# The tables, created if they are missing. Punk ships no migrations.
AuthApp::Schema->ensure(punk_app->config_object->get('database.dsn'));

# Outbound mail. With RESEND_API_KEY in the environment every message goes
# through Resend; without it the capture transport keeps each one under
# var/mail/new/ as a .eml file - what `punk dev` and the tests read. Links
# in every mail are built on the `host` declared in punk.yml.
my $resend = $ENV{RESEND_API_KEY};
plugin 'Mailer' => {
    transport => $resend ? 'resend' : 'capture',
    from      => $ENV{AUTHAPP_MAIL_FROM} // 'AuthApp <no-reply@example.com>',
    mail_dir  => 'root/mail',                  # base defaults to `host`
    $resend ? (resend  => { api_key => $resend })
            : (capture => { dir => 'var/mail' }),
};

# Sign in with GitHub or Google. The presets carry the endpoints; the
# credentials come from the secrets system; the callback URLs are built
# from the one declared origin.
plugin 'OAuth2';

oauth2 github => {
    preset        => 'github',
    client_id     => secret('oauth.github_id'),
    client_secret => secret('oauth.github_secret'),
};
oauth2 google => {
    preset        => 'google',
    client_id     => secret('oauth.google_id'),
    client_secret => secret('oauth.google_secret'),
};

oauth2_login '/auth' => {
    on_login => 'Web::Auth#on_login',
    base_url => host(),
};

# Every page goes through the layout with the same four things: who is
# signed in, the one-request notice the last action left in the flash, and
# the CSRF field every form prints.
helper page => sub {
    my ($c, $template, $vars, %opt) = @_;
    my $flash = $c->flash || {};
    return $c->render($template, {
        user   => $c->current_user,
        notice => $flash->{notice},
        kind   => $flash->{kind} // 'ok',
        csrf   => $c->csrf_field,
        %{ $vars || {} },
    }, %opt);
};

# The second-factor challenge page, named by `render: totp_page` in
# punk.yml. The plugin's own default form carries no CSRF token, and with
# `csrf` on its POST is checked like any other - so the page is ours.
helper totp_page => sub {
    my ($c, $error) = @_;
    return $c->page('auth/totp', { error => $error ? 1 : 0 });
};

# THE chokepoint: the one place an identity becomes a session. Password
# login, a verification link, a reset link and a social login all return
# through here, so a user who enrolled a second factor meets it whichever
# door they came in by - a mailed link cannot bypass the factor.
helper sign_in => sub {
    my ($c, $user, %opt) = @_;
    my $to = $opt{to} // '/account';
    return $c->totp_challenge($user, to => $to) if $user->{totp_enabled};
    $c->login($user);
    return $c->redirect($to);
};

get  '/'               => 'Web::Root#index';

get  '/register'       => 'Web::Auth#register_form';
post '/register'       => 'Web::Auth#register';
get  '/verify/:token'  => 'Web::Auth#verify';
get  '/login'          => 'Web::Auth#login_form';
post '/login'          => 'Web::Auth#login';
post '/logout'         => 'Web::Auth#logout';
get  '/forgot'         => 'Web::Auth#forgot_form';
post '/forgot'         => 'Web::Auth#forgot';
get  '/reset/:token'   => 'Web::Auth#reset_form';
post '/reset/:token'   => 'Web::Auth#reset';

# Signed in: the account page, enrolment and recovery codes.
my $account = under '/account' => auth_guard;
$account->get ('/'         => 'Web::Account#home');
$account->post('/totp'     => 'Web::Account#enrol');
$account->post('/recovery' => 'Web::Account#recovery');

# Signed in AND this session passed the second factor. A session that has
# not is stepped up to the challenge and comes back here afterwards.
my $vault = under '/vault' => totp_guard();
$vault->get('/secrets' => 'Web::Vault#secrets');

1;

__END__

=head1 NAME

AuthApp - passwords, mail, a second factor and social login on Punk

=head1 DESCRIPTION

The application built in the guide beside this directory. Start it from
the application root:

    punk dev

=cut

lib/AuthApp/Controller/Web/Auth.pm:

package AuthApp::Controller::Web::Auth;

use strict;
use warnings;
use parent 'Punk::Controller';
use POSIX ();
use Punk::Auth::Password ();

our $VERSION = '0.01';

my $MIN_PASSWORD = 10;

sub _clean_email {
    my ($email) = @_;
    $email = lc($email // '');
    $email =~ s/\A\s+|\s+\z//g;
    return $email;
}

sub _valid_email { $_[0] =~ /\A[^@\s]+@[^@\s]+\.[^@\s]+\z/ }

sub _now { POSIX::strftime('%Y-%m-%dT%H:%M:%SZ', gmtime) }

# ---- sign up, then prove the address ---------------------------------------

sub register_form {
    my ($c) = @_;
    return $c->page('auth/register');
}

sub register {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $pw    = $c->param('password') // '';

    return $c->page('auth/register',
        { email => $email, error => 'Enter a valid email address.' })
        unless _valid_email($email);
    return $c->page('auth/register',
        { email => $email, error => "Use at least $MIN_PASSWORD characters." })
        if length $pw < $MIN_PASSWORD;

    # An address that already has an account gets the same page and no
    # mail: the response must not say which addresses are registered.
    my $users = $c->model('User');
    my ($result, $link);
    unless ($users->get(email => $email)) {
        my $user = $users->create({
            email         => $email,
            password_hash => Punk::Auth::Password::hash($pw),
            verified      => 0,
            totp_enabled  => 0,
            created       => _now(),
        });
        ($result, $link) = $c->mail_token($user,
            kind     => 'verify',
            ttl      => 2 * 24 * 60 * 60,
            path     => '/verify/%s',
            template => 'verify',
            subject  => 'Verify your AuthApp account',
        );
    }
    return $c->page('auth/sent', {
        kind     => 'verify',
        email    => $email,
        sent     => ($result && $result->accepted) ? 1 : 0,
        dev_link => $c->app->env eq 'development' ? ($link // '') : '',
    });
}

# The token is spent the moment it is presented, valid or not: a second
# click on the same link is a 410, not a second sign-in.
sub verify {
    my ($c) = @_;
    my $row = $c->take_token($c->param('token'), 'verify')
        or return $c->page('auth/verify', { ok => 0 }, status => 410);
    my $user = $c->model('User')->update({ id => $row->{user_id}, verified => 1 });
    $c->flash(kind => 'ok', notice => 'Your address is verified.');
    return $c->sign_in($user);
}

# ---- the password door --------------------------------------------------------

sub login_form {
    my ($c) = @_;
    return $c->page('auth/login', { to => $c->safe_path($c->param('to'), '') });
}

sub login {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $pw    = $c->param('password') // '';
    my $user  = $c->model('User')->get(email => $email);

    # check_password burns the same work when there is no user, so the
    # response time does not say whether the address exists
    return $c->page('auth/login',
        { email => $email, error => 'Wrong email or password.' })
        unless $c->check_password($user, $pw);
    return $c->page('auth/login',
        { email => $email, error => 'Verify your address first - the link is in your mail.' })
        unless $user->{verified};

    if (Punk::Auth::Password::needs_rehash($user->{password_hash})) {
        $c->model('User')->update({ id => $user->{id},
            password_hash => Punk::Auth::Password::hash($pw) });
    }
    return $c->sign_in($user, to => $c->safe_path($c->param('to'), '/account'));
}

sub logout {
    my ($c) = @_;
    $c->logout;
    return $c->redirect('/');
}

# ---- forgotten passwords --------------------------------------------------------

sub forgot_form {
    my ($c) = @_;
    return $c->page('auth/forgot');
}

# The same page whatever the address: an answer that differed would be a
# way to list accounts one address at a time.
sub forgot {
    my ($c) = @_;
    my $email = _clean_email($c->param('email'));
    my $user  = _valid_email($email) ? $c->model('User')->get(email => $email) : undef;
    my ($result, $link);
    ($result, $link) = $c->mail_token($user,
        kind     => 'reset',
        ttl      => 24 * 60 * 60,
        path     => '/reset/%s',
        template => 'reset',
        subject  => 'Reset your AuthApp password',
    ) if $user;
    return $c->page('auth/sent', {
        kind     => 'reset',
        email    => $email,
        sent     => ($result && $result->accepted) ? 1 : 0,
        dev_link => $c->app->env eq 'development' ? ($link // '') : '',
    });
}

# GET shows the form and leaves the token alone; only a submitted password
# spends it, so a preview fetch by a mail client cannot burn the link.
sub reset_form {
    my ($c) = @_;
    return $c->page('auth/reset', { token => $c->param('token') });
}

sub reset {
    my ($c) = @_;
    my $token = $c->param('token');
    my $pw    = $c->param('password') // '';
    return $c->page('auth/reset',
        { token => $token, error => "Use at least $MIN_PASSWORD characters." })
        if length $pw < $MIN_PASSWORD;

    my $row = $c->take_token($token, 'reset')
        or return $c->page('auth/verify', { ok => 0, kind => 'reset' }, status => 410);
    my $user = $c->model('User')->update({
        id            => $row->{user_id},
        password_hash => Punk::Auth::Password::hash($pw),
        verified      => 1,                 # the mail reached them
    });
    $c->flash(kind => 'ok', notice => 'Your password is changed.');
    return $c->sign_in($user);
}

# ---- social login -------------------------------------------------------------

# Called by the OAuth2 plugin with a verified identity. Only an address the
# provider has itself verified may claim an account here; a returned
# reference becomes the response, so the redirect decision is sign_in's.
sub on_login {
    my ($c, $identity, $tokens) = @_;
    return $c->redirect('/login?error=oauth')
        unless $identity->{email_verified} && $identity->{email};

    my $email = _clean_email($identity->{email});
    my $users = $c->model('User');
    my $user  = $users->get(email => $email) // $users->create({
        email        => $email,
        verified     => 1,
        totp_enabled => 0,
        created      => _now(),
    });
    return $c->sign_in($user);
}

1;

__END__

=head1 NAME

AuthApp::Controller::Web::Auth - sign-up, sign-in, mailed links and on_login

=cut

Testing the whole flow in process

t/01-basic.t drives every door without a browser, a mail server or a provider. Here it is whole; the walk-through follows it.

t/01-basic.t:

#!perl
use 5.010;
use strict;
use warnings;
use FindBin ();
use lib "$FindBin::Bin/../lib";
use Test::More;

# The whole flow, in process: sign-up, the mailed link, sign-in, reset,
# the second factor, recovery codes, and the first hop of a social login.
# One Punk::Test object is one browser: its cookie jar carries the session
# across every request below, and `csrf => 1` sends the token the last
# page minted.

# The test's environment: its own database layer, a session key, and
# placeholder OAuth credentials - every `{ $env }` in punk.yml has to
# resolve, or boot refuses.
BEGIN {
    $ENV{PUNK_ENV}            //= 'test';
    $ENV{AUTHAPP_SESSION_KEY} //= 'test-only-session-key-' x 2;
    $ENV{"AUTHAPP_$_"}        //= "placeholder-\L$_" for qw(GITHUB_ID GITHUB_SECRET GOOGLE_ID GOOGLE_SECRET);
    delete $ENV{RESEND_API_KEY};                   # always the capture transport here
}

use Punk::Test;
use Punk::TOTP ();

chdir "$FindBin::Bin/.." or die "cannot chdir to the application root: $!\n";
unlink 'var/test.db';                              # a fresh database every run

my $t = Punk::Test->new('AuthApp');
my $mail = sub { Punk::Plugin::Mailer->engine_for('AuthApp')->transport->messages };
my $link_in = sub {                                # the link a captured mail carries
    my ($kind) = @_;
    my ($link) = $mail->()->[-1]{spec}{text} =~ m{(http://localhost:5000/\Q$kind\E/[\w~.-]+)};
    (my $path = $link // '') =~ s{^http://localhost:5000}{};
    return $path;
};

# ---- signed out ------------------------------------------------------------
$t->get_ok('/')->status_is(200)->content_like(qr/Create an account/, 'the front page');
# auth_guard negotiates on Accept: a browser is redirected to the login
# with a way back, anything else gets a 401 - so ask as a browser does.
$t->get_ok('/account', headers => { Accept => 'text/html' })->status_is(302)
  ->header_like(Location => qr{^/login\?to=}, 'auth_guard sends a stranger to the login, with a way back');
$t->get_ok('/account')->status_is(401, 'and answers a non-browser client with a 401');
$t->get_ok('/register')->status_is(200)->content_like(qr/name="_csrf"/, 'forms carry the CSRF field');

# ---- sign up, verify by mail ------------------------------------------------
$t->post_ok('/register', form => { email => 'Alice@Example.com', password => 'short' }, csrf => 1)
  ->status_is(200)->content_like(qr/at least 10 characters/, 'a short password is refused');
$t->post_ok('/register', form => { email => 'Alice@Example.com', password => 'correct horse battery' }, csrf => 1)
  ->status_is(200)->content_like(qr/Check your mail/, 'a sign-up is acknowledged');
is scalar @{ $mail->() }, 1, 'one verification mail went out';
ok $mail->()->[0]{result}->accepted, 'and the transport accepted it';
is $mail->()->[0]{spec}{to}, 'alice@example.com', 'to the lowercased address';
my $verify = $link_in->('verify');
ok $verify, "the mail carries the link: $verify";

$t->post_ok('/register', form => { email => 'alice@example.com', password => 'correct horse battery' }, csrf => 1)
  ->status_is(200)->content_like(qr/Check your mail/, 'the same address again gets the same page');
is scalar @{ $mail->() }, 1, 'and no second mail - the response does not say which addresses exist';

$t->post_ok('/login', form => { email => 'alice@example.com', password => 'correct horse battery' }, csrf => 1)
  ->status_is(200)->content_like(qr/Verify your address first/, 'signing in before verifying is refused');

$t->get_ok($verify)->status_is(302)->header_is(Location => '/account', 'the link verifies and signs in');
$t->get_ok($verify)->status_is(410, 'the same link a second time is spent');
$t->get_ok('/account')->status_is(200)->content_like(qr/Enrol a phone/, 'signed in: enrolment is offered');
$t->post_ok('/logout', csrf => 1)->status_is(302);

# ---- the password door --------------------------------------------------------
$t->get_ok('/login')->status_is(200)
  ->content_like(qr{href="/auth/github"}, 'the social buttons are on the login page');
$t->post_ok('/login', form => { email => 'alice@example.com', password => 'wrong wrong wrong' }, csrf => 1)
  ->status_is(200)->content_like(qr/Wrong email or password/, 'a wrong password is refused');
$t->post_ok('/login', form => { email => 'nobody@example.com', password => 'wrong wrong wrong' }, csrf => 1)
  ->status_is(200)->content_like(qr/Wrong email or password/, 'with the same answer for an unknown address');
$t->post_ok('/login', form => { email => 'alice@example.com', password => 'correct horse battery' }, csrf => 1)
  ->status_is(302)->header_is(Location => '/account', 'the right password signs in');
$t->post_ok('/logout', csrf => 1)->status_is(302);

# ---- forgotten password -------------------------------------------------------
$t->get_ok('/forgot')->status_is(200);
$t->post_ok('/forgot', form => { email => 'nobody@example.com' }, csrf => 1)
  ->status_is(200)->content_like(qr/Check your mail/, 'an unknown address gets the same page');
is scalar @{ $mail->() }, 1, 'and no mail';
$t->post_ok('/forgot', form => { email => 'alice@example.com' }, csrf => 1)->status_is(200);
my $reset1 = $link_in->('reset');
$t->post_ok('/forgot', form => { email => 'alice@example.com' }, csrf => 1)->status_is(200);
my $reset2 = $link_in->('reset');
is scalar @{ $mail->() }, 3, 'two reset mails';
isnt $reset1, $reset2, 'with different links';

$t->get_ok($reset2)->status_is(200)->content_like(qr/Choose a new password/, 'GET shows the form without spending the token');
$t->post_ok($reset1, form => { password => 'a brand new password' }, csrf => 1)
  ->status_is(410, 'the earlier link died when the later one was issued');
$t->post_ok($reset2, form => { password => 'tiny' }, csrf => 1)
  ->status_is(200)->content_like(qr/at least 10 characters/, 'a bad password does not spend the link');
$t->post_ok($reset2, form => { password => 'a brand new password' }, csrf => 1)
  ->status_is(302)->header_is(Location => '/account', 'the reset signs in');
$t->post_ok('/logout', csrf => 1);
$t->get_ok('/login');                              # logout emptied the session, token included
$t->post_ok('/login', form => { email => 'alice@example.com', password => 'a brand new password' }, csrf => 1)
  ->status_is(302, 'and the new password works');

# ---- the second factor --------------------------------------------------------
$t->get_ok('/account')->status_is(200);
my ($secret) = $t->body =~ m{by hand: <code>([A-Z2-7]+)</code>};
ok $secret, 'the enrolment page shows the pending secret';
like $t->body, qr/<svg/, 'and the QR';
my $now = time;
$t->post_ok('/account/totp', form => { code => '000000' }, csrf => 1)->status_is(302);
$t->get_ok('/account')->content_like(qr/did not match/, 'a wrong code is refused');
$t->post_ok('/account/totp', form => { code => Punk::TOTP->code($secret, time => $now) }, csrf => 1)->status_is(302);
$t->get_ok('/account')->content_like(qr/Second factor enabled/, 'a right code completes enrolment')
  ->content_like(qr/has not passed the factor yet/, 'but this session has not met the challenge');

$t->get_ok('/vault/secrets')->status_is(302)->header_is(Location => '/login/totp', 'totp_guard steps up');
$t->get_ok('/login/totp')->status_is(200)
  ->content_like(qr/Second factor/, 'the challenge page is ours')
  ->content_like(qr/name="_csrf"/, 'and carries the CSRF field the plugin form lacks');
$t->post_ok('/login/totp', form => { code => Punk::TOTP->code($secret, time => $now) }, csrf => 1)
  ->status_is(200)->content_like(qr/did not work/, 'the enrolment code is a replay - refused by the floor');
$t->post_ok('/login/totp', form => { code => Punk::TOTP->code($secret, time => $now + 30) }, csrf => 1)
  ->status_is(302)->header_is(Location => '/vault/secrets', 'the next window passes and returns to the stepped-up page');
$t->get_ok('/vault/secrets')->status_is(200)->content_like(qr/The vault/);

$t->post_ok('/account/recovery', csrf => 1)->status_is(200);
my @codes = $t->body =~ m{<code>([A-Z2-7]{8}-[A-Z2-7]{8})</code>}g;
is scalar @codes, 5, 'five recovery codes, shown once';

# ---- every door now leads to the challenge ------------------------------------
$t->post_ok('/logout', csrf => 1);
$t->get_ok('/login');
$t->post_ok('/login', form => { email => 'alice@example.com', password => 'a brand new password' }, csrf => 1)
  ->status_is(302)->header_is(Location => '/login/totp', 'enrolled: the password leads to the challenge');
$t->get_ok('/account')->status_is(401, 'pending is not a login - the account page is still guarded');
$t->get_ok('/login/totp');
$t->post_ok('/login/totp', form => { code => lc $codes[0] }, csrf => 1)
  ->status_is(302)->header_is(Location => '/account', 'a recovery code passes, case folded');
$t->get_ok('/account')->status_is(200)->content_like(qr/this session passed the factor/);

$t->post_ok('/forgot', form => { email => 'alice@example.com' }, csrf => 1);
my $reset3 = $link_in->('reset');
$t->post_ok('/logout', csrf => 1);
$t->get_ok($reset3);
$t->post_ok($reset3, form => { password => 'yet another password' }, csrf => 1)
  ->status_is(302)->header_is(Location => '/login/totp', 'a mailed link cannot bypass the factor either');

# ---- social login: the first hop --------------------------------------------
$t->get_ok('/auth/github')->status_is(302)
  ->header_like(Location => qr{^https://github\.com/login/oauth/authorize\?}, 'GitHub: off to the provider')
  ->header_like(Location => qr{code_challenge_method=S256}, 'with PKCE')
  ->header_like(Location => qr{redirect_uri=http%3A%2F%2Flocalhost%3A5000%2Fauth%2Fgithub%2Fcallback}, 'and the callback built from the declared host');
$t->get_ok('/auth/google')->status_is(302)
  ->header_like(Location => qr{^https://accounts\.google\.com/}, 'Google: off to the provider');
$t->get_ok('/auth/nope')->status_is(404, 'an unknown provider is a 404');

$t->get_ok('/no-such-page')->status_is(404);
done_testing();

The setup supplies what the configuration references, because a missing variable is a boot error here exactly as it is in production. PUNK_ENV=test selects config/punk.test.yml, whose one block points the database at var/test.db, so the suite never touches the file punk dev is using:

config/punk.test.yml:

# Loaded over punk.yml when PUNK_ENV=test, which t/01-basic.t sets: the
# suite gets its own database file and never touches the one `punk dev`
# is using.
database:
  dsn: dbi:SQLite:dbname=var/test.db

One Punk::Test object is one browser - its cookie jar carries the session across every request - and csrf => 1 on a POST sends the token the last page minted. The mailed links come out of the capture transport: Punk::Plugin::Mailer->engine_for('AuthApp') is the engine the plugin built, its transport holds every message it was handed, and $link_in pulls the link out of the last one's text.

From there the test reads like the guide: sign up, assert one mail to the lowercased address, sign in before verifying and be refused, follow the link and land on /account, follow it again and get a 410. Two reset requests, and the first link is dead because the second revoked it. Then the factor: the secret comes off the enrolment page, the codes are computed with the engine underneath the plugin, Punk::TOTP, and the code that enrolled the phone is refused at the challenge thirty seconds later as a replay. Social login cannot complete without a provider, so the suite asserts the first hop and what it carries - the provider's authorize URL, PKCE, and a callback built from the declared host.

Running it

export AUTHAPP_SESSION_KEY=$(punk secret)
export AUTHAPP_GITHUB_ID=...      AUTHAPP_GITHUB_SECRET=...
export AUTHAPP_GOOGLE_ID=...      AUTHAPP_GOOGLE_SECRET=...

# optional: real mail through Resend; without it every message is
# captured under var/mail/new/ as a .eml file
export RESEND_API_KEY=re_...
export AUTHAPP_MAIL_FROM='AuthApp <no-reply@your-verified-domain.example>'

punk dev

punk dev runs the application under Hyperman on port 5000 and restarts it when lib, config or root/templates change. Placeholder OAuth values are fine for everything except completing a social login. punk test runs the suite, punk routes prints the table at the top of this post, and punk config check resolves the configuration and reports every secret it could not find - the diagnostic for a boot that refused.

Punk: a MVC framework

LNATION — Thu, 06 Aug 2026 22:22:14 +0000

Every web framework does a certain amount of thinking on every request. It
looks at the path and decides which route matched. It works out which chain of
before filters are applied. It resolves 'Web::Book#view' into an actual coderef.
It checks whether this action wants JSON. None of that work depends on the
request in any interesting way, the answers are the same on request one and
request one million, yet most frameworks compute them again every time,
because that is the natural way to write a framework and because the cost is
invisible until it isn't.

Punk is a Perl MVC framework built on the opposite instinct: do all of that
once, at startup, and freeze the result. By the time your application is
serving traffic there is no routing table to interpret, no filter chain to
assemble, no string to resolve. Dispatch is a hash lookup or a short bucket
scan. Guards are a walk over a frozen array. The handler is a plain coderef
call that receives exactly one argument, the context object.

It looks like a normal framework:

package MyApp;
use Punk;

get  '/'          => 'Web::Book#home';
get  '/books/:id' => 'Web::Book#view';
post '/books'     => 'Web::Book#create';

my $admin = under '/admin' => sub {
    my ($c) = @_;
    return $c->redirect('/') unless $c->req->header('authorization');
    return;
};
$admin->get('/books' => 'Web::Book#admin_list');

static '/static' => 'root/static';

1;

# app.psgi
use MyApp;
MyApp->to_app;

The interesting moment is to_app. That is where Punk walks everything you
declared, resolves it, and builds the compiled form. 'Web::Book#view' becomes
the actual coderef it names. /admin merges its guard into every route beneath
it. The static mount becomes a C closure. After that the declaration is
finished with, and what serves your traffic is a frozen structure that nothing
interprets.

What that buys, and what it costs

The obvious payoff is that per request work goes down. The less obvious one is
that errors move to boot time. A controller method that does not exist, a
view engine that will not accept an option, a security scheme the spec requires
but no checker was supplied for, a docs path that collides with a real route -
all of these fail when the application starts, with a message naming the thing,
rather than on the unlucky request that first reaches them. An application that
starts is an application whose wiring is known to be sound.

The cost is the honest one: you cannot add a route at runtime. There is no
live structure to patch. If that is a thing you need, Punk is the wrong shape
and I would rather say so plainly than pretend otherwise.

It also has a consequence I did not anticipate when I started, which is that a
compiled at boot application is opaque from the outside. Everything is
resolved and frozen inside one coderef, so you cannot read the routing table by
eyeballing the source - the source is the declaration, not the result. That is
what the command line is for, and I will come back to it.

The keywords

The DSL is small and each keyword does one thing.

Routing. get, post, put, patch, del, any, and under for
scopes. A scope carries a prefix and a guard, nests, and returns a handle you
hang routes off. A guard that returns a response short circuits; a guard that
returns nothing lets the request through.

Realtime. websocket routes like a GET (upgrade requests are GETs), so
it sits under the same scopes and guards as anything else and a guard can
refuse a client with an ordinary HTTP response before the handshake happens.
Once validated, the handler gets the context and the connection, wires the
events it wants, and returns; the connection then lives on the server's event
loop. sse is the same idea for Server-Sent Events, with a heartbeat.

Sessions and security. session gives you signed cookie sessions -
$c->session is a hashref, HMAC-SHA256-signed, written back only when it
actually changes. csrf layers single use tokens on top: every unsafe request
must carry a live token, and using one spends it. cors is handled inside the
dispatcher rather than as middleware, which matters more than it sounds:
preflights are answered before routing, so no OPTIONS route is needed, and
the headers reach the 404s and 405s that never build a context.
Access-Control-Allow-Methods is answered from the router itself, so it cannot
promise a method the application does not actually serve.

Configuration and secrets. config loads layered YAML - punk.yml, then
punk.$PUNK_ENV.yml, then a gitignored punk.local.yml. Blocks that mirror a
DSL keyword register for real, so a views: or database: block in the file
is exactly equivalent to the keyword, and deployment configuration needs no
code change. Secrets are deliberately not in the file: a value written
{ $env: NAME }, { $file: PATH } or { $exec: [...] } is resolved at boot
from outside it, $app->config shows [redacted] in its place, and
$app->secret('database.password') reaches the real value. A plaintext value
under a secret shaped key warns, and secrets => 'strict' refuses to start.

Everything else. static, mount, views, database and model, hook,
middleware, on_error, plugin, helper.

OpenAPI as a first class mount

my $api = api 'openapi.json';
docs '/docs';

api mounts an OpenAPI 3.1 document. Each operation dispatches to the
controller method named after its operationId, and request validation,
security as guards and per prefix guards are all resolved at boot alongside
everything else. Under a scope it inherits that scope's prefix and guards, so a
spec can live behind the same authentication as the rest of the site without
restating it.

This is the part where the compile at boot idea earns the most. A spec is a
large pile of declarative facts - paths, parameters, schemas, security
requirements - and every one of them is knowable before the first request. So
Punk turns the document into the same frozen structures as everything else, and
a spec driven route costs what a hand written one costs.

The stack underneath

Punk sits on top of a set of modules I have been building for a while, and the
way they connect is the part I am most pleased with.

Hyperman is the server: a preforking, event-loop PSGI server with its hot path in C.
Open::API does OpenAPI routing and validation.
Template::Stencil is the view engine, a {% %} template compiler.
File::Raw::JSON does JSON.
JSON::Schema::Fast validates against JSON Schema.

Each of those exposes a C ABI: a versioned table of function pointers,
resolved at runtime through a _abi_ptr lookup. So when Punk renders a
template, the path from the dispatcher to the template VM is C calling C, with
no Perl frame in the middle. Same for JSON encoding a response, same for
validating a request against a spec.

The runtime resolution matters. There is no link time coupling between these
distributions: each one checks the table's version at boot and falls back, or
refuses to start with a message naming the version it needed. They can be
released independently, and a consumer compiled against an older table keeps
working against a newer one because the tables only ever grow at the end. It is
the DBI driver pattern, applied to a web stack.

Punk vendors none of those headers. All four arrive through
ExtUtils::Depends, so each contract has exactly one copy and it is the one
its provider ships.

The command line

Because the compiled application is opaque from outside, punk exists to open
it up.

punk new MyApp
punk new MyApp --api ./openapi.json

punk new writes a running application, not a stub: routes, a controller,
Stencil views with a wrapper, config/punk.yml, a psgi entry point, a README,
and a test that builds the app and requests a page. Point it at an OpenAPI
document and it mounts that too, generating one controller of operation stubs
per tag, each answering 501 until you implement it. Generation is deterministic

operations arrive in hash order, which perl randomises per process, so they are sorted before anything is written. Without that, regenerating the same spec shuffled subs between files and every diff was noise.

The rest of the commands report on a live application:

punk routes prints the whole table: routes, spec operations, websocket routes, mounted apps, guard counts. Targets are recovered from the compiled coderef rather than the declaration, so what it prints is where a request actually lands.
punk doctor reports versions and, the part no version number answers, which C ABI tables resolved and at what version.
punk config check resolves every $env, $file and $exec reference in every layer independently, so one missing secret does not hide the rest. Non-zero exit on failure, which makes it a deployment gate. Secret values never reach the output.
punk console is a REPL with $app, $psgi and a throwaway context.
punk dev serves under Hyperman and restarts on change. A compiled at boot application cannot hot reload - there is no live structure to patch - so restarting is the implementation.
punk api sync adds a stub for every operation the document declares and the controllers do not implement, and touches nothing else. An operation the spec no longer declares is reported, never removed.

Async

A handler can return a future instead of a response, and Punk awaits anything
future-shaped (then / on_ready / get).

get '/slow' => sub {
    my ($c) = @_;
    $c->timer(2)->then(sub { $c->json({ waited => 2 }) });
};

On a Hyperman worker that runs on the event loop and the worker serves other
requests while it is pending, so the two second wait costs no capacity.
Anywhere else it blocks, which is the correct fallback rather than a broken
one.

A note on speed

This is not a benchmark post, so: one table, and the honest reading of it. Every
app below is the same app shape, hosted on the same server, driven by the same
wrk harness, on my Mac with client and Hyperman server sharing the box.

App	req/s
bare PSGI coderef, no framework	205,461
Punk, hello	205,967
Punk, JSON	205,797
Punk, dynamic route	205,339
Punk, OpenAPI mount with validation	202,105
Punk, dynamic Template Stencil render	155,752
Mojolicious, hello	22,835
Catalyst, hello	6,691

Where it is

Punk needs Perl 5.10 or later and a C compiler. Currently it is not supported on
Windows but it may be in the future. It is young and the shape of it is settled
but the edges are not. If you try it and something is wrong or missing I would
like to hear from you about it below.

https://punkperl.com/

Hyperman into Fetch

LNATION — Sat, 01 Aug 2026 23:55:43 +0000

This is the story of two pieces of software I published recently - Hyperman, an event-loop PSGI server, and Fetch, a Future based HTTP client - and of why building the first one enticed me to build the second.

This story really starts a few months ago when I published another module Hypersonic. Hypersonic is fast, really fast but it's also flawed in its just in time nature when it comes to compiling. I have deliberately left Hypersonic out of the numbers below - it is not the point here, and lining that "crazy" JIT up against ahead-of-time hard code mostly invites the wrong conclusions.

What Hypersonic taught me was where the speed actually comes from, and Hyperman and Fetch are an attempt to keep that speed while moving the compilation to a saner time. Instead of compiling just in time, the hot path is written once, in C, and compiled ahead of time into XS - so there is no warmup and the code running under load is exactly the code you, I and cpantesters has tested.

All numbers below were measured on a 10-core macOS laptop (4 performance + 6 efficiency cores) over loopback, with a trivial PSGI app returning a 256-byte body. They are relative, your mileage will vary.

Hyperman

Hyperman is a preforking, event-loop PSGI server. A supervisor process forks a pool of workers, each worker runs a single-threaded event loop written in C that accepts connections, parses HTTP, calls your PSGI app, and writes the response - all without blocking, so one worker can juggle thousands of connections at once.

Pluggable readiness backends behind one vtable. kqueue on macOS and the BSDs, epoll or io_uring on Linux, and a portable poll fallback everywhere else (Except windows). Selection is automatic; you can force one with HYPERMAN_BACKEND.

A real async story. Handlers can return a Hyperman::Future (or any on_ready-compatible object) instead of a response, and the worker parks the connection and services others until the future resolves. psgi.streaming delayed responses, a streaming writer, psgix.io, and cancellation on client disconnect all work. The Future implementation is entirely XS over an array slot object, with continuations trampolined through a fire queue so long then-chains run iteratively with bounded stack depth.

Production behaviour. Worker respawn with crash loop backoff, SIGHUP zero-downtime recycle, graceful TERM/INT drain, idle and slow request timeouts, a pipelining fairness cap, a request-size ceiling, opt-in SO_REUSEPORT per-worker listeners on Linux, an access-log callback, and per-worker stats.

HTTP/2 and TLS. A non-blocking OpenSSL layer with SNI and ALPN, and an HTTP/2 path (nghttp2 for framing and HPACK) negotiated via ALPN over TLS. Both degrade gracefully to stubs when the libraries are absent - HTTP/1.1 keeps working with no OpenSSL at all.

It runs any Plack app: plackup -s Hyperman.

How fast is it?

Same PSGI app, same load (wrk -t4 -c100), access logging off (PLACK_ENV=deployment), four workers where the server supports them, best of three runs:

Server	req/s
HTTP::Server::PSGI (1 process)	17,231
Gazelle (4 workers)	34,490
Starman (4 workers)	76,403
Hyperman (4 workers)	185,932

Roughly 2.4x Starman and an order of magnitude over the single-process core server, on this box. (Gazelle is tuned for Linux with Server::Starter and SO_REUSEPORT; it likely does better in its native habitat than under plackup on macOS. The point of the table is the harness is identical for everyone.)

The problem: how do you even measure that?

Here is the wall I hit. A server that can answer ~186,000 requests a second is only interesting if you can prove it, and to prove it you need a client that can ask 186,000 times a second. That turns out to be surprisingly hard to do from Perl.

The standard Perl HTTP clients are all blocking: they send one request, wait for the reply, then send the next. One request in flight at a time, per process. So the number you measure is not the server's capacity - it is the client's round trip latency. Point a blocking client at Hyperman and you learn how fast the client is, and conclude, wrongly, that your server does ~30k/s.

You can work around it by forking dozens of client processes and summing their throughput, but that is fiddly to coordinate, noisy to measure, and awkward to put in a test suite. You can reach for wrk or ab - excellent C tools - but now your all Perl stack has a C dependency in its own test harness, and you cannot easily express "hammer this server with 500 concurrent requests and assert the p99 latency" as a Perl test.

What I actually wanted was a Perl HTTP client that could keep hundreds of requests in flight on one event loop - fast enough to saturate Hyperman from inside Perl. There wasn't one other than what exists inside of Hypersonic. So Fetch happened.

Part 2: Fetch

Fetch is an HTTP user agent whose socket, TLS, HTTP/2 framing and HTTP/1.1 parsing live in vendored C, and whose asynchronous results are Fetch::Future objects. It works out of the box with no event loop to set up - it ships its own - and it cooperates with an existing loop when you have one.

use Fetch;

# no framework, no setup
my $res = Fetch->new->get('https://example.com')->get;
print $res->content;

# hundreds of requests, one loop, all concurrent
my @f = map { $ua->get($_) } @urls;
Fetch::Future->needs_all(@f)->get;

The same C core as the server. Fetch reuses Hyperman's readiness backends and its Future primitive. A request is a non-blocking connect + send + recv + parse driven by a C readiness callback - no Perl runs per event. HTTP/1.1 and HTTP/2 (ALPN over TLS), streaming bodies, redirect following, per-request timeouts, cookies (RFC 6265), keep-alive connection pooling, WebSockets (RFC 6455), and JSON decode are all there, with the hot paths in C.

It rides any loop. Fetch's C core arms readiness through one tiny method an adapter provides, so Fetch runs on IO::Async, AnyEvent, or - the natural pairing - a Hyperman::Loop. A Hyperman worker can make concurrent outbound HTTP/2 calls on the same loop it serves inbound connections with.

How fast is it?

All clients pointed at one Hyperman server, keep-alive on, measured with the core Benchmark module (cmpthese), one request per iteration:

Client	req/s	vs LWP
LWP::UserAgent	9,934	1.0x
HTTP::Tiny	25,862	2.6x
Furl	41,379	4.2x
Fetch (sequential)	100,000	10x

Sequentially, Fetch is already ~10x LWP and ~2.4x Furl (the fastest of the blocking clients), because the request/response hot path never leaves C.

But sequential is not the point. The point is this:

Client	req/s
Fetch, 200 requests in flight	164,342

One process, one core, 200 requests concurrently on a single event loop - and now we are within striking distance of the 186k the server can serve, and far past anything a blocking client can do. (Benchmark's one-call-per-iteration model can't express in-flight concurrency, so that last figure is a straight wall-clock measurement over the batch.)

Okay we are not quite wrk just yet, but I have a few ideas on how to get that with an option for a more optimised response without any blessing of objects... BUT we are close enough with a full featured user agent and currently far ahead of other perl equivalents.

Getting them

Both are available on CPAN:

Hyperman
Fetch

I encourage you to read the documentation.

As always any questions just post below.

PDF Generation, Extraction and Modification with PDF::Make

LNATION — Sun, 28 Jun 2026 09:39:01 +0000

I’ve always been fascinated by PDFs. They look simple on the surface. Just a document you can open anywhere but underneath they’re a full layout engine, object graph, drawing model, and archival format all at once. I enjoy that mix of precision and complexity and that is exactly what led me to build PDF::Make. I wanted a fully featured toolkit that could both generate PDFs and let me inspect/edit them programmatically.

At the low level, PDF::Make exposes the raw building blocks of the format: PDF objects, pages, the drawing canvas, a parser/reader, and import/merge primitives. This is the layer you reach for when you need fine grained control or want to work with the structure of a document directly.

For everyday document creation, PDF::Make::Builder sits on top of that foundation and provides a higher level API. It handles the boilerplate of page setup, fonts, text flow, and layout so you can produce a polished PDF in just a few lines of Perl.

The same toolkit is also designed for post-processing. You can open an existing PDF, extract structured text along with its coordinates, and then draw annotations or overlays back onto the page, making it straightforward to build review, QA, or markup workflows on top of documents you didn’t originally generate.

This post shows a practical two step flow:

Create a PDF
Re-open it, extract text coordinates, and draw border highlights around matched words

1) Create a PDF with `PDF::Make::Builder`

Script:

#!/usr/bin/perl
use strict;
use warnings;

use PDF::Make::Builder;

my $pdf = PDF::Make::Builder->new(
    file_name => 'source_demo.pdf',
    configure => {
        text => {
            font => { family => 'Helvetica', size => 12, colour => '#222222' },
        },
    },
);

$pdf->add_page(page_size => 'Letter')
    ->add_h1(text => 'PDF::Make blog demo')
    ->add_text(text => 'PDF::Make builds and edits PDF files directly from Perl.')
    ->add_text(text => 'In the next step we extract text coordinates and highlight matches.')
    ->add_text(text => 'Target terms: PDF::Make, extract_structured, highlight.')
    ->add_text(text => 'This line repeats PDF::Make so multiple boxes are drawn around matches.')
    ->save;

print "source_demo.pdf\n";

That gives us a baseline document to post process.

2) Extract text coordinates, then overlay border highlights

Now we:

open the source PDF as an editable builder document,
run extract_structured page by page,
find words that match a regex,
draw a stroked rectangle on each match.

#!/usr/bin/perl
use strict;
use warnings;
use PDF::Make::Builder;

my $in  = $ARGV[0] // 'source_demo.pdf';
my $out = $ARGV[1] // 'source_demo_highlighted.pdf';
my $re  = $ARGV[2] // 'PDF::Make';

my $b = PDF::Make::Builder->open_existing($in, file_name => $out);
my $pad = 1.5;
my $page_count = $b->page_count;
for my $idx (0 .. $page_count - 1) {
    my $res = $b->extract_structured($in, page => $idx, invisible => 1);
    my $blocks = $res->data || [];

    $b->open_page($idx + 1);
    my $canvas = $b->page->canvas;

    for my $block (@$blocks) {
        my $lines = $block->{lines} || [];
        for my $line (@$lines) {
            my $words = $line->{words} || [];
            for my $w (@$words) {
                my $text = $w->{text} // '';
                next unless $text =~ /$re/i;

                my ($x0, $y0, $x1, $y1) = @{$w}{qw/x0 y0 x1 y1/};
                my $rx  = $x0 - $pad;
                my $ry  = $y0 - $pad;
                my $rw  = ($x1 - $x0) + (2 * $pad);
                my $rh  = ($y1 - $y0) + (2 * $pad);
                # border highlight (red stroke, no fill)
                $canvas->q->w(0.8)->RG(1, 0, 0)->re($rx, $ry, $rw, $rh)->S->Q;
            }
        }
    }
}

$b->save;
print "Created $out\n";

I would recommend reading the full documentation on CPAN to get the most out of the toolkit. The PDF::Make and PDF::Make::Builder pages cover the complete API, configuration options, and additional examples that go well beyond what this post touches on. Whether you’re generating documents from scratch, post-processing existing ones, or building review workflows on top of them, the CPAN docs and examples are the best place to explore what’s possible next. If you do have additional questions please do not hesitate to ask below.

A "switch" for Perl that compiles away: introducing Switch::Declare

LNATION — Sat, 13 Jun 2026 20:45:51 +0000

Perl has had a complicated relationship with switch.

given/when arrived leaning on smartmatch, and smartmatch turned out to be a pit of surprising behaviour — so the whole feature was been experimental, then discouraged, then warned-about for years. Switch::Back.pm is given/when for a post-given/when Perl then there is the old Switch.pm that reached for a source filter, which means it rewrites your program text before Perl ever sees it; and then finally there are a handful of other implementations on cpan including my own Switch::Again.

So most of us generally just write if/elsif chains and move on. They're honest and fast, but they're also noisy: the scrutinee gets repeated on every branch, and a six way string dispatch turns into six eq comparisons stacked on top of each other.

Switch::Declare is an attempt to get the nice syntax without any of the historical baggage. The pitch in one line:

a real switch/case keyword that is parsed entirely at compile time,
scoped lexically like a proper pragma, and lowered to the same op tree
no source filter, no smartmatch, no runtime dependencies.

use Switch::Declare;

switch ($value) {
    case 200           { handle_ok()    }   # numeric   -> ==
    case "GET"         { handle_get()   }   # string    -> eq
    case /^\d+$/       { all_digits()   }   # regex     -> =~
    case [400 .. 499]  { client_error() }   # range     -> >= && <=
    case ["a","b","c"] { in_set()       }   # list      -> membership
    case \&is_weekend  { weekend()      }   # predicate -> $code->($topic)
    default            { fallback()     }
}

It's an expression, too

The construct yields the value of the arm that ran, so you can use it on the right hand side of an assignment instead of mutating a variable in each branch:

my $label = switch ($status) {
    case 200 { "ok" }
    case 404 { "missing" }
    default  { "other" }
};

The scrutinee - $status here - is evaluated exactly once. The first matching case wins, there is no implicit fall-through, and a trailing default catches everything else. As an expression with no match and no default, you get undef.

The patterns are a small, predictable grammar

Rather than try to be clever, case recognises a deliberately tiny set of literal pattern shapes, and each one lowers to the cheapest operator that does the job:

Pattern	Example	Becomes
number literal	`case 200`	numeric `==`
string literal	`case "GET"`	string `eq`
regex	`case /^\d+$/`	`$topic =~ /.../`
range `[LO .. HI]`	`case [400..499]`	inclusive bounds
list `[a, b, c]`	`case [1, 2, 3]`	membership (OR)
predicate	`case \&is_even`	`$code->($topic)`

The predicate form takes either a code reference (\&name, package-qualified names work too) or an inline sub { ... } that closes over the surrounding lexicals, which is the escape hatch for anything the literal grammar deliberately doesn't cover:

my $limit = 100;
switch ($n) {
    case sub { $_[0] > $limit } { "over" }
    default                     { "ok"   }
}

Because the grammar is literals rather than arbitrary expressions,
classification is never ambiguous, and the compiler always knows exactly which operator to emit.

Why "compile-time" matters for speed

This is the part I'm most pleased with. switch is installed through Perl's core keyword-plugin and lexer APIs. When the parser reaches the keyword, the module reads the whole construct, builds an op tree for it then and there, and hands that back in place of the keyword. After compilation, nothing of the parser remains — there is no dispatcher subroutine sitting between you and your code at runtime, no per-call wrapper, no closure to invoke.

For the common case — a plain variable or constant scrutinee with
single-expression arms — switch compiles to exactly a hand-written if/elsif (ternary) chain: no temporary, no extra scope, no extra ops. In the bundled benchmark (xt/bench.pl) the two run within measurement noise of each other (0–2%).

Dispatch mode: O(n) chain → O(1) lookup

There's a nice bonus. When a switch is effectively a lookup table, every case maps a string literal to a constant value, and there are at least a handful of arms the module quietly lowers it to a single hash lookup against a table built once at compile time, instead of walking a chain of eq tests:

# compiles to one hash lookup, not six string comparisons
my $name = switch ($code) {
    case "GET"    { "read"   }
    case "PUT"    { "update" }
    case "POST"   { "create" }
    case "DELETE" { "remove" }
    case "PATCH"  { "modify" }
    case "HEAD"   { "peek"   }
    default       { "?"      }
};

In the benchmark, a 20-arm string switch in dispatch mode runs about 2.5× faster than the equivalent if/elsif chain. You never opt in or out, it's chosen automatically, and it never changes behaviour.

A real lexical pragma

The switch keyword only exists inside the lexical scope of a
use Switch::Declare, and you can turn it off again with no Switch::Declare:

{
    use Switch::Declare;
    switch ($x) { ... }   # 'switch' is the keyword here
}

switch();                 # ...and an ordinary sub call out here

Outside that scope, switch is just an identifier. So the keyword can't collide with a switch function in unrelated code, and importing the module has no spooky action at a distance.

Benchmarking

Numbers help. As I mentioned years ago I wrote
Switch::Again, which solves the same problem from the opposite end: switch LIST builds a closure at run time that matches each call's argument against its keys (via Struct::Match).

Here is the same 20-way string dispatch written both ways:

# Switch::Declare — parsed once at compile time, lowered to a hash lookup
my $n = switch ($key) {
    case "k0" { 0 } case "k1" { 1 } ... case "k19" { 19 }
    default   { -1 }
};

# Switch::Again — dispatcher closure built once, then called
my $sw = switch
    k0  => sub { 0 },
    k1  => sub { 1 },
    ...
    k19 => sub { 19 },
    default => sub { -1 };
my $n = $sw->($key);

The benchmark builds the Switch::Again dispatcher once,
outside the timed loop, so we're comparing steady-state per-call cost — the fairest possible footing for a runtime matcher. Results on perl 5.42:

== 6 string arms (Switch::Declare chain mode) ==
                      Rate   Switch::Again        if/elsif Switch::Declare
Switch::Again     411555/s              --            -97%            -98%
if/elsif        13282260/s           3127%              --            -33%
Switch::Declare 19891605/s           4733%             50%              --

== 20 string arms (Switch::Declare dispatch mode -> hash lookup) ==
                      Rate   Switch::Again  hand %dispatch Switch::Declare
Switch::Again     183089/s              --            -98%            -99%
hand %dispatch  11888675/s           6393%              --            -40%
Switch::Declare 19837923/s          10735%             67%              --

== 3 regex arms ==
                     Rate   Switch::Again Switch::Declare
Switch::Again   1233188/s              --            -82%
Switch::Declare 6736915/s            446%              --

So at six string arms Switch::Declare is about 48× faster than Switch::Again; at twenty arms, where dispatch mode kicks in, it's about 108× faster — and still 67% faster than a hand rolled %dispatch table, because it returns the matched constant straight out of the hash instead of calling a coderef per hit. Even on regexes, where there's no hash trick to play, it's about 5.5× ahead.

Getting it

cpanm Switch::Declare

Give it a try, and let me know how it goes in the comment section below.

Enums for Perl: Adopting Devel::CallParser and Building Enum::Declare

LNATION — Tue, 14 Apr 2026 10:15:35 +0000

Adopting one from Zefram

Back in 2011, Andrew Main, known to the Perl community as Zefram, released Devel::CallParser. It was a quiet piece of infrastructure: a C API that let XS modules attach custom argument parsers to Perl subroutines. Where the core's PL_keyword_plugin API was awkward to work with directly, CallParser gave you a structured way to extend Perl's syntax from C.

Zefram maintained it through 2013, fixing compatibility issues with indirect and Sub::StrictDecl, working around padrange optimiser changes, and shipping version 0.002. Then silence. The module sat on CPAN, unmaintained, while Perl kept moving.

By the current year and perl version it was breaking. I personally could not install it locally on my hardened macOS runtimes, many reports of issues on threaded builds, shifted qerror internals, and many red reports on CPAN testers. I needed CallParser for Object::Proto::Sugar, so I adopted it and so far have shipped six dev releases (0.003_01 through 0.003_06) to try get it passing green again on all envs. Not glamorous work, but Zefram built something worth preserving.

(RIP Zefram... I didn't know them personally but the infrastructure they left behind is still making new things possible.)

The Idea

With CallParser working again, I decided to implement an idea I'd thought about for a long time: give Perl a proper enum keyword.

Not a hash. Not a bunch of use constant lines. Not a class/object pretending to be an enumeration. An actual keyword that declares an enum at compile time, generates real constants, and gives you a meta object for introspection.

Enum::Declare

Here's what it looks like:

use Enum::Declare;

enum Colour {
    Red,
    Green,
    Blue
}

say Red;    # 0
say Green;  # 1
say Blue;   # 2

That's it. enum is a real keyword, parsed at compile time by an XS callback wired through cv_set_call_parser. The constants are true constants, not subroutine calls, not tied variables. The compiler sees them.

Explicit Values

enum HttpStatus {
    OK        = 200,
    Created   = 201,
    NotFound  = 404,
    Internal  = 500
}

String Enums

enum LogLevel :Str {
    Debug,
    Info,
    Warn = "warning",
    Error,
    Fatal
}

say Debug;  # "debug"
say Warn;   # "warning"

Without an explicit value, :Str lowercases the constant name. With one, it uses what you gave it.

Bitflags

enum Perms :Flags {
    Read,
    Write,
    Execute
}

my $rw = Read | Write;
say "can read"  if $rw & Read;
say "can write" if $rw & Write;

:Flags assigns powers of two automatically. Combine them with bitwise operators as you'd expect.

Exporting

# In your module:
enum StatusCode :Export {
    OK      = 200,
    NotFound = 404
}

# Consumers get the constants automatically, or use tags:
use MyModule qw(:StatusCode);

Meta Objects

Every enum gets a meta object accessible by calling the enum name as a function:

my $meta = Colour();

say $meta->count;           # 3
say $meta->name(0);         # "Red"
say $meta->value('Blue');   # 2
say $meta->valid(1);        # true

my @pairs = $meta->pairs;  # (Red => 0, Green => 1, Blue => 2)

Exhaustive Matching

Colour()->match($val, {
    Red   => sub { "stop" },
    Green => sub { "go" },
    Blue  => sub { "sky" },
});

Miss a variant and it dies. Every key/branch must be covered.

How It Works

Under the hood, use Enum::Declare installs an XS stub named enum into the calling package, then attaches a custom parser via cv_set_call_parser. When Perl encounters enum during compilation, the parser callback fires and:

Reads the enum name (lex_read_ident)
Reads optional attributes - :Str, :Flags, :Export, :Type
Reads the { Name = Value, ... } variant block
Builds the constant subs and enum data structures
Installs the meta object
Optionally wires up @EXPORT / @EXPORT_OK

All of this happens at compile time. By the time Perl starts executing your code, the constants exist, the meta object is ready, and the exports are in place.

Enum::Declare::Common

Once the keyword worked, the obvious next step was a library of common enums:

use Enum::Declare::Common::HTTP qw(:StatusCode :Method);
use Enum::Declare::Common::Calendar qw(:Weekday :Month);
use Enum::Declare::Common::Color qw(:CSS);

say OK;        # 200
say GET;       # "get"
say Monday;    # 1
say January;   # 1

Enum::Declare::Common ships 20 submodules covering HTTP status codes and methods, ISO country and currency codes, MIME types, 148 named CSS hex colours, timezone offsets, Unix permissions, log levels, and more. All built on the same enum keyword, all with meta objects, all exportable.

Integration with Object::Proto

Every enum in the Common collection is declared with the :Type attribute:

enum StatusCode :Type :Export {
    OK      = 200,
    Created = 201,
    ...
}

This registers the enum as a type in Object::Proto at load time, so you can use enum names directly as slot types:

use Enum::Declare::Common::HTTP qw(:StatusCode :Method);
use Enum::Declare::Common::LogLevel qw(:Level);
use Object::Proto;

object 'APIRequest',
    'method:Method:required',
    'status:StatusCode',
    'log_level:Level:default(' . Info . ')',
;

my $req = new APIRequest method => GET;
$req->status(OK);       # valid
$req->status(9999);     # dies - not a valid StatusCode
$req->status(200);      # coercion - resolves to OK

The type checks and coercions run in C via object_register_type_xs_ex. No Perl callback overhead. A single pair of C functions serves every enum type, only the data pointer differs.

If you're writing Perl and you've been using hashes or use constant blocks to fake enums, give Enum::Declare a try. In my opinion it's enums the way they should have always worked.

As always if you have any questions just post below.

Learning XS - Custom Ops

LNATION — Sat, 11 Apr 2026 18:34:39 +0000

This is the next tutorial in my Learning XS series. This post explores one of Perl's most powerful optimisation techniques: Custom Ops. We'll build a real-world example, reimplementing one of my first XS cpan modules - a Shannon entropy calculator - and explain how to bypass Perl's subroutine call overhead entirely.

So firstly... What are Custom Ops?

When you call a Perl subroutine, Perl executes an entersub op that:

Sets up a new stack frame
Pushes arguments onto the stack
Magical things happens
Jumps to the subroutine code
More Magical things can happens
Cleans up and returns

For simple functions called millions of times (like mathematical operations), this overhead dominates execution time. Custom ops let you replace the entire entersub call with a single, specialised op - eliminating that overhead.

Next.. What is Shannon Entropy?

Shannon entropy measures the information content (or "randomness") of a string:

"aaaa" → 0 bits (no randomness, completely predictable)
"abcd" → 2 bits (4 equally likely symbols = log₂(4))
Random data → ~8 bits per byte (maximum entropy)

It's used in compression, cryptography, and password strength estimation. A perfect candidate for a small, focused XS module.

In Perl the algorithm for Shannon entropy can look something like:

sub entropy {
    my ($entropy, $len, $p, %t) = (0, length($_[0]));
    $t{$_}++ foreach split '', $_[0];
    foreach (values %t) {
        $p = $_/$len;
        $entropy -= $p * log $p;
    } 
    return $entropy / log 2;
}

Creating the Distribution

First we will need to create a new perl distribution. As we have done in the past we will use Module::Starter.

module-starter --module="Shannon::Entropy::XS" --author="Your Name" --email="your@email.com"

This will create a new directory called Shannon-Entropy-XS with the basic structure of a perl module.

Next we will need to update the Makefile.PL so that it knows we are using XS. One simple way to do this is to add XSMULTI => 1 to the WriteMakefile call. Which will tell MakeMaker to look for XS files in the lib/Shannon/Entropy/ directory.

use ExtUtils::MakeMaker;

my %WriteMakefileArgs = (
    NAME             => 'Shannon::Entropy::XS',
    AUTHOR           => q{Your Name <your@email.com>},
    VERSION_FROM     => 'lib/Shannon/Entropy/XS.pm',
    XSMULTI          => 1,
    LIBS             => [''],
    # ... rest of your config
);

WriteMakefile(%WriteMakefileArgs);

Next lets update the lib/Shannon/Entropy/XS.pm file to load our XS:

package Shannon::Entropy::XS;

use strict;
use warnings;
our $VERSION = '0.01';

require XSLoader;
XSLoader::load("Shannon::Entropy::XS", $VERSION);

use Exporter qw(import);
our @EXPORT_OK = qw(entropy);

1;

Now we can create the XS file. Create a new file called lib/Shannon/Entropy/XS.xs and add the basic structure:

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

MODULE = Shannon::Entropy::XS  PACKAGE = Shannon::Entropy::XS
PROTOTYPES: ENABLE

That defines the package. If we compile this now, the basic tests added by Module::Starter will pass. To test that:

perl Makefile.PL
make test

Adding the Entropy Function

With the basic structure working, lets write a test for our entropy function. Create or update t/01-test.t:

use Test::More;
use strict;
use warnings;
use Shannon::Entropy::XS qw/entropy/;

is(entropy(''), 0);
is(entropy('0'), 0);
is(sprintf('%.3f', entropy('1223334444')), 1.846);
is(entropy('0123456789abcdef'), 4),
is(sprintf('%.3f', entropy('abcdefghijklmnopqrst123456789!@£[]"')), 5.170),

done_testing();

Now we need to implement the entropy calculation. First, add the C helper functions to our XS file, before the MODULE line:

#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <math.h>

static int makehist(const unsigned char *str, int *hist, int len) {
    int chars[256];
    int histlen = 0, i;
    for (i = 0; i < 256; i++) chars[i] = -1;
    for (i = 0; i < len; i++) {
        int c = (int)str[i];
        if (chars[c] == -1) {
            chars[c] = histlen;
            histlen++;
        }
        hist[chars[c]]++;
    }
    return histlen;
}

static double entropy(const char *str) {
    int len = strlen(str);
    int hist[256] = {0};
    int histlen, i;
    double out = 0.0;
    if (len == 0) return 0.0;
    histlen = makehist((const unsigned char *)str, hist, len);
    for (i = 0; i < histlen; i++) {
        double p = (double)hist[i] / len;
        out -= p * log2(p);
    }
    return out;
}

MODULE = Shannon::Entropy::XS  PACKAGE = Shannon::Entropy::XS
PROTOTYPES: ENABLE

double
entropy(string)
    SV *string
    CODE:
        STRLEN len;
        const char *str = SvPV(string, len);
        RETVAL = entropy(str);
    OUTPUT:
        RETVAL

So what exactly are we doing here? The makehist() function builds a histogram of character frequencies by iterating through the string and mapping each unique character to a slot in the hist array. The chars[256] lookup table tracks which slot each byte value maps to, with -1 meaning "not yet seen". When we encounter a new character, we assign it the next available slot and increment histlen.

The entropy() function then implements the Shannon entropy formula. For each unique character in the histogram, we calculate its probability (count / total length) and accumulate the entropy value. Empty strings return 0 immediately to avoid division by zero.

Finally, the XS wrapper extracts the string from the Perl SV using SvPV() (which gives us both the string pointer and its length) and calls our C function. The result is returned as a double.

Now run make test and our entropy tests should pass. But every call still goes through Perl's entersub op. Let's optimise that with custom ops.

Adding Custom Ops

Custom ops require Perl 5.14+. We'll add three pieces:

An XOP structure (for debugging/introspection)
A PP function (the actual operation)
A call checker (transforms the op tree at compile time)

First we need to add some back porting as part of the API we are about to use was introduced in 5.26, after the last import add:

#ifndef OpSIBLING
#  define OpSIBLING(o)              ((o)->op_sibling)
#endif
#ifndef OpMORESIB_set
#  define OpMORESIB_set(o, sib)     ((o)->op_sibling = (sib))
#endif
#ifndef OpLASTSIB_set
#  define OpLASTSIB_set(o, parent)  ((o)->op_sibling = NULL)
#endif

Next, we can add the XOP declaration after the last endif from above add:

#if PERL_VERSION >= 14
static XOP entropy_xop;
#endif

The XOP (eXtended OP) structure provides metadata - the op's name and description that appear in tools like B::Concise.

The PP Function

Every Perl op has a "pp" (push-pop) function that does the actual work. Add this after your entropy functions, inside a #if PERL_VERSION >= 14 block:

#if PERL_VERSION >= 14

static OP* pp_entropy(pTHX) {
    dSP;
    SV *sv = TOPs;
    STRLEN len;
    const char *str = SvPV(sv, len);
    double result = entropy(str);
    POPs;
    mPUSHn(result);
    RETURN;
}

#endif

A line by line explanation of the above code:

dSP - Declares the stack pointer local variable
SV *sv = TOPs - Gets the top of stack (our argument) without popping it
SvPV(sv, len) - Extracts the string and its length
entropy(str) - Calls our C function
POPs - Pops the argument off the stack
mPUSHn(result) - Pushes the result as a mortal (auto-freed) numeric value
RETURN - Returns control to the next op in the chain

The Call Checker

This is where the real magic happens. A call checker is invoked at compile time when Perl sees a call to our function. We can inspect the op tree and transform it. Add this after the pp function:

static OP* entropy_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    OP *pushop, *argop, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cLISTOPx(entersubop)->op_first;
    if (!pushop) return entersubop;

    /* Handle null op wrapper in modern Perl */
    if (pushop->op_type == OP_NULL && cLISTOPx(pushop)->op_first) {
        pushop = cLISTOPx(pushop)->op_first;
    }

    argop = OpSIBLING(pushop);
    if (!argop) return entersubop;

    nextop = OpSIBLING(argop);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(argop, NULL);
    newop = newUNOP(OP_CUSTOM, 0, argop);
    newop->op_ppaddr = pp_entropy;
    op_free(entersubop);
    return newop;
}

#endif

So what is actually happening here? The call checker receives the entersub op that Perl normally uses to call subroutines. Inside an entersub, the child ops form a linked list: pushmark -> arg1 -> arg2 -> ... -> cv. We use cLISTOPx(entersubop)->op_first to get the first child. In modern Perl (5.22+), this is often wrapped in a null op, so we check for that and unwrap it to find the actual pushmark. Then we use OpSIBLING() to navigate to our argument.

Before we do anything destructive, we validate that the call matches our expected signature. The series of null checks and the OpSIBLING(nextop) test ensure we have exactly one argument. If someone called entropy($a, $b) with two arguments, or used the &entropy sigil syntax, we bail out early by returning entersubop unchanged - Perl falls back to the normal subroutine call mechanism.

Once we've validated the call, we surgically detach the argument op from the entersub's child list. OpMORESIB_set(pushop, nextop) rewires pushmark to skip over our argument, linking it directly to the CV. OpLASTSIB_set(argop, NULL) disconnects argop from its siblings entirely, leaving it as a standalone op.

With the argument detached, we create our custom op using newUNOP(OP_CUSTOM, 0, argop). This creates a unary op with our argument as its child. We then assign our pp function to execute when this op runs: newop->op_ppaddr = pp_entropy. Finally, we free the original entersub with op_free() since it's no longer needed, and return our shiny new custom op to take its place in the op tree.

Wiring It Up in BOOT

The BOOT section runs when the module loads. We register our custom op and install the call checker. Add this after your XS entropy function:

BOOT:
#if PERL_VERSION >= 14
{
    CV *entropy_cv;
    XopENTRY_set(&entropy_xop, xop_name, "entropy");
    XopENTRY_set(&entropy_xop, xop_desc, "Shannon entropy calculation");
    Perl_custom_op_register(aTHX_ pp_entropy, &entropy_xop);
    entropy_cv = get_cv("Shannon::Entropy::XS::entropy", 0);
    if (entropy_cv) {
        cv_set_call_checker(entropy_cv, entropy_call_checker, (SV *)entropy_cv);
    }
}
#endif

The first thing we do is set up the XOP metadata using XopENTRY_set(). This registers the name "entropy" and a description "Shannon entropy calculation" with our custom op. These strings appear in debugging tools like B::Concise and Devel::Peek, making it much easier to understand op trees when things do go wrong.

Next, Perl_custom_op_register() connects our pp function to the XOP structure. This tells Perl's introspection system that whenever it encounters an OP_CUSTOM with our pp_entropy address, it should use our XOP metadata for display purposes.

Finally, we wire up the call checker itself. get_cv() retrieves the CV (code value) for our Shannon::Entropy::XS::entropy function - this is the subroutine object that Perl created when it compiled the XSUB. We then call cv_set_call_checker() to install our call checker on that CV. From now on, whenever Perl compiles a call to entropy(), it will invoke our entropy_call_checker function, giving us the chance to transform the op tree.

Now run make clean && make test and all tests should still pass - but now with custom ops!

Verifying It Works

You can use B::Concise to see the optimised op tree. Create a simple test script:

use B::Concise;
use Shannon::Entropy::XS qw(entropy);

B::Concise::compile('-exec', sub { entropy("test") })->();

Without custom ops, you'd see entersub. With them, you'll see our entropy custom op directly in the tree - proof that we've eliminated the subroutine call overhead!

B::Concise::compile(CODE(0x12b02b4f0))
1  <;> nextstate(main 1816 test.pl:4) v
2  <$> const[PV "test"] s
3  <0> entropy K/1
4  <1> leavesub[1 ref] K/REFC,1

Okay at this point you may or may not be asking why you would replace 9 lines of code with 111 lines... well it would be for the performance improvement you've just achieved. Take this quick benchmark as justification:

Benchmark: Short string (5 chars)
----------------------------------------
                           Rate     Shannon::Entropy Shannon::Entropy::XS
Shannon::Entropy       908579/s                   --                 -95%
Shannon::Entropy::XS 18023002/s                1884%                   --

Benchmark: Medium string (43 chars)
----------------------------------------
                          Rate     Shannon::Entropy Shannon::Entropy::XS
Shannon::Entropy      165257/s                   --                 -98%
Shannon::Entropy::XS 8525479/s                5059%                   --

Extension: Alternative Approaches to Custom Ops

So far we've covered what I consider the proper way to implement custom ops. But you may encounter other patterns in existing code, and it's worth understanding why some approaches are better than others.

The Proper Way (What We Did)

Our call checker restructures the op tree properly:

Detaches arguments from the entersub
Creates a new OP_CUSTOM unop
Frees the old entersub entirely

newop = newUNOP(OP_CUSTOM, 0, argop);
newop->op_ppaddr = pp_entropy;
op_free(entersubop);
return newop;

This is more code, but it's correct. The op tree is clean, B::Concise shows your custom op, and it works in all contexts.

The Quick Hack (Avoid This)

Some other modules take a shortcut - they just swap the op_ppaddr pointer without restructuring the tree:

static OP* hack_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *protosv) {
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(protosv);
    entersubop->op_ppaddr = my_custom_op;
    return entersubop;  /* Return unchanged! */
}

The problem is that your pp function now has to deal with the entersub's stack frame, using TOPMARK/POPMARK manipulation:

static OP* my_custom_op(pTHX) {
    dSP;
    I32 ax = TOPMARK + 1;
    I32 items = (SP - PL_stack_base - TOPMARK) - 1;
    if (items < 1) croak("requires at least 1 argument");
    SV *sv = PL_stack_base[ax];
    /* ... do work ... */
    SP = PL_stack_base + POPMARK;
    EXTEND(SP, 1);
    PUSHs(newSVnv(result));  /* Memory leak! */
    PUTBACK;
    return NORMAL;
}

Why avoid this?

Fragile - Breaks when your function is called inside other expressions
Memory leaks - Easy to forget mortalization (note newSVnv() above leaks!)
Debugging confusion - B::Concise still shows entersub, not your custom op
Complex code - The pp function is harder to understand and maintain

Shared Call Checker (For Multiple Functions)

If you're building a library with many similar functions (like a maths library), you can use a generic call checker that takes a function pointer:

static OP* vec_unary_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj, OP* (*pp_func)(pTHX)) {
    OP *pushop, *selfop, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) return entersubop;

    selfop = OpSIBLING(pushop);
    if (!selfop) return entersubop;

    nextop = OpSIBLING(selfop);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(selfop, NULL);

    newop = newUNOP(OP_CUSTOM, 0, selfop);
    newop->op_ppaddr = pp_func;
    op_free(entersubop);
    return newop;
}

Then create thin wrappers for each function:

static OP* vec_sum_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_sum);
}

static OP* vec_mean_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_mean);
}

static OP* vec_min_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    return vec_unary_call_checker(aTHX_ entersubop, namegv, ckobj, pp_vec_min);
}

This keeps your code DRY while still doing proper op tree restructuring.

Binary Ops (Two Arguments)

For functions taking two arguments, use newBINOP instead of newUNOP:

static OP* binary_call_checker(pTHX_ OP *entersubop, GV *namegv, SV *ckobj) {
    OP *pushop, *arg1, *arg2, *nextop, *newop;
    PERL_UNUSED_ARG(namegv);
    PERL_UNUSED_ARG(ckobj);

    pushop = cUNOPx(entersubop)->op_first;
    if (!OpHAS_SIBLING(pushop)) return entersubop;

    arg1 = OpSIBLING(pushop);
    if (!arg1) return entersubop;

    arg2 = OpSIBLING(arg1);
    if (!arg2) return entersubop;

    nextop = OpSIBLING(arg2);
    if (!nextop) return entersubop;

    if (OpSIBLING(nextop)) return entersubop;

    OpMORESIB_set(pushop, nextop);
    OpLASTSIB_set(arg1, NULL);
    OpLASTSIB_set(arg2, NULL);

    newop = newBINOP(OP_CUSTOM, 0, arg1, arg2);
    newop->op_ppaddr = pp_my_binary_func;
    op_free(entersubop);
    return newop;
}

The pp function for a binary op pops two values:

static OP* pp_my_binary_func(pTHX) {
    dSP;
    SV *right = POPs;
    SV *left = POPs;
    /* combine left and right */
    mPUSHn(result);
    RETURN;
}

If you have any further questions then please do post them below.