File Coverage

blib/lib/Dancer.pm

Criterion	Covered	Total	%
statement	236	285	82.8
branch	56	78	71.7
condition	15	36	41.6
subroutine	90	107	84.1
pod	67	67	100.0
total	464	573	80.9

package Dancer;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: lightweight yet powerful web application framework
$Dancer::VERSION = '1.3514_04'; # TRIAL
$Dancer::VERSION = '1.351404';
use strict;
use warnings;
use Carp;
use Cwd 'realpath';

use Dancer::App;
use Dancer::Config;
use Dancer::Cookies;
use Dancer::FileUtils;
use Dancer::GetOpt;
use Dancer::Error;
use Dancer::Hook;
use Dancer::Logger;
use Dancer::Renderer;
use Dancer::Route;
use Dancer::Serializer::JSON;
use Dancer::Serializer::YAML;
use Dancer::Serializer::XML;
use Dancer::Serializer::Dumper;
use Dancer::Session;
use Dancer::SharedData;
use Dancer::Handler;
use Dancer::MIME;
use Dancer::Exception qw(:all);

use Dancer::Continuation::Halted;
use Dancer::Continuation::Route::Forwarded;
use Dancer::Continuation::Route::Passed;
use Dancer::Continuation::Route::ErrorSent;
use Dancer::Continuation::Route::FileSent;
use Dancer::Continuation::Route::Templated;

use File::Spec;
use Scalar::Util;

use base 'Exporter';

our @EXPORT    = qw(
  after
  any
  before
  before_template
  cookie
  cookies
  config
  content_type
  dance
  dancer_version
  debug
  del
  dirname
  info
  error
  engine
  false
  forward
  from_dumper
  from_json
  from_yaml
  from_xml
  get
  halt
  header
  headers
  hook
  layout
  load
  load_app
  logger
  mime
  options
  param
  param_array
  params
  pass
  path
  patch
  post
  prefix
  push_header
  put
  redirect
  render_with_layout
  request
  send_file
  send_error
  set
  setting
  set_cookie
  session
  splat
  status
  start
  template
  to_dumper
  to_json
  to_yaml
  to_xml
  true
  upload
  captures
  uri_for
  var
  vars
  warning
);

# Dancer's syntax

sub after           {
    Dancer::Deprecation->deprecated(reason => "use hooks!",
                                    version => '1.3080',
                                    fatal => 0);
    Dancer::Hook->new('after', @_);
}
sub before          {
    Dancer::Deprecation->deprecated(reason => "use hooks!",
                                    version => '1.3080',
                                    fatal => 0);
    Dancer::Hook->new('before', @_);
}
sub before_template {
    Dancer::Deprecation->deprecated(reason => "use hooks!",
                                    version => '1.3080',
                                    fatal => 0);
    Dancer::Hook->new('before_template', @_);
}

sub any             { Dancer::App->current->registry->any_add(@_) }
sub captures        { Dancer::SharedData->request->params->{captures} }
sub cookie          { Dancer::Cookies->cookie( @_ ) }
sub cookies         { Dancer::Cookies->cookies }
sub config          { Dancer::Config::settings() }
sub content_type    { Dancer::SharedData->response->content_type(@_) }
sub dance           { goto &start }
sub dancer_version  { Dancer->VERSION }
sub debug           { goto &Dancer::Logger::debug }
sub del             { Dancer::App->current->registry->universal_add('delete',  @_) }
sub dirname         { Dancer::FileUtils::dirname(@_) }
sub engine          { Dancer::Engine->engine(@_) }
sub error           { goto &Dancer::Logger::error }
sub false           { 0 }
sub forward         { Dancer::SharedData->response->forward(@_);
                      # throw a special continuation exception
                      Dancer::Continuation::Route::Forwarded->new->throw;
                    }
sub from_dumper     { Dancer::Serializer::Dumper::from_dumper(@_) }
sub from_json       { Dancer::Serializer::JSON::from_json(@_) }
sub from_xml        { Dancer::Serializer::XML::from_xml(@_) }
sub from_yaml       { Dancer::Serializer::YAML::from_yaml(@_) }
sub get             { map { my $r = $_; Dancer::App->current->registry->universal_add($r, @_) } qw(head get)  }
sub halt            { Dancer::SharedData->response->halt(@_);
                      # throw a special continuation exception
                      Dancer::Continuation::Halted->new->throw;
                    }
sub header          { goto &headers }
sub info            { goto &Dancer::Logger::info }
sub push_header     { Dancer::SharedData->response->push_header(@_); }
sub headers         { Dancer::SharedData->response->headers(@_); }
sub hook            { Dancer::Hook->new(@_) }
sub layout          {
    Dancer::Deprecation->deprecated(reason => "use 'set layout => \"value\"'",
                                    version => '1.3050',
                                    fatal => 1);
}
sub load            { require $_ for @_ }
sub load_app        { goto &_load_app } # goto doesn't add a call frame. So caller() will work as expected
sub logger          {
    Dancer::Deprecation->deprecated(reason => "use 'set logger => \"value\"'",
                                    fatal => 1,version=>'1.3050');
}
sub mime            { Dancer::MIME->instance() }
sub options         { Dancer::App->current->registry->universal_add('options', @_) }
sub params          { Dancer::SharedData->request->params(@_) }
sub param           { params->{$_[0]} }
sub param_array     {
    my $value = param(shift);

    my @array = ref $value eq 'ARRAY' ? @$value
              : defined $value        ? ( $value )
              :                         ()
              ;

    return @array;
}
sub pass            { Dancer::SharedData->response->pass(1);
                      # throw a special continuation exception
                      Dancer::Continuation::Route::Passed->new->throw;
                    }
sub patch            { Dancer::App->current->registry->universal_add('patch', @_) }
sub path            { Dancer::FileUtils::path(@_) }
sub post            { Dancer::App->current->registry->universal_add('post', @_) }
sub prefix          { @_ == 0 ? Dancer::App->current->get_prefix :
                          Dancer::App->current->set_prefix(@_) }
sub put             { Dancer::App->current->registry->universal_add('put',     @_) }
sub redirect        { goto &_redirect }
sub render_with_layout { Dancer::Template::Abstract->_render_with_layout(@_) }
sub request         { Dancer::SharedData->request }
sub send_error      { Dancer::Continuation::Route::ErrorSent->new(
                          return_value => Dancer::Error->new(
                              message => $_[0],
                              code => $_[1] || 500)->render()
                      )->throw }
#sub send_file       { goto &_send_file }
sub send_file       { Dancer::Continuation::Route::FileSent->new(
                          return_value => _send_file(@_)
                      )->throw
                    }
sub set             { goto &setting }
sub set_cookie      { Dancer::Cookies->set_cookie(@_) }
sub setting         { Dancer::App->applications ? Dancer::App->current->setting(@_) : Dancer::Config::setting(@_) }
sub session         { goto &_session }
sub splat           { @{ Dancer::SharedData->request->params->{splat} || [] } }
sub start           { goto &_start }
sub status          { Dancer::SharedData->response->status(@_) }
sub template        { Dancer::Template::Abstract->template(@_) }
sub to_dumper       { Dancer::Serializer::Dumper::to_dumper(@_) }
sub to_json         { Dancer::Serializer::JSON::to_json(@_) }
sub to_xml          { Dancer::Serializer::XML::to_xml(@_) }
sub to_yaml         { Dancer::Serializer::YAML::to_yaml(@_) }
sub true            { 1 }
sub upload          { Dancer::SharedData->request->upload(@_) }
sub uri_for         { Dancer::SharedData->request->uri_for(@_) }
sub var             { Dancer::SharedData->var(@_) }
sub vars            { Dancer::SharedData->vars }
sub warning         { goto &Dancer::Logger::warning }

# When importing the package, strict and warnings pragma are loaded,
# and the appdir detection is performed.
{
    my $as_script   = 0;

sub import {
    my ($class, @args) = @_;
    my ($package, $script) = caller;

    strict->import;
    warnings->import;
    utf8->import;

    my @final_args;
    my $syntax_only = 0;
    foreach (@args) {
        if ( $_ eq ':moose' ) {
            push @final_args, '!before', '!after';
        }
        elsif ( $_ eq ':tests' ) {
            push @final_args, '!pass';
        }
        elsif ( $_ eq ':syntax' ) {
            $syntax_only = 1;
        }
        elsif ($_ eq ':script') {
            $as_script = 1;
        } else {
            push @final_args, $_;
        }
    }

    $class->export_to_level(1, $class, @final_args);

    # if :syntax option exists, don't change settings
    return if $syntax_only;

    $as_script = 1 if $ENV{PLACK_ENV};

    Dancer::GetOpt->process_args unless $as_script;

    _init_script_dir($script);
    Dancer::Config->load;
}

}

# private code

# FIXME handle previous usage of load_app with multiple app names
sub _load_app {
    my ($app_name, %options) = @_;
    my $script = (caller)[1];
    Dancer::Logger::core("loading application $app_name");

    # set the application
    my $app = Dancer::App->set_running_app($app_name);

    # Application options
    $app->set_app_prefix($options{prefix}) if $options{prefix};
    $app->settings($options{settings}) if $options{settings};

    # load the application
    _init_script_dir($script);
    my ($res, $error) = Dancer::ModuleLoader->load($app_name);
    $res or raise core => "unable to load application $app_name : $error";

    # restore the main application
    Dancer::App->set_running_app('main');
}

sub _init_script_dir {
    my ($script) = @_;

    my ($script_vol, $script_dirs, $script_name) =
      File::Spec->splitpath(File::Spec->rel2abs($script));

    # normalize
    if ( -d ( my $fulldir = File::Spec->catdir( $script_dirs, $script_name ) ) ) {
        $script_dirs = $fulldir;
        $script_name = '';
    }

    my @script_dirs = File::Spec->splitdir($script_dirs);
    my $script_path;
    if ($script_vol) {
        $script_path = Dancer::path($script_vol, $script_dirs);
    } else {
        $script_path = Dancer::path($script_dirs);
    }

    my $LAYOUT_PRE_DANCER_1_2 = 1;

    # in bin/ or public/ or t/ we need to go one level up to find the appdir
    $LAYOUT_PRE_DANCER_1_2 = 0
      if ($script_dirs[$#script_dirs - 1] eq 'bin')
      or ($script_dirs[$#script_dirs - 1] eq 'public')
      or ($script_dirs[$#script_dirs - 1] eq 't');

    my $appdir = $ENV{DANCER_APPDIR} || (
          $LAYOUT_PRE_DANCER_1_2
        ? $script_path
        : File::Spec->rel2abs(Dancer::path($script_path, '..'))
    );
    Dancer::setting(appdir => $appdir);

    # once the dancer_appdir have been defined, we export to env
    $ENV{DANCER_APPDIR} = $appdir;

    Dancer::Logger::core("initializing appdir to: `$appdir'");

    Dancer::setting(confdir => $ENV{DANCER_CONFDIR}
      || $appdir) unless Dancer::setting('confdir');

    Dancer::setting(public => $ENV{DANCER_PUBLIC}
      || Dancer::FileUtils::path($appdir, 'public'));

    Dancer::setting(views => $ENV{DANCER_VIEWS}
      || Dancer::FileUtils::path($appdir, 'views'));

    my ($res, $error) = Dancer::ModuleLoader->use_lib(Dancer::FileUtils::path($appdir, 'lib'));
    $res or raise core => "unable to set libdir : $error";
}


# Scheme grammar as defined in RFC 2396
#  scheme = alpha *( alpha | digit | "+" | "-" | "." )
my $scheme_re = qr{ [a-z][a-z0-9\+\-\.]* }ix;
sub _redirect {
    my ($destination, $status) = @_;

    # RFC 2616 requires an absolute URI with a scheme,
    # turn the URI into that if it needs it
    if ($destination !~ m{^ $scheme_re : }x) {
        my $request = Dancer::SharedData->request;
        $destination = $request->uri_for($destination, {}, 1);
    }
    my $response = Dancer::SharedData->response;
    $response->status($status || 302);
    $response->headers('Location' => $destination);
}

sub _session {
    engine 'session'
      or raise core => "Must specify session engine in settings prior to using 'session' keyword";
      @_ == 0 ? Dancer::Session->get
    : @_ == 1 ? Dancer::Session->read(@_)
    :           Dancer::Session->write(@_);
}

sub _send_file {
    my ($path, %options) = @_;
    my $env = Dancer::SharedData->request->env;

    my $request = Dancer::Request->new_for_request('GET' => $path);
    Dancer::SharedData->request($request);

    # if you asked for streaming but it's not supported in PSGI
    if ( $options{'streaming'} && ! $env->{'psgi.streaming'} ) {
        # TODO: throw a fit (AKA "exception") or a Dancer::Error?
        raise core => 'Sorry, streaming is not supported on this server.';
    }

    if (exists($options{content_type})) {
        $request->content_type($options{content_type});
    }

    # If we're given an IO::Scalar object, DTRT (take the scalar ref from it)
    if (Scalar::Util::blessed($path) && $path->isa('IO::Scalar')) {
        $path = $path->sref;
    }

    my $resp;
    if (ref($path) eq "SCALAR") {
        # send_data
        $resp = Dancer::SharedData->response() || Dancer::Response->new();
        $resp->header('Content-Type' => exists($options{content_type}) ?
                                        $options{content_type} : Dancer::MIME->default());
        $resp->content($$path);
    } else {
        # real send_file
        if ($options{system_path} && -f $path) {
            $resp = Dancer::Renderer->get_file_response_for_path($path);
        } else {
            $resp = Dancer::Renderer->get_file_response();
        }
    }

    if ($resp) {

        if (exists($options{filename})) {
            $resp->push_header('Content-Disposition' =>
                "attachment; filename=\"$options{filename}\""
            );
        }

        if ( $options{'streaming'} ) {
            # handle streaming
            $resp->streamed( sub {
                my ( $status, $headers ) = @_;
                my %callbacks = defined $options{'callbacks'} ?
                                %{ $options{'callbacks'} }    :
                                ();

                return sub {
                    my $respond = shift;
                    exists $callbacks{'override'}
                        and return $callbacks{'override'}->( $respond, $resp );

                    # get respond callback and set headers, get writer in return
                    my $writer = $respond->( [
                        $status,
                        $headers,
                    ] );

                    # get content from original response
                    my $content = $resp->content;

                    exists $callbacks{'around'}
                        and return $callbacks{'around'}->( $writer, $content );

                    if ( ref $content ) {
                        my $bytes = $options{'bytes'} || '43008'; # 42K (dams)
                        my $buf;
                        while ( ( my $read = sysread $content, $buf, $bytes ) != 0 ) {
                            if ( exists $callbacks{'around_content'} ) {
                                $callbacks{'around_content'}->( $writer, $buf );
                            } else {
                                $writer->write($buf);
                            }
                        }
                    } else {
                        $writer->write($content);
                    }
                };
            } );
        }

        return $resp;

    }

    Dancer::Error->new(
        code    => 404,
        message => "No such file: `$path'"
    )->render();
}

# Start/Run the application with the chosen apphandler
sub _start {
    my ($class, $request) = @_;
    Dancer::Config->load;

    # Backward compatibility for app.psgi that has sub { Dancer->dance($req) }
    if ($request) {
        Dancer::Handler->init_request_headers( $request->env );
        # TODO _build_headers should either not be private, or we should call
        # init
        $request->_build_headers;
        return Dancer::Handler->handle_request($request);
    }

    my $handler = Dancer::Handler->get_handler;
    Dancer::Logger::core("loading handler '".ref($handler)."'");
    return $handler->dance;
}


1;

__END__