File Coverage

blib/lib/MVC/Neaf/Route/Main.pm

Criterion	Covered	Total	%
statement	511	517	98.8
branch	207	234	88.4
condition	82	116	70.6
subroutine	60	61	98.3
pod	28	28	100.0
total	888	956	92.8

package MVC::Neaf::Route::Main;

use strict;
use warnings;
our $VERSION = '0.2800_01';

=head1 NAME

MVC::Neaf::Route::Main - main application class for Not Even A Framework.

=head1 DESCRIPTION

This class contains a L application structure
and implements the core of Neaf logic.

It is a L object itself,
containing a hash of other routes designated by their path prefixes.

=head1 APPLICATION SETUP METHODS

=cut

use Carp;
use Cwd qw(cwd abs_path);
use Encode;
use File::Basename qw(dirname);
use Module::Load;
use Scalar::Util qw( blessed looks_like_number reftype );
use URI::Escape;

use parent qw(MVC::Neaf::Route);
use MVC::Neaf::Request::PSGI;
use MVC::Neaf::Route::PreRoute;
use MVC::Neaf::Util qw(
    caller_info
    canonize_path
    check_path
    data_fh
    decode_b64
    encode_b64
    extra_missing
    http_date
    maybe_list
    run_all
    run_all_nodie
    supported_methods
);
use MVC::Neaf::Util::Container;

# TODO 0.30 remove
sub _one_and_true {
    my $self = shift;
    return $self if ref $self;

    my $method = [caller 1]->[3];
    $method =~ s/.*:://;

    if ($self eq 'MVC::Neaf') {
        require MVC::Neaf;
        carp "MVC::Neaf->$method() call is DEPRECATED, use neaf->$method or MVC::Neaf->new()";
        return MVC::Neaf::neaf();
    };

    croak "Method $method called on unblessed '$self'";
};

=head2 new()

    new( )

This is also called by Cnew>,
in case one wants to instantiate a Neaf application object
instead of using the default L.

A hash of %options may be added in the future, but isn't supported currently.

=cut

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

    croak('MVC::Neaf->new: no options currently supported: '.join ", ", sort keys %opt)
        if %opt;

    my $self = bless {}, $class;

    $self->set_path_defaults( { -status => 200, -view => 'JS' } );

    # This is required for $self->hooks to produce something.
    # See also todo_hooks where the real hooks sit.
    $self->{hooks} = {};

    # magical by default
    $self->{magic} = 1;

    return $self;
};

=head2 add_route()

Define a handler for given by URI path and HTTP method(s).
This is the backend behind NEAF's C route specifications.

    route( '/path' => CODEREF, %options )

Any incoming request to uri matching C
(C too, but NOT C)
will now be directed to CODEREF.

Longer paths are GUARANTEED to be checked first.

Dies if the same method and path combination is given twice
(but see C and C below).
Multiple methods may be given for the same path.

Exactly one leading slash will be prepended no matter what you do.
(C, C and C are all the same).

The C MUST accept exactly one argument,
referred to as C<$request> or C<$req> hereafter,
and return an unblessed hashref with response data.

%options may include:

=over

=item * C - list of allowed HTTP methods.
Default is [GET, POST].
Multiple handles can be defined for the same path, provided that
methods do not intersect.
HEAD method is automatically handled if GET is present, however,
one MAY define a separate HEAD handler explicitly.

=item * C => C - allow URI subpaths
to be handled by this handler.

A 404 error will be generated unless C is present
and PATH_INFO matches the regex (without the leading slashes).

If path_info_regex matches, it will be available in the controller
as C<$req-Epath_info>.

If capture groups are present in said regular expression,
their content will also be available as C<$req-Epath_info_split>.

B<[EXPERIMENTAL]> Name and semantics MAY change in the future.

=item * C => { name => C, name2 => C<'\d+'> }

Add predefined regular expression validation to certain request parameters,
so that they can be queried by name only.
See C in L.

B<[EXPERIMENTAL]> Name and semantics MAY change in the future.

=item * strict => 1|0

If true, request's C and C
will emit HTTP error 422
whenever mandatory validation fails.

If parameter or cookie is missing, just return default.
This MAY change in the future.

B<[EXPERIMENTAL]> Name and meaning MAY change in the future.

=item * C - default View object for this Controller.
Must be a name of preloaded view,
an object with a C method, or a CODEREF
receiving hashref and returning a list of two scalars
(content and content-type).

B<[DEPRECATED]> Use C<-view> instead, meaning is exactly the same.

=item * C - if set, set Expires: HTTP header accordingly.

B<[EXPERIMENTAL]> Name and semantics MAY change in the future.

=item * C - a C<\%hash> of values that will be added to results
EVERY time the handler returns.
Consider using C below if you need to append
the same values to multiple paths.

=item * C => 1 - replace old route even if it exists.
If not set, route collisions causes exception.
Use this if you know better.

This still issues a warning.

B<[EXPERIMENTAL]> Name and meaning may change in the future.

=item * C => 1 - if route is already defined, do nothing.
If not, allow to redefine it later.

B<[EXPERIMENTAL]> Name and meaning may change in the future.

=item * C - just for information, has no action on execution.
This will be displayed if application called with --list (see L).

=item * C => 0|1 - a flag just for information.
In theory, public endpoints should be searchable from the outside
while non-public ones should only be reachable from other parts of application.
This is not enforced whatsoever.

=back

Also, any number of dash-prefixed keys MAY be present.
This is the same as putting them into C hash.

=cut

my $year = 365 * 24 * 60 * 60;
my %known_route_args;
$known_route_args{$_}++ for qw(
    default method view cache_ttl
    path_info_regex param_regex strict
    description caller tentative override public
);

sub add_route {
    my $self = shift;

    $self->my_croak( "Odd number of elements in hash assignment" )
        if @_ % 2;
    my ($path, $sub, %args) = @_;
    $self = _one_and_true($self);

    $self->my_croak( "handler must be a coderef, not ".ref $sub )
        unless UNIVERSAL::isa( $sub, "CODE" );

    # check defaults to be a hash before accessing them
    $self->my_croak( "default must be unblessed hash" )
        if $args{default} and ref $args{default} ne 'HASH';

    # minus-prefixed keys are typically defaults
    $_ =~ /^-/ and $args{default}{$_} = delete $args{$_}
        for keys %args;

    # kill extra args
    my @extra = grep { !$known_route_args{$_} } keys %args;
    $self->my_croak( "Unexpected keys in route setup: @extra" )
        if @extra;

    $args{path} = $path = check_path canonize_path( $path );

    $args{method} = maybe_list( $args{method}, qw( GET POST ) );
    $_ = uc $_ for @{ $args{method} };

    $self->my_croak("Public endpoint must have nonempty description")
        if $args{public} and not $args{description};

    my @real_method = $self->_detect_duplicate( \%args, $args{method} );

    # Do the work
    $args{parent}    = $self;
    $args{code}      = $sub;

    # Always have regex defined to simplify routing
    $args{path_info_regex} = (defined $args{path_info_regex})
        ? qr#^$args{path_info_regex}$#
        : qr#^$#;

    # Just for information
    $args{public}      = $args{public} ? 1 : 0;
    $args{caller}    ||= [caller(0)]; # save file,line

    if (exists $args{view}) {
        # TODO 0.30
        carp "NEAF: route(): view argument is deprecated, use -view instead";
        $args{default}{-view} = delete $args{view};
    };

    # preload view so that we can fail early
    $args{default}{-view} = $self->get_view( $args{default}{-view} )
        if $args{default}{-view};

    # ready, shallow copy handler & burn cache
    delete $self->{route_re};

    $self->{route}{ $path }{$_} = MVC::Neaf::Route->new( %args, method => $_ )
        for @real_method;

    # This is for get+post sugar
    $self->{last_added} = \%args;

    return $self;
}; # end sub route

# in: { path => '/...', tentative => 0|1, override=> 0|1 }, \@method_list
# out: @real_method_list
# dies/warns if violations found
sub _detect_duplicate {
    my ($self, $profile, $methods) = @_;

    my $path = $profile->{path};
    # Handle duplicate route definitions
    my @dupe = grep {
        exists $self->{route}{$path}{$_}
        and !$self->{route}{$path}{$_}{tentative};
    } @$methods;

    if (@dupe) {
        my %olddef;
        foreach (@dupe) {
            my $where = $self->{route}{$path}{$_}{where};
            push @{ $olddef{$where} }, $_;
        };

        # flatten olddef hash, format list
        my $oldwhere = join ", ", map { "$_ [@{ $olddef{$_} }]" } keys %olddef;
        my $oldpath = $path || '/';

        # Alas, must do error message by hand
        my $caller = [caller 1]->[3];
        $caller =~ s/.*:://;
        if ($profile->{override}) {
            carp( (ref $self)."->$caller: Overriding old handler for"
                ." $oldpath defined $oldwhere");
        } elsif( $profile->{tentative} ) {
            # if we're tentative, filter out already known method/route pairs
            my %filter;
            $filter{$_}++ for @{ $methods };
            delete $filter{$_} for @dupe;
            return keys %filter;
        } else {
            croak( (ref $self)."->$caller: Attempting to set duplicate handler for"
                ." $oldpath defined $oldwhere");
        };
    };

    return @$methods;
};

# This is for get+post sugar
# TODO 0.90 merge with alias, GET => implicit HEAD
# TODO 0.30 public method
sub _dup_route {
    my ($self, $method, $profile) = @_;

    $profile ||= $self->{last_added};
    my $path = $profile->{path};

    my @real_method = $self->_detect_duplicate($profile, [ $method ]);

    delete $self->{route_re};
    $self->{route}{ $path }{$_} = MVC::Neaf::Route->new( %$profile, method => $_ )
        for @real_method;
};

=head2 static()

    $neaf->static( '/path' => $local_path, %options );

    $neaf->static( '/other/path' => [ "content", "content-type" ] );

Serve static content located under C<$file_path>.
Both directories and single files may be added.

If an arrayref of C<[ $content, $content_type ]> is given as second argument,
serve content from memory instead.

%options may include:

=over

=item * C => C - buffer size for reading/writing files.
Default is 4096. Smaller values may be set, but are NOT recommended.

=item * C => C - if given, files below the buffer size
will be stored in memory for C seconds.

B<[EXPERIMENTAL]> Cache API is not yet established.

=item * allow_dots => 1|0 - if true, serve files/directories
starting with a dot (.git etc), otherwise give a 404.

B<[EXPERIMENTAL]>

=item * dir_index => 1|0 - if true, generate index for a directory;
otherwise a 404 is returned, and deliberately so, for security reasons.

B<[EXPERIMENTAL]>

=item * dir_template - specify template for directory listing
(with images etc). A sane default is provided.

B<[EXPERIMENTAL]>

=item * view - specify view object for rendering directory template.
By default a localized C instance is used.

B<[EXPERIMENTAL]> Name MAY be changed (dir_view etc).

=item * override - override the route that was here before.
See C above.

=item * tentative - don't complain if replaced later.

=item * description - comment. The default is "Static content at $directory"

=item * public => 0|1 - a flag just for information.
In theory, public endpoints should be searchable from the outside
while non-public ones should only be reachable from other parts of application.
This is not enforced whatsoever.

=back

See L for implementation.

File type detection is based on extentions so far, and the list is quite short.
This MAY change in the future.
Known file types are listed in C<%MVC::Neaf::X::Files::ExtType> hash.
Patches welcome.

I
using a web application framework.
Use a real web server instead.
Not need to set up one for merely testing icons/js/css, though.>

=cut

sub static {
    my ($self, $path, $dir, %options) = @_;
    $self = _one_and_true($self);

    $options{caller} ||= [caller 0];

    my %fwd_opt;
    defined $options{$_} and $fwd_opt{$_} = delete $options{$_}
        for qw( tentative override caller public );

    if (ref $dir eq 'ARRAY') {
        my $sub = $self->_static_global->preload( $path => $dir )->one_file_handler;
        return $self->route( $path => $sub, method => 'GET', %fwd_opt,
            , description => Carp::shortmess( "Static content from memory" ));
    };

    require MVC::Neaf::X::Files;
    my $xfiles = MVC::Neaf::X::Files->new(
        %options, root => $self->dir($dir), base_url => $path );
    return $self->route( $xfiles->make_route, %fwd_opt );
};

# Instantiate a global static handler to preload in-memory
#    static files into.
# TODO 0.30 lame name, find better
sub _static_global {
    my $self = shift;

    return $self->{global_static} ||= do {
        require MVC::Neaf::X::Files;
        MVC::Neaf::X::Files->new( root => '/dev/null' );
    };
};


=head2 alias()

    $neaf->alias( $newpath => $oldpath )

Create a new name for already registered route.
The handler will be executed as is,
but the hooks and defaults will be re-calculated.
So be careful.

B<[CAUTION]> As of 0.21, C does NOT adhere tentative/override switches.
This needs to be fixed in the future.

=cut

# TODO 0.30 add_alias or something
sub alias {
    my ($self, $new, $old) = @_;
    $self = _one_and_true($self);

    $new = canonize_path( $new );
    $old = canonize_path( $old );

    check_path( $old, $new );

    $self->{route}{$old}
        or $self->my_croak( "Cannot create alias for unknown route $old" );

    # TODO 0.30 restrict methods, handle tentative/override, detect dupes
    $self->my_croak( "Attempting to set duplicate handler for path "
        .( length $new ? $new : "/" ) )
            if $self->{route}{ $new };

    # reset cache
    delete $self->{route_re};

    # FIXME clone()
    $self->{route}{$new} = $self->{route}{$old};
    return $self;
};

=head2 set_path_defaults

    set_path_defaults( { version => 0.99 }, path => '/api', %options );

%options may include:

=over

=item * path - restrict this set of defaults to given prefix(es);

=item * method - restrict this set of defaults to given method(s);

=item * exclude - exclude some prefixes;

=back

Append the given values to the hash returned by I route
under the given path(s) and method(s).

Longer paths take over the shorter ones.
Route's own default values take over any path-based defaults.
Whatever the controller returns overrides all of these.

=cut

# TODO 0.30 rename defaults => [something]
sub set_path_defaults {
    my $self = shift;
    $self = _one_and_true($self);

    # Old form - path => \%hash
    # TODO 0.30 kill
    if (@_ == 2) {
        carp "set_path_defaults(): '/prefix' => \%values form is DEPRECATED, use \%values, path => '/prefix' instead";
        push @_, path => shift;
    };

    my ($values, %opt) = @_;

    $self->my_croak( "values must be a \%hash" )
        unless ref $values eq 'HASH';

    extra_missing( \%opt, { path => 1, method => 1 } );

    $self->{defaults} ||= MVC::Neaf::Util::Container->new;
    $self->{defaults}->store( $values, %opt );

    return $self;
};

=head2 get_path_defaults

    get_path_defaults ( $methods, $path, [ \%override ... ] )

Fetch default values for given (path, method) combo as a single hash.

=cut

sub get_path_defaults {
    my ($self, $method, $path, @override) = @_;

    my @source = $self->{defaults}->fetch( method => $method, path => $path );
    my %hash = map { %$_ } @source, grep defined, @override;
    defined $hash{$_} or delete $hash{$_}
        for keys %hash;

    \%hash;
};


=head2 add_hook()

    $neaf->add_hook ( phase => CODEREF, %options );

Set hook that will be executed on a given request processing phase.

Valid phases include:

=over

=item * pre_route [die]

=item * pre_logic [die]

=item * pre_content

=item * pre_render [die]

=item * pre_reply [reverse]

=item * pre_cleanup [reverse]

=back

See L below for detailed
discussion of each phase.

The CODEREF receives one and only argument - the C<$request> object.
Return value is B, see explanation below.

Use C<$request>'s C, C, and C methods
for communication between hooks.

Dying in a hook MAY cause interruption of request processing
or merely a warning, depending on the phase.

%options may include:

=over

=item * path => '/path' - where the hook applies. Default is '/'.
Multiple locations may be supplied via C<[ /foo, /bar ...]>

=item * exclude => '/path/skip' - don't apply to these locations,
even if under '/path'.
Multiple locations may be supplied via C<[ /foo, /bar ...]>

=item * method => 'METHOD' || [ list ]
List of request HTTP methods to which given hook applies.

=item * prepend => 0|1 - all other parameters being equal,
hooks will be executed in order of adding.
This option allows to override this and run given hook first.
Note that this does NOT override path bubbling order.

=back

=cut

my %add_hook_args;
$add_hook_args{$_}++ for qw(method path exclude prepend);

our %hook_phases;
$hook_phases{$_}++ for qw(pre_route
    pre_logic pre_content pre_render pre_reply pre_cleanup);

sub add_hook {
    my ($self, $phase, $code, %opt) = @_;
    $self = _one_and_true($self);

    extra_missing( \%opt, \%add_hook_args );
    $self->my_croak( "hook must be a coderef, not ".ref $code )
        unless UNIVERSAL::isa( $code, 'CODE' );
    $self->my_croak( "illegal phase: $phase" )
        unless $hook_phases{$phase};

    $opt{method} = maybe_list( $opt{method}, supported_methods() );
    if ($phase eq 'pre_route') {
        # handle pre_route separately
        $self->my_croak("cannot specify paths/excludes for $phase")
            if defined $opt{path} || defined $opt{exclude};
    };

    $opt{path}      = maybe_list( $opt{path}, '' );
    $opt{caller}  ||= [ caller(0) ]; # where the hook was set

    $self->{todo_hooks}{$phase} ||= MVC::Neaf::Util::Container->new;
    $self->{todo_hooks}{$phase}->store( $code, %opt );

    return $self;
};

=head2 get_hooks

    get_hooks( $method, $path )

Fetch all hooks previously set for given path as a { phase => [ list ] } hash.

=cut

sub get_hooks {
    my ($self, $method, $path) = @_;

    my %ret;

    foreach my $phase ( keys %{ $self->{todo_hooks} } ) {
        $ret{$phase} = [ $self->{todo_hooks}{$phase}->fetch( method => $method, path => $path ) ];
    };

    # Some hooks to be executed in reverse order
    $ret{$_} and @{ $ret{$_} } = reverse @{ $ret{$_} }
        for qw( pre_reply pre_cleanup );

    # Prepend session handler unconditionally, if present
    if (my $key = $self->{session_view_as}) {
        unshift @{ $ret{pre_render} }, sub {
            $_[0]->reply->{$key} = $_[0]->load_session;
        };
    };

    if (my $force_view = $self->{force_view}) {
        # TODO 0.40 also push pre-rendered -content through force_view
        push @{ $ret{pre_render} }, sub { $_[0]->reply->{-view} = $force_view };
    };

    return \%ret;
};

=head2 set_helper

    set_helper( name => \&code, %options )

=cut

sub set_helper {
    my ($self, $name, $code, %opt) = @_;

    $self->my_croak( "helper must be a CODEREF, not ".ref $code )
        unless ref $code and UNIVERSAL::isa( $code, 'CODE' );
    _install_helper( $name );

    $self->{todo_helpers}{$name} ||= MVC::Neaf::Util::Container->new( exclusive => 1 );
    $self->{todo_helpers}{$name}->store( $code, %opt );
};

sub _install_helper {
    my $name = shift;

    return if $MVC::Neaf::Request::allow_helper{$name};

    croak( "NEAF: helper: inappropriate helper name '$name'" )
        if $name !~ /^[a-z][a-z_0-9]*/ or $name =~ /^(?:do|neaf)/;

    croak "NEAF: helper: Cannot override existing method '$name' in Request"
        if MVC::Neaf::Request->can( $name );

    my $sub = sub {
        my $req = shift;

        my $code = $req->route->helpers->{$name};
        croak ("Helper '$name' is not defined for ".$req->method." ".$req->route->path)
            unless $code;

        $code->( $req, @_ );
    };

    # HACK magic here - plant method into request
    {
        no strict 'refs'; ## no critic
        use warnings FATAL => qw(all);
        *{"MVC::Neaf::Request::$name"} = $sub;
    };

    $MVC::Neaf::Request::allow_helper{$name}++;
};

=head2 get_helpers

=cut

sub get_helpers {
    my ($self, $method, $path) = @_;

    my $todo = $self->{todo_helpers};

    my %ret;
    foreach my $name( keys %$todo ) {
        my ($last) = reverse $todo->{$name}->fetch( method => $method, path => $path );
        $ret{$name} = $last if $last;
    };

    return \%ret;
};

=head2 load_view()

    load_view( "name", $view_object );  # stores object
                                        # assuming it's an L
    load_view( "name", $module_name, %params ); # calls new()
    load_view( "name", $module_alias ); # ditto, see list of aliases below
    load_view( "name", \&CODE );        # use that sub to generate
                                        # content from hash

Setup view under name C<$name>.
Subsequent requests with C<-view = $name> would be processed by that view
object.

Use C to fetch the object itself.

=over

=item * if object is given, just save it.

=item * if module name + parameters is given, try to load module
and create new() instance.

Short aliases C, C, and C may be used
for corresponding C modules.

=item * if coderef is given, use it as a C method.

=back

Returns the view object, NOT the object this method was called on.

=cut

my %view_alias = (
    TT     => 'MVC::Neaf::View::TT',
    JS     => 'MVC::Neaf::View::JS',
    Dumper => 'MVC::Neaf::View::Dumper',
);
sub load_view {
    my ($self, $name, $obj, @param) = @_;
    $self = _one_and_true($self);

    $self->my_croak("At least two arguments required")
        unless defined $name and defined $obj;

    # Instantiate if needed
    if (!ref $obj) {
        # in case an alias is used, apply alias
        $obj = $view_alias{ $obj } || $obj;

        # Try loading...
        if (!$obj->can("new")) {
            eval { load $obj; 1 }
                or $self->my_croak( "Failed to load view $name=>$obj: $@" );
        };
        $obj = $obj->new( neaf_base_dir => $self->neaf_base_dir, @param );
    };

    $self->my_croak( "view must be a coderef or a MVC::Neaf::View object" )
        unless blessed $obj and $obj->can("render")
            or ref $obj eq 'CODE';

    $self->{seen_view}{$name} = $obj;

    return $obj;
};

=head2 set_forced_view()

    $neaf->set_forced_view( $view )

If set, this view object will be user instead of ANY other view.

See L.

Returns self.

=cut

sub set_forced_view {
    my ($self, $view) = @_;
    $self = _one_and_true($self);

    delete $self->{force_view};
    return $self unless $view;

    $self->{force_view} = $self->get_view( $view );

    return $self;
};

=head2 magic( bool )

Get/set "magic" bit that triggers stuff like loading resources from __DATA__
on run() and such.

Neaf is magical by default.

=cut

# Dumb accessor(boolean)
sub magic {
    my $self = shift;
    if (@_) {
        $self->{magic} = !! shift;
        return $self;
    } else {
        return $self->{magic};
    };
};

=head2 load_resources()

    $neaf->load_resources( $file_name || \*FH )

Load pseudo-files from a file (typically C<__DATA__>),
say templates or static files.

As of 0.27, load_resources happens automatically upon L,
but only once for each calling file.
Use Cmagic(0)> if you know better
(e.g. you want to use __DATA__ for something else).

The format is as follows:

    @@ /main.html view=TT

    [% some_tt_template %]

    @@ /favicon.ico format=base64 type=png

    iVBORw0KGgoAAAANSUhEUgAAACAAAAAgCAMAAABEpIrGAAAABGdBTUEAAL
    GPC/xhBQAAAAFzUkdCAK7OHOkAAAAgY0hS<....more encoded lines>

I,
in a slightly incompatible way.>

An entry starts with a literal C<@@>, followed by 1 or more spaces,
followed by a slash and a file name, optionally followed by a list
of options, and finally by a newline.

Everything following the newline and until next such entry
is considered file content.

Options may include:

=over

=item * C

=item * C

=item * C - specify a template for given view(s)
Leading slash will be stripped in this case.

=back

Entries with unknown options will be skipped with a warning.

B<[EXPERIMENTAL]> This method and exact format of data is being worked on.

=cut

# TODO split this sub & move to a separate file
my $INLINE_SPEC = qr/^(?:\[(\w+)\]\s+)?(\S+)((?:\s+\w+=\S+)*)$/;
my %load_resources_opt;
$load_resources_opt{$_}++ for qw( view format type );
sub load_resources {
    my ($self, $file, $name) = @_;

    if (!ref $file and defined $file) {
        open my $fd, "<", $file
            or $self->my_croak( "Failed to open(r) $file: $!" );
        $name = $file;
        $file = $fd;
    };

    # Don't load the same filename twice
    return $self
        if defined $name and $self->{load_resources}{$name}++;

    my $content;

    if (ref $file eq 'GLOB') {
        local $/;
        $content = <$file>;
        defined $content
            or $self->my_croak( "Failed to read from $file: $!" );
        close $file;
        # Die later
    } elsif (ref $file eq 'SCALAR') {
        $content = $$file;
    } else {
        $self->my_croak( "Argument must be a scalar, a scalar ref, or a file descriptor" );
    };

    defined $content
        or $self->my_croak( "Failed load content" );

    # TODO 0.40 The regex should be: ^@@\s+(/\S+(?:\s+\w+=\S+)*)\s*$
    #     but we must deprecate '[TT] foo.html' first
    my @parts = split m{^@@\s+(\S.*?)\s*$}m, $content, -1;
    shift @parts;
    confess "NEAF load_resources failed unexpectedly, file a bug in MVC::Neaf"
        if @parts % 2;

    my %templates;
    my %static;
    while (@parts) {
        # parse pseudo-file
        my $spec = shift @parts;
        my $content = shift @parts;

        # process header
        my ($dest, $name, $extra) = ($spec =~ $INLINE_SPEC);
        $self->my_croak("Bad resource spec format @@ $spec")
            unless defined $name;
        my %opt = $extra =~ /(\w+)=(\S+)/g;
        if ($dest) {
            $opt{view} = $dest;
            carp "DEPRECATED '@@ [$dest]' resource format,"
                ." use '@@ $name view=$dest' instead";
        };

        if ( my @unknown = grep { !$load_resources_opt{$_} } keys %opt ) {
            carp "Unknown options (@unknown) in '@@ name' in $file, skipping";
            next;
        };

        # process content
        if (!$opt{format}) {
            $content =~ s/^\n+//s;
            $content =~ s/\s+$//s;
            $content = Encode::decode_utf8( $content, 1 );
        } elsif ($opt{format} eq 'base64') {
            $content = decode_b64( $content );
        } else {
            # TODO 0.50 calculate line
            $self->my_croak("Unknown format $opt{format} in '@@ $spec' in $file");
        };

        # store for loading
        if (defined( my $view = $opt{view} )) {
            # template
            $self->my_croak("Duplicate template '@@ $spec' in $file")
                if defined $templates{$view}{$name};
            $templates{$view}{$name} = $content;
        } else {
            # static file
            $self->my_croak("Duplicate static file '@@ $spec' in $file")
                if $static{$name};
            $static{$name} = [ $content, $opt{type} ];
        };
    }; # end while @parts

    # now do the loading
    foreach my $name( keys %templates ) {
        my $view = $self->get_view( $name, 1 );
        if (!$view) {
            carp "NEAF: Unknown view $name mentioned in $file";
        } elsif ($view->can("preload")) {
            $view->preload( %{ $templates{$name} } );
        } else  {
            carp "NEAF: View $name mentioned in $file doesn't support template preloading";
        };
    };
    if( %static ) {
        my $st = $self->_static_global;
        $st->preload( %static );
        foreach( keys %static ) {
            $self->add_route( $_ => $st->one_file_handler, method => 'GET'
                , description => "Static resource from $file" );
        };
    };

    return $self;
};

=head2 set_session_handler()

    $neaf->set_session_handler( %options )

Set a handler for managing sessions.

If such handler is set, the request object will provide C,
C, and C methods to manage
cross-request user data.

% options may include:

=over

=item * C (required in method form, first argument in DSL form)
- an object providing the storage primitives;

=item * C - time to live for session (default is 0, which means until
browser is closed);

=item * C - name of cookie storing session id.
The default is "session".

=item * C - if set, add the whole session into data hash
under this name before view processing.

=back

The engine MUST provide the following methods
(see L for details):

=over

=item * session_ttl (implemented in MVC::Neaf::X::Session);

=item * session_id_regex (implemented in MVC::Neaf::X::Session);

=item * get_session_id (implemented in MVC::Neaf::X::Session);

=item * create_session (implemented in MVC::Neaf::X::Session);

=item * save_session (required);

=item * load_session (required);

=item * delete_session (implemented in MVC::Neaf::X::Session);

=back

=cut

sub set_session_handler {
    my ($self, %opt) = @_; # TODO 0.30 use helpers when ready
    $self = _one_and_true($self);

    my $sess = delete $opt{engine};
    my $cook = $opt{cookie} || 'neaf.session';

    $self->my_croak("engine parameter is required")
        unless $sess;

    if (!ref $sess) {
        $opt{session_ttl} = delete $opt{ttl} || $opt{session_ttl};

        my $obj = eval { load $sess; $sess->new( %opt ); }
            or $self->my_croak("Failed to load session '$sess': $@");

        $sess = $obj;
    };

    my @missing = grep { !$sess->can($_) }
        qw(get_session_id session_id_regex session_ttl
            create_session load_session save_session delete_session );
    $self->my_croak("engine object does not have methods: @missing")
        if @missing;

    my $regex = $sess->session_id_regex;
    my $ttl   = $opt{ttl} || $sess->session_ttl || 0;

    my $setup = {
        engine => $sess,
        cookie => $cook,
        regex  => $regex,
        ttl    => $ttl,
    };

    $self->set_helper( _session_setup => sub { $setup }, override => 1 );
    $self->{session_view_as} = $opt{view_as};
    return $self;
};

=head2 set_error_handler()

    $neaf->set_error_handler ( $status => CODEREF( $request, %options ), %where )

Set custom error handler.

Status MUST be a 3-digit number (as in HTTP).

%where may include C, C, and C keys.
If omitted, just install error handler globally.

Other allowed keys MAY appear in the future.

The following options will be passed to coderef:

=over

=item * status - status being returned;

=item * caller - file:line where the route was set up;
This is DEPRECATED and will silently disappear around version 0.25

=item * error - exception, an L object.

=back

The coderef MUST return an unblessed hash just like a normal controller does.

In case of exception or unexpected return format
default HTML error page will be returned.

Also available in static form, as C \%hash )>.

This is a synonym to C $status,  ... } }>.

=cut

sub set_error_handler {
    my ($self, $status, $code, %where) = @_;
    $self = _one_and_true($self);

    $status =~ /^(?:\d\d\d)$/
        or $self->my_croak( "1st argument must be an http status");
    extra_missing( \%where, { path => 1, exclude => 1, method => 1 } );

    if (ref $code eq 'HASH') {
        my $hash = $code;
        $code = sub {
            my ($req, %opt) = @_;

            return { -status => $opt{status}, %opt, %$hash };
        };
    };
    reftype $code eq 'CODE'
        or $self->my_croak( "2nd argument must be a callback or hash");

    my $store = $self->{error_template}{$status}
        ||= MVC::Neaf::Util::Container->new();

    $store->store( $code, %where );

    return $self;
};

=head2 on_error()

    on_error( sub { my ($request, $error) = @_ } )

Install custom error handler for a dying controller.
Neaf's own exceptions, redirects, and C status returns will NOT
trigger it.

E.g. write to log, or something.

Return value from this callback is ignored.
If it dies, only a warning is emitted.

=cut

sub on_error {
    my ($self, $code) = @_;
    $self = _one_and_true($self);

    if (defined $code) {
        ref $code eq 'CODE'
            or $self->my_croak( "Argument MUST be a callback" );
        $self->{on_error} = $code;
    } else {
        delete $self->{on_error};
    };

    return $self;
};

=head2 post_setup

This function is run after configuration has been completed,
but before first request is served.

It goes as follows:

=over

=item * compile all the routes into a giant regexp;

=item * Add HEAD handling to where only GET exists;

=item * finish set_session_handler works

=item * set the lock on route;

=back

Despite the locking, further modifications are not prohibited.
This MAY change in the future.

=cut

sub post_setup {
    my $self = shift;

    # TODO 0.30 disallow calling this method twice
    # confess "Attempt to call post_setup twice"
    #     if $self->{lock};

    $self->{route_re} ||= $self->_make_route_re;

    # Add implicit HEAD for all GETs via shallow copy
    foreach my $node (values %{ $self->{route} }) {
        $node->{GET} or next;
        $node->{HEAD} ||= $node->{GET}->clone( method => 'HEAD' );
    };

    $self->{lock}++;
};

# Create a giant regexp from a hash of paths
# PURE
# The regex can be matched against an URI path,
# in which case it returns either nothing,
# or mathed route in $1 (prefix) and the rest of the string in $2 (postfix)
sub _make_route_re {
    my ($self, $hash) = @_;

    $hash ||= $self->{route};

    # Make longest paths come first
    my @path_list = reverse sort keys %$hash;

    # escape all metacharacters except /
    # which is converted to '/+' so that foo///bar is also matched
    my $re = join "|", map {
        join '/+', map {
            quotemeta
        } split /\/+/, $_
    } @path_list;

    # split path into (/foo/bar)/(baz)?param=value
    # return prefix as $1 and postfix as $2, if present
    return qr{^($re)(?:/+([^?]*))?(?:\?|$)};
};

=head2 run()

    $neaf->run();

Run the application.
This SHOULD be the last statement in your application's main file.

When run() is called, the routes are compiled into one giant regex,
and the post-setup is run, if needed.

Additionally if neaf is in magical mode,
L is called on the enclosing file's DATA descriptor.
Magic mode is on by default. See L.

If called in void context, assumes execution as C
and prints results to C.
If command line options are present at the moment,
enters debug mode via L.
Call C for more.

Otherwise returns a C-compliant coderef.
This will also happen if you application is C'd,
meaning that it returns a true value and actually serves nothing until
C is called again.

Running under mod_perl requires setting a handler with
L.

=cut

sub run {
    my $self = shift;
    $self = _one_and_true($self);

    # "Magically" load __DATA__ section from calling file
    if ($self->{magic}) {
        my ($file, $data) = data_fh(1);
        $self->load_resources( $data, $file )
            if $data;
    };

    if (!defined wantarray) {
        # void context - we're being called as CGI
        if (@ARGV) {
            require MVC::Neaf::CLI;
            MVC::Neaf::CLI->run($self);
        } else {
            require Plack::Handler::CGI;
            # Somehow this caused uninitialized warning in Plack::Handler::CGI
            $ENV{SCRIPT_NAME} = ''
                unless defined $ENV{SCRIPT_NAME};
            Plack::Handler::CGI->new->run( $self->run );
        };
        return;
    };

    # Do postsetup after CGI/CLI execution
    # because it's unneeded there - only one route may be needed so why bother
    $self->post_setup;

    return sub {
        $self->handle_request(
            MVC::Neaf::Request::PSGI->new( env => $_[0] ));
    };
};

=head1 INTROSPECTION AND TESTING METHODS

=head2 run_test()

    $neaf->run_test( \%PSGI_ENV, %options )

    $neaf->run_test( "/path?parameter=value", %options )

Run a L request and return a list of
C<($status, HTTP::Headers::Fast, $whole_content )>.

Returns just the content in scalar context.

Just as the name suggests, useful for testing only (it reduces boilerplate).

Continuation responses are supported, but will be returned in one chunk.

%options may include:

=over

=item * method - set method (default is GET)

=item * cookie = \%hash - force HTTP_COOKIE header

=item * header = \%hash - override some headers
This gets overridden by type, cookie etc. in case of conflict

=item * body = 'DATA' - force body in request

=item * type - content-type of body

=item * uploads - a hash of L objects.

=item * secure = 0|1 - C vs C

=item * override = \%hash - force certain data in C
Gets overridden by all of the above.

=back

=cut


my %run_test_allow;
$run_test_allow{$_}++
    for qw( type method cookie body override secure uploads header );
sub run_test {
    my ($self, $env, %opt) = @_;
    $self = _one_and_true($self);

    my @extra = grep { !$run_test_allow{$_} } keys %opt;
    $self->my_croak( "Extra keys @extra" )
        if @extra;

    if (!ref $env) {
        $env =~ /^(.*?)(?:\?(.*))?$/;
        $env = {
            REQUEST_URI => $env,
            REQUEST_METHOD => 'GET',
            QUERY_STRING => defined $2 ? $2 : '',
            SERVER_NAME => 'localhost',
            SERVER_PORT => 80,
            SCRIPT_NAME => '',
            PATH_INFO => $1,
            'psgi.version' => [1,1],
            'psgi.errors' => \*STDERR,
        }
    };
    # TODO 0.30 complete emulation of everything a sane person needs
    $env->{REQUEST_METHOD} = $opt{method} if $opt{method};
    $env->{$_} = $opt{override}{$_} for keys %{ $opt{override} };

    if (my $head = $opt{header} ) {
        foreach (keys %$head) {
            my $name = uc $_;
            $name =~ tr/-/_/;
            $env->{"HTTP_$name"} = $head->{$_};
        };
    };
    if (exists $opt{secure}) {
        $env->{'psgi.url_scheme'} = $opt{secure} ? 'https' : 'http';
    };
    if (my $cook = $opt{cookie}) {
        if (ref $cook eq 'HASH') {
            $cook = join '; ', map {
                uri_escape_utf8($_).'='.uri_escape_utf8($cook->{$_})
            } keys %$cook;
        };
        $env->{HTTP_COOKIE} = $env->{HTTP_COOKIE}
            ? "$env->{HTTP_COOKIE}; $cook"
            : $cook;
    };
    if (my $body = $opt{body} ) {
        open my $dummy, "<", \$body
            or die ("NEAF: FATAL: Redirect failed in run_test");
        $env->{'psgi.input'} = $dummy;
        $env->{CONTENT_LENGTH} = length $body;
    };
    if (my $type = $opt{type}) {
        $type = 'application/x-www-form-urlencoded' if $type eq '?';
        $env->{CONTENT_TYPE} = $opt{type} eq '?' ? '' : $opt{type}
    };

    my %fake;
    $fake{uploads} = delete $opt{uploads};

    scalar $self->run; # warm up caches

    my $req = MVC::Neaf::Request::PSGI->new( %fake, env => $env );

    my $ret = $self->handle_request( $req );
    if (ref $ret eq 'CODE') {
        # PSGI functional interface used.
        require MVC::Neaf::Request::FakeWriter;
        $ret = MVC::Neaf::Request::FakeWriter->new->respond( $ret );
    };

    return (
        $ret->[0],
        HTTP::Headers::Fast->new( @{ $ret->[1] } ),
        join '', @{ $ret->[2] },
    );
};

=head2 get_routes()

    $neaf->get_routes( $callback->(\%route_spec, $path, $method) )

Returns a 2-level hashref with ALL routes for inspection.

So C<$hash{'/path'}{'GET'} = { handler, expected params, description etc }>

If callback is present, run it against route definition
and append to hash its return value, but ONLY if it's true.

As of 0.20, route definitions are only protected by shallow copy,
so be careful with them.

This SHOULD NOT be used by application itself.

=cut

# TODO 0.30 Route->inspect, Route::Main->inspect
sub get_routes {
    my ($self, $code) = @_;
    $self = _one_and_true($self);

    $code ||= sub { $_[0] };
    scalar $self->run; # burn caches

    # TODO 0.30 must do deeper copying
    my $all = $self->{route};
    my %ret;
    foreach my $path ( keys %$all ) {
        my $batch = $all->{$path};
        foreach my $method ( keys %$batch ) {
            my $route = $batch->{$method};
            $route->post_setup
                unless $route->is_locked;

            my $filtered = $code->( $route->clone, $path, $method );
            $ret{$path}{$method} = $filtered if $filtered;
        };
    };

    return \%ret;
};

=head1 RUN TIME METHODS

=head2 handle_request

    handle_request( $req )

This is the CORE of Not Even A Framework.
Should not be called directly - use C instead.

C really boils down to

    my ($self, $req) = @_;

    my $req->path =~ /($self->{GIANT_ROUTING_RE})/
        or die 404;

    my $endpoint = $self->{ROUTES}{$1}{ $req->method }
        or die 405;

    my $reply_hash = $endpoint->{CODE}->($req);

    my $content = $reply_hash->{-view}->render( $reply_hash );

    return [ $reply_hash->{-status}, [...], [ $content ] ];

The rest 200+ lines of it, spread across this module and L,
are for running callbacks, handling corner cases, and substituting sane defaults.

=cut

sub handle_request {
    my ($self, $req) = @_;
    $self = _one_and_true($self);

    my $data = eval {
        my $hash = $self->dispatch_logic( $req, '', $req->path );
        $hash = $req->_set_reply( $hash );

        if (my $hooks = $req->route->hooks->{pre_content}) {
            run_all_nodie( $hooks, sub {
                    $req->log_error( "NEAF: pre_content hook failed: $@" )
            }, $req );
        };

        $hash->{-content} = $self->dispatch_view( $req )
            unless defined $hash->{-content};
        $hash;
    };

    if (!$data) {
        # TODO 0.30 Error handler should be route-dependent.
        $req->_unset_reply;
        $data = $self->_error_to_reply( $req, $@ );
    };

    # Encode content, fix headers - do it before hooks
    $req->_mangle_headers;
    $req->_apply_late_hooks;
    $req->_respond;
};

=head2 get_view()

    $route->get_view( "name", $lazy )

Fetch view object by name.

This is used to fetch/instantiate whatever is in C<-view> of the
controller return hash.

Uses C ( name => name ) if needed, unless $lazy flag is on.

If L was called, return its argument instead.

=cut

sub get_view {
    my ($self, $view, $lazy) = @_;
    $self = _one_and_true($self);

    # An object/code means controller knows better
    return $view
        if ref $view;

    # Try loading & caching if not present.
    $self->load_view( $view, $view )
        unless $lazy || $self->{seen_view}{$view};

    # Finally, return the thing.
    return $self->{seen_view}{$view};
};

=head2 INTERNAL LOGIC METHODS

The following methods are part of NEAF's core and should not be called
unless you want something I special.

The following terminology is used hereafter:

=over

=item * prefix - part of URI that matched given NEAF route;

=item * suffix - anything after the matching part
but before query parameters (the infamous C).

=back

When recursive routing is applied, C is left untouched,
C becomes prefix, and C is split into new C + C.

When a leaf route is found, it matches $suffix to its own regex
and either dies 404 or proceeds with application logic.

=head2 find_route( $method, $suffix )

Find subtree that matches given ($method, $suffix) pair.

May die 404 or 405 if no suitable route is found.

Otherwise returns (route, new_stem, new_suffix).

=cut

sub find_route {
    my ($self, $method, $path) = @_;

    # Lookup the rules for the given path
    $path =~ $self->{route_re}
        or die "404\n";

    my ($prefix, $postfix) = ($1, $2);
    $prefix =~ s#//+#/#g; # CANONIZE

    my $node = $self->{route}{$prefix}
        or die "404\n";

    my $route = $node->{ $method };
    unless ($route) {
        die MVC::Neaf::Exception->new(
            -status => 405,
            -headers => [Allow => join ", ", keys %$node]
        );
    };

    $postfix = '' unless defined $postfix;
    return ($route, $prefix, $postfix);
};

=head2 dispatch_logic

    dispatch_logic( $req, $prefix, $suffix )

Find a matching route and apply it to the request.

This is recursive, may die, and may spoil C<$req>.

Upon successful termination, a reply hash is returned.
See also L.

=cut

sub dispatch_logic {
    my ($self, $req, $stem, $suffix) = @_;

    $self->post_setup
        unless $self->{lock};

    my $method = $req->method;

    # We MUST now ensure that $req->route is avail at any time
    # so add self to route
    # but maybe this whould be in dispatch_logic
    my $stub = $self->{pre_route_stub}{ $method }
        ||= MVC::Neaf::Route::PreRoute->new(
             method => $method, parent => $self );
    $req->_import_route( $stub );

    # run pre_route hooks if any
    my $pre_route_hooks = $stub->hooks->{pre_route};
    run_all( $pre_route_hooks, $req )
        if $pre_route_hooks;

    my ($route, $new_stem, $new_suffix) = $self->find_route( $method, $suffix );

    $route->dispatch_logic( $req, $new_stem, $new_suffix );
};

=head2 dispatch_view

Apply view to a request.

=cut

sub dispatch_view {
    my ($self, $req) = @_;

    my $data  = $req->reply;
    my $route = $req->route;

    my $content;

    eval {
        run_all( $route->hooks->{pre_render}, $req )
            if $route->hooks->{pre_render};

        my $view = $self->get_view( $data->{-view} );

        ($content, my $type) = blessed $view
            ? $view->render( $data ) : $view->( $data );

        $data->{-type} ||= $type;
    };

    if (!defined $content) {
        $req->log_error( "NEAF: Request processed, but rendering failed: ". ($@ || "unknown error") );
        die MVC::Neaf::Exception->new(
            -status => 500,
            -reason => "Rendering error: $@"
        );
    };

    return $content;
};

sub _error_to_reply {
    my ($self, $req, $err) = @_;

    # Convert all errors to Neaf expt.
    if (!blessed $err) {
        $err = MVC::Neaf::Exception->new(
            -status   => $err,
            -nocaller => 1,
        );
    }
    elsif ( !$err->isa("MVC::Neaf::Exception")) {
        $err = MVC::Neaf::Exception->new(
            -status   => 500,
            -sudden   => 1,
            -reason   => $err,
            -nocaller => 1,
        );
    };

    # Now $err is guaranteed to be a Neaf error

    # Use on_error callback to fixup error or gather stats
    if( $err->is_sudden and exists $self->{on_error}) {
        eval {
            $self->{on_error}->($req, $err, $req->endpoint_origin);
            1;
        }
            or $req->log_error( "NEAF: on_error callback failed: ".($@ || "unknown reason") );
    };

    # Try fancy error template
    if (my $tpl = $self->_get_error_handler( $err->status, $req )) {
        my $ret = eval {
            my $data = $tpl->( $req,
                status => $err->status,
                error => $err,
            );
            $data->{-status}  ||= $err->status;
            $data = $req->_set_reply( $data );
            $data->{-content} ||= $self->dispatch_view( $req );
            $data;
        };
        return $ret if $ret;
        $req->log_error( "NEAF: error_template for ".$err->status." failed:"
            .( $@ || "unknown reason") );
    };

    # Options exhausted - return plain error message,
    #    keep track of reason on the inside
    $req->log_error( $err->reason )
        if $err->is_sudden;
    $req->_set_reply( $err->make_reply( $req ) );
};

sub _get_error_handler {
    my ($self, $status, $req) = @_;

    my $store = $self->{error_template}{$status};
    return unless $store;

    return $store->fetch_last( method => $req->method, path => $req->path );
};

=head2 neaf_base_dir()

Returns the containing directory of the first non-Neaf calling file,
or cwd() with a warning otherwise.

=cut

# Should we cache? If so, how to determine we're in a different file now?
sub neaf_base_dir {
    my $self = shift;

    my $file = caller_info()->[1];
    if (defined $file and -f $file) {
        $file = abs_path($file);
        # TODO actually don't use magic, add use param instead
        return $file =~ /(.*)\.pm$/ ? $1 : dirname $file;
    };

    my $cwd = cwd;
    carp "Unable to determine relative path via caller, consider using absolute paths. Defaulting to cwd='$cwd'";
    return $cwd;
};

=head1 DEPRECATED METHODS

Some methods become obsolete during Neaf development.
Anything that is considered deprecated will continue to be supported
I after official deprecation
and a corresponding warning being added.

Please keep an eye on C though.

B

=over

=item * route

Old alias for L.

=cut

sub route {
    my $self = shift;

    # TODO 0.30 deprecate

    $self->add_route(@_);
};

=back

=head1 LICENSE AND COPYRIGHT

This module is part of L suite.

Copyright 2016-2023 Konstantin S. Uvarin C.

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See L for more information.

=cut

1;