—package
Mojo::Message;
use
Mojo::Asset::Memory;
use
Mojo::DOM;
use
Mojo::JSON;
use
Mojo::Parameters;
use
Mojo::Upload;
has
content
=>
sub
{ Mojo::Content::Single->new };
has
default_charset
=>
'UTF-8'
;
has
dom_class
=>
'Mojo::DOM'
;
has
json_class
=>
'Mojo::JSON'
;
has
max_message_size
=>
sub
{
$ENV
{MOJO_MAX_MESSAGE_SIZE} || 5242880 };
has
version
=>
'1.1'
;
# "I'll keep it short and sweet. Family. Religion. Friendship.
# These are the three demons you must slay if you wish to succeed in
# business."
sub
at_least_version {
my
(
$self
,
$version
) =
@_
;
# Major and minor
my
(
$search_major
,
$search_minor
) =
split
/\./,
$version
;
my
(
$current_major
,
$current_minor
) =
split
/\./,
$self
->version;
# Version is equal or newer
return
1
if
$search_major
<
$current_major
;
return
1
if
$search_major
==
$current_major
&&
$search_minor
<=
$current_minor
;
# Version is older
return
;
}
sub
body {
my
$self
=
shift
;
# Downgrade multipart content
$self
->content(Mojo::Content::Single->new)
if
$self
->content->is_multipart;
my
$content
=
$self
->content;
# Get
return
$content
->asset->slurp
unless
defined
(
my
$new
=
shift
);
# Callback
if
(
ref
$new
eq
'CODE'
) {
weaken
$self
;
return
$content
->on(
read
=>
sub
{
$self
->
$new
(
pop
) });
}
# Set text content
else
{
$content
->asset(Mojo::Asset::Memory->new->add_chunk(
$new
)) }
return
$self
;
}
sub
body_params {
my
$self
=
shift
;
# Cached
return
$self
->{body_params}
if
$self
->{body_params};
# Charset
my
$params
= Mojo::Parameters->new;
my
$type
=
$self
->headers->content_type ||
''
;
$params
->charset(
$self
->default_charset);
$type
=~ /charset=
"?(\S+)"
?/ and
$params
->charset($1);
# "x-application-urlencoded" and "application/x-www-form-urlencoded"
if
(
$type
=~ /(?:x-application|application\/x-www-form)-urlencoded/i) {
$params
->parse(
$self
->content->asset->slurp);
}
# "multipart/formdata"
elsif
(
$type
=~ /multipart\/form-data/i) {
my
$formdata
=
$self
->_parse_formdata;
# Formdata
for
my
$data
(
@$formdata
) {
my
$name
=
$data
->[0];
my
$filename
=
$data
->[1];
my
$value
=
$data
->[2];
# File
next
if
$filename
;
# Form value
$params
->append(
$name
,
$value
);
}
}
return
$self
->{body_params} =
$params
;
}
sub
body_size {
shift
->content->body_size }
# "My new movie is me, standing in front of a brick wall for 90 minutes.
# It cost 80 million dollars to make.
# How do you sleep at night?
# On top of a pile of money, with many beautiful women."
sub
build_body {
my
$self
=
shift
;
my
$body
=
$self
->content->build_body(
@_
);
$self
->{state} =
'finished'
;
$self
->emit(
'finish'
);
return
$body
;
}
sub
build_headers {
my
$self
=
shift
;
# HTTP 0.9 has no headers
return
''
if
$self
->version eq
'0.9'
;
$self
->fix_headers;
return
$self
->content->build_headers;
}
sub
build_start_line {
my
$self
=
shift
;
my
$startline
=
''
;
my
$offset
= 0;
while
(1) {
my
$chunk
=
$self
->get_start_line_chunk(
$offset
);
# No start line yet, try again
next
unless
defined
$chunk
;
# End of start line
last
unless
length
$chunk
;
# Start line
$offset
+=
length
$chunk
;
$startline
.=
$chunk
;
}
return
$startline
;
}
sub
cookie {
my
(
$self
,
$name
) =
@_
;
return
unless
$name
;
# Map
unless
(
$self
->{cookies}) {
my
$cookies
= {};
for
my
$cookie
(@{
$self
->cookies}) {
my
$cookie_name
=
$cookie
->name;
# Multiple cookies with same name
if
(
exists
$cookies
->{
$cookie_name
}) {
$cookies
->{
$cookie_name
} = [
$cookies
->{
$cookie_name
}]
unless
ref
$cookies
->{
$cookie_name
} eq
'ARRAY'
;
push
@{
$cookies
->{
$cookie_name
}},
$cookie
;
}
# Cookie
else
{
$cookies
->{
$cookie_name
} =
$cookie
}
}
$self
->{cookies} =
$cookies
;
}
# Multiple
my
$cookies
=
$self
->{cookies}->{
$name
};
my
@cookies
;
@cookies
=
ref
$cookies
eq
'ARRAY'
?
@$cookies
: (
$cookies
)
if
$cookies
;
return
wantarray
?
@cookies
:
$cookies
[0];
}
sub
dom {
my
$self
=
shift
;
# Parse
return
if
$self
->is_multipart;
my
$charset
;
(
$self
->headers->content_type ||
''
) =~ /charset=
"?([^"
\s;]+)"?/
and
$charset
= $1;
my
$dom
=
$self
->dom_class->new(
charset
=>
$charset
)->parse(
$self
->body);
# Find right away
return
$dom
->find(
@_
)
if
@_
;
return
$dom
;
}
sub
error {
my
$self
=
shift
;
# Get
unless
(
@_
) {
return
unless
my
$error
=
$self
->{error};
return
wantarray
?
@$error
:
$error
->[0];
}
# Set
$self
->{error} = [
@_
];
$self
->{state} =
'finished'
;
return
$self
;
}
sub
fix_headers {
my
$self
=
shift
;
# Content-Length header or connection close is required in HTTP 1.0
# unless the chunked transfer encoding is used
if
(
$self
->at_least_version(
'1.0'
) && !
$self
->is_chunked) {
my
$headers
=
$self
->headers;
unless
(
$headers
->content_length) {
$self
->is_dynamic
?
$headers
->connection(
'close'
)
:
$headers
->content_length(
$self
->body_size);
}
}
return
$self
;
}
sub
get_body_chunk {
my
$self
=
shift
;
# Progress
$self
->emit(
progress
=>
'body'
,
@_
);
# Chunk
my
$chunk
=
$self
->content->get_body_chunk(
@_
);
return
$chunk
if
!
defined
$chunk
||
length
$chunk
;
# Finish
$self
->{state} =
'finished'
;
$self
->emit(
'finish'
);
return
$chunk
;
}
sub
get_header_chunk {
my
$self
=
shift
;
# Progress
$self
->emit(
progress
=>
'headers'
,
@_
);
# HTTP 0.9 has no headers
return
''
if
$self
->version eq
'0.9'
;
return
$self
->content->get_header_chunk(
@_
);
}
sub
get_start_line_chunk {
my
(
$self
,
$offset
) =
@_
;
$self
->emit(
progress
=>
'start_line'
,
@_
);
return
substr
$self
->{start_line_buffer} //=
$self
->_build_start_line,
$offset
, CHUNK_SIZE;
}
sub
has_leftovers {
shift
->content->has_leftovers }
sub
header_size {
my
$self
=
shift
;
$self
->fix_headers;
return
$self
->content->header_size;
}
sub
headers {
my
$self
=
shift
;
if
(
@_
) {
$self
->content->headers(
@_
);
return
$self
;
}
return
$self
->content->headers(
@_
);
}
sub
is_chunked {
shift
->content->is_chunked }
# DEPRECATED in Leaf Fluttering In Wind!
sub
is_done {
warn
<<EOF;
Mojo::Message->is_done is DEPRECATED in favor of Mojo::Message->is_finished!
EOF
shift
->is_finished;
}
sub
is_dynamic {
shift
->content->is_dynamic }
sub
is_finished {
return
1
if
(
shift
->{state} ||
''
) eq
'finished'
;
return
;
}
sub
is_limit_exceeded {
my
$self
=
shift
;
return
unless
my
$code
= (
$self
->error)[1];
return
unless
$code
~~ [413, 431];
return
1;
}
sub
is_multipart {
shift
->content->is_multipart }
sub
json {
my
$self
=
shift
;
return
if
$self
->is_multipart;
return
$self
->json_class->new->decode(
$self
->body);
}
sub
leftovers {
shift
->content->leftovers }
sub
max_line_size {
shift
->headers->max_line_size(
@_
) }
# DEPRECATED in Smiling Face With Sunglasses!
sub
on_finish {
warn
<<EOF;
Mojo::Message->on_finish is DEPRECATED in favor of using Mojo::Message->on!
EOF
shift
->on(
finish
=>
shift
);
}
# DEPRECATED in Smiling Face With Sunglasses!
sub
on_progress {
warn
<<EOF;
Mojo::Message->on_progress is DEPRECATED in favor of using Mojo::Message->on!
EOF
shift
->on(
progress
=>
shift
);
}
sub
param {
my
$self
=
shift
;
$self
->{body_params} ||=
$self
->body_params;
return
$self
->{body_params}->param(
@_
);
}
sub
parse {
shift
->_parse(0,
@_
) }
sub
parse_until_body {
shift
->_parse(1,
@_
) }
sub
start_line_size {
length
shift
->build_start_line }
sub
to_string {
my
$self
=
shift
;
$self
->build_start_line .
$self
->build_headers .
$self
->build_body;
}
sub
upload {
my
(
$self
,
$name
) =
@_
;
return
unless
$name
;
# Map
unless
(
$self
->{uploads}) {
my
$uploads
= {};
for
my
$upload
(@{
$self
->uploads}) {
my
$uname
=
$upload
->name;
# Multiple uploads with same name
if
(
exists
$uploads
->{
$uname
}) {
$uploads
->{
$uname
} = [
$uploads
->{
$uname
}]
unless
ref
$uploads
->{
$uname
} eq
'ARRAY'
;
push
@{
$uploads
->{
$uname
}},
$upload
;
}
# Upload
else
{
$uploads
->{
$uname
} =
$upload
}
}
$self
->{uploads} =
$uploads
;
}
# Multiple
my
$uploads
=
$self
->{uploads}->{
$name
};
my
@uploads
;
@uploads
=
ref
$uploads
eq
'ARRAY'
?
@$uploads
: (
$uploads
)
if
$uploads
;
return
wantarray
?
@uploads
:
$uploads
[0];
}
sub
uploads {
my
$self
=
shift
;
# Only multipart messages have uplaods
my
@uploads
;
return
\
@uploads
unless
$self
->is_multipart;
# Extract formdata
my
$formdata
=
$self
->_parse_formdata;
for
my
$data
(
@$formdata
) {
my
$name
=
$data
->[0];
my
$filename
=
$data
->[1];
my
$part
=
$data
->[2];
# Just a form value
next
unless
$filename
;
# Uploaded file
my
$upload
= Mojo::Upload->new;
$upload
->name(
$name
);
$upload
->asset(
$part
->asset);
$upload
->filename(
$filename
);
$upload
->headers(
$part
->headers);
push
@uploads
,
$upload
;
}
return
\
@uploads
;
}
sub
write
{
shift
->content->
write
(
@_
) }
sub
write_chunk {
shift
->content->write_chunk(
@_
) }
sub
_build_start_line {
croak
'Method "_build_start_line" not implemented by subclass'
;
}
sub
_parse {
my
(
$self
,
$until_body
,
$chunk
) =
@_
;
# Add chunk
$self
->{buffer} //=
''
;
$self
->{raw_size} //= 0;
if
(
defined
$chunk
) {
$self
->{raw_size} +=
length
$chunk
;
$self
->{buffer} .=
$chunk
;
}
# Check message size
return
$self
->error(
'Maximum message size exceeded.'
, 413)
if
$self
->{raw_size} >
$self
->max_message_size;
# Start line
unless
(
$self
->{state}) {
# Check line size
my
$len
=
index
$self
->{buffer},
"\x0a"
;
$len
=
length
$self
->{buffer}
if
$len
< 0;
return
$self
->error(
'Maximum line size exceeded.'
, 431)
if
$len
>
$self
->max_line_size;
# Parse
$self
->_parse_start_line;
}
# Content
if
((
$self
->{state} ||
''
) ~~ [
qw/body content finished/
]) {
# Until body
my
$content
=
$self
->content;
my
$buffer
=
delete
$self
->{buffer};
if
(
$until_body
) {
$self
->content(
$content
->parse_until_body(
$buffer
)) }
# CGI
elsif
(
$self
->{state} eq
'body'
) {
$self
->content(
$content
->parse_body(
$buffer
));
}
# HTTP 0.9
elsif
(
$self
->version eq
'0.9'
) {
$self
->content(
$content
->parse_body_once(
$buffer
));
}
# Parse
else
{
$self
->content(
$content
->parse(
$buffer
)) }
}
# Check line size
return
$self
->error(
'Maximum line size exceeded.'
, 431)
if
$self
->headers->is_limit_exceeded;
# Finished
$self
->{state} =
'finished'
if
$self
->content->is_finished;
# Progress
$self
->emit(
'progress'
);
# Finished
$self
->emit(
'finish'
)
if
$self
->is_finished;
return
$self
;
}
sub
_parse_start_line {
croak
'Method "_parse_start_line" not implemented by subclass'
;
}
sub
_parse_formdata {
my
$self
=
shift
;
# Check content
my
@formdata
;
my
$content
=
$self
->content;
return
\
@formdata
unless
$content
->is_multipart;
my
$default
=
$self
->default_charset;
(
$self
->headers->content_type ||
''
) =~ /charset=
"?(\S+)"
?/
and
$default
= $1;
# Walk the tree
my
@parts
;
push
@parts
,
$content
;
while
(
my
$part
=
shift
@parts
) {
# Multipart
if
(
$part
->is_multipart) {
unshift
@parts
, @{
$part
->parts};
next
;
}
# Charset
my
$charset
=
$default
;
(
$part
->headers->content_type ||
''
) =~ /charset=
"?(\S+)"
?/
and
$charset
= $1;
# "Content-Disposition"
my
$disposition
=
$part
->headers->content_disposition;
next
unless
$disposition
;
my
(
$name
) =
$disposition
=~ /\ name=
"?([^"
;]+)"?/;
my
(
$filename
) =
$disposition
=~ /\ filename=
"?([^"
]*)"?/;
my
$value
=
$part
;
# Unescape
url_unescape
$name
if
$name
;
url_unescape
$filename
if
$filename
;
if
(
$charset
) {
my
$backup
=
$name
;
decode
$charset
,
$name
if
$name
;
$name
//=
$backup
;
$backup
=
$filename
;
decode
$charset
,
$filename
if
$filename
;
$filename
//=
$backup
;
}
# Form value
unless
(
$filename
) {
$value
=
$part
->asset->slurp;
if
(
$charset
&& !
$part
->headers->content_transfer_encoding) {
my
$backup
=
$value
;
decode
$charset
,
$value
;
$value
//=
$backup
;
}
}
push
@formdata
, [
$name
,
$filename
,
$value
];
}
return
\
@formdata
;
}
1;
__END__
=head1 NAME
Mojo::Message - HTTP 1.1 message base class
=head1 SYNOPSIS
use Mojo::Base 'Mojo::Message';
=head1 DESCRIPTION
L<Mojo::Message> is an abstract base class for HTTP 1.1 messages as described
in RFC 2616 and RFC 2388.
=head1 EVENTS
L<Mojo::Message> can emit the following events.
=head2 C<finish>
$message->on(finish => sub {
my $message = shift;
});
Emitted after message building or parsing is finished.
my $before = time;
$message->on(finish => sub {
my $message = shift;
$message->headers->header('X-Parser-Time' => time - $before);
});
=head2 C<progress>
$message->on(progress => sub {
my $message = shift;
});
Emitted when message building or parsing makes progress.
$message->on(progress => sub {
my $message = shift;
return unless my $len = $message->headers->content_length;
my $size = $message->content->progress;
say 'Progress: ', $size == $len ? 100 : int($size / ($len / 100)), '%';
});
=head1 ATTRIBUTES
L<Mojo::Message> implements the following attributes.
=head2 C<content>
my $message = $message->content;
$message = $message->content(Mojo::Content::Single->new);
Content container, defaults to a L<Mojo::Content::Single> object.
=head2 C<default_charset>
my $charset = $message->default_charset;
$message = $message->default_charset('UTF-8');
Default charset used for form data parsing, defaults to C<UTF-8>.
=head2 C<dom_class>
my $class = $message->dom_class;
$message = $message->dom_class('Mojo::DOM');
Class to be used for DOM manipulation with the C<dom> method, defaults to
L<Mojo::DOM>.
=head2 C<json_class>
my $class = $message->json_class;
$message = $message->json_class('Mojo::JSON');
Class to be used for JSON deserialization with the C<json> method, defaults
to L<Mojo::JSON>.
=head2 C<max_message_size>
my $size = $message->max_message_size;
$message = $message->max_message_size(1024);
Maximum message size in bytes, defaults to C<5242880>.
=head1 METHODS
L<Mojo::Message> inherits all methods from L<Mojo::EventEmitter> and
implements the following new ones.
=head2 C<at_least_version>
my $success = $message->at_least_version('1.1');
Check if message is at least a specific version.
=head2 C<body>
my $string = $message->body;
$message = $message->body('Hello!');
my $cb = $message->body(sub {...});
Access and replace text content or register C<read> event with content, which
will be emitted when new content arrives.
=head2 C<body_params>
my $params = $message->body_params;
C<POST> parameters, usually a L<Mojo::Parameters> object.
=head2 C<body_size>
my $size = $message->body_size;
Size of the body in bytes.
=head2 C<build_body>
my $string = $message->build_body;
Render whole body.
=head2 C<build_headers>
my $string = $message->build_headers;
Render all headers.
=head2 C<build_start_line>
my $string = $message->build_start_line;
Render start line.
=head2 C<cookie>
my $cookie = $message->cookie('foo');
my @cookies = $message->cookie('foo');
Access message cookies, usually L<Mojo::Cookie::Request> or
L<Mojo::Cookie::Response> objects.
=head2 C<dom>
my $dom = $message->dom;
my $collection = $message->dom('a[href]');
Turns content into a L<Mojo::DOM> object and takes an optional selector to
perform a C<find> on it right away, which returns a collection.
=head2 C<error>
my $message = $message->error;
my ($message, $code) = $message->error;
$message = $message->error('Parser error.');
$message = $message->error('Parser error.', 500);
Parser errors and codes.
=head2 C<fix_headers>
$message = $message->fix_headers;
Make sure message has all required headers for the current HTTP version.
=head2 C<get_body_chunk>
my $string = $message->get_body_chunk($offset);
Get a chunk of body data starting from a specific position.
=head2 C<get_header_chunk>
my $string = $message->get_header_chunk($offset);
Get a chunk of header data, starting from a specific position.
=head2 C<get_start_line_chunk>
my $string = $message->get_start_line_chunk($offset);
Get a chunk of start line data starting from a specific position.
=head2 C<has_leftovers>
my $success = $message->has_leftovers;
Check if message parser has leftover data.
=head2 C<header_size>
my $size = $message->header_size;
Size of headers in bytes.
=head2 C<headers>
my $headers = $message->headers;
$message = $message->headers(Mojo::Headers->new);
Message headers, defaults to a L<Mojo::Headers> object.
=head2 C<is_chunked>
my $success = $message->is_chunked;
Check if message content is chunked.
=head2 C<is_dynamic>
my $success = $message->is_dynamic;
Check if message content will be dynamic.
Note that this method is EXPERIMENTAL and might change without warning!
=head2 C<is_finished>
my $success = $message->is_finished;
Check if parser is finished.
=head2 C<is_limit_exceeded>
my $success = $message->is_limit_exceeded;
Check if message has exceeded C<max_line_size> or C<max_message_size>.
Note that this method is EXPERIMENTAL and might change without warning!
=head2 C<is_multipart>
my $success = $message->is_multipart;
Check if message content is a L<Mojo::Content::MultiPart> object.
=head2 C<json>
my $object = $message->json;
my $array = $message->json;
Decode JSON message body directly using L<Mojo::JSON> if possible, returns
C<undef> otherwise.
=head2 C<leftovers>
my $bytes = $message->leftovers;
Remove leftover data from message parser.
=head2 C<max_line_size>
$message->max_line_size(1024);
Maximum line size in bytes.
Note that this method is EXPERIMENTAL and might change without warning!
=head2 C<param>
my $param = $message->param('foo');
my @params = $message->param('foo');
Access C<GET> and C<POST> parameters.
=head2 C<parse>
$message = $message->parse('HTTP/1.1 200 OK...');
Parse message chunk.
=head2 C<parse_until_body>
$message = $message->parse_until_body('HTTP/1.1 200 OK...');
Parse message chunk until the body is reached.
=head2 C<start_line_size>
my $size = $message->start_line_size;
Size of the start line in bytes.
=head2 C<to_string>
my $string = $message->to_string;
Render whole message.
=head2 C<upload>
my $upload = $message->upload('foo');
my @uploads = $message->upload('foo');
Access C<multipart/form-data> file uploads, usually L<Mojo::Upload> objects.
=head2 C<uploads>
my $uploads = $message->uploads;
All C<multipart/form-data> file uploads, usually L<Mojo::Upload> objects.
=head2 C<version>
my $version = $message->version;
$message = $message->version('1.1');
HTTP version of message.
=head2 C<write>
$message->write('Hello!');
$message->write('Hello!', sub {...});
Write dynamic content non-blocking, the optional drain callback will be
invoked once all data has been written.
=head2 C<write_chunk>
$message->write_chunk('Hello!');
$message->write_chunk('Hello!', sub {...});
Write dynamic content non-blocking with the C<chunked> transfer encoding, the
optional drain callback will be invoked once all data has been written.
=head1 SEE ALSO
L<Mojolicious>, L<Mojolicious::Guides>, L<http://mojolicio.us>.
=cut