File Coverage

blib/lib/Kelp.pm

Criterion	Covered	Total	%
statement	143	148	96.6
branch	40	52	76.9
condition	17	22	77.2
subroutine	34	36	94.4
pod	14	16	87.5
total	248	274	90.5

package Kelp;

use Kelp::Base;

use Carp qw/ longmess croak /;
use FindBin;
use Encode;
use Try::Tiny;
use Data::Dumper;
use Sys::Hostname;
use Plack::Util;
use Class::Inspector;
use Scalar::Util qw(blessed);

our $VERSION = '1.05';

# Basic attributes
attr -host => hostname;
attr  mode => $ENV{KELP_ENV} // $ENV{PLACK_ENV} // 'development';
attr -path => $FindBin::Bin;
attr -name => sub { ( ref( $_[0] ) =~ /(\w+)$/ ) ? $1 : 'Noname' };
attr  request_obj  => 'Kelp::Request';
attr  response_obj => 'Kelp::Response';


# Debug
attr long_error => $ENV{KELP_LONG_ERROR} // 0;

# The charset is UTF-8 unless otherwise instructed
attr -charset => sub {
    $_[0]->config("charset") // 'UTF-8';
};

# Name the config module
attr config_module => 'Config';

# Undocumented.
# Used to unlock the undocumented features of the Config module.
attr __config => undef;

attr -loaded_modules => sub { {} };

# Each route's request an response objects will
# be put here:
attr req => undef;
attr res => undef;

# Initialization
sub new {
    my $self = shift->SUPER::new(@_);

    # Always load these modules, but allow client to override
    $self->_load_config();
    $self->_load_routes();

    # Load the modules from the config
    if ( defined( my $modules = $self->config('modules') ) ) {
        $self->load_module($_) for (@$modules);
    }

    $self->build();
    return $self;
}

my $last_anon = 0;
sub new_anon {
    my $class = shift;

    # make sure we don't eval something dodgy
    die "invalid class for new_anon"
        if ref $class                         # not a string
        || !$class                            # not an empty string, undef or 0
        || !Class::Inspector->loaded($class)  # not a loaded class
        || !$class->isa(__PACKAGE__)          # not a correct class
    ;

    my $anon_class = "Kelp::Anonymous::$class" . ++$last_anon;
    my $err = do {
        local $@;
        my $eval_status = eval qq[
                        {
                                package $anon_class;
                                use parent -norequire, '$class';
                        }
                        1;
                ];
        $@ || !$eval_status;
    };

    if ($err) {
        die "Couldn't create anonymous Kelp instance: " .
            (length $err > 1 ? $err : 'unknown error');
    }

    return $anon_class->new(@_);
}

sub _load_config {
    my $self = shift;
    $self->load_module( $self->config_module, extra => $self->__config );
}

sub _load_routes {
    my $self = shift;
    $self->load_module('Routes');
}

# Create a shallow copy of the app, optionally blessed into a
# different subclass.
sub _clone {
    my $self = shift;
    my $subclass = shift || ref($self);

    ref $self or croak '_clone requires instance';
    return bless { %$self }, $subclass;
}

sub load_module {
    my ( $self, $name, %args ) = @_;

    # A module name with a leading + indicates it's already fully
    # qualified (i.e., it does not need the Kelp::Module:: prefix).
    my $prefix = $name =~ s/^\+// ? undef : 'Kelp::Module';

    # Make sure the module was not already loaded
    return if $self->loaded_modules->{$name};

    my $class = Plack::Util::load_class( $name, $prefix );
    my $module = $self->loaded_modules->{$name} = $class->new( app => $self );

    # When loading the Config module itself, we don't have
    # access to $self->config yet. This is why we check if
    # config is available, and if it is, then we pull the
    # initialization hash.
    my $args_from_config = {};
    if ( $self->can('config') ) {
        $args_from_config = $self->config("modules_init.$name") // {};
    }

    $module->build( %$args_from_config, %args );
    return $module;
}

# Override this one to add custom initializations
sub build {
}

# Override to use a custom request object
sub build_request {
    my ( $self, $env ) = @_;
    my $package = $self->request_obj;
    eval qq{require $package};
    return $package->new( app => $self, env => $env);
}

# Override to use a custom response object
sub build_response {
    my $self = shift;
    my $package = $self->response_obj;
    eval qq{require $package};
    return $package->new( app => $self );
}

# Override to manipulate the end response
sub before_finalize {
    my $self = shift;
    $self->res->header('X-Framework' => 'Perl Kelp');
}

# Override this to wrap more middleware around the app
sub run {
    my $self = shift;
    my $app = sub { $self->psgi(@_) };

    # Add middleware
    if ( defined( my $middleware = $self->config('middleware') ) ) {
        for my $class (@$middleware) {

            # Make sure the middleware was not already loaded
            # This does not apply for testing, in which case we want
            # the middleware to wrap every single time
            next if $self->{_loaded_middleware}->{$class}++ && !$ENV{KELP_TESTING};

            my $mw = Plack::Util::load_class($class, 'Plack::Middleware');
            my $args = $self->config("middleware_init.$class") // {};
            $app = $mw->wrap( $app, %$args );
        }
    }

    return $app;
}

sub psgi {
    my ( $self, $env ) = @_;

    # Create the request and response objects
    my $req = $self->req( $self->build_request($env) );
    my $res = $self->res( $self->build_response );

    # Get route matches
    my $match = $self->routes->match( $req->path, $req->method );

    # None found? Show 404 ...
    if ( !@$match ) {
        $res->render_404;
        return $self->finalize;
    }

    try {

        # Go over the entire route chain
        for my $route (@$match) {

            # Dispatch
            $self->req->named( $route->named );
            $self->req->route_name( $route->name );
            my $data = $self->routes->dispatch( $self, $route );

            # Log info about the route
            if ( $self->can('logger') ) {
                $self->info(
                    sprintf( "%s - %s %s - %s",
                        $req->address, $req->method,
                        $req->path,    $route->to )
                );
            }

            # Is it a bridge? Bridges must return a true value
            # to allow the rest of the routes to run.
            if ( $route->bridge ) {
                if ( !$data ) {
                    $res->render_403 unless $res->rendered;
                    last;
                }
                next;
            }

            # If the route returned something, then analyze it and render it
            if ( defined $data ) {

                # Handle delayed response if CODE
                return $data if ref($data) eq 'CODE';
                $res->render($data) unless $res->rendered;
            }
        }

        # If nothing got rendered
        if ( !$self->res->rendered ) {
            # render 404 if only briges matched
            if ( $match->[-1]->bridge ) {
                $res->render_404;
            }
            # or die with error
            else {
              die $match->[-1]->to
              . " did not render for method "
              . $req->method;
            }
        }

        $self->finalize;
    }
    catch {
        my $exception = $_;
        my $res = $self->res;

        if (blessed $exception && $exception->isa('Kelp::Exception')) {
            # No logging here, since it is a message for the user with a code
            # rather than a real exceptional case
            # (Nothing really broke, user code invoked this)

            $res->render_exception($exception);
        }
        else {
            my $message = $self->long_error ? longmess($exception) : $exception;

            # Log error
            $self->logger( 'critical', $message ) if $self->can('logger');

            # Render 500
            $res->render_500($_);
        }
        $self->finalize;
    };
}

sub finalize {
    my $self = shift;
    $self->before_finalize;
    $self->res->finalize;
}


#----------------------------------------------------------------
# Request and Response shortcuts
#----------------------------------------------------------------
sub param {
    my $self = shift;
    unshift @_, $self->req;

    # goto will allow carp show the correct caller
    goto $_[0]->can('param');
}

sub session { shift->req->session(@_) }

sub stash {
    my $self = shift;
    @_ ? $self->req->stash->{$_[0]} : $self->req->stash;
}

sub named {
    my $self = shift;
    @_ ? $self->req->named->{$_[0]} : $self->req->named;
}

#----------------------------------------------------------------
# Utility
#----------------------------------------------------------------

sub url_for {
    my ( $self, $name, @args ) = @_;
    my $result = $name;
    try { $result = $self->routes->url( $name, @args ) };
    return $result;
}

sub abs_url {
    my ( $self, $name, @args ) = @_;
    my $url = $self->url_for( $name, @args );
    return URI->new_abs( $url, $self->config('app_url') )->as_string;
}

1;

__END__

=pod

=head1 NAME

Kelp - A web framework light, yet rich in nutrients.

=head1 SYNOPSIS

    package MyApp;
    use parent 'Kelp';

    # bootstrap your application
    sub build {
        my ($self) = @_;

        my $r = $self->routes;

        $r->add('/simple/route', 'route_handler');
        $r->add('/route/:name', {
            to => 'namespace::controller::action',
            ... # other options, see Kelp::Routes
        });
    }

    # example route handler
    sub route_handler {
        my ($kelp_instance, @route_parameters) = @_;

        return 'text to be rendered';
    }

    1;

=head1 DESCRIPTION

Kelp is a light, modular web framework built on top of Plack.

This document lists all the methods and attributes available in the main
instance of a Kelp application, passed as a first argument to route handling
routines.

See L<Kelp::Manual> for a complete reference.

See L<Kelp::Manual::Cookbook> for solutions to common problems.

=head1 ATTRIBUTES

=head2 hostname

Gets the current hostname.

    sub some_route {
        my $self = shift;
        if ( $self->hostname eq 'prod-host' ) {
            ...
        }
    }

=head2 mode

Sets or gets the current mode. The mode is important for the app to know what
configuration file to merge into the main configuration. See
L<Kelp::Module::Config> for more information.

    my $app = MyApp->new( mode => 'development' );
    # conf/config.pl and conf/development.pl are merged with priority
    # given to the second one.

=head2 request_obj

Provide a custom package name to define the global ::Request object. Defaults to
L<Kelp::Request>.

=head2 response_obj

Provide a custom package name to define the global ::Response object. Defaults to
L<Kelp::Response>.

=head2 config_module

Sets of gets the class of the configuration module to be loaded on startup. The
default value is C<Config>, which will cause the C<Kelp::Module::Config> to get
loaded. See the documentation for L<Kelp::Module::Config> for more information
and for an example of how to create and use other config modules.

=head2 loaded_modules

A hashref containing the names and instances of all loaded modules. For example,
if you have these two modules loaded: Template and JSON, then a dump of
the C<loaded_modules> hash will look like this:

    {
        Template => Kelp::Module::Template=HASH(0x208f6e8),
        JSON     => Kelp::Module::JSON=HASH(0x209d454)
    }

This can come in handy if your module does more than just registering a new method
into the application. Then, you can use its object instance to access that
additional functionality.


=head2 path

Gets the current path of the application. That would be the path to C<app.psgi>

=head2 name

Gets or sets the name of the application. If not set, the name of the main
class will be used.

    my $app = MyApp->new( name => 'Twittar' );

=head2 charset

Sets of gets the encoding charset of the app. It will be C<UTF-8>, if not set to
anything else. The charset could also be changed in the config files.

=head2 long_error

When a route dies, Kelp will by default display a short error message. Set this
attribute to a true value if you need to see a full stack trace of the error.
The C<KELP_LONG_ERROR> environment variable can also set this attribute.

=head2 req

This attribute only makes sense if called within a route definition. It will
contain a reference to the current L<Kelp::Request> instance.

    sub some_route {
        my $self = shift;
        if ( $self->req->is_json ) {
            ...
        }
    }

=head2 res

This attribute only makes sense if called within a route definition. It will
contain a reference to the current L<Kelp::Response> instance.

    sub some_route {
        my $self = shift;
        $self->res->json->render( { success => 1 } );
    }

=head1 METHODS

=head2 new

    my $the_only_kelp = KelpApp->new;

A standard constructor. B<Cannot> be called multiple times: see L</new_anon>.

=head2 new_anon

    my $kelp1 = KelpApp->new_anon(config => 'conf1');
    my $kelp2 = KelpApp->new_anon(config => 'conf2');

A constructor that can be called repeatedly. Cannot be mixed with L</new>.

It works by creating a new anonymous class extending the class of your
application and running I<new> on it. C<ref $kelp> will return I<something
else> than the name of your Kelp class, but C<< $kelp->isa('KelpApp') >> will
be true. This will likely be useful during testing or when running multiple
instances of the same application with different configurations.

=head2 build

On its own, the C<build> method doesn't do anything. It is called by the
constructor, so it can be overridden to add route destinations and
initializations.

    package MyApp;

    sub build {
        my $self = shift;
        my $r = $self->routes;

        # Load some modules
        $self->load_module("MongoDB");
        $self->load_module("Validate");

        # Add all route destinations
        $r->add("/one", "one");
        ...

    }

=head2 load_module

C<load_module($name, %options)>

Used to load a module. All modules must be under the C<Kelp::Module::>
namespace.

    $self->load_module("Redis", server => '127.0.0.1');
    # Will look for and load Kelp::Module::Redis

Options for the module may be specified after its name, or in the
C<modules_init> hash in the config. Precedence is given to the
inline options.
See L<Kelp::Module> for more information on making and using modules.

=head2 build_request

This method is used to create the request object for each HTTP request. It
returns an instance of the class defined in the request_obj attribute (defaults to
L<Kelp::Request>), initialized with the current request's environment. You can
override this method to use a custom request module if you need to do something
interesting. Though there is a provided attribute that can be used to overide
the class of the object used.

    package MyApp;
    use MyApp::Request;

    sub build_request {
        my ( $self, $env ) = @_;
        return MyApp::Request->new( app => $app, env => $env );
    }

    # Now each request will be handled by MyApp::Request

=head2 before_finalize

Override this method to modify the response object just before it gets
finalized.

    package MyApp;

    sub before_finalize {
        my $self = shift;
        $self->res->set_header("X-App-Name", "MyApp");
    }

    ...

The above is an example of how to insert a custom header into the response of
every route.

=head2 build_response

This method creates the response object, e.g. what an HTTP request will return.
By default the object created is L<Kelp::Response> though this can be
overwritten via the respone_obj attribute. Much like L</build_request>, the
response can also be overridden to use a custom response object if you need
something completely custom.

=head2 run

This method builds and returns the PSGI app. You can override it in order to
include middleware. See L<Kelp::Manual/Adding middleware> for an example.

=head2 param

A shortcut to C<$self-E<gt>req-E<gt>param>:

    sub some_route {
        my $self = shift;
        if ( $self->param('age') > 18 ) {
            $self->can_watch_south_path(1);
        }
    }

This function can be tricky to use because of context sensivity. See
L<Kelp::Request/param> for more information and examples.

=head2 session

A shortcut to C<$self-E<gt>req-E<gt>session>. Take a look at L<Kelp::Request/session>
for more information and examples.

=head2 stash

Provides safe access to C<$self-E<gt>req-E<gt>stash>. When called without
arguments, it will return the stash hash. If called with a single argument, it
will return the value of the corresponding key in the stash.
See L<Kelp::Request/stash> for more information and examples.

=head2 named

Provides safe access to C<$self-E<gt>req-E<gt>named>. When called without
arguments, it will return the named hash. If called with a single argument, it
will return the value of the corresponding key in the named hash.
See L<Kelp::Request/named> for more information and examples.

=head2 url_for

A safe shortcut to C<$self-E<gt>routes-E<gt>url>. Builds a URL from path and
arguments.

    sub build {
        my $self = shift;
        $self->routes->add("/:name/:id", { name => 'name', to => sub {
            ...
        }});
    }

    sub check {
        my $self = shift;
        my $url_for_name = $self->url_for('name', name => 'jake', id => 1003);
        $self->res->redirect_to( $url_for_name );
    }

=head2 abs_url

Same as L</url_for>, but returns the full absolute URI for the current
application (based on configuration).

=head1 AUTHOR

Stefan Geneshky - minimal <at> cpan.org

=head1 LICENSE

This module and all the modules in this package are governed by the same license
as Perl itself.

=cut