@@ -1,4 +1,26 @@
+5.16 2014-07-21
+ - Improved Mojo::Asset::File to allow appending data to existing files.
+ (iakuf, sri)
+
+5.15 2014-07-17
+ - Improved Mojo::DOM::HTML performance slightly.
+ - Fixed small selector bug in get command.
+
+5.14 2014-07-14
+ - Improved all_text performance in Mojo::DOM.
+ - Improved Mojo::DOM::CSS, Mojo::DOM::HTML and Mojo::JSON performance with
+ regular expression optimizations.
+ - Fixed deep recursion warnings in Mojo::DOM and Mojo::DOM::HTML. (jberger)
+
+5.13 2014-07-13
+ - Added json_like, json_message_like, json_message_unlike and json_unlike
+ methods to Test::Mojo.
+ - Improved HTML5.1 compliance of Mojo::DOM::HTML.
+ - Fixed bug where Mojo::UserAgent would keep too many connections alive.
+ - Fixed Mojo::Reactor::Poll bug where watchers were active after they have
+ been removed. (jberger)
+
5.12 2014-07-04
- Fixed a few multipart form handling bugs.
- Fixed AUTOLOAD bug in Mojo::Collection where it would behave differently
@@ -51,5 +51,5 @@
},
"x_MailingList" : "http://groups.google.com/group/mojolicious"
},
- "version" : "5.12"
+ "version" : "5.16"
}
@@ -26,4 +26,4 @@ resources:
homepage: http://mojolicio.us
license: http://www.opensource.org/licenses/artistic-license-2.0
repository: http://github.com/kraih/mojo
-version: '5.12'
+version: '5.16'
@@ -3,7 +3,7 @@ use Mojo::Base 'Mojo::Asset';
use Carp 'croak';
use Errno 'EEXIST';
-use Fcntl qw(O_CREAT O_EXCL O_RDWR);
+use Fcntl qw(O_APPEND O_CREAT O_EXCL O_RDONLY O_RDWR);
use File::Copy 'move';
use File::Spec::Functions 'catfile';
use IO::File;
@@ -17,14 +17,15 @@ has handle => sub {
my $handle = IO::File->new;
my $path = $self->path;
if (defined $path && -f $path) {
- $handle->open($path, '<') or croak qq{Can't open file "$path": $!};
+ $handle->open($path, -w _ ? O_APPEND | O_RDWR : O_RDONLY)
+ or croak qq{Can't open file "$path": $!};
return $handle;
}
# Open new or temporary file
my $base = catfile $self->tmpdir, 'mojo.tmp';
my $name = $path // $base;
- until ($handle->open($name, O_CREAT | O_EXCL | O_RDWR)) {
+ until ($handle->open($name, O_APPEND | O_CREAT | O_EXCL | O_RDWR)) {
croak qq{Can't open file "$name": $!} if defined $path || $! != $!{EEXIST};
$name = "$base." . md5_sum(time . $$ . rand 999);
}
@@ -46,13 +47,9 @@ sub DESTROY {
sub add_chunk {
my ($self, $chunk) = @_;
-
- my $handle = $self->handle;
- $handle->sysseek(0, SEEK_END);
$chunk //= '';
croak "Can't write to asset: $!"
- unless defined $handle->syswrite($chunk, length $chunk);
-
+ unless defined $self->handle->syswrite($chunk, length $chunk);
return $self;
}
@@ -10,7 +10,7 @@ sub set {
my $cache = $self->{cache} ||= {};
my $queue = $self->{queue} ||= [];
- delete $cache->{shift @$queue} if @$queue >= $self->max_keys;
+ delete $cache->{shift @$queue} while @$queue >= $self->max_keys;
push @$queue, $key unless exists $cache->{$key};
$cache->{$key} = $value;
@@ -52,7 +52,9 @@ sub grep {
return $self->new(grep { $_ =~ $cb } @$self);
}
-sub join { Mojo::ByteStream->new(join $_[1] // '', map({"$_"} @{$_[0]})) }
+sub join {
+ Mojo::ByteStream->new(join $_[1] // '', map {"$_"} @{$_[0]});
+}
sub last { shift->[-1] }
@@ -515,7 +515,7 @@ Check if content is chunked.
my $bool = $content->is_compressed;
-Check if content is C<gzip> compressed.
+Check if content is gzip compressed.
=head2 is_dynamic
@@ -27,16 +27,12 @@ my $TOKEN_RE = qr/
((?:[^[\\:\s,]|$ESCAPE_RE\s?)+)? # Element
($PSEUDO_CLASS_RE*)? # Pseudoclass
((?:$ATTR_RE)*)? # Attributes
- (?:
- \s*
- ([>+~]) # Combinator
- )?
+ (?:\s*([>+~]))? # Combinator
/x;
sub match {
my $tree = shift->tree;
- return undef if $tree->[0] ne 'tag';
- return _match(_compile(shift), $tree, $tree);
+ return $tree->[0] ne 'tag' ? undef : _match(_compile(shift), $tree, $tree);
}
sub select { shift->_select(0, @_) }
@@ -94,7 +90,7 @@ sub _compile {
my $css = shift;
my $pattern = [[]];
- while ($css =~ /$TOKEN_RE/g) {
+ while ($css =~ /$TOKEN_RE/go) {
my ($separator, $element, $pc, $attrs, $combinator)
= ($1, $2 // '', $3, $6, $11);
@@ -116,18 +112,18 @@ sub _compile {
push @$selector, ['tag', $tag];
# Class or ID
- while ($element =~ /$CLASS_ID_RE/g) {
+ while ($element =~ /$CLASS_ID_RE/go) {
push @$selector, ['attr', 'class', _regex('~', $1)] if defined $1;
push @$selector, ['attr', 'id', _regex('', $2)] if defined $2;
}
# Pseudo classes (":not" contains more selectors)
push @$selector, ['pc', "$1", $1 eq 'not' ? _compile($2) : $2]
- while $pc =~ /$PSEUDO_CLASS_RE/g;
+ while $pc =~ /$PSEUDO_CLASS_RE/go;
# Attributes
push @$selector, ['attr', _unescape($1), _regex($2 // '', $3 // $4)]
- while $attrs =~ /$ATTR_RE/g;
+ while $attrs =~ /$ATTR_RE/go;
# Combinator
push @$part, [combinator => $combinator] if $combinator;
@@ -171,37 +167,25 @@ sub _parent {
sub _pc {
my ($class, $args, $current) = @_;
- # ":first-*"
- if ($class =~ /^first-(?:(child)|of-type)$/) {
- $class = defined $1 ? 'nth-child' : 'nth-of-type';
- $args = 1;
- }
-
- # ":last-*"
- elsif ($class =~ /^last-(?:(child)|of-type)$/) {
- $class = defined $1 ? 'nth-last-child' : 'nth-last-of-type';
- $args = '-n+1';
- }
-
- # ":checked"
- if ($class eq 'checked') {
- my $attrs = $current->[2];
- return 1 if exists $attrs->{checked} || exists $attrs->{selected};
- }
-
# ":empty"
- elsif ($class eq 'empty') { return 1 unless defined $current->[4] }
+ return !defined $current->[4] if $class eq 'empty';
# ":root"
- elsif ($class eq 'root') {
- if (my $parent = $current->[3]) { return 1 if $parent->[0] eq 'root' }
- }
+ return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root';
# ":not"
- elsif ($class eq 'not') { return 1 if !_match($args, $current, $current) }
+ return !_match($args, $current, $current) if $class eq 'not';
+
+ # ":checked"
+ return exists $current->[2]{checked} || exists $current->[2]{selected}
+ if $class eq 'checked';
+
+ # ":first-*" or ":last-*" (rewrite with equation)
+ ($class, $args) = $1 ? ("nth-$class", 1) : ("nth-last-$class", '-n+1')
+ if $class =~ s/^(?:(first)|last)-//;
# ":nth-*"
- elsif ($class =~ /^nth-/) {
+ if ($class =~ /^nth-/) {
my $type = $class =~ /of-type$/ ? $current->[1] : undef;
my @siblings = @{_siblings($current, $type)};
@@ -507,16 +491,16 @@ An C<E> element, only sibling of its type.
=head2 E.warning
- my $warning = $css->select('div.warning');
-
An C<E> element whose class is "warning".
-=head2 E#myid
+ my $warning = $css->select('div.warning');
- my $foo = $css->select('div#foo');
+=head2 E#myid
An C<E> element with C<ID> equal to "myid".
+ my $foo = $css->select('div#foo');
+
=head2 E:not(s)
An C<E> element that does not match simple selector C<s>.
@@ -21,31 +21,29 @@ my $ATTR_RE = qr/
)?
\s*
/x;
-my $END_RE = qr!^\s*/\s*(.+)!;
my $TOKEN_RE = qr/
- ([^<]+)? # Text
+ ([^<]+)? # Text
(?:
- <\?(.*?)\?> # Processing Instruction
- |
- <!--(.*?)--\s*> # Comment
- |
- <!\[CDATA\[(.*?)\]\]> # CDATA
- |
- <!DOCTYPE(
- \s+\w+
- (?:(?:\s+\w+)?(?:\s+(?:"[^"]*"|'[^']*'))+)? # External ID
- (?:\s+\[.+?\])? # Int Subset
- \s*
- )>
- |
- <(
- \s*
- [^<>\s]+ # Tag
- \s*
- (?:(?:$ATTR_RE){0,32766})*+ # Attributes
+ <(?:
+ !(?:
+ DOCTYPE(
+ \s+\w+ # Doctype
+ (?:(?:\s+\w+)?(?:\s+(?:"[^"]*"|'[^']*'))+)? # External ID
+ (?:\s+\[.+?\])? # Int Subset
+ \s*)
+ |
+ --(.*?)--\s* # Comment
+ |
+ \[CDATA\[(.*?)\]\] # CDATA
+ )
+ |
+ \?(.*?)\? # Processing Instruction
+ |
+ (\s*[^<>\s]+ # Tag
+ \s*(?:(?:$ATTR_RE){0,32766})*+) # Attributes
)>
|
- (<) # Runaway "<"
+ (<) # Runaway "<"
)??
/xis;
@@ -84,9 +82,9 @@ my %EMPTY = map { $_ => 1 } (
my @PHRASING = (
qw(a abbr area audio b bdi bdo br button canvas cite code data datalist),
qw(del dfn em embed i iframe img input ins kbd keygen label link map mark),
- qw(math meta meter noscript object output progress q ruby s samp script),
- qw(select small span strong sub sup svg template textarea time u var video),
- qw(wbr)
+ qw(math meta meter noscript object output picture progress q ruby s samp),
+ qw(script select small span strong sub sup svg template textarea time u),
+ qw(var video wbr)
);
my @OBSOLETE = qw(acronym applet basefont big font strike tt);
my %PHRASING = map { $_ => 1 } @OBSOLETE, @PHRASING;
@@ -107,8 +105,8 @@ sub parse {
my $xml = $self->xml;
my $current = my $tree = ['root'];
- while ($html =~ m/\G$TOKEN_RE/gcs) {
- my ($text, $pi, $comment, $cdata, $doctype, $tag, $runaway)
+ while ($html =~ m/\G$TOKEN_RE/gcso) {
+ my ($text, $doctype, $comment, $cdata, $pi, $tag, $runaway)
= ($1, $2, $3, $4, $5, $6, $11);
# Text (and runaway "<")
@@ -119,16 +117,16 @@ sub parse {
if (defined $tag) {
# End
- if ($tag =~ $END_RE) { _end($xml ? $1 : lc($1), $xml, \$current) }
+ if ($tag =~ /^\s*\/\s*(.+)/) { _end($xml ? $1 : lc $1, $xml, \$current) }
# Start
elsif ($tag =~ m!([^\s/]+)([\s\S]*)!) {
- my ($start, $attr) = ($xml ? $1 : lc($1), $2);
+ my ($start, $attr) = ($xml ? $1 : lc $1, $2);
# Attributes
my (%attrs, $closing);
- while ($attr =~ /$ATTR_RE/g) {
- my ($key, $value) = ($xml ? $1 : lc($1), $2 // $3 // $4);
+ while ($attr =~ /$ATTR_RE/go) {
+ my ($key, $value) = ($xml ? $1 : lc $1, $2 // $3 // $4);
# Empty tag
++$closing and next if $key eq '/';
@@ -205,9 +203,8 @@ sub _end {
sub _node {
my ($current, $type, $content) = @_;
- my $new = [$type, $content, $current];
+ push @$current, my $new = [$type, $content, $current];
weaken $new->[2];
- push @$current, $new;
}
sub _render {
@@ -248,7 +245,7 @@ sub _render {
push @attrs, $key and next unless defined(my $value = $tree->[2]{$key});
# Key and value
- push @attrs, qq{$key="} . xml_escape($value) . '"';
+ push @attrs, $key . '="' . xml_escape($value) . '"';
}
$result .= join ' ', '', @attrs if @attrs;
@@ -261,6 +258,7 @@ sub _render {
}
# Render whole tree
+ no warnings 'recursion';
$result .= _render($tree->[$_], $xml)
for ($type eq 'root' ? 1 : 4) .. $#$tree;
@@ -295,9 +293,8 @@ sub _start {
}
# New tag
- my $new = ['tag', $start, $attrs, $$current];
+ push @$$current, my $new = ['tag', $start, $attrs, $$current];
weaken $new->[3];
- push @$$current, $new;
$$current = $new;
}
@@ -198,8 +198,16 @@ sub _all {
}
sub _all_text {
- my $tree = shift->tree;
- return _text([_nodes($tree)], shift, _trim($tree, @_));
+ my ($self, $recurse, $trim) = @_;
+
+ # Detect "pre" tag
+ my $tree = $self->tree;
+ if (!defined $trim || $trim) {
+ $trim = 1;
+ $_->[1] eq 'pre' and $trim = 0 for $self->_ancestors, $tree;
+ }
+
+ return _text([_nodes($tree)], $recurse, $trim);
}
sub _ancestors {
@@ -306,7 +314,7 @@ sub _siblings {
sub _start { $_[0][0] eq 'root' ? 1 : 4 }
-sub _tag { $_[0]->new->tree($_[1])->xml($_[2]) }
+sub _tag { shift->new->tree(shift)->xml(shift) }
sub _text {
my ($nodes, $recurse, $trim) = @_;
@@ -325,7 +333,8 @@ sub _text {
# Nested tag
my $content = '';
if ($type eq 'tag' && $recurse) {
- $content = _text([_nodes($n)], 1, _trim($n, $trim));
+ no warnings 'recursion';
+ $content = _text([_nodes($n)], 1, $n->[1] eq 'pre' ? 0 : $trim);
}
# Text
@@ -344,21 +353,6 @@ sub _text {
return $text;
}
-sub _trim {
- my ($n, $trim) = @_;
-
- # Disabled
- return 0 unless $n && ($trim = defined $trim ? $trim : 1);
-
- # Detect "pre" tag
- while ($n->[0] eq 'tag') {
- return 0 if $n->[1] eq 'pre';
- last unless $n = $n->[3];
- }
-
- return 1;
-}
-
sub _wrap {
my ($self, $content, $new) = @_;
@@ -409,11 +403,11 @@ Mojo::DOM - Minimalistic HTML/XML DOM parser with CSS selectors
say $dom->div->children('p')->first->{id};
# Iterate
- $dom->find('p[id]')->each(sub { say shift->{id} });
+ $dom->find('p[id]')->each(sub { say $_->{id} });
# Loop
for my $e ($dom->find('p[id]')->each) {
- say $e->text;
+ say $e->{id}, ':', $e->text;
}
# Modify
@@ -116,7 +116,7 @@ Mojo::IOLoop::Delay - Manage callbacks and control the flow of events
Mojo::IOLoop::Delay->new->steps(
sub {
my $delay = shift;
- die 'Intentional error!';
+ die 'Intentional error';
},
sub {
my ($delay, @args) = @_;
@@ -490,7 +490,7 @@ will be passed along to L<Mojo::IOLoop::Delay/"steps">.
Mojo::IOLoop->delay(
sub {
my $delay = shift;
- die 'Intentional error!';
+ die 'Intentional error';
},
sub {
my ($delay, @args) = @_;
@@ -31,8 +31,6 @@ my %ESCAPE = (
my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
for (0x00 .. 0x1f) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
-my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;
-
sub decode {
my $self = shift->error(undef);
my $value;
@@ -77,23 +75,23 @@ sub _decode {
my $value = _decode_value();
# Leftover data
- _exception('Unexpected data') unless m/\G$WHITESPACE_RE\z/gc;
+ _exception('Unexpected data') unless m/\G[\x20\x09\x0a\x0d]*\z/gc;
return $value;
}
sub _decode_array {
my @array;
- until (m/\G$WHITESPACE_RE\]/gc) {
+ until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
# Value
push @array, _decode_value();
# Separator
- redo if m/\G$WHITESPACE_RE,/gc;
+ redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
# End
- last if m/\G$WHITESPACE_RE\]/gc;
+ last if m/\G[\x20\x09\x0a\x0d]*\]/gc;
# Invalid character
_exception('Expected comma or right square bracket while parsing array');
@@ -104,27 +102,27 @@ sub _decode_array {
sub _decode_object {
my %hash;
- until (m/\G$WHITESPACE_RE\}/gc) {
+ until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
# Quote
- m/\G$WHITESPACE_RE"/gc
+ m/\G[\x20\x09\x0a\x0d]*"/gc
or _exception('Expected string while parsing object');
# Key
my $key = _decode_string();
# Colon
- m/\G$WHITESPACE_RE:/gc
+ m/\G[\x20\x09\x0a\x0d]*:/gc
or _exception('Expected colon while parsing object');
# Value
$hash{$key} = _decode_value();
# Separator
- redo if m/\G$WHITESPACE_RE,/gc;
+ redo if m/\G[\x20\x09\x0a\x0d]*,/gc;
# End
- last if m/\G$WHITESPACE_RE\}/gc;
+ last if m/\G[\x20\x09\x0a\x0d]*\}/gc;
# Invalid character
_exception('Expected comma or right curly bracket while parsing object');
@@ -191,7 +189,7 @@ sub _decode_string {
sub _decode_value {
# Leading whitespace
- m/\G$WHITESPACE_RE/gc;
+ m/\G[\x20\x09\x0a\x0d]*/gc;
# String
return _decode_string() if m/\G"/gc;
@@ -275,7 +273,7 @@ sub _encode_value {
sub _exception {
# Leading whitespace
- m/\G$WHITESPACE_RE/gc;
+ m/\G[\x20\x09\x0a\x0d]*/gc;
# Context
my $context = 'Malformed JSON: ' . shift;
@@ -51,7 +51,7 @@ sub is_level {
sub is_warn { shift->is_level('warn') }
-sub log { shift->emit('message', lc(shift), @_) }
+sub log { shift->emit('message', lc shift, @_) }
sub new {
my $self = shift->SUPER::new(@_);
@@ -12,10 +12,9 @@ has 'reverse_proxy';
my $START_LINE_RE = qr/
^
- ([a-zA-Z]+) # Method
- \s+
- ([0-9a-zA-Z!#\$\%&'()*+,\-.\/:;=?\@[\\\]^_`\{|\}~]+) # URL
- \s+HTTP\/(\d\.\d) # Version
+ ([a-zA-Z]+) # Method
+ \s+([0-9a-zA-Z!#\$\%&'()*+,\-.\/:;=?\@[\\\]^_`\{|\}~]+) # URL
+ \s+HTTP\/(\d\.\d) # Version
$
/x;
@@ -253,7 +253,7 @@ sub _cache {
sub _limit {
my ($self, $msg, $code) = @_;
$self->{limit} = 1;
- $self->error({message => $msg, advice => $code});
+ return $self->error({message => $msg, advice => $code});
}
sub _parse_formdata {
@@ -42,10 +42,14 @@ sub one_tick {
# I/O
if (keys %{$self->{io}}) {
$poll->poll($timeout);
- ++$i and $self->_sandbox('Read', $self->{io}{fileno $_}{cb}, 0)
- for $poll->handles(POLLIN | POLLPRI | POLLHUP | POLLERR);
- ++$i and $self->_sandbox('Write', $self->{io}{fileno $_}{cb}, 1)
- for $poll->handles(POLLOUT);
+ for my $handle ($poll->handles(POLLIN | POLLPRI | POLLHUP | POLLERR)) {
+ next unless my $io = $self->{io}{fileno $handle};
+ ++$i and $self->_sandbox('Read', $io->{cb}, 0);
+ }
+ for my $handle ($poll->handles(POLLOUT)) {
+ next unless my $io = $self->{io}{fileno $handle};
+ ++$i and $self->_sandbox('Write', $io->{cb}, 1);
+ }
}
# Wait for timeout if poll can't be used
@@ -203,13 +203,10 @@ sub _remove {
sub _write {
my ($self, $id) = @_;
- # Not writing
+ # Get chunk and write
return unless my $c = $self->{connections}{$id};
return unless my $tx = $c->{tx};
- return unless $tx->is_writing;
-
- # Get chunk and write
- return if $c->{writing}++;
+ return if !$tx->is_writing || $c->{writing}++;
my $chunk = $tx->server_write;
delete $c->{writing};
warn "-- Server >>> Client (@{[$tx->req->url->to_abs]})\n$chunk\n" if DEBUG;
@@ -373,6 +373,11 @@ L<Mojo::ByteStream> objects are always excluded from automatic escaping.
% use Mojo::ByteStream 'b';
<%= b('<div>excluded!</div>') %>
+Whitespace characters around tags can be trimmed by adding an additional equal
+sign to the end of a tag.
+
+ <%= All whitespace characters around this expression will be trimmed =%>
+
Newline characters can be escaped with a backslash.
This is <%= 1 + 1 %> a\
@@ -385,10 +390,6 @@ backslash.
in multiple\\
lines
-Whitespace characters around tags can be trimmed with a special tag ending.
-
- <%= All whitespace characters around this expression will be trimmed =%>
-
You can capture whole template blocks for reuse later with the C<begin> and
C<end> keywords.
@@ -25,7 +25,7 @@ sub add {
next unless my $path = $cookie->path;
next unless length(my $name = $cookie->name // '');
my $jar = $self->{jar}{$domain} ||= [];
- @$jar = (grep({_compare($_, $path, $name, $origin)} @$jar), $cookie);
+ @$jar = (grep({ _compare($_, $path, $name, $origin) } @$jar), $cookie);
}
return $self;
@@ -36,7 +36,7 @@ sub all {
return map { @{$jar->{$_}} } sort keys %$jar;
}
-sub empty { shift->{jar} = {} }
+sub empty { delete shift->{jar} }
sub extract {
my ($self, $tx) = @_;
@@ -3,9 +3,7 @@ use Mojo::Base 'Mojo::EventEmitter';
# "Fry: Since when is the Internet about robbing people of their privacy?
# Bender: August 6, 1991."
-use Carp 'croak';
use Mojo::IOLoop;
-use Mojo::URL;
use Mojo::Util 'monkey_patch';
use Mojo::UserAgent::CookieJar;
use Mojo::UserAgent::Proxy;
@@ -32,7 +30,7 @@ has transactor => sub { Mojo::UserAgent::Transactor->new };
# Common HTTP methods
for my $name (qw(DELETE GET HEAD OPTIONS PATCH POST PUT)) {
- monkey_patch __PACKAGE__, lc($name), sub {
+ monkey_patch __PACKAGE__, lc $name, sub {
my $self = shift;
my $cb = ref $_[-1] eq 'CODE' ? pop : undef;
return $self->start($self->build_tx($name, @_), $cb);
@@ -76,11 +74,11 @@ sub _cleanup {
# Clean up active connections (by closing them)
delete $self->{pid};
- $self->_handle($_, 1) for keys %{$self->{connections} || {}};
+ $self->_finish($_, 1) for keys %{$self->{connections} || {}};
# Clean up keep-alive connections
$loop->remove($_->[1]) for @{delete $self->{queue} || []};
- $loop = Mojo::IOLoop->singleton;
+ $loop = $self->_loop(1);
$loop->remove($_->[1]) for @{delete $self->{nb_queue} || []};
return $self;
@@ -111,10 +109,10 @@ sub _connect {
# Connection established
$stream->on(
timeout => sub { $self->_error($id, 'Inactivity timeout', 1) });
- $stream->on(close => sub { $self->_handle($id, 1) });
+ $stream->on(close => sub { $self && $self->_finish($id, 1) });
$stream->on(error => sub { $self && $self->_error($id, pop) });
$stream->on(read => sub { $self->_read($id, pop) });
- $cb->();
+ $self->$cb($id);
}
);
}
@@ -145,9 +143,8 @@ sub _connect_proxy {
my $handle = $loop->stream($id)->steal_handle;
my $c = delete $self->{connections}{$id};
$loop->remove($id);
- weaken $self;
$id = $self->_connect($nb, $self->transactor->endpoint($old),
- $handle, sub { $self->_start($nb, $old->connection($id), $cb) });
+ $handle, sub { shift->_start($nb, $old->connection($id), $cb) });
$self->{connections}{$id} = $c;
}
);
@@ -194,9 +191,7 @@ sub _connection {
# Connect
warn "-- Connect ($proto:$host:$port)\n" if DEBUG;
($proto, $host, $port) = $self->transactor->peer($tx);
- weaken $self;
- $id = $self->_connect(
- ($nb, $proto, $host, $port, $id) => sub { $self->_connected($id) });
+ $id = $self->_connect(($nb, $proto, $host, $port, $id) => \&_connected);
$self->{connections}{$id} = {cb => $cb, nb => $nb, tx => $tx};
return $id;
@@ -205,17 +200,17 @@ sub _connection {
sub _dequeue {
my ($self, $nb, $name, $test) = @_;
- my $found;
my $loop = $self->_loop($nb);
- my $old = $self->{$nb ? 'nb_queue' : 'queue'} || [];
- my $new = $self->{$nb ? 'nb_queue' : 'queue'} = [];
+ my $old = $self->{$nb ? 'nb_queue' : 'queue'} ||= [];
+ my ($found, @new);
for my $queued (@$old) {
- push @$new, $queued and next if $found || !grep { $_ eq $name } @$queued;
+ push @new, $queued and next if $found || !grep { $_ eq $name } @$queued;
# Search for id/name and sort out corrupted connections if necessary
next unless my $stream = $loop->stream($queued->[1]);
$test && $stream->is_readable ? $stream->close : ($found = $queued->[1]);
}
+ @$old = @new;
return $found;
}
@@ -226,8 +221,8 @@ sub _enqueue {
# Enforce connection limit
my $queue = $self->{$nb ? 'nb_queue' : 'queue'} ||= [];
my $max = $self->max_connections;
- $self->_remove(shift(@$queue)->[1]) while @$queue > $max;
- push @$queue, [$name, $id] if $max;
+ $self->_remove(shift(@$queue)->[1]) while @$queue && @$queue >= $max;
+ $max ? push @$queue, [$name, $id] : $self->_loop($nb)->stream($id)->close;
}
sub _error {
@@ -237,10 +232,10 @@ sub _error {
$tx->res->error({message => $err});
}
elsif (!$timeout) { return $self->emit(error => $err) }
- $self->_handle($id, 1);
+ $self->_finish($id, 1);
}
-sub _handle {
+sub _finish {
my ($self, $id, $close) = @_;
# Remove request timeout
@@ -248,32 +243,25 @@ sub _handle {
return unless my $loop = $self->_loop($c->{nb});
$loop->remove($c->{timeout}) if $c->{timeout};
+ return $self->_remove($id, $close) unless my $old = $c->{tx};
+ $old->client_close($close);
+
# Finish WebSocket
- my $old = $c->{tx};
- if ($old && $old->is_websocket) {
- delete $self->{connections}{$id};
- $self->_remove($id, $close);
- $old->client_close;
- }
+ return $self->_remove($id, 1) if $old->is_websocket;
+
+ if (my $jar = $self->cookie_jar) { $jar->extract($old) }
# Upgrade connection to WebSocket
- elsif ($old && (my $new = $self->_upgrade($id))) {
- if (my $jar = $self->cookie_jar) { $jar->extract($old) }
- $old->client_close;
- $c->{cb}->($self, $new);
- $new->client_read($old->res->content->leftovers);
+ if (my $new = $self->transactor->upgrade($old)) {
+ weaken $self;
+ $new->on(resume => sub { $self->_write($id) });
+ $c->{cb}->($self, $c->{tx} = $new);
+ return $new->client_read($old->res->content->leftovers);
}
- # Finish normal connection
- else {
- $self->_remove($id, $close);
- return unless $old;
- if (my $jar = $self->cookie_jar) { $jar->extract($old) }
- $old->client_close($close);
-
- # Handle redirects
- $c->{cb}->($self, $new || $old) unless $self->_redirect($c, $old);
- }
+ # Finish normal connection and handle redirects
+ $self->_remove($id, $close);
+ $c->{cb}->($self, $old) unless $self->_redirect($c, $old);
}
sub _loop { $_[1] ? Mojo::IOLoop->singleton : $_[0]->ioloop }
@@ -288,8 +276,15 @@ sub _read {
# Process incoming data
warn "-- Client <<< Server (@{[$tx->req->url->to_abs]})\n$chunk\n" if DEBUG;
$tx->client_read($chunk);
- if ($tx->is_finished) { $self->_handle($id) }
- elsif ($c->{tx}->is_writing) { $self->_write($id) }
+ if ($tx->is_finished) { $self->_finish($id) }
+ elsif ($tx->is_writing) { $self->_write($id) }
+}
+
+sub _redirect {
+ my ($self, $c, $old) = @_;
+ return undef unless my $new = $self->transactor->redirect($old);
+ return undef unless @{$old->redirects} < $self->max_redirects;
+ return $self->_start($c->{nb}, $new, delete $c->{cb});
}
sub _remove {
@@ -299,8 +294,8 @@ sub _remove {
my $c = delete $self->{connections}{$id} || {};
my $tx = $c->{tx};
if ($close || !$tx || !$tx->keep_alive || $tx->error) {
- $self->_dequeue($_, $id) for (1, 0);
- $self->_loop($_)->remove($id) for (1, 0);
+ $self->_dequeue($_, $id) for 1, 0;
+ $self->_loop($_)->remove($id) for 1, 0;
return;
}
@@ -309,13 +304,6 @@ sub _remove {
unless uc $tx->req->method eq 'CONNECT';
}
-sub _redirect {
- my ($self, $c, $old) = @_;
- return undef unless my $new = $self->transactor->redirect($old);
- return undef unless @{$old->redirects} < $self->max_redirects;
- return $self->_start($c->{nb}, $new, delete $c->{cb});
-}
-
sub _start {
my ($self, $nb, $tx, $cb) = @_;
@@ -340,30 +328,18 @@ sub _start {
return $id;
}
-sub _upgrade {
- my ($self, $id) = @_;
-
- my $c = $self->{connections}{$id};
- return undef unless my $new = $self->transactor->upgrade($c->{tx});
- weaken $self;
- $new->on(resume => sub { $self->_write($id) });
-
- return $c->{tx} = $new;
-}
-
sub _write {
my ($self, $id) = @_;
# Get and write chunk
return unless my $c = $self->{connections}{$id};
return unless my $tx = $c->{tx};
- return unless $tx->is_writing;
- return if $c->{writing}++;
+ return if !$tx->is_writing || $c->{writing}++;
my $chunk = $tx->client_write;
delete $c->{writing};
warn "-- Client >>> Server (@{[$tx->req->url->to_abs]})\n$chunk\n" if DEBUG;
my $stream = $self->_loop($c->{nb})->stream($id)->write($chunk);
- $self->_handle($id) if $tx->is_finished;
+ $self->_finish($id) if $tx->is_finished;
# Continue writing
return unless $tx->is_writing;
@@ -404,7 +380,7 @@ Mojo::UserAgent - Non-blocking I/O HTTP and WebSocket user agent
say $ua->get('www.perl.org')->res->dom->html->head->title->text;
# Scrape the latest headlines from a news site with CSS selectors
- say $ua->get('perlnews.org')->res->dom('h2 > a')->text->shuffle;
+ say $ua->get('blogs.perl.org')->res->dom('h2 > a')->text->shuffle;
# IPv6 PUT request with content
my $tx
@@ -582,7 +558,8 @@ Local address to bind to.
$ua = $ua->max_connections(5);
Maximum number of keep-alive connections that the user agent will retain
-before it starts closing the oldest ones, defaults to C<5>.
+before it starts closing the oldest ones, defaults to C<5>. Setting the value
+to C<0> will prevent any connections from being kept alive.
=head2 max_redirects
@@ -91,32 +91,30 @@ sub _say { length && say encode('UTF-8', $_) for @_ }
sub _select {
my ($buffer, $selector, $charset, @args) = @_;
+ # Keep a strong reference to the root
$buffer = decode($charset, $buffer) // $buffer if $charset;
- my $results = Mojo::DOM->new($buffer)->find($selector);
+ my $dom = Mojo::DOM->new($buffer);
+ my $results = $dom->find($selector);
while (defined(my $command = shift @args)) {
# Number
- ($results = [$results->[$command]])->[0] ? next : return
- if $command =~ /^\d+$/;
+ ($results = $results->slice($command)) and next if $command =~ /^\d+$/;
# Text
- return _say(map { $_->text } @$results) if $command eq 'text';
+ return _say($results->text->each) if $command eq 'text';
# All text
- return _say(map { $_->all_text } @$results) if $command eq 'all';
+ return _say($results->all_text->each) if $command eq 'all';
# Attribute
- if ($command eq 'attr') {
- return unless my $name = shift @args;
- return _say(map { $_->attr->{$name} } @$results);
- }
+ return _say($results->attr($args[0] // '')->each) if $command eq 'attr';
# Unknown
die qq{Unknown command "$command".\n};
}
- _say(@$results);
+ _say($results->each);
}
1;
@@ -226,18 +226,22 @@ Python's WSGI and Ruby's Rack. L<Mojolicious> applications are ridiculously
simple to deploy with L<Plack>.
$ plackup ./script/myapp
- HTTP::Server::PSGI: Accepting connections at http://0:5000/
L<Plack> provides many server and protocol adapters for you to choose from,
such as C<FCGI>, C<uWSGI> and C<mod_perl>.
$ plackup ./script/myapp -s FCGI -l /tmp/myapp.sock
+The C<MOJO_REVERSE_PROXY> environment variable can be used to enable proxy
+support, this allows L<Mojolicious> to automatically pick up the
+C<X-Forwarded-For> and C<X-Forwarded-Proto> headers.
+
+ $ MOJO_REVERSE_PROXY=1 plackup ./script/myapp
+
If an older server adapter is not be able to correctly detect the application
home directory, you can simply use the C<MOJO_HOME> environment variable.
$ MOJO_HOME=/home/sri/myapp plackup ./script/myapp
- HTTP::Server::PSGI: Accepting connections at http://0:5000/
There is no need for a C<.psgi> file, just point the server adapter at your
application script, it will automatically act like one if it detects the
@@ -845,7 +849,8 @@ L<Mojo::Message/"json">.
=head2 Basic authentication
-You can just add username and password to the URL.
+You can just add username and password to the URL, an C<Authorization> header
+will be automatically generated.
use Mojo::UserAgent;
@@ -977,8 +982,8 @@ L<Mojo::UserAgent> makes it actually easy.
$tx = $ua->start($tx);
The event L<Mojo::Content/"read"> will be emitted for every chunk of data that
-is received, even C<chunked> encoding will be handled transparently if
-necessary.
+is received, even C<chunked> encoding and gzip compression will be handled
+transparently if necessary.
=head2 Streaming request
@@ -1150,6 +1155,31 @@ choice.
Fun L<Mojolicious> application hacks for all occasions.
+=head2 Basic authentication
+
+Basic authentication data will be automatically extracted from the
+C<Authorization> header.
+
+ use Mojolicious::Lite;
+
+ get '/' => sub {
+ my $c = shift;
+
+ # Check for username "Bender" and password "rocks"
+ return $c->render(text => 'Hello Bender!')
+ if $c->req->url->to_abs->userinfo eq 'Bender:rocks';
+
+ # Require authentication
+ $c->res->headers->www_authenticate('Basic');
+ $c->render(text => 'Authentication required!', status => 401);
+ };
+
+ app->start;
+
+This can be combined with TLS for a secure authentication mechanism.
+
+ $ ./myapp.pl daemon -l https://*:3000?cert=./server.crt&key=./server.key
+
=head2 Adding a configuration file
Adding a configuration file to your application is as easy as adding a file to
@@ -57,7 +57,8 @@ with plugins, but more about that later.
L<Mojolicious> includes a minimalistic but very powerful template system out
of the box called Embedded Perl or C<ep> for short. It allows the embedding of
Perl code right into actual content using a small set of special tags and line
-start characters.
+start characters. For all templates L<strict>, L<warnings>, L<utf8> and Perl
+5.10 features are automatically enabled.
<% Perl code %>
<%= Perl expression, replaced with XML escaped result %>
@@ -110,12 +111,19 @@ An additional equal sign can be used to disable escaping of the characters
C<E<lt>>, C<E<gt>>, C<&>, C<'> and C<"> in results from Perl expressions,
which is the default to prevent XSS attacks against your application.
- <%= 'lalala' %>
- <%== '<p>test</p>' %>
+ <%= 'I ♥ Mojolicious!' %>
+ <%== '<p>I ♥ Mojolicious!</p>' %>
Only L<Mojo::ByteStream> objects are excluded from automatic escaping.
- <%= b('<p>test</p>') %>
+ <%= b('<p>I ♥ Mojolicious!</p>') %>
+
+Whitespace characters around tags can be trimmed by adding an additional equal
+sign to the end of a tag.
+
+ <% for (1 .. 3) { %>
+ <%= 'trim all whitespace characters around this expression' =%>
+ <% } %>
Newline characters can be escaped with a backslash.
@@ -129,14 +137,6 @@ backslash.
in multiple\\
lines
-You can also add an additional equal sign to the end of a tag to have it
-automatically remove all surrounding whitespace, this allows you to freely
-indent your code without ruining the result.
-
- <% for (1 .. 3) { %>
- <%= $foo =%>
- <% } %>
-
Stash values that don't have invalid characters in their name get
automatically initialized as normal variables in the template, and the
controller object as both C<$self> and C<$c>.
@@ -1054,11 +1054,11 @@ lot more efficient to use L<Mojolicious/"after_render">.
# Check if "gzip => 1" has been set in the stash
return unless $c->stash->{gzip};
- # Check if user agent accepts GZip compression
+ # Check if user agent accepts gzip compression
return unless ($c->req->headers->accept_encoding // '') =~ /gzip/i;
$c->res->headers->append(Vary => 'Accept-Encoding');
- # Compress content with GZip
+ # Compress content with gzip
$c->res->headers->content_encoding('gzip');
gzip $output, \my $compressed;
$$output = $compressed;
@@ -806,8 +806,7 @@ unescaped and decoded from bytes to characters.
Until the first request has been handled, all routes can still be moved around
or even removed with methods like L<Mojolicious::Routes::Route/"add_child">
-and L<Mojolicious::Routes::Route/"remove">. Especially for rearranging routes
-created by plugins this can be very useful.
+and L<Mojolicious::Routes::Route/"remove">.
# GET /example/show -> {controller => 'example', action => 'show'}
my $show = $r->get('/show')->to('example#show');
@@ -817,7 +816,8 @@ created by plugins this can be very useful.
$r->get('/secrets/show')->to('secrets#show')->name('show_secrets');
$r->find('show_secrets')->remove;
-To find routes by their name you can use L<Mojolicious::Routes::Route/"find">.
+Especially for rearranging routes created by plugins this can be very useful,
+to find routes by their name you can use L<Mojolicious::Routes::Route/"find">.
=head2 Conditions
@@ -63,7 +63,8 @@ sub render {
# Merge values with defaults
my $format = ($values ||= {})->{format};
- $values = {%{$self->defaults}, %$values};
+ my $defaults = $self->defaults;
+ $values = {%$defaults, %$values};
# Placeholders can only be optional without a format
my $optional = !$format;
@@ -77,15 +78,12 @@ sub render {
if ($op eq 'slash') { $fragment = '/' unless $optional }
# Text
- elsif ($op eq 'text') {
- $fragment = $value;
- $optional = 0;
- }
+ elsif ($op eq 'text') { ($fragment, $optional) = ($value, 0) }
- # Placeholder, relaxed or wildcard
- elsif ($op eq 'placeholder' || $op eq 'relaxed' || $op eq 'wildcard') {
+ # Placeholder
+ else {
$fragment = $values->{$value} // '';
- my $default = $self->defaults->{$value};
+ my $default = $defaults->{$value};
if (!defined $default || ($default ne $fragment)) { $optional = 0 }
elsif ($optional) { $fragment = '' }
}
@@ -113,17 +111,13 @@ sub _compile {
# Slash
if ($op eq 'slash') {
- $regex = ($optional ? "(?:/$block)?" : "/$block") . $regex;
- $block = '';
- $optional = 1;
+ $regex = ($optional ? "(?:/$block)?" : "/$block") . $regex;
+ ($block, $optional) = ('', 1);
next;
}
# Text
- elsif ($op eq 'text') {
- $fragment = quotemeta $value;
- $optional = 0;
- }
+ elsif ($op eq 'text') { ($fragment, $optional) = (quotemeta $value, 0) }
# Placeholder
elsif ($op eq 'placeholder' || $op eq 'relaxed' || $op eq 'wildcard') {
@@ -186,51 +180,42 @@ sub _tokenize {
my $relaxed = $self->relaxed_start;
my $wildcard = $self->wildcard_start;
- my $state = 'text';
- my (@tree, $quoted);
+ my (@tree, $inside, $quoted);
for my $char (split '', $pattern) {
- my $inside = !!grep { $_ eq $state } qw(placeholder relaxed wildcard);
# Quote start
if ($char eq $quote_start) {
push @tree, ['placeholder', ''];
- $state = 'placeholder';
- $quoted = 1;
+ ($inside, $quoted) = (1, 1);
}
# Placeholder start
elsif ($char eq $placeholder) {
- push @tree, ['placeholder', ''] if $state ne 'placeholder';
- $state = 'placeholder';
+ push @tree, ['placeholder', ''] unless $inside++;
}
# Relaxed or wildcard start (upgrade when quoted)
elsif ($char eq $relaxed || $char eq $wildcard) {
push @tree, ['placeholder', ''] unless $quoted;
- $tree[-1][0] = $state = $char eq $relaxed ? 'relaxed' : 'wildcard';
+ $tree[-1][0] = $char eq $relaxed ? 'relaxed' : 'wildcard';
+ $inside = 1;
}
# Quote end
- elsif ($char eq $quote_end) {
- $state = 'text';
- $quoted = 0;
- }
+ elsif ($char eq $quote_end) { ($inside, $quoted) = (0, 0) }
# Slash
elsif ($char eq '/') {
push @tree, ['slash'];
- $state = 'text';
+ $inside = 0;
}
# Placeholder, relaxed or wildcard
- elsif ($inside && $char =~ /\w/) { $tree[-1][-1] .= $char }
+ elsif ($inside) { $tree[-1][-1] .= $char }
# Text
- else {
- push @tree, ['text', $char] and next unless $tree[-1][0] eq 'text';
- $tree[-1][-1] .= $char;
- $state = 'text';
- }
+ elsif ($tree[-1][0] eq 'text') { $tree[-1][-1] .= $char }
+ else { push @tree, ['text', $char] }
}
return $self->pattern($pattern)->tree(\@tree);
@@ -43,7 +43,7 @@ has types => sub { Mojolicious::Types->new };
has validator => sub { Mojolicious::Validator->new };
our $CODENAME = 'Tiger Face';
-our $VERSION = '5.12';
+our $VERSION = '5.16';
sub AUTOLOAD {
my $self = shift;
@@ -115,29 +115,30 @@ sub head_ok { shift->_build_ok(HEAD => @_) }
sub header_is {
my ($self, $name, $value, $desc) = @_;
- $desc ||= "$name: " . ($value ? $value : '');
- return $self->_test('is', scalar $self->tx->res->headers->header($name),
- $value, $desc);
+ $desc ||= "$name: " . ($value // '');
+ return $self->_test('is', $self->tx->res->headers->header($name), $value,
+ $desc);
}
sub header_isnt {
my ($self, $name, $value, $desc) = @_;
- $desc ||= "not $name: " . ($value ? $value : '');
- return $self->_test('isnt', scalar $self->tx->res->headers->header($name),
- $value, $desc);
+ $desc ||= "not $name: " . ($value // '');
+ return $self->_test('isnt', $self->tx->res->headers->header($name), $value,
+ $desc);
}
sub header_like {
my ($self, $name, $regex, $desc) = @_;
- return $self->_test('like', scalar $self->tx->res->headers->header($name),
- $regex, $desc || "$name is similar");
+ $desc ||= "$name is similar";
+ return $self->_test('like', $self->tx->res->headers->header($name), $regex,
+ $desc);
}
sub header_unlike {
my ($self, $name, $regex, $desc) = @_;
- return $self->_test('unlike',
- scalar $self->tx->res->headers->header($name) // '',
- $regex, $desc || "$name is not similar");
+ $desc ||= "$name is not similar";
+ return $self->_test('unlike', $self->tx->res->headers->header($name),
+ $regex, $desc);
}
sub json_has {
@@ -161,6 +162,12 @@ sub json_is {
return $self->_test('is_deeply', $self->tx->res->json($p), $data, $desc);
}
+sub json_like {
+ my ($self, $p, $regex, $desc) = @_;
+ $desc ||= encode 'UTF-8', qq{similar match for JSON Pointer "$p"};
+ return $self->_test('like', $self->tx->res->json($p), $regex, $desc);
+}
+
sub json_message_has {
my ($self, $p, $desc) = @_;
$desc ||= encode 'UTF-8', qq{has value for JSON Pointer "$p"};
@@ -180,6 +187,24 @@ sub json_message_is {
return $self->_test('is_deeply', $self->_json(get => $p), $data, $desc);
}
+sub json_message_like {
+ my ($self, $p, $regex, $desc) = @_;
+ $desc ||= encode 'UTF-8', qq{similar match for JSON Pointer "$p"};
+ return $self->_test('like', $self->_json(get => $p), $regex, $desc);
+}
+
+sub json_message_unlike {
+ my ($self, $p, $regex, $desc) = @_;
+ $desc ||= encode 'UTF-8', qq{no similar match for JSON Pointer "$p"};
+ return $self->_test('unlike', $self->_json(get => $p), $regex, $desc);
+}
+
+sub json_unlike {
+ my ($self, $p, $regex, $desc) = @_;
+ $desc ||= encode 'UTF-8', qq{no similar match for JSON Pointer "$p"};
+ return $self->_test('unlike', $self->tx->res->json($p), $regex, $desc);
+}
+
sub message_is {
my ($self, $value, $desc) = @_;
return $self->_message('is', $value, $desc || 'exact match for message');
@@ -382,7 +407,8 @@ Test::Mojo - Testing Mojo!
->status_is(200)
->header_is('Server' => 'Mojolicious (Perl)')
->header_isnt('X-Bender' => 'Bite my shiny metal ass!')
- ->json_is('/results/4/title' => 'Perl rocks!');
+ ->json_is('/results/4/title' => 'Perl rocks!')
+ ->json_like('/results/7/title' => qr/Perl/);
# WebSocket
$t->websocket_ok('/echo')
@@ -676,6 +702,14 @@ Opposite of L</"json_has">.
Check the value extracted from JSON response using the given JSON Pointer with
L<Mojo::JSON::Pointer>, which defaults to the root value if it is omitted.
+=head2 json_like
+
+ $t = $t->json_like('/foo/1' => qr/^\d+$/);
+ $t = $t->json_like('/foo/1' => qr/^\d+$/, 'right value');
+
+Check the value extracted from JSON response using the given JSON Pointer with
+L<Mojo::JSON::Pointer> for similar match.
+
=head2 json_message_has
$t = $t->json_message_has('/foo');
@@ -701,6 +735,28 @@ Check the value extracted from JSON WebSocket message using the given JSON
Pointer with L<Mojo::JSON::Pointer>, which defaults to the root value if it is
omitted.
+=head2 json_message_like
+
+ $t = $t->json_message_like('/foo/1' => qr/^\d+$/);
+ $t = $t->json_message_like('/foo/1' => qr/^\d+$/, 'right value');
+
+Check the value extracted from JSON WebSocket message using the given JSON
+Pointer with L<Mojo::JSON::Pointer> for similar match.
+
+=head2 json_message_unlike
+
+ $t = $t->json_message_unlike('/foo/1' => qr/^\d+$/);
+ $t = $t->json_message_unlike('/foo/1' => qr/^\d+$/, 'different value');
+
+Opposite of L</"json_message_like">.
+
+=head2 json_unlike
+
+ $t = $t->json_unlike('/foo/1' => qr/^\d+$/);
+ $t = $t->json_unlike('/foo/1' => qr/^\d+$/, 'different value');
+
+Opposite of L</"json_like">.
+
=head2 message_is
$t = $t->message_is({binary => $bytes});
@@ -183,6 +183,18 @@ ok !$asset->is_file, 'stored in memory';
$asset = $asset->add_chunk('lala');
ok !$asset->is_file, 'stored in memory';
+# Append to file asset
+$file = Mojo::Asset::File->new(cleanup => 0);
+is $file->add_chunk('hello')->slurp, 'hello', 'right content';
+$path = $file->path;
+undef $file;
+ok -e $path, 'file still exists';
+$file = Mojo::Asset::File->new(path => $path, cleanup => 1);
+is $file->add_chunk(' world')->slurp, 'hello world', 'right content';
+is $file->add_chunk('!')->slurp, 'hello world!', 'right content';
+undef $file;
+ok !-e $path, 'file has been cleaned up';
+
# Temporary directory
{
my $tmpdir = tempdir CLEANUP => 1;
@@ -19,6 +19,9 @@ is $cache->get('foo'), undef, 'no result';
is $cache->get('bar'), undef, 'no result';
is $cache->get('baz'), 'yada', 'right result';
is $cache->get('yada'), 23, 'right result';
+$cache->max_keys(1)->set(one => 1)->set(two => 2);
+is $cache->get('one'), undef, 'no result';
+is $cache->get('two'), 2, 'right result';
$cache = Mojo::Cache->new(max_keys => 3);
is $cache->get('foo'), undef, 'no result';
@@ -43,7 +43,7 @@ get '/proxy' => sub {
# Reverse proxy
{
ok !Mojo::Server::CGI->new->reverse_proxy, 'no reverse proxy';
- local $ENV{MOJO_REVERSE_PROXY} = 25;
+ local $ENV{MOJO_REVERSE_PROXY} = 1;
ok !!Mojo::Server::CGI->new->reverse_proxy, 'reverse proxy';
}
@@ -41,7 +41,7 @@ use Mojolicious;
# Reverse proxy
{
ok !Mojo::Server::Daemon->new->reverse_proxy, 'no reverse proxy';
- local $ENV{MOJO_REVERSE_PROXY} = 25;
+ local $ENV{MOJO_REVERSE_PROXY} = 1;
ok !!Mojo::Server::Daemon->new->reverse_proxy, 'reverse proxy';
}
@@ -2363,8 +2363,13 @@ is $dom->tree->[5][1], ' HTML4 ', 'right comment';
is $dom->tree->[7][1], ' bad idea -- HTML4 ', 'right comment';
# Huge number of attributes
-my $huge = '<div ' . ('a=b ' x 32768) . '>Test</div>';
-$dom = Mojo::DOM->new($huge);
+$dom = Mojo::DOM->new('<div ' . ('a=b ' x 32768) . '>Test</div>');
is $dom->at('div[a=b]')->text, 'Test', 'right text';
+# Huge number of nested tags
+my $huge = ('<a>' x 100) . 'works' . ('</a>' x 100);
+$dom = Mojo::DOM->new($huge);
+is $dom->all_text, 'works', 'right text';
+is "$dom", $huge, 'right result';
+
done_testing();
@@ -37,7 +37,7 @@ get '/proxy' => sub {
# Reverse proxy
{
ok !Mojo::Server::PSGI->new->reverse_proxy, 'no reverse proxy';
- local $ENV{MOJO_REVERSE_PROXY} = 25;
+ local $ENV{MOJO_REVERSE_PROXY} = 1;
ok !!Mojo::Server::PSGI->new->reverse_proxy, 'reverse proxy';
}
@@ -150,6 +150,13 @@ ok !$recurring, 'recurring was not triggered again';
my $reactor2 = Mojo::Reactor::EV->new;
is ref $reactor2, 'Mojo::Reactor::Poll', 'right object';
+# Reset while watchers are active
+$writable = undef;
+$reactor->io($_ => sub { ++$writable and shift->reset })->watch($_, 0, 1)
+ for $client, $server;
+$reactor->start;
+is $writable, 1, 'only one handle was writable';
+
# Concurrent reactors
$timer = 0;
$reactor->recurring(0 => sub { $timer++ });
@@ -148,6 +148,13 @@ ok !$recurring, 'recurring was not triggered again';
my $reactor2 = Mojo::Reactor::Poll->new;
is ref $reactor2, 'Mojo::Reactor::Poll', 'right object';
+# Reset while watchers are active
+$writable = undef;
+$reactor->io($_ => sub { ++$writable and shift->reset })->watch($_, 0, 1)
+ for $client, $server;
+$reactor->start;
+is $writable, 1, 'only one handle was writable';
+
# Concurrent reactors
$timer = 0;
$reactor->recurring(0 => sub { $timer++ });
@@ -521,4 +521,19 @@ ok $tx->success, 'successful';
is $tx->res->code, 200, 'right status';
is $tx->res->body, 'Hi!', 'right content';
+# Connection limit
+$ua = Mojo::UserAgent->new(max_connections => 2);
+my $result;
+Mojo::IOLoop->delay(
+ sub {
+ my $delay = shift;
+ $ua->get('/' => $delay->begin) for 1 .. 5;
+ },
+ sub {
+ my $delay = shift;
+ $result = [grep {defined} map { Mojo::IOLoop->stream($_->connection) } @_];
+ }
+)->wait;
+is scalar @$result, 2, 'two active connections';
+
done_testing();
@@ -55,7 +55,9 @@ my $sock = IO::Socket::INET->new(PeerAddr => 'mojolicio.us', PeerPort => 80);
my $address = $sock->sockhost;
isnt $address, '127.0.0.1', 'different address';
$ua->local_address('127.0.0.1')->max_connections(0);
-is $ua->get('/remote_address')->res->body, '127.0.0.1', 'right address';
+my $tx = $ua->get('/remote_address');
+ok !$ua->ioloop->stream($tx->connection), 'connection is not active';
+is $tx->res->body, '127.0.0.1', 'right address';
$ua->local_address($address);
is $ua->get('/remote_address')->res->body, $address, 'right address';
@@ -64,7 +66,7 @@ $ua = Mojo::UserAgent->new;
# Connection refused
my $port = Mojo::IOLoop::Server->generate_port;
-my $tx = $ua->build_tx(GET => "http://localhost:$port");
+$tx = $ua->build_tx(GET => "http://localhost:$port");
$ua->start($tx);
ok $tx->is_finished, 'transaction is finished';
ok $tx->error, 'has error';
@@ -1,36 +1,36 @@
-use Mojo::Base -strict;
-
-BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' }
-
-use Test::More;
-use Cwd 'cwd';
-use File::Spec::Functions 'catdir';
-use File::Temp 'tempdir';
-use Mojolicious::Command;
-
-# Application
-my $command = Mojolicious::Command->new;
-isa_ok $command->app, 'Mojo', 'right application';
-isa_ok $command->app, 'Mojolicious', 'right application';
-
-# Generating files
-my $cwd = cwd;
-my $dir = tempdir CLEANUP => 1;
-chdir $dir;
-$command->create_rel_dir('foo/bar');
-ok -d catdir(qw(foo bar)), 'directory exists';
-my $template = "@@ foo_bar\njust <%= 'works' %>!\n";
-open my $data, '<', \$template;
-no strict 'refs';
-*{"Mojolicious::Command::DATA"} = $data;
-$command->render_to_rel_file('foo_bar', 'bar/baz.txt');
-open my $txt, '<', $command->rel_file('bar/baz.txt');
-is join('', <$txt>), "just works!\n", 'right result';
-$command->chmod_rel_file('bar/baz.txt', 0700);
-ok -e $command->rel_file('bar/baz.txt'), 'file is executable';
-$command->write_rel_file('123.xml', "seems\nto\nwork");
-open my $xml, '<', $command->rel_file('123.xml');
-is join('', <$xml>), "seems\nto\nwork", 'right result';
-chdir $cwd;
-
-done_testing();
+use Mojo::Base -strict;
+
+BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' }
+
+use Test::More;
+use Cwd 'cwd';
+use File::Spec::Functions 'catdir';
+use File::Temp 'tempdir';
+use Mojolicious::Command;
+
+# Application
+my $command = Mojolicious::Command->new;
+isa_ok $command->app, 'Mojo', 'right application';
+isa_ok $command->app, 'Mojolicious', 'right application';
+
+# Generating files
+my $cwd = cwd;
+my $dir = tempdir CLEANUP => 1;
+chdir $dir;
+$command->create_rel_dir('foo/bar');
+ok -d catdir(qw(foo bar)), 'directory exists';
+my $template = "@@ foo_bar\njust <%= 'works' %>!\n";
+open my $data, '<', \$template;
+no strict 'refs';
+*{"Mojolicious::Command::DATA"} = $data;
+$command->render_to_rel_file('foo_bar', 'bar/baz.txt');
+open my $txt, '<', $command->rel_file('bar/baz.txt');
+is join('', <$txt>), "just works!\n", 'right result';
+$command->chmod_rel_file('bar/baz.txt', 0700);
+ok -e $command->rel_file('bar/baz.txt'), 'file is executable';
+$command->write_rel_file('123.xml', "seems\nto\nwork");
+open my $xml, '<', $command->rel_file('123.xml');
+is join('', <$xml>), "seems\nto\nwork", 'right result';
+chdir $cwd;
+
+done_testing();
@@ -920,7 +920,10 @@ $t->get_ok('/json')->status_is(200)->header_is(Server => 'Mojolicious (Perl)')
->content_type_is('application/json')->json_is({foo => [1, -2, 3, 'b☃r']})
->json_is('/foo' => [1, -2, 3, 'b☃r'])
->json_is('/foo/3', 'b☃r', 'right value')->json_has('/foo')
- ->json_hasnt('/bar');
+ ->json_hasnt('/bar')->json_like('/foo/3' => qr/r$/)
+ ->json_unlike('/foo/3' => qr/b$/)
+ ->json_like('/foo/3' => qr/^b/, 'right value')
+ ->json_unlike('/foo/3' => qr/^r/, 'different value');
# JSON ("null")
$t->get_ok('/json' => json => undef)->status_is(200)
@@ -209,9 +209,13 @@ $t->websocket_ok('/json')->send_ok({json => {test => 23, snowman => '☃'}})
->json_message_is('/2' => 3, 'right value')
->json_message_hasnt('/5', 'not five elements')
->send_ok({json => {'☃' => [1, 2, 3]}})
- ->message_ok->json_message_is('/☃', [1, 2, 3])->send_ok({json => 'works'})
- ->message_ok->json_message_is('works')->send_ok({json => undef})
- ->message_ok->json_message_is(undef)->finish_ok;
+ ->message_ok->json_message_is('/☃', [1, 2, 3])
+ ->json_message_like('/☃/1' => qr/\d/)
+ ->json_message_unlike('/☃/1' => qr/[a-z]/)
+ ->json_message_like('/☃/2' => qr/3/, 'right value')
+ ->json_message_unlike('/☃/2' => qr/2/, 'different value')
+ ->send_ok({json => 'works'})->message_ok->json_message_is('works')
+ ->send_ok({json => undef})->message_ok->json_message_is(undef)->finish_ok;
# Plain request
$t->get_ok('/plain')->status_is(200)->content_is('Nothing to see here!');