File Coverage

blib/lib/PAGI/Test/Response.pm

Criterion	Covered	Total	%
statement	53	60	88.3
branch	14	18	77.7
condition	10	13	76.9
subroutine	17	18	94.4
pod	14	14	100.0
total	108	123	87.8

package PAGI::Test::Response;
$PAGI::Test::Response::VERSION = '0.002000';
use strict;
use warnings;
use Carp 'croak';

# Maximum bytes of response body to include in JSON decode error messages
our $JSON_ERROR_BODY_LIMIT = 1500;

sub new {
    my ($class, %args) = @_;
    return bless {
        status    => $args{status} // 200,
        headers   => $args{headers} // [],
        body      => $args{body} // '',
        exception => $args{exception},
    }, $class;
}

# Status code
sub status { shift->{status} }

# Raw body bytes
sub content { shift->{body} }

# Decoded text based on Content-Type charset
sub text {
    my ($self) = @_;
    my $body = $self->{body};
    return $body unless defined $body && length $body;

    # Parse charset from Content-Type header
    my $charset = $self->_extract_charset // 'UTF-8';

    require Encode;
    return Encode::decode($charset, $body, Encode::FB_CROAK());
}

# Extract charset from Content-Type header
sub _extract_charset {
    my ($self) = @_;
    my $ct = $self->content_type or return undef;

    # Match charset=... (with or without quotes)
    if ($ct =~ /charset\s*=\s*"?([^";,\s]+)"?/i) {
        return $1;
    }
    return undef;
}

# Header lookup (case-insensitive)
sub header {
    my ($self, $name) = @_;
    $name = lc($name);
    for my $pair (@{$self->{headers}}) {
        return $pair->[1] if lc($pair->[0]) eq $name;
    }
    return undef;
}

# All headers as hashref (last value wins for duplicates)
sub headers {
    my ($self) = @_;
    my %h;
    for my $pair (@{$self->{headers}}) {
        $h{lc($pair->[0])} = $pair->[1];
    }
    return \%h;
}

# Status helpers
sub is_success  { my $s = shift->status; $s >= 200 && $s < 300 }
sub is_redirect { my $s = shift->status; $s >= 300 && $s < 400 }
sub is_error    { my $s = shift->status; $s >= 400 }

# Exception from app (if trapped)
sub exception { shift->{exception} }

# Parse body as JSON
sub json {
    my ($self) = @_;
    require JSON::MaybeXS;

    my $body = $self->{body};
    my $data = eval { JSON::MaybeXS::decode_json($body) };

    if (my $err = $@) {
        my $status = $self->status;
        my $ct = $self->content_type // '(none)';

        # Truncate body preview if too long
        my $preview = defined $body ? $body : '(undef)';
        if (length($preview) > $JSON_ERROR_BODY_LIMIT) {
            $preview = substr($preview, 0, $JSON_ERROR_BODY_LIMIT) . "\n... [truncated, " . length($body) . " bytes total]";
        }

        $err =~ s/\s+at \S+ line \d+\.?\s*$//;  # Strip file/line from JSON error

        croak "Response body is not valid JSON (status=$status, content-type=$ct)\n"
            . "Body: $preview\n"
            . "JSON error: $err";
    }

    return $data;
}

# Convenience header shortcuts
sub content_type   { shift->header('content-type') }
sub content_length { shift->header('content-length') }
sub location       { shift->header('location') }

1;

__END__