File Coverage

blib/lib/PAGI/Session.pm

Criterion	Covered	Total	%
statement	62	62	100.0
branch	21	24	87.5
condition	7	12	58.3
subroutine	16	16	100.0
pod	13	13	100.0
total	119	127	93.7

package PAGI::Session;

use strict;
use warnings;
use Scalar::Util 'blessed';

=head1 NAME

PAGI::Session - Standalone helper object for session data access

=head1 SYNOPSIS

    use PAGI::Session;

    # Construct from scope or request object
    my $session = PAGI::Session->new($scope);
    my $session = PAGI::Session->new($req);  # any object with ->scope
    my $session = PAGI::Session->new(@_);    # extra args ignored

    # Test convenience - wrap raw data directly
    my $session = PAGI::Session->from_data({ _id => 'test', user_id => 42 });

    # Strict get - dies if key doesn't exist (catches typos)
    my $user_id = $session->get('user_id');

    # Safe get with default for optional keys
    my $theme = $session->get('theme', 'light');

    # Set, delete, check existence
    $session->set('cart_count', 3);
    $session->delete('cart_count');
    if ($session->exists('user_id')) { ... }

    # List user keys (excludes internal _prefixed keys)
    my @keys = $session->keys;

    # Session lifecycle
    $session->regenerate;  # Request new session ID
    $session->destroy;     # Mark session for deletion

=head1 DESCRIPTION

PAGI::Session wraps the raw session data hashref and provides a clean
accessor interface with strict key checking. It is a standalone helper
that is not attached to any request or protocol object.

The strict C method dies when a key does not exist, catching
typos at runtime. Use the two-argument form C
for keys that may or may not be present.

=head1 CONSTRUCTOR

=head2 new

    my $session = PAGI::Session->new($scope);
    my $session = PAGI::Session->new($request);   # any object with ->scope
    my $session = PAGI::Session->new(@_);          # extra args ignored

Scope-based constructor. Resolves to the C<< $scope->{'pagi.session'} >>
hashref. Accepts a scope hashref directly, or any blessed object with a
C method. Extra positional arguments (C<$receive>, C<$send>) are
silently ignored, so you can write C<< PAGI::Session->new(@_) >> in a
handler.

Dies if the scope does not contain a C key (session
middleware must run first).

=head2 from_data

    my $session = PAGI::Session->from_data({ _id => 'test', user_id => 42 });

Test convenience constructor. Wraps a raw hashref directly as the backing
data, bypassing scope resolution. The returned object behaves identically
to one created via C.

=cut

sub new {
    my ($class, @args) = @_;

    my $arg = $args[0];

    # Object with ->scope method (e.g., PAGI::Request, PAGI::SSE)
    if (blessed($arg) && $arg->can('scope')) {
        my $scope = $arg->scope;
        die "PAGI::Session requires scope hashref with 'pagi.session' key\n"
            unless ref $scope eq 'HASH' && exists $scope->{'pagi.session'};
        return bless { _data => $scope->{'pagi.session'} }, $class;
    }

    # Scope hashref - must have pagi.session key
    if (ref $arg eq 'HASH' && exists $arg->{'pagi.session'}) {
        return bless { _data => $arg->{'pagi.session'} }, $class;
    }

    die "PAGI::Session requires a scope hashref (with 'pagi.session' key) or object with ->scope method\n";
}

sub from_data {
    my ($class, $data) = @_;
    die "from_data() requires a hashref\n" unless ref $data eq 'HASH';
    return bless { _data => $data }, $class;
}

=head1 METHODS

=head2 id

    my $id = $session->id;

Returns the session ID from C<< $data->{_id} >>.

=cut

sub id {
    my ($self) = @_;
    return $self->{_data}{_id};
}

=head2 data

    my $href = $session->data;
    $href->{key} = $value;  # direct mutation

Returns the raw backing hashref. Mutations are visible through
C/C since they operate on the same reference.

=cut

sub data {
    my ($self) = @_;
    return $self->{_data};
}

=head2 get

    my $value = $session->get('key');           # dies if missing
    my $value = $session->get('key', $default); # returns $default if missing

Retrieves a value from the session. With one argument, dies with an
error including the key name if the key does not exist. With a default
argument, returns the default when the key is missing (even if the
default is C).

=cut

sub get {
    my ($self, @args) = @_;
    die "get() requires 1 or 2 arguments\n" if @args == 0 || @args > 2;
    my ($key, @rest) = @args;
    if (!exists $self->{_data}{$key}) {
        return $rest[0] if @rest;
        my @user_keys = sort grep { !/^_/ } keys %{$self->{_data}};
        if (@user_keys <= 10) {
            die "Session key '$key' does not exist. Available keys: "
                . join(', ', @user_keys) . "\n";
        }
        else {
            die "Session key '$key' does not exist (session has "
                . scalar(@user_keys) . " user keys)\n";
        }
    }
    return $self->{_data}{$key};
}

=head2 set

    $session->set('key', $value);
    $session->set(user_id => 42, role => 'admin', email => '[e-mail]');
    $session->set('a', 1)->set('b', 2);  # chaining

Sets one or more keys in the session data. Accepts key-value pairs.
Returns C<$self> for method chaining. With zero arguments, acts as a
no-op returning C<$self>. Dies if given an odd number of arguments.

=cut

sub set {
    my ($self, @args) = @_;
    return $self unless @args;
    die "set() requires key => value pairs\n" if @args % 2;
    my %pairs = @args;
    $self->{_data}{$_} = $pairs{$_} for CORE::keys %pairs;
    return $self;
}

=head2 exists

    if ($session->exists('key')) { ... }

Returns true if the key exists in the session data.

=cut

sub exists {
    my ($self, $key) = @_;
    return exists $self->{_data}{$key} ? 1 : 0;
}

=head2 delete

    $session->delete('key');
    $session->delete('k1', 'k2', 'k3');
    $session->delete('a')->delete('b');  # chaining

Removes one or more keys from the session data. Returns C<$self> for
method chaining.

=cut

sub delete {
    my ($self, @keys) = @_;
    delete $self->{_data}{$_} for @keys;
    return $self;
}

=head2 keys

    my @keys = $session->keys;

Returns a list of user keys, filtering out internal keys that start
with an underscore (e.g. C<_id>, C<_created>, C<_last_access>).

=cut

sub keys {
    my ($self) = @_;
    return grep { !/^_/ } keys %{$self->{_data}};
}

=head2 slice

    my %data = $session->slice('user_id', 'role', 'email');

Returns a hash of key-value pairs for the requested keys. Keys that
do not exist in the session are silently skipped (unlike C,
which dies on missing keys).

=cut

sub slice {
    my ($self, @keys) = @_;
    return map { CORE::exists($self->{_data}{$_}) ? ($_ => $self->{_data}{$_}) : () } @keys;
}

=head2 clear

    $session->clear;

Removes all user keys from the session, preserving internal
C<_>-prefixed keys (C<_id>, C<_created>, C<_last_access>, etc.).
Use this for a "soft logout" that keeps the session ID but wipes
application data.

=cut

sub clear {
    my ($self) = @_;
    for my $key ($self->keys) {
        delete $self->{_data}{$key};
    }
}

=head2 regenerate

    $session->regenerate;

Requests session ID regeneration. The middleware will generate a new
session ID, delete the old session from the store, save session data
under the new ID, and update the client cookie/header.

B Always call this after authentication (login) to prevent
session fixation attacks.

=cut

sub regenerate {
    my ($self) = @_;
    $self->{_data}{_regenerated} = 1;
}

=head2 destroy

    $session->destroy;

Marks the session for destruction. The middleware will delete the
session data from the store and clear the client-side state (e.g.,
expire the cookie). Use this for logout.

=cut

sub destroy {
    my ($self) = @_;
    $self->{_data}{_destroyed} = 1;
}

1;

__END__