DEV Community: LNATION

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.

LRU::Cache - A Fast Least Recently Used Cache For Perl

LNATION — Wed, 08 Apr 2026 12:08:47 +0000

Caching is one of those things every application needs eventually. Whether it's DNS lookups, database rows, or computed results, keeping frequently accessed data close avoids expensive recomputation. The classic data structure for this is the Least Recently Used (LRU) cache: a fixed-size store that automatically evicts the oldest unused entry when full.

LRU::Cache is a new CPAN module that implements an LRU cache entirely in C via XS. Every operation — get, set, delete, exists — is O(1). No Perl-level hash ties, no linked list objects, no method dispatch on the hot path if you don't want it.

Quick Start

use LRU::Cache;

my $cache = LRU::Cache::new(1000);

$cache->set('user:42', { name => 'Alice', role => 'admin' });
$cache->set('user:43', { name => 'Bob',   role => 'editor' });

my $user = $cache->get('user:42');   # promotes to front
print $user->{name};                 # "Alice"

The constructor takes a single argument: the maximum number of entries. Once the cache hits capacity, the next set evicts whatever was accessed longest ago.

The Eviction Model

Every get or set promotes an entry to the front of the list. The entry at the tail — the one untouched for the longest — is the first to go when the cache is full.

my $cache = LRU::Cache::new(3);

$cache->set('a', 1);
$cache->set('b', 2);
$cache->set('c', 3);

# Access 'a' — it moves to the front
$cache->get('a');

# Cache is full. This evicts 'b' (the least recently used).
$cache->set('d', 4);

# 'b' is gone
print $cache->get('b');   # undef

After the get('a'), the internal order is a → c → b. Adding d evicts b from the tail.

Peeking Without Promoting

Sometimes you want to check a value without affecting the eviction order. peek does exactly that:

my $cache = LRU::Cache::new(3);
$cache->set('a', 1);
$cache->set('b', 2);
$cache->set('c', 3);

# peek returns the value but doesn't promote
my $val = $cache->peek('a');   # 1

# 'a' is still the oldest
my ($oldest_key) = $cache->oldest;   # 'a'

# Now get('a') promotes it
$cache->get('a');
($oldest_key) = $cache->oldest;      # 'b'

This is useful when you're iterating over cache contents for monitoring or debugging without disturbing the access pattern.

Inspecting the Cache

oldest and newest return both the key and value:

my $cache = LRU::Cache::new(5);
$cache->set('first',  'I was first');
$cache->set('second', 'I was second');
$cache->set('third',  'I was third');

my ($newest_key, $newest_val) = $cache->newest;
# $newest_key = 'third', $newest_val = 'I was third'

my ($oldest_key, $oldest_val) = $cache->oldest;
# $oldest_key = 'first', $oldest_val = 'I was first'

keys returns all keys in most-recently-used order:

$cache->get('first');   # promote 'first'
my @keys = $cache->keys;
# ('first', 'third', 'second')

And delete hands back whatever was removed:

my $deleted = $cache->delete('second');
# $deleted = 'I was second'

The Function-Style API

Method dispatch in Perl isn't free. For a cache that sits in a tight loop, the overhead of $cache->get(...) — which goes through entersub, method resolution, and argument shifting — adds up. LRU::Cache offers a function-style API that is custom OP optimised that eliminates this entirely:

use LRU::Cache qw(import);

my $cache = LRU::Cache::new(10_000);

lru_set($cache, 'key', $value);
my $v   = lru_get($cache, 'key');
my $hit = lru_exists($cache, 'key');
my $p   = lru_peek($cache, 'key');
lru_delete($cache, 'key');

As I say these aren't just wrappers. At compile time, Perl's call checker mechanism replaces the entersub op with a custom op that goes directly to the C implementation. No method lookup, no @_ construction, no argument unpacking. The cache pointer is read directly off the pad.

The result is roughly 2x faster than the method-style API, and 5–20x faster than a pure Perl implementation.

Benchmarks

Single-operation rates, no batching loops — each iteration is one cache call:

Operation	Pure Perl	XS Method	XS Function
set (existing)	1,715,893/s	21,445,932/s	45,124,820/s
get (hit)	5,271,976/s	18,302,304/s	33,017,565/s
get (miss)	8,133,594/s	22,125,453/s	46,998,887/s
exists (hit)	7,080,776/s	19,521,882/s	38,745,035/s
peek	6,410,022/s	16,842,291/s	32,437,007/s

A Practical Example: Caching Expensive Lookups

Here's a pattern that comes up constantly — wrapping an expensive operation with a cache:

use LRU::Cache qw(import);

my $dns_cache = LRU::Cache::new(1000);

sub resolve {
    my ($domain) = @_;
    my $ip = lru_get($dns_cache, $domain);
    if (!defined $ip) {
        $ip = expensive_dns_lookup($domain);
        lru_set($dns_cache, $domain, $ip);
    }
    return $ip;
}

The cache transparently sits in front of the expensive call. Hits are served from C-backed memory in constant time. Misses fall through to the real lookup and get cached for next time. When the cache fills up, stale domains are evicted automatically.

Install

cpanm LRU::Cache

Heap::PQ — A Binary Heap (Priority Queue) Implementation for Perl

LNATION — Tue, 07 Apr 2026 07:09:03 +0000

So What Is A Binary Heap?

A binary heap is really just an sorted array pretending to be a tree. Each element has a parent and children, but instead of pointers you find them with simple array indexes. The trick is that every parent follows one rule relative to its children, and that rule decides what kind of heap you get:

Min heap - every parent is less than or equal to its children. The smallest element always lives at the root/top.
Max heap - every parent is greater than or equal to its children. The largest element always lives at the root/top.

Because the tree is complete, the parent of element at index i sits at index floor((i−1)/2), and its children sit at 2i+1 and 2i+2. No pointers, no linked lists — just arithmetic on array indices. That cache friendly layout is one reason heaps are so fast in practice.

The key operations:

Operation	Time	What it does
push	O(log n)	Insert a value, then sift it up to restore order
pop	O(log n)	Remove the root, move the last element up, sift down
peek	O(1)	Read the root without removing it
make_heap	O(n)	Turn an existing unsorted array into a valid heap (`make_heap_min` / `make_heap_max`, `new('min')`, `new('max')`)

This makes a heap the natural backbone of a priority queue — a collection where you always want the next most important item and you need insertions to stay fast.

Why Heap::PQ?

Heap::PQ brings binary heaps to Perl as a C extension. Where a pure Perl heap tops out around 300 operations per second, Heap::PQ's functional interface clocks over 11,000 when pushing a 1000 random integers — and if you are just handling plain integers then there is an optimised NV heap implementation that squeezes out 50% more performance. It ships with three interfaces (object oriented, functional custom ops or a raw array) so you can trade readability for throughput depending on what your code needs.

Installation

cpanm Heap::PQ

Getting Started

Create a heap, push values in, and they come back out in priority order:

use Heap::PQ;

my $pq = Heap::PQ::new('min');

$pq->push(5);
$pq->push(1);
$pq->push(3);

print $pq->peek, "\n";  # 1 — the smallest value is always at the root

while (!$pq->is_empty) {
    print $pq->pop, "\n";  # 1, 3, 5
}

Switch to 'max' and the largest element comes out first instead.

Three Ways to Use It

OO Interface

The object oriented API is the clearest to read if you're a traditional perl developer that likes OO. push returns the heap so calls can be chained:

my $heap = Heap::PQ::new('min');
$heap->push(10)->push(20)->push(5);
$heap->push_all(8, 2, 15);

my $top = $heap->pop;    # 2
my $size = $heap->size;  # 5

Functional Interface

Import with 'import' and Heap::PQ installs heap_push, heap_pop, heap_peek, heap_size, and heap_is_empty as custom ops. Perl compiles them down to optimised opcodes so there is no method dispatch overhead at runtime:

use Heap::PQ 'import';

my $h = Heap::PQ::new('min');

heap_push($h, 42);
heap_push($h, 7);

my $val  = heap_pop($h);      # 7
my $size = heap_size($h);     # 1
my $top  = heap_peek($h);     # 42

This is the fastest path as stated functional custom ops removes the method->dispatch overhead.

Raw Array Interface

You can also operate directly on a Perl array. Import with 'raw' to get make_heap_min, push_heap_min, pop_heap_min (and their _max counterparts). This skips the object entirely but the functional interface is still faster thanks to custom op optimisation:

use Heap::PQ 'raw';

my @data = (9, 4, 7, 1, 3);
Heap::PQ::make_heap_min(\@data);  # O(n) heapify in place

my $min = Heap::PQ::pop_heap_min(\@data);   # 1
Heap::PQ::push_heap_min(\@data, 2);

No object, no opaque struct — just an array whose layout satisfies the heap property. Useful when you already have data in an array and want to avoid copying it.

Custom Comparators

By default the heap compares values numerically. Pass a code reference as a second argument to new and you can heap order anything — hash references, objects, strings:

my $tasks = Heap::PQ::new('min', sub {
    $a->{due} <=> $b->{due}
});

$tasks->push({ name => 'Write tests',  due => 3 });
$tasks->push({ name => 'Ship release', due => 5 });
$tasks->push({ name => 'Fix bug',      due => 1 });

while (!$tasks->is_empty) {
    my $t = $tasks->pop;
    print "$t->{name}\n";
}
# Fix bug
# Write tests
# Ship release

The comparator receives two elements in $a and $b — exactly like Perl's sort — and should return a negative, zero, or positive value. String ordering works the same way:

my $alpha = Heap::PQ::new('min', sub { $a cmp $b });
$alpha->push_all('banana', 'apple', 'cherry');
print $alpha->pop, "\n";  # apple

Key Path Comparators

When your heap contains hash references and you just want to compare by a numeric field, pass the field name as a string instead of a code reference. The comparison happens entirely in C — no Perl callback overhead at all:

my $tasks = Heap::PQ::new('min', 'priority');

$tasks->push({ name => 'Write tests',  priority => 3 });
$tasks->push({ name => 'Ship release', priority => 5 });
$tasks->push({ name => 'Fix bug',      priority => 1 });

while (!$tasks->is_empty) {
    my $t = $tasks->pop;
    print "$t->{name}\n";
}
# Fix bug
# Write tests
# Ship release

Dot separated paths reach into nested hashes:

my $heap = Heap::PQ::new('min', 'meta.score');
$heap->push({ id => 'a', meta => { score => 42 } });
$heap->push({ id => 'b', meta => { score => 17 } });
print $heap->pop->{id};  # 'b'

The key is extracted once when you push, so sift operations run at the same speed as a plain numeric heap. In benchmarks, key path heaps match the no-comparator path (~6,400/s) while custom Perl comparators top out around ~1,200/s — a 5× difference.

NV Heaps — Native Doubles, No SV Overhead

When every value is a number, new_nv stores them as raw C doubles instead of Perl scalars. That eliminates SV allocation and reference counting entirely:

my $h = Heap::PQ::new_nv('min');
$h->push_all(3.14, 2.71, 1.41, 1.73);
print $h->pop, "\n";  # 1.41

In benchmarks the NV heap runs roughly 1.5× faster than the functional interface for push heavy workloads, and nearly 57× faster than pure Perl.

Searching and Deleting

Both search and delete accept a callback that receives each element in $_. search returns matching elements; delete removes them and returns how many were dropped:

my $pq = Heap::PQ::new('min');
$pq->push_all(1, 5, 10, 15, 20, 25);

# Find all elements greater than 12
my @big = $pq->search(sub { $_ > 12 });
# @big = (15, 20, 25)

# Remove them from the heap
my $removed = $pq->delete(sub { $_ > 12 });
# $removed = 3, heap now contains (1, 5, 10)

After a delete, Heap::PQ rebuilds the heap in O(n) with Floyd's algorithm so the ordering invariant is always intact.

Peeking at the Top N

peek_n returns the top N elements in sorted order without removing them:

my $scores = Heap::PQ::new('max');
$scores->push_all(88, 95, 72, 99, 84, 91);

my @top3 = $scores->peek_n(3);  # (99, 95, 91)
# Heap is unchanged — still has all 6 elements

peek_n works with the heap's built-in numeric comparison, so it is best suited to plain numeric heaps. For heaps that use a custom comparator, pop and re-push to inspect the top N.

Putting It Together: An Event Scheduler

A priority queue is a natural fit for an event loop — push events with a timestamp, pop them in chronological order:

use Heap::PQ 'import';

my $scheduler = Heap::PQ::new('min', 'time'); # compare by the 'time' key in C

heap_push($scheduler, { time => 1712500800, action => 'start_server' });
heap_push($scheduler, { time => 1712497200, action => 'load_config' });
heap_push($scheduler, { time => 1712504400, action => 'open_connections' });
heap_push($scheduler, { time => 1712502600, action => 'warm_cache' });

while (!heap_is_empty($scheduler)) {
    my $event = heap_pop($scheduler);
    printf "t=%d  %s\n", $event->{time}, $event->{action};
}

# t=1712497200  load_config
# t=1712500800  start_server
# t=1712502600  warm_cache
# t=1712504400  open_connections

Benchmarks

All numbers below are from pushing 1,000 random integers then popping them all, measured with Benchmark:

Implementation	Rate	vs Pure Perl
Pure Perl	305/s	—
Custom comparator	1,194/s	4x
Array::Heap	6,087/s	20x
Heap::PQ OO key path	6,359/s	21x
Heap::PQ OO	6,685/s	22x
Heap::PQ raw	8,665/s	28x
Heap::PQ func	11,416/s	37x
Heap::PQ NV	16,747/s	55x

The custom op overhead reduction is clearly visible in the functional row, and the NV heap's custom op implementation plus avoidance of SV allocation pushes throughput higher still.

If you have any questions please do comment.

A Side note: I'm currently on look out for a new contract or permanent opportunity. If you know of any relevant openings, I'd appreciate hearing from you - email@lnation.org

Chandra: Cross-Platform Desktop GUIs in Perl

LNATION — Sat, 04 Apr 2026 18:53:20 +0000

Building desktop applications has traditionally been a challenge in the Perl ecosystem. While we have excellent tools for web development, backend services, and system administration, creating native feeling desktop apps often meant learning and wrestling with complex GUI toolkits or abandoning Perl altogether.

Chandra attempts to change that equation.

What is Chandra?

Chandra is a Perl module that lets you build cross-platform desktop applications using the web technologies you already know — HTML, CSS, and JavaScript — while keeping your application logic in Perl. Under the hood, it leverages native webview components (WebKit on macOS/Linux, Edge on Windows) to render your UI, giving you the best of both worlds: native performance with web flexibility.

use Chandra::App;

my $app = Chandra::App->new(
    title  => 'My First App',
    width  => 800,
    height => 600,
);

$app->set_content('<h1>Hello from Perl!</h1>');
$app->run;

That's it. Five lines to create a windowed application.

The Bridge Between Worlds

The real power of Chandra lies in its seamless bidirectional communication between Perl and JavaScript. You can expose Perl functions to your frontend with a simple bind call:

my $app = Chandra::App->new(title => 'Counter');

my $count = 0;

$app->bind('increment', sub {
    $count++;
    return $count;
});

$app->bind('decrement', sub {
    $count--;
    return $count;
});

$app->set_content(<<'HTML');
<!DOCTYPE html>
<html>
<body>
    <h1 id="counter">0</h1>
    <button onclick="inc()">+</button>
    <button onclick="dec()">-</button>
    <script>
        async function inc() {
            let val = await window.chandra.invoke('increment');
            document.getElementById('counter').textContent = val;
        }
        // or
        function dec() {
            window.chandra.invoke('decrement').then(function(val) {
                document.getElementById('counter').textContent = val;
            });
        }
    </script>
</body>
</html>
HTML

$app->run;

Your JavaScript calls window.chandra.invoke('increment'), Perl increments the counter, and the result flows back as a Promise. JSON serialization happens automatically.

Building UIs the Perl Way

If you prefer constructing your UI in Perl rather than writing raw HTML strings, Chandra::Element provides a DOM-like interface:

use Chandra::Element;

my $ui = Chandra::Element->new({
    tag => 'div',
    class => 'container',
    style => { padding => '20px', background => '#f5f5f5' },
    children => [
        { tag => 'h1', data => 'Welcome' },
        {
            tag => 'button',
            data => 'Click Me',
            onclick => sub {
                my ($event, $app) = @_;
                print "Button clicked!\n";
            },
        },
    ],
});

$app->set_content($ui);

Event handlers are automatically wired up — when the button is clicked, your Perl callback fires.

Single-Page Apps with Built-in Routing

Modern desktop apps often benefit from SPA-style navigation. Chandra has you covered:

my $app = Chandra::App->new(title => 'My SPA');

$app->layout(sub {
    my ($body) = @_;
    return qq{
        <nav>
            <a href="/">Home</a>
            <a href="/settings">Settings</a>
        </nav>
        <div id="chandra-content">$body</div>
    };
});

$app->route('/' => sub {
    return '<h1>Home</h1><p>Welcome!</p>';
});

$app->route('/settings' => sub {
    return '<h1>Settings</h1><p>Configure your app...</p>';
});

$app->route('/user/:id' => sub {
    my (%params) = @_;
    return "<h1>User $params{id}</h1>";
});

$app->run;

Navigation happens client-side with no page reloads — just like a web SPA, but in a native window.

Native Integration Done Right

Chandra doesn't just wrap a browser. It provides genuine desktop integration:

Native Dialogs

# File picker
my $path = $app->dialog->open_file(title => 'Select a file');

# Directory picker  
my $dir = $app->dialog->open_directory;

# Save dialog
my $save_path = $app->dialog->save_file(
    title   => 'Save As',
    default => 'document.txt',
);

# Alert dialogs
$app->dialog->info(message => 'Operation complete!');
$app->dialog->error(message => 'Something went wrong');

System Tray

use Chandra::Tray;

my $tray = Chandra::Tray->new(
    app     => $app,
    icon    => 'icon.png',
    tooltip => 'My App',
);

$tray->add_item('Show Window' => sub { $app->show });
$tray->add_separator;
$tray->add_item('Quit' => sub { $app->terminate });
$tray->show;

Persistent Storage

my $store = $app->store;  # ~/.chandra/<app-name>/store.json

$store->set('theme', 'dark');
$store->set('window.width', 1200);
$store->set('recent_files', ['/path/a', '/path/b']);

my $theme = $store->get('theme');  # 'dark'

Dot notation for nested keys, automatic JSON serialization, atomic writes with file locking — storage that just works.

Hot Reload

Wtch your source files and refresh automatically:

$app->watch('lib/', sub {
    my ($changed) = @_;
    print "Files changed: @$changed\n";
    $app->set_content(build_ui());
    $app->refresh;
});

$app->run;

DevTools

Need to inspect elements or debug JavaScript? Enable developer tools:

my $app = Chandra::App->new(
    title => 'Debug App',
    debug => 1,  # Press F12 to open DevTools
);

Platform Support

Chandra works across the major desktop platforms:

macOS — Uses WebKit via WKWebView
Linux — Uses WebKitGTK
Windows — Uses MSHTML/Edge

Getting Started

Install from CPAN:

cpanm Chandra

Or from source:

perl Makefile.PL
make
make install

Then dive into the examples directory for working demonstrations of all major features or I also have several modules already available for you to test:

Chandra::EPUB

Ascii::Text::Chandra

Chandra::Game::Tetris

A Side note: I'm currently on look out for a new contract or permanent opportunity. If you know of any relevant openings, I'd appreciate hearing from you - email@lnation.org

Introducing Object::Proto — A Prototype Object System for Perl

LNATION — Fri, 03 Apr 2026 11:54:34 +0000

Perl's object system is famously flexible. bless a reference, add some accessors, and you're in business. Over the years, modules like Moose, Moo, and Mouse have built increasingly sophisticated layers on top of that foundation — giving us type constraints, roles, lazy attributes, and declarative syntax.

But they all share the same bedrock: a blessed hash reference.

Object::Proto takes a less used approach. It stores objects as blessed arrays, maps property names to slot indices at compile time, and compiles accessors down to custom ops — the same mechanism Perl uses internally for built-in operations. The result is an object system that is type-safe, feature-rich, and significantly faster than the previously mentioned alternatives.

The Basics

use Object::Proto;

object 'Animal',
    'name:Str:required',
    'sound:Str:default(silence)',
    'age:Int';

my $cat = new Animal name => 'Whiskers', age => 3;
print $cat->name;      # Whiskers
print $cat->sound;     # silence
$cat->age(4);          # setter

The object keyword defines a class at compile time. Property specifications use a colon-separated format: name:Type:modifier. No hash lookups at runtime — $cat->name compiles to a direct array slot access.

Both positional and named constructors are supported:

my $cat = new Animal 'Whiskers', 'meow', 3;     # positional (fastest)
my $cat = new Animal name => 'Whiskers', age => 3; # named pairs

What You Get

Built-in Types (Zero Overhead)

Any  Defined  Str  Int  Num  Bool  ArrayRef  HashRef  CodeRef  Object

These are checked inline at the C level — no function call, no callback. You can also register custom types in Perl or in XS.

Slot Modifiers

object 'Person',
    'name:Str:required',
    'email:Str:required:readonly',
    'age:Int:default(0)',
    'nickname:Str:clearer:predicate',
    'settings:HashRef:lazy:builder(_build_settings)',
    'parent:Object:weak',
    'internal_id:Int:arg(_id)',       # constructor uses _id, accessor uses internal_id
    'score:Num:trigger(on_score_change)',
    'rank:Str:reader(get_rank):writer(set_rank)';

Everything you'd expect from a modern object system: required, readonly, default, lazy, builder, clearer, predicate, reader, writer, trigger, weak references, and arg (init_arg) — all compiled to C/XS.

Inheritance

object 'Animal', 'name:Str:required', 'sound:Str';

object 'Dog',
    extends => 'Animal',
    'breed:Str';

my $dog = new Dog name => 'Rex', sound => 'Woof', breed => 'Lab';
print $dog->isa('Animal');  # 1

Multiple inheritance and multi-level chains work as youl would expect:

object 'Triathlete',
    extends => ['Swimmer', 'Runner'],
    'event:Str';

Important note: because Object::Proto objects are arrays and Moo/Moose/Mouse objects are hashes, you cannot inherit from Moo, Moose, or Mouse classes (or vice versa). The internal representations are fundamentally incompatible. If you need to interoperate, use composition (roles or delegation via slots) rather than inheritance.

Roles

Roles work the way you'd expect — define a bundle of slots and method requirements, then compose them into any class. A role can carry its own attributes and demand that consuming classes implement specific methods:

use Object::Proto;

role('Printable', 'format:Str:default(text)');
requires('Printable', 'to_string');

object 'Document',
    'title:Str:required',
    'body:Str';

with('Document', 'Printable');

package Document;
sub to_string { $_[0]->title . ': ' . $_[0]->body }

The format slot from Printable is merged into Document at define time. If Document didn't provide a to_string method, the with call would croak. You can check role consumption at runtime with Object::Proto::does($obj, 'Printable').

Method Modifiers

You can wrap existing methods without subclassing. before runs code ahead of the original, after runs code after it, and around gives you full control — you receive the original method as $orig and decide whether (and how) to call it:

before 'bark' => sub {
    my ($self) = @_;
    warn "About to bark...";
};

after 'bark' => sub {
    my ($self) = @_;
    warn "Done barking.";
};

around 'bark' => sub {
    my ($orig, $self, @args) = @_;
    return uc $self->$orig(@args);
};

Multiple modifiers can be stacked on the same method. They're stored as linked lists in C, so the dispatch overhead is minimal.

Prototype Chains

This is where Object::Proto gets its name. Like JavaScript's prototype model, any object can delegate to another object. When you access a property that is undef in the current object, the lookup walks up the prototype chain until it finds a defined value:

my $defaults = new Animal name => 'Default', sound => 'silence';
my $cat = new Animal name => 'Whiskers';
$cat->set_prototype($defaults);

print $cat->sound;  # 'silence' — resolved from prototype

$cat has no sound of its own, so the accessor walks up to $defaults and returns 'silence'. Setting $cat->sound('meow') writes to $cat directly — prototypes are never mutated by child writes. You can inspect the full chain with Object::Proto::prototype_chain($obj) and measure its depth with Object::Proto::prototype_depth($obj).

Mutability Controls

Objects can be locked (preventing structural changes) or frozen (permanent deep immutability). A frozen object's setters will croak on any attempt to modify — useful for configuration objects, default prototypes, or any value you want to guarantee stays constant:

$obj->lock;       # prevent structural changes
$obj->unlock;
$obj->freeze;     # permanent immutability — setters will croak
$obj->is_frozen;  # true

Locking is reversible; freezing is not. The frozen check is implemented as a single bitflag test in C — it adds no measurable overhead to the normal (unfrozen) code path.

Cloning & Introspection

Object::Proto provides a full introspection API. You can clone objects (the clone is always fresh, unfrozen and unlocked, even if the original wasn't), list properties, inspect slot metadata, and walk the inheritance tree:

my $clone = Object::Proto::clone($obj);     # shallow copy, unfrozen
my @props = Object::Proto::properties('Dog');
my $info  = Object::Proto::slot_info('Dog', 'name');
my @chain = Object::Proto::ancestors('Dog');

slot_info returns a hashref with everything about a slot: its type, whether it's required, readonly, lazy, has a default, trigger, builder, and so on. Useful for building serializers, form generators, or debugging tools.

Singletons

Need a class that only ever has one instance? Mark it as a singleton and use ->instance() instead of new. The first call constructs the object; every subsequent call returns the same one:

object 'Config', 'db_host:Str', 'db_port:Int';
Object::Proto::singleton('Config');

my $c = Config->instance(db_host => 'localhost', db_port => 5432);
# Config->instance returns the same object every time after first call

This is handled at the C level — no Perl-side state variable or CHECK block trickery.

Function-Style Accessors

For the absolute fastest access, Object::Proto offers function-style accessors that bypass method dispatch entirely. These are compiled to custom ops at compile time — a direct array slot read/write with no entersub, no method resolution, no hash lookup:

use Object::Proto;

object 'Point', 'x:Num', 'y:Num';
Object::Proto::import_accessors('Point');

my $p = new Point 1.0, 2.0;
print x($p);         # 1.0 — custom op, not a method call
y($p, 3.0);          # set y to 3.0

Performance

Here are benchmarks from a mixed new + set + get workload:

                       Rate    Pure Hash  Pure Array    XS OO   Typed  Raw Hash Ref  XS func  Raw Hash
Pure Hash         1824921/s           --       -14%     -48%     -64%       -66%       -66%     -70%
Pure Array        2124357/s          16%         --     -40%     -58%       -60%       -61%     -65%
Object::Proto OO  3541833/s          94%        67%       --     -31%       -34%       -35%     -41%
Object::Proto T   5114883/s         180%       141%      44%       --        -4%        -6%     -15%
Raw Hash Ref      5331773/s         192%       151%      51%       4%         --        -2%     -12%
Object::Proto fn  5427162/s         197%       156%      53%       6%        2%          --     -10%
Raw Hash          6024884/s         230%       184%      70%      18%       13%        11%       --

The function-style path (XS func) runs slightly faster than raw hash reference access — while giving you a real object with type constraints, constructors, and a class hierarchy. The method-style path (XS OO) is nearly 2x faster than a pure-Perl hash-based object.

For hot set + get loops on pre-constructed objects, the XS function path has been measured at over 32 million operations per second — faster than a hash $hash{key} access.

Extending the Type System from XS

If you write XS modules, you can register types with C-level check functions that run at near-zero cost (~5 CPU cycles vs ~100 for Perl callbacks):

/* In your BOOT section */
#include "object_types.h"

static bool check_positive_int(pTHX_ SV *val) {
    return SvIOK(val) && SvIV(val) > 0;
}

BOOT:
    object_register_type_xs(aTHX_ "PositiveInt", check_positive_int, NULL);

use MyTypes;  # registers in BOOT
use Object::Proto;

object 'Counter', 'value:PositiveInt:required';

For Moo/Moose Users: Object::Proto::Sugar

If you prefer declarative Moo-style syntax, Object::Proto::Sugar wraps the XS layer with familiar keywords. Everything compiles down to the same custom ops underneath:

package Animal;
use Object::Proto::Sugar;

has name  => ( is => 'rw', isa => Str, required => 1 );
has sound => ( is => 'rw', isa => Str, default  => 'silence' );
has age   => ( is => 'rw', isa => Int );

sub speak { $_[0]->sound }

package Dog;
use Object::Proto::Sugar;

extends 'Animal';

has breed => ( is => 'rw', isa => Str );

package main;

my $dog = new Dog name => 'Rex', sound => 'Woof', breed => 'Lab';
print $dog->speak;         # Woof
print $dog->isa('Animal'); # 1

Every feature from the core module is available through the Sugar interface: lazy, builder, coerce, trigger, predicate, clearer, reader, writer, weak_ref, init_arg, roles (use Object::Proto::Sugar -role / with / requires), method modifiers (before, after, around), and function-style accessors via accessor => 1. The Sugar layer runs at compile time via BEGIN::Lift and then Devel::Hook via BIGIN and UNITCHECK hooks — by the time your first line of runtime code executes, everything has been compiled down to the same custom ops as the raw object keyword.

Sugar with Function-Style Accessors

Add accessor => 1 to a has declaration to get a function style accessor alongside the method style one. Then call import_accessors in your package so the functions are visible when your calling code compiles.

package Point;
use Object::Proto::Sugar;

has x => ( is => 'rw', isa => Num, accessor => 1 );
has y => ( is => 'rw', isa => Num, accessor => 1 );

package main;

Point->import_accessors;     # install before compilation

my $p = new Point x => 1.0, y => 2.0;
print x($p);       # 1.0 — compiled to custom op
y($p, 3.0);        # direct array write

Sugar Benchmarks vs Moo and Mouse

                       Rate       Moo     Mouse   Sugar   Sugar (fn)
Moo               1264320/s        --       -2%    -55%       -60%
Mouse             1290237/s        2%        --    -54%       -59%
Sugar (method)    2784378/s      120%      116%      --       -12%
Sugar (func)      3174093/s      151%      146%     14%         --

Sugar method-style is 2.2x Moo. Sugar function-style is 2.5x Moo.

A Note on Compatibility

Once again a reminder: because Object::Proto objects are arrays and Moo/Moose/Mouse objects are hashes, you cannot inherit across the boundary. extends 'My::Moo::Class' will not work. Use role or delegation to bridge the two worlds if needed. Within its own ecosystem — Object::Proto classes inheriting from other Object::Proto classes — everything works seamlessly, including multiple inheritance.

Object::Proto is available on CPAN and licensed under the Artistic License 2.0.

cpanm Object::Proto
cpanm Object::Proto::Sugar   # optional, for Moo-like syntax

MetaCPAN

DEV Community: LNATION

Template::Stencil - A Fast Template Engine

One delimiter, one closer

Output tags

Filters

Conditionals

Loops

Assignment

Includes

Wrapper

Comments and literal braces

The Perl API

new

render

Template::Stencil::PSGI

Encoding, errors, concurrency

What it will not do

The numbers

Where it is

Punk: Fully Authed

What you are building

punk new AuthApp

Secrets before sessions

A database and two models

Wiring auth

Mail through Resend

Verification links with mail_token

Forgotten passwords

One chokepoint for signing in

A second factor

Sign in with GitHub and Google

The application class and the auth controller, complete

Testing the whole flow in process

Running it

Punk: a MVC framework

What that buys, and what it costs

The keywords

OpenAPI as a first class mount

The stack underneath

The command line

Async

A note on speed

Where it is

Hyperman into Fetch

Hyperman

How fast is it?

The problem: how do you even measure that?

Part 2: Fetch

How fast is it?

Getting them

PDF Generation, Extraction and Modification with PDF::Make

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

2) Extract text coordinates, then overlay border highlights

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

It's an expression, too

The patterns are a small, predictable grammar

Why "compile-time" matters for speed

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

A real lexical pragma

Benchmarking

Getting it

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

Adopting one from Zefram

The Idea

Enum::Declare

Explicit Values

String Enums

Bitflags

Exporting

Meta Objects

Exhaustive Matching

How It Works

Enum::Declare::Common

Integration with Object::Proto

Learning XS - Custom Ops

Creating the Distribution

Adding the Entropy Function

Adding Custom Ops

The PP Function

The Call Checker

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