Dancer

 view release on metacpan or  search on metacpan

lib/Dancer/Request.pm  view on Meta::CPAN

package Dancer::Request;
our $AUTHORITY = 'cpan:SUKRIA';
#ABSTRACT: interface for accessing incoming requests
$Dancer::Request::VERSION = '1.3522';
use strict;
use warnings;
use Carp;

use base 'Dancer::Object';

use Dancer::Config 'setting';
use Dancer::Request::Upload;
use Dancer::SharedData;
use Dancer::Session;
use Dancer::Exception qw(:all);
use Encode;
use HTTP::Body;
use URI;
use URI::Escape;

my @http_env_keys = (
    'user_agent',      'accept_language', 'accept_charset',
    'accept_encoding', 'keep_alive', 'connection',      'accept',
    'accept_type',     'referer',  #'host', managed manually
);
my $count = 0;

__PACKAGE__->attributes(

    # query
    'env',          'path',    'method',
    'content_type', 'content_length',
    'id',
    'uploads',      'headers', 'path_info',
    'ajax',         'is_forward',
    @http_env_keys,
);

sub new {
    my ($self, @args) = @_;
    if (@args == 1) {
        @args = ('env' => $args[0]);
        Dancer::Deprecation->deprecated(
                      fatal   => 1,
                      feature => 'Calling Dancer::Request->new($env)',
                      version => 1.3059,
                      reason  => 'Please use Dancer::Request->new( env => $env ) instead',
         );
    }
    $self->SUPER::new(@args);
}

# aliases
sub agent                 { $_[0]->user_agent }
sub remote_address        { $_[0]->address }
sub forwarded_for_address { $_[0]->env->{'X_FORWARDED_FOR'} || $_[0]->env->{'HTTP_X_FORWARDED_FOR'} }
sub address {
    setting('behind_proxy')
        ? $_[0]->forwarded_for_address()
        : $_[0]->env->{REMOTE_ADDR}
}
sub host {
    if (@_==2) {
        $_[0]->{host} = $_[1];
    } else {
        my $host;
        $host = ($_[0]->env->{X_FORWARDED_HOST} || $_[0]->env->{HTTP_X_FORWARDED_HOST}) if setting('behind_proxy');
        $host || $_[0]->{host} || $_[0]->env->{HTTP_HOST};
    }
}
sub remote_host           { $_[0]->env->{REMOTE_HOST} }
sub protocol              { $_[0]->env->{SERVER_PROTOCOL} }
sub port                  { $_[0]->env->{SERVER_PORT} }
sub request_uri           { $_[0]->env->{REQUEST_URI} }
sub user                  { $_[0]->env->{REMOTE_USER} }
sub script_name           { $_[0]->env->{SCRIPT_NAME} }
sub request_base          { $_[0]->env->{REQUEST_BASE} || $_[0]->env->{HTTP_REQUEST_BASE} }
sub scheme                {
    my $scheme;
    if (setting('behind_proxy')) {
        # PSGI specs say that X_FORWARDED_PROTO will
        # be converted into HTTP_X_FORWARDED_PROTO
        # but Dancer::Test doesn't use PSGI (for now)

lib/Dancer/Request.pm  view on Meta::CPAN

sub is_ajax {
    my $self = shift;

    # when using Plack::Builder headers are not set
    # so we're checking if it's actually there with PSGI plain headers
    if ( defined $self->{x_requested_with} ) {
        if ( $self->{x_requested_with} eq "XMLHttpRequest" ) {
            return 1;
        }
    }

    return 0 unless defined $self->headers;
    return 0 unless defined $self->header('X-Requested-With');
    return 0 if $self->header('X-Requested-With') ne 'XMLHttpRequest';
    return 1;
}

# context-aware accessor for uploads
sub upload {
    my ($self, $name) = @_;
    my $res = $self->{uploads}{$name};

    return $res unless wantarray;
    return ()   unless defined $res;
    return (ref($res) eq 'ARRAY') ? @$res : $res;
}

# Some Dancer's core components sometimes need to alter
# the parsed request params, these protected accessors are provided
# for this purpose
sub _set_route_params {
    my ($self, $params) = @_;
    $self->{_route_params} = $params;
    $self->_build_params();
}

sub _set_body_params {
    my ($self, $params) = @_;
    $self->{_body_params} = $params;
    $self->_build_params();
}

sub _set_query_params {
    my ($self, $params) = @_;
    $self->{_query_params} = $params;
    $self->_build_params();
}

sub _build_request_env {
    my ($self) = @_;

   # Don't refactor that, it's called whenever a request object is needed, that
   # means at least once per request. If refactored in a loop, this will cost 4
   # times more than the following static map.
    my $env = $self->env;
    $self->{user_agent}       = $env->{HTTP_USER_AGENT};
    $self->{host}             = $env->{HTTP_HOST};
    $self->{accept_language}  = $env->{HTTP_ACCEPT_LANGUAGE};
    $self->{accept_charset}   = $env->{HTTP_ACCEPT_CHARSET};
    $self->{accept_encoding}  = $env->{HTTP_ACCEPT_ENCODING};
    $self->{keep_alive}       = $env->{HTTP_KEEP_ALIVE};
    $self->{connection}       = $env->{HTTP_CONNECTION};
    $self->{accept}           = $env->{HTTP_ACCEPT};
    $self->{accept_type}      = $env->{HTTP_ACCEPT_TYPE};
    $self->{referer}          = $env->{HTTP_REFERER};
    $self->{x_requested_with} = $env->{HTTP_X_REQUESTED_WITH};
}

sub _build_headers {
    my ($self) = @_;
    $self->{headers} = Dancer::SharedData->headers;
}

sub _build_params {
    my ($self) = @_;

    # params may have been populated by before filters
    # _before_ we get there, so we have to save it first
    my $previous = $self->{params};

    # now parse environment params...
    $self->_parse_get_params();
    if ($self->is_forward) {
        $self->{_body_params} ||= {};
    } else {
        $self->_parse_post_params();
    }

    # and merge everything
    $self->{params} = {
        %$previous,                %{$self->{_query_params}},
        %{$self->{_route_params}}, %{$self->{_body_params}},
    };

}

# Written from PSGI specs:
# http://search.cpan.org/dist/PSGI/PSGI.pod
sub _build_path {
    my ($self) = @_;
    my $path = "";

    $path .= $self->script_name if defined $self->script_name;
    $path .= $self->env->{PATH_INFO} if defined $self->env->{PATH_INFO};

    # fallback to REQUEST_URI if nothing found
    # we have to decode it, according to PSGI specs.
    if (defined $self->request_uri) {
        $path ||= $self->_url_decode($self->request_uri);
    }

    raise core_request => "Cannot resolve path" if not $path;
    $self->{path} = $path;
}

sub _build_path_info {
    my ($self) = @_;
    my $info = $self->env->{PATH_INFO};
    if (defined $info) {

        # Empty path info will be interpreted as "root".

lib/Dancer/Request.pm  view on Meta::CPAN

Whereas with a manual access to the hash table, you'll end up with one element
in @uploads, being the ARRAY ref:

    my @uploads = request->uploads->{'many_uploads'}; # $uploads[0]: ARRAY(0xXXXXX)

That is why this accessor should be used instead of a manual access to
C<uploads>.

=head1 Values

Given a request to http://perldancer.org:5000/request-methods?a=1 these are
the values returned by the various request->  method calls:

  base         http://perldancer.org:5000/
  host         perldancer.org
  uri_base     http://perldancer.org:5000
  uri          /request-methods?a=1
  request_uri  /request-methods?a=1
  path         /request-methods
  path_info    /request-methods
  method       GET
  port         5000
  protocol     HTTP/1.1
  scheme       http

=head1 HTTP environment variables

All HTTP environment variables that are in %ENV will be provided in the
Dancer::Request object through specific accessors, here are those supported:

=over 4

=item C<accept>

=item C<accept_charset>

=item C<accept_encoding>

=item C<accept_language>

=item C<accept_type>

=item C<agent> (alias for C<user_agent>)

=item C<connection>

=item C<forwarded_for_address>

Looks for HTTP_X_FORWARDED_FOR if X_FORWARDED_FOR is not there.

=item C<forwarded_protocol>

=item C<forwarded_host>

=item C<host>

If you app is on a non-standard port, you can expect this to return the hostname
and port, e.g. C<example.com:5000>.

=item C<keep_alive>

=item C<path_info>

=item C<referer>

=item C<remote_address>

=item C<request_base>

=item C<user_agent>

=back

=head1 AUTHORS

This module has been written by Alexis Sukrieh and was mostly
inspired by L<Plack::Request>, written by Tatsuiko Miyagawa.

Tatsuiko Miyagawa also gave a hand for the PSGI interface.

=head1 LICENCE

This module is released under the same terms as Perl itself.

=head1 SEE ALSO

L<Dancer>

=head1 AUTHOR

Dancer Core Developers

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2010 by Alexis Sukrieh.

This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.

=cut