File Coverage

blib/lib/Hypersonic/Request.pm

Criterion	Covered	Total	%
statement	79	81	97.5
branch	9	12	75.0
condition	1	2	50.0
subroutine	12	13	92.3
pod	4	6	66.6
total	105	114	92.1

package Hypersonic::Request;

use strict;
use warnings;
use 5.010;

our $VERSION = '0.15';

# JIT-compiled Request object using array-based slots for maximum speed
# Generates XS accessors at compile time via XS::JIT::Builder

use XS::JIT;
use XS::JIT::Builder;

# Request slots (array indices) - these map to the array-based request object
# The order MUST match what C code generates in call_dynamic_handler
use constant {
    SLOT_METHOD           => 0,
    SLOT_PATH             => 1,
    SLOT_BODY             => 2,
    SLOT_PARAMS           => 3,   # HV* of named path params
    SLOT_QUERY            => 4,   # HV* of query string params
    SLOT_QUERY_STRING     => 5,   # Raw query string
    SLOT_HEADERS          => 6,   # HV* of headers
    SLOT_COOKIES          => 7,   # HV* of cookies
    SLOT_JSON             => 8,   # Parsed JSON body
    SLOT_FORM             => 9,   # HV* of form data
    SLOT_SEGMENTS         => 10,  # AV* of path segments
    SLOT_ID               => 11,  # Last path segment (legacy)
    SLOT_SESSION          => 12,  # Session data hashref
    SLOT_SESSION_ID       => 13,  # Session ID string
    SLOT_SESSION_MODIFIED => 14,  # Session modified flag
    SLOT_COUNT            => 15,  # Total number of slots
};

# Export slot constants for direct access
use Exporter 'import';
our @EXPORT_OK = qw(
    SLOT_METHOD SLOT_PATH SLOT_BODY SLOT_PARAMS SLOT_QUERY
    SLOT_QUERY_STRING SLOT_HEADERS SLOT_COOKIES SLOT_JSON
    SLOT_FORM SLOT_SEGMENTS SLOT_ID
    SLOT_SESSION SLOT_SESSION_ID SLOT_SESSION_MODIFIED
    SLOT_COUNT
);

my $COMPILED = 0;
my $MODULE_ID = 0;

# Unified compile interface
sub compile {
    my ($class, %opts) = @_;
    return $class->compile_accessors(%opts);
}

# Generate and compile XS accessors
sub compile_accessors {
    my ($class, %opts) = @_;

    return 1 if $COMPILED;

    my $cache_dir = $opts{cache_dir} // '_hypersonic_cache/request';
    my $module_name = 'Hypersonic::Request::Accessors_' . $MODULE_ID++;

    my $builder = XS::JIT::Builder->new;

    # Generate read-only accessors for simple scalar slots
    $builder->op_ro_accessor('jit_method', SLOT_METHOD);
    $builder->op_ro_accessor('jit_path', SLOT_PATH);
    $builder->op_ro_accessor('jit_body', SLOT_BODY);
    $builder->op_ro_accessor('jit_query_string', SLOT_QUERY_STRING);
    $builder->op_ro_accessor('jit_id', SLOT_ID);

    # Generate accessors for hashref slots (params, query, headers, cookies, form)
    # These return the hashref directly for fast access
    $builder->op_ro_accessor('jit_params', SLOT_PARAMS);
    $builder->op_ro_accessor('jit_query', SLOT_QUERY);
    $builder->op_ro_accessor('jit_headers', SLOT_HEADERS);
    $builder->op_ro_accessor('jit_cookies', SLOT_COOKIES);
    $builder->op_ro_accessor('jit_form', SLOT_FORM);
    $builder->op_ro_accessor('jit_json', SLOT_JSON);
    $builder->op_ro_accessor('jit_segments', SLOT_SEGMENTS);

    # Generate param($name) accessor - fetches from params hashref
    $builder->xs_function('jit_param')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* params = (HV*)SvRV(ary[' . SLOT_PARAMS . ']);')
      ->if('items > 1')
        ->line('STRLEN klen;')
        ->line('const char* key = SvPV(ST(1), klen);')
        ->line('SV** val = hv_fetch(params, key, klen, 0);')
        ->line('ST(0) = val && *val ? *val : &PL_sv_undef;')
      ->else
        ->line('ST(0) = newRV_inc((SV*)params);')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate query_param($name) accessor
    $builder->xs_function('jit_query_param')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* query = (HV*)SvRV(ary[' . SLOT_QUERY . ']);')
      ->if('items > 1')
        ->line('STRLEN klen;')
        ->line('const char* key = SvPV(ST(1), klen);')
        ->line('SV** val = hv_fetch(query, key, klen, 0);')
        ->line('ST(0) = val && *val ? *val : &PL_sv_undef;')
      ->else
        ->line('ST(0) = newRV_inc((SV*)query);')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate header($name) accessor - normalizes header name
    $builder->xs_function('jit_header')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* headers = (HV*)SvRV(ary[' . SLOT_HEADERS . ']);')
      ->if('items > 1')
        ->line('STRLEN klen;')
        ->line('const char* key = SvPV(ST(1), klen);')
        ->comment('Normalize: lowercase, hyphens to underscores')
        ->line('char norm_key[256];')
        ->line('int i;')
        ->line('for (i = 0; i < klen && i < 255; i++) {')
        ->line('    char c = key[i];')
        ->line('    norm_key[i] = (c >= \'A\' && c <= \'Z\') ? c + 32 : (c == \'-\') ? \'_\' : c;')
        ->line('}')
        ->line('norm_key[i] = 0;')
        ->line('SV** val = hv_fetch(headers, norm_key, i, 0);')
        ->line('ST(0) = val && *val ? *val : &PL_sv_undef;')
      ->else
        ->line('ST(0) = newRV_inc((SV*)headers);')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate cookie($name) accessor
    $builder->xs_function('jit_cookie')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* cookies = (HV*)SvRV(ary[' . SLOT_COOKIES . ']);')
      ->if('items > 1')
        ->line('STRLEN klen;')
        ->line('const char* key = SvPV(ST(1), klen);')
        ->line('SV** val = hv_fetch(cookies, key, klen, 0);')
        ->line('ST(0) = val && *val ? *val : &PL_sv_undef;')
      ->else
        ->line('ST(0) = newRV_inc((SV*)cookies);')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate form($name) accessor
    $builder->xs_function('jit_form_field')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* form = (HV*)SvRV(ary[' . SLOT_FORM . ']);')
      ->if('items > 1')
        ->line('STRLEN klen;')
        ->line('const char* key = SvPV(ST(1), klen);')
        ->line('SV** val = hv_fetch(form, key, klen, 0);')
        ->line('ST(0) = val && *val ? *val : &PL_sv_undef;')
      ->else
        ->line('ST(0) = newRV_inc((SV*)form);')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate is_json() - check Content-Type header
    $builder->xs_function('jit_is_json')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* headers = (HV*)SvRV(ary[' . SLOT_HEADERS . ']);')
      ->line('SV** ct = hv_fetch(headers, "content_type", 12, 0);')
      ->if('ct && *ct && SvOK(*ct)')
        ->line('STRLEN len;')
        ->line('const char* str = SvPV(*ct, len);')
        ->if('len >= 16 && memcmp(str, "application/json", 16) == 0')
          ->line('ST(0) = &PL_sv_yes;')
        ->else
          ->line('ST(0) = &PL_sv_no;')
        ->endif
      ->else
        ->line('ST(0) = &PL_sv_no;')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Generate is_form() - check Content-Type header
    $builder->xs_function('jit_is_form')
      ->xs_preamble
      ->line('SV** ary = AvARRAY((AV*)SvRV(ST(0)));')
      ->line('HV* headers = (HV*)SvRV(ary[' . SLOT_HEADERS . ']);')
      ->line('SV** ct = hv_fetch(headers, "content_type", 12, 0);')
      ->if('ct && *ct && SvOK(*ct)')
        ->line('STRLEN len;')
        ->line('const char* str = SvPV(*ct, len);')
        ->if('len >= 33 && memcmp(str, "application/x-www-form-urlencoded", 33) == 0')
          ->line('ST(0) = &PL_sv_yes;')
        ->else
          ->line('ST(0) = &PL_sv_no;')
        ->endif
      ->else
        ->line('ST(0) = &PL_sv_no;')
      ->endif
      ->xs_return('1')
      ->xs_end;

    # Build functions hash
    my %functions = (
        # Simple slot accessors
        'Hypersonic::Request::method'       => { source => 'jit_method', is_xs_native => 1 },
        'Hypersonic::Request::path'         => { source => 'jit_path', is_xs_native => 1 },
        'Hypersonic::Request::body'         => { source => 'jit_body', is_xs_native => 1 },
        'Hypersonic::Request::query_string' => { source => 'jit_query_string', is_xs_native => 1 },
        'Hypersonic::Request::id'           => { source => 'jit_id', is_xs_native => 1 },

        # Hashref slot accessors
        'Hypersonic::Request::params'   => { source => 'jit_params', is_xs_native => 1 },
        'Hypersonic::Request::query'    => { source => 'jit_query', is_xs_native => 1 },
        'Hypersonic::Request::headers'  => { source => 'jit_headers', is_xs_native => 1 },
        'Hypersonic::Request::cookies'  => { source => 'jit_cookies', is_xs_native => 1 },
        'Hypersonic::Request::form'     => { source => 'jit_form_field', is_xs_native => 1 },
        'Hypersonic::Request::json'     => { source => 'jit_json', is_xs_native => 1 },
        'Hypersonic::Request::segments' => { source => 'jit_segments', is_xs_native => 1 },

        # Keyed accessors
        'Hypersonic::Request::param'       => { source => 'jit_param', is_xs_native => 1 },
        'Hypersonic::Request::query_param' => { source => 'jit_query_param', is_xs_native => 1 },
        'Hypersonic::Request::header'      => { source => 'jit_header', is_xs_native => 1 },
        'Hypersonic::Request::cookie'      => { source => 'jit_cookie', is_xs_native => 1 },

        # Type checks
        'Hypersonic::Request::is_json' => { source => 'jit_is_json', is_xs_native => 1 },
        'Hypersonic::Request::is_form' => { source => 'jit_is_form', is_xs_native => 1 },
    );

    # JIT: Only generate response helpers if requested
    if ($opts{response_helpers}) {
        # text_response($text, $status) - returns {status, headers, body}
        $builder->xs_function('jit_text_response')
          ->xs_preamble
          ->line('SV* text = items > 1 ? ST(1) : newSVpvs("");')
          ->line('IV status = items > 2 && SvOK(ST(2)) ? SvIV(ST(2)) : 200;')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("text/plain"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(status), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('hv_store(resp, "body", 4, newSVsv(text), 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # html_response($html, $status) - returns {status, headers, body}
        $builder->xs_function('jit_html_response')
          ->xs_preamble
          ->line('SV* html = items > 1 ? ST(1) : newSVpvs("");')
          ->line('IV status = items > 2 && SvOK(ST(2)) ? SvIV(ST(2)) : 200;')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("text/html"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(status), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('hv_store(resp, "body", 4, newSVsv(html), 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # redirect($url, $status) - returns {status, headers, body}
        $builder->xs_function('jit_redirect')
          ->xs_preamble
          ->line('SV* url = items > 1 ? ST(1) : newSVpvs("/");')
          ->line('IV status = items > 2 && SvOK(ST(2)) ? SvIV(ST(2)) : 302;')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Location", 8, newSVsv(url), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(status), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('hv_store(resp, "body", 4, newSVpvs(""), 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # error($message, $status) - returns {status, headers, body} as JSON
        $builder->xs_function('jit_error')
          ->xs_preamble
          ->line('const char* msg = "Internal Server Error";')
          ->line('STRLEN msg_len = 21;')
          ->line('if (items > 1 && SvOK(ST(1))) { msg = SvPV(ST(1), msg_len); }')
          ->line('IV status = items > 2 && SvOK(ST(2)) ? SvIV(ST(2)) : 500;')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(status), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->comment('Build JSON: {"error":"message"}')
          ->line('SV* body = newSV(msg_len + 12);')
          ->line('sv_setpvs(body, "{\"error\":\"");')
          ->line('sv_catpvn(body, msg, msg_len);')
          ->line('sv_catpvs(body, "\"}");')
          ->line('hv_store(resp, "body", 4, body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # not_found($message) - calls error with 404
        $builder->xs_function('jit_not_found')
          ->xs_preamble
          ->line('const char* msg = "Not Found";')
          ->line('STRLEN msg_len = 9;')
          ->line('if (items > 1 && SvOK(ST(1))) { msg = SvPV(ST(1), msg_len); }')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(404), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('SV* body = newSV(msg_len + 12);')
          ->line('sv_setpvs(body, "{\"error\":\"");')
          ->line('sv_catpvn(body, msg, msg_len);')
          ->line('sv_catpvs(body, "\"}");')
          ->line('hv_store(resp, "body", 4, body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # bad_request($message) - calls error with 400
        $builder->xs_function('jit_bad_request')
          ->xs_preamble
          ->line('const char* msg = "Bad Request";')
          ->line('STRLEN msg_len = 11;')
          ->line('if (items > 1 && SvOK(ST(1))) { msg = SvPV(ST(1), msg_len); }')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(400), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('SV* body = newSV(msg_len + 12);')
          ->line('sv_setpvs(body, "{\"error\":\"");')
          ->line('sv_catpvn(body, msg, msg_len);')
          ->line('sv_catpvs(body, "\"}");')
          ->line('hv_store(resp, "body", 4, body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # unauthorized($message) - calls error with 401
        $builder->xs_function('jit_unauthorized')
          ->xs_preamble
          ->line('const char* msg = "Unauthorized";')
          ->line('STRLEN msg_len = 12;')
          ->line('if (items > 1 && SvOK(ST(1))) { msg = SvPV(ST(1), msg_len); }')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(401), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('SV* body = newSV(msg_len + 12);')
          ->line('sv_setpvs(body, "{\"error\":\"");')
          ->line('sv_catpvn(body, msg, msg_len);')
          ->line('sv_catpvs(body, "\"}");')
          ->line('hv_store(resp, "body", 4, body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # forbidden($message) - calls error with 403
        $builder->xs_function('jit_forbidden')
          ->xs_preamble
          ->line('const char* msg = "Forbidden";')
          ->line('STRLEN msg_len = 9;')
          ->line('if (items > 1 && SvOK(ST(1))) { msg = SvPV(ST(1), msg_len); }')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(403), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('SV* body = newSV(msg_len + 12);')
          ->line('sv_setpvs(body, "{\"error\":\"");')
          ->line('sv_catpvn(body, msg, msg_len);')
          ->line('sv_catpvs(body, "\"}");')
          ->line('hv_store(resp, "body", 4, body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # json_response($data, $status) - needs to call Perl JSON encoder
        # This one calls back to Perl for Cpanel::JSON::XS::encode_json
        $builder->xs_function('jit_json_response')
          ->xs_preamble
          ->line('SV* data = items > 1 ? ST(1) : newRV_noinc((SV*)newHV());')
          ->line('IV status = items > 2 && SvOK(ST(2)) ? SvIV(ST(2)) : 200;')
          ->line('ENTER; SAVETMPS;')
          ->line('PUSHMARK(SP);')
          ->line('XPUSHs(data);')
          ->line('PUTBACK;')
          ->line('int count = call_pv("Cpanel::JSON::XS::encode_json", G_SCALAR);')
          ->line('SPAGAIN;')
          ->line('SV* json_body = count > 0 ? POPs : newSVpvs("{}");')
          ->line('SvREFCNT_inc(json_body);')
          ->line('PUTBACK; FREETMPS; LEAVE;')
          ->line('HV* resp = newHV();')
          ->line('HV* hdrs = newHV();')
          ->line('hv_store(hdrs, "Content-Type", 12, newSVpvs("application/json"), 0);')
          ->line('hv_store(resp, "status", 6, newSViv(status), 0);')
          ->line('hv_store(resp, "headers", 7, newRV_noinc((SV*)hdrs), 0);')
          ->line('hv_store(resp, "body", 4, json_body, 0);')
          ->line('ST(0) = sv_2mortal(newRV_noinc((SV*)resp));')
          ->xs_return('1')
          ->xs_end;

        # Add response helpers to functions hash
        $functions{'Hypersonic::Request::text_response'} = { source => 'jit_text_response', is_xs_native => 1 };
        $functions{'Hypersonic::Request::html_response'} = { source => 'jit_html_response', is_xs_native => 1 };
        $functions{'Hypersonic::Request::redirect'}      = { source => 'jit_redirect', is_xs_native => 1 };
        $functions{'Hypersonic::Request::error'}         = { source => 'jit_error', is_xs_native => 1 };
        $functions{'Hypersonic::Request::not_found'}     = { source => 'jit_not_found', is_xs_native => 1 };
        $functions{'Hypersonic::Request::bad_request'}   = { source => 'jit_bad_request', is_xs_native => 1 };
        $functions{'Hypersonic::Request::unauthorized'}  = { source => 'jit_unauthorized', is_xs_native => 1 };
        $functions{'Hypersonic::Request::forbidden'}     = { source => 'jit_forbidden', is_xs_native => 1 };
        $functions{'Hypersonic::Request::json_response'} = { source => 'jit_json_response', is_xs_native => 1 };
    }

    # Compile via XS::JIT
    XS::JIT->compile(
        code      => $builder->code,
        name      => $module_name,
        cache_dir => $cache_dir,
        functions => \%functions,
    );

    $COMPILED = 1;
    return 1;
}

# Session methods - implemented in Perl because they need to interact
# with the session store. JIT: require cached after first load.

my $SESSION_LOADED;

sub session {
    my $self = shift;
    require Hypersonic::Session unless $SESSION_LOADED++;
    return Hypersonic::Session::get_set($self, @_);
}

sub session_data {
    my $self = shift;
    require Hypersonic::Session unless $SESSION_LOADED++;
    return Hypersonic::Session::get_all($self);
}

sub session_clear {
    my $self = shift;
    require Hypersonic::Session unless $SESSION_LOADED++;
    return Hypersonic::Session::clear($self);
}

sub session_regenerate {
    my $self = shift;
    require Hypersonic::Session unless $SESSION_LOADED++;
    return Hypersonic::Session::regenerate($self);
}

1;

__END__