Login Manager

- + - + + @@ -94,7 +99,7 @@ mojoDrawer('#more', '#infos'); }); -

@@ -200,11 +205,15 @@

% my $walk = begin % my ($walk, $route, $depth) = @_; - + % my $pattern = $route->pattern; + % my $unparsed = $pattern->unparsed || '/'; + % $unparsed = "+$unparsed" if $depth; + % $pattern->match('/', $route->is_endpoint && !$route->partial); + % my $regex = (regexp_pattern $pattern->regex)[0]; + - % my $pattern = $route->pattern->unparsed || '/'; - % $pattern = "+$pattern" if $depth; -

<%= '  ' x $depth %><%= $pattern %>

<%= '  ' x $depth %><%= $unparsed %>

<%= uc(join ',', @{$route->methods // []}) || '*' %>

@@ -302,7 +311,7 @@

diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Match.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Match.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Match.pm 2021-01-17 14:57:25.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Match.pm 2021-06-30 13:58:00.000000000 +0000 @@ -13,21 +13,21 @@ my ($self, $name, %values) = (shift, Mojo::Util::_options(@_)); # Current route - my $route; - if (!$name || $name eq 'current') { return {} unless $route = $self->endpoint } + my ($route, $current) = (undef, !$name || $name eq 'current'); + if ($current) { return {} unless $route = $self->endpoint } # Find endpoint else { return {path => $name} unless $route = $self->root->lookup($name) } # Merge values (clear format) - my $captures = $self->stack->[-1] // {}; - %values = (%$captures, format => undef, %values); - my $pattern = $route->pattern; - $values{format} //= defined $captures->{format} ? $captures->{format} : $pattern->defaults->{format} - if $pattern->constraints->{format}; + my $captures = $self->stack->[-1] // {}; + my %merged = (%$captures, format => undef, %values); + my $pattern = $route->pattern; + my $constraints = $pattern->constraints; + $merged{format} = ($current ? $captures->{format} : undef) // $pattern->defaults->{format} + if !exists $values{format} && $constraints->{format} && $constraints->{format} ne '1'; - my $path = $route->render(\%values); - return {path => $path, websocket => $route->has_websocket}; + return {path => $route->render(\%merged), websocket => $route->has_websocket}; } sub _match { @@ -101,19 +101,18 @@ # Routes my $r = Mojolicious::Routes->new; - $r->get('/:controller/:action'); - $r->put('/:controller/:action'); + $r->get('/user/:id'); + $r->put('/user/:id'); # Match my $c = Mojolicious::Controller->new; my $match = Mojolicious::Routes::Match->new(root => $r); - $match->find($c => {method => 'PUT', path => '/foo/bar'}); - say $match->stack->[0]{controller}; - say $match->stack->[0]{action}; + $match->find($c => {method => 'PUT', path => '/user/23'}); + say $match->stack->[0]{id}; # Render say $match->path_for->{path}; - say $match->path_for(action => 'baz')->{path}; + say $match->path_for(id => 24)->{path}; =head1 DESCRIPTION diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Pattern.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Pattern.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Pattern.pm 2021-01-17 14:57:25.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Pattern.pm 2021-06-30 13:58:00.000000000 +0000 @@ -53,8 +53,6 @@ sub render { my ($self, $values, $endpoint) = @_; - my $start = $self->type_start; - # Placeholders can only be optional without a format my $optional = !(my $format = $values->{format}); @@ -71,7 +69,7 @@ # Placeholder else { - my $name = (split /\Q$start/, $value)[0] // ''; + my $name = $value->[0]; my $default = $self->defaults->{$name}; $part = $values->{$name} // $default // ''; if (!defined $default || ($default ne $part)) { $optional = 0 } @@ -88,11 +86,9 @@ sub _compile { my ($self, $detect) = @_; - my $placeholders = $self->placeholders; - my $constraints = $self->constraints; - my $defaults = $self->defaults; - my $start = $self->type_start; - my $types = $self->types; + my $constraints = $self->constraints; + my $defaults = $self->defaults; + my $types = $self->types; my $block = my $regex = ''; my $optional = 1; @@ -112,15 +108,14 @@ # Placeholder else { - if ($value =~ /^(.+)\Q$start\E(.+)$/) { ($value, $part) = ($1, _compile_req($types->{$2} // '?!')) } - else { $part = $type ? $type eq 'relaxed' ? '([^/]+)' : '(.+)' : '([^/.]+)' } - unshift @$placeholders, $value; + if ($value->[1]) { $part = _compile_req($types->{$value->[1]} // '?!') } + else { $part = $type ? $type eq 'relaxed' ? '([^/]+)' : '(.+)' : '([^/.]+)' } # Custom regex - if (my $c = $constraints->{$value}) { $part = _compile_req($c) } + if (my $c = $constraints->{$value->[0]}) { $part = _compile_req($c) } # Optional placeholder - exists $defaults->{$value} ? ($part .= '?') : ($optional = 0); + exists $defaults->{$value->[0]} ? ($part .= '?') : ($optional = 0); } $block = $part . $block; @@ -130,23 +125,23 @@ $regex = $block . $regex if $block; # Format - $regex .= _compile_format($constraints->{format}, $defaults->{format}) if $detect; + $regex .= _compile_format($constraints->{format}, exists $defaults->{format}) if $detect; $self->regex(qr/^$regex/ps); } sub _compile_format { - my ($format, $default) = @_; - - # Default regex - return '/?(?:\.([^/]+))?$' unless defined $format; + my ($format, $has_default) = @_; # No regex return '' unless $format; + # Default regex + return '/?(?:\.([^/]+))?$' if $format eq '1'; + # Compile custom regex my $regex = '\.' . _compile_req($format); - return $default ? "/?(?:$regex)?\$" : "/?$regex\$"; + return $has_default ? "/?(?:$regex)?\$" : "/?$regex\$"; } sub _compile_req { @@ -158,11 +153,13 @@ sub _tokenize { my ($self, $pattern) = @_; - my $quote_end = $self->quote_end; - my $quote_start = $self->quote_start; - my $start = $self->placeholder_start; - my $relaxed = $self->relaxed_start; - my $wildcard = $self->wildcard_start; + my $placeholders = $self->placeholders; + my $type_start = $self->type_start; + my $quote_end = $self->quote_end; + my $quote_start = $self->quote_start; + my $start = $self->placeholder_start; + my $relaxed = $self->relaxed_start; + my $wildcard = $self->wildcard_start; my (@tree, $spec, $more); for my $char (split //, $pattern) { @@ -196,6 +193,13 @@ else { push @tree, ['text', $char] } } + # Placeholder types + for my $token (reverse @tree) { + next unless $token->[0] eq 'placeholder'; + $token->[1] = $token->[1] =~ /^(.+)\Q$type_start\E(.+)$/ ? [$1, $2] : [$token->[1]]; + unshift @$placeholders, $token->[1][0]; + } + return $self->unparsed($pattern)->tree(\@tree); } @@ -338,25 +342,24 @@ =head2 new my $pattern = Mojolicious::Routes::Pattern->new; - my $pattern = Mojolicious::Routes::Pattern->new('/:action'); - my $pattern - = Mojolicious::Routes::Pattern->new('/:action', action => qr/\w+/); - my $pattern = Mojolicious::Routes::Pattern->new(format => 0); + my $pattern = Mojolicious::Routes::Pattern->new('/users/:id'); + my $pattern = Mojolicious::Routes::Pattern->new('/user/:id', id => qr/\d+/); + my $pattern = Mojolicious::Routes::Pattern->new(format => ['json', 'yaml']); Construct a new L object and L pattern if necessary. =head2 parse - $pattern = $pattern->parse('/:action'); - $pattern = $pattern->parse('/:action', action => qr/\w+/); - $pattern = $pattern->parse(format => 0); + $pattern = $pattern->parse('/user/:id'); + $pattern = $pattern->parse('/user/:id', id=> qr/\d+/); + $pattern = $pattern->parse(format => ['json', 'yaml']); Parse pattern. =head2 render - my $path = $pattern->render({action => 'foo'}); - my $path = $pattern->render({action => 'foo'}, 1); + my $path = $pattern->render({id => 24}); + my $path = $pattern->render({id => 24}, 1); Render pattern into a path with parameters, format rendering is disabled by default. diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Route.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Route.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes/Route.pm 2021-01-17 14:57:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes/Route.pm 2021-06-30 13:58:00.000000000 +0000 @@ -1,7 +1,7 @@ package Mojolicious::Routes::Route; use Mojo::Base -base; -use Carp (); +use Carp qw(croak); use Mojo::DynamicMethods -dispatch; use Mojo::Util; use Mojolicious::Routes::Pattern; @@ -11,6 +11,12 @@ has parent => undef, weak => 1; has pattern => sub { Mojolicious::Routes::Pattern->new }; +# Reserved stash values +my %RESERVED = map { $_ => 1 } ( + qw(action app cb controller data extends format handler inline json layout namespace path status template text), + qw(variant) +); + sub BUILD_DYNAMIC { my ($class, $method, $dyn_methods) = @_; @@ -19,7 +25,7 @@ my $dynamic = $dyn_methods->{$self->root}{$method}; return $self->$dynamic(@_) if $dynamic; my $package = ref($self); - Carp::croak qq{Can't locate object method "$method" via package "$package"}; + croak qq{Can't locate object method "$method" via package "$package"}; }; } @@ -34,12 +40,6 @@ sub delete { shift->_generate_route(DELETE => @_) } -# DEPRECATED! -sub detour { - Mojo::Util::deprecated 'Mojolicious::Routes::Route::detour is DEPRECATED'; - shift->partial(1)->to(@_); -} - sub find { shift->_index->{shift()} } sub get { shift->_generate_route(GET => @_) } @@ -54,6 +54,8 @@ sub is_endpoint { $_[0]->inline ? undef : !@{$_[0]->children} } +sub is_reserved { !!$RESERVED{$_[1]} } + sub is_websocket { !!shift->{websocket} } sub methods { @@ -73,13 +75,6 @@ sub options { shift->_generate_route(OPTIONS => @_) } -# DEPRECATED! -sub over { - Mojo::Util::deprecated - 'Mojolicious::Routes::Route::over is DEPRECATED in favor of Mojolicious::Routes::Route::requires'; - shift->requires(@_); -} - sub parse { my $self = shift; $self->{name} = $self->pattern->parse(@_)->unparsed // ''; @@ -110,21 +105,15 @@ my $self = shift; # Routes with conditions can't be cached - return $self->{over} unless @_; + return $self->{requires} unless @_; my $conditions = ref $_[0] eq 'ARRAY' ? $_[0] : [@_]; return $self unless @$conditions; - $self->{over} = $conditions; + $self->{requires} = $conditions; $self->root->cache->max_keys(0); return $self; } -# DEPRECATED! -sub route { - Mojo::Util::deprecated 'Mojolicious::Routes::Route::route is DEPRECATED in favor of Mojolicious::Routes::Route::any'; - shift->_route(@_); -} - sub suggested_method { my $self = shift; @@ -168,13 +157,6 @@ sub under { shift->_generate_route(under => @_) } -# DEPRECATED! -sub via { - Mojo::Util::deprecated - 'Mojolicious::Routes::Route::via is DEPRECATED in favor of Mojolicious::Routes::Route::methods'; - shift->methods(@_); -} - sub websocket { my $route = shift->get(@_); $route->{websocket} = 1; @@ -233,10 +215,19 @@ } sub _route { - my $self = shift; - my $route = $self->add_child(__PACKAGE__->new->parse(@_))->children->[-1]; - my $format = $self->pattern->constraints->{format}; - $route->pattern->constraints->{format} //= 0 if defined $format && !$format; + my $self = shift; + + my $route = $self->add_child(__PACKAGE__->new->parse(@_))->children->[-1]; + my $new_pattern = $route->pattern; + croak qq{Route pattern "@{[$new_pattern->unparsed]}" contains a reserved stash value} + if grep { $self->is_reserved($_) } @{$new_pattern->placeholders}; + + my $old_pattern = $self->pattern; + my $constraints = $old_pattern->constraints; + $new_pattern->constraints->{format} //= $constraints->{format} if exists $constraints->{format}; + my $defaults = $old_pattern->defaults; + $new_pattern->defaults->{format} //= $defaults->{format} if exists $defaults->{format}; + return $route; } @@ -419,6 +410,12 @@ Check if this route qualifies as an endpoint. +=head2 is_reserved + + my $bool = $r->is_reserved('controller'); + +Check if string is a reserved stash value. + =head2 is_websocket my $bool = $r->is_websocket; @@ -467,9 +464,9 @@ =head2 parse - $r = $r->parse('/:action'); - $r = $r->parse('/:action', action => qr/\w+/); - $r = $r->parse(format => 0); + $r = $r->parse('/user/:id'); + $r = $r->parse('/user/:id', id => qr/\d+/); + $r = $r->parse(format => ['json', 'yaml']); Parse pattern. @@ -597,7 +594,7 @@ my $route = $r->under('/:foo' => {foo => 'bar'}); my $route = $r->under('/:foo' => [foo => qr/\w+/]); my $route = $r->under('/:foo' => (agent => qr/Firefox/)); - my $route = $r->under([format => 0]); + my $route = $r->under([format => ['json', 'yaml']]); Generate L object for a nested route with its own intermediate destination, takes the same arguments as L (except for the HTTP methods to match, which are not available). See diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Routes.pm 2021-01-17 14:57:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Routes.pm 2021-08-09 16:33:56.000000000 +0000 @@ -1,6 +1,7 @@ package Mojolicious::Routes; use Mojo::Base 'Mojolicious::Routes::Route'; +use Carp qw(croak); use List::Util qw(first); use Mojo::Cache; use Mojo::DynamicMethods; @@ -11,7 +12,6 @@ has cache => sub { Mojo::Cache->new }; has [qw(conditions shortcuts)] => sub { {} }; has types => sub { {num => qr/[0-9]+/} }; -has hidden => sub { [qw(attr has new tap)] }; has namespaces => sub { [] }; sub add_condition { $_[0]->conditions->{$_[1]} = $_[2] and return $_[0] } @@ -53,14 +53,6 @@ return 1; } -sub hide { push @{shift->hidden}, @_ } - -sub is_hidden { - my ($self, $method) = @_; - my $h = $self->{hiding} ||= {map { $_ => 1 } @{$self->hidden}}; - return !!($h->{$method} || $method =~ /^_/ || $method =~ /^[A-Z_]+$/); -} - sub lookup { ($_[0]{reverse} //= $_[0]->_index)->{$_[1]} } sub match { @@ -98,7 +90,7 @@ sub _callback { my ($self, $c, $cb, $last) = @_; $c->stash->{'mojo.routed'} = 1 if $last; - $c->helpers->log->debug('Routing to a callback'); + $c->helpers->log->trace('Routing to a callback'); return _action($c->app, $c, $cb, $last); } @@ -115,8 +107,8 @@ # Specific namespace elsif (defined(my $ns = $field->{namespace})) { - if ($class) { push @classes, $ns ? "${ns}::$class" : $class } - elsif ($ns) { push @classes, $ns } + croak qq{Namespace "$ns" requires a controller} unless $class; + push @classes, $ns ? "${ns}::$class" : $class; } # All namespaces @@ -127,16 +119,15 @@ for my $class (@classes) { # Failed - next unless defined(my $found = $self->_load($class)); - return !$log->debug(qq{Class "$class" is not a controller}) unless $found; + next unless defined(my $found = $self->_load($class)); + croak qq{Class "$class" is not a controller} unless $found; # Success return $class->new(%$c); } # Nothing found - $log->debug(qq{Controller "$classes[-1]" does not exist}) if @classes; - return @classes ? undef : 0; + return @classes ? croak qq{Controller "$classes[-1]" does not exist} : 0; } sub _controller { @@ -150,7 +141,7 @@ my $class = ref $new; my $log = $old->helpers->log; if ($new->isa('Mojolicious')) { - $log->debug(qq{Routing to application "$class"}); + $log->trace(qq{Routing to application "$class"}); # Try to connect routes if (my $sub = $new->can('routes')) { @@ -163,19 +154,18 @@ # Action elsif (my $method = $field->{action}) { - if (!$self->is_hidden($method)) { - $log->debug(qq{Routing to controller "$class" and action "$method"}); - - if (my $sub = $new->can($method)) { - $old->stash->{'mojo.routed'} = 1 if $last; - return 1 if _action($old->app, $new, $sub, $last); - } + $log->trace(qq{Routing to controller "$class" and action "$method"}); - else { $log->debug('Action not found in controller') } + if (my $sub = $new->can($method)) { + $old->stash->{'mojo.routed'} = 1 if $last; + return 1 if _action($old->app, $new, $sub, $last); } - else { $log->debug(qq{Action "$method" is not allowed}) } + + else { $log->trace('Action not found in controller') } } + else { croak qq{Controller "$class" requires an action} } + return undef; } @@ -195,7 +185,7 @@ my $c = shift; my $stash = $c->stash; return if $stash->{'mojo.rendered'}; - $c->render_maybe or $stash->{'mojo.routed'} or $c->helpers->reply->not_found; + $c->render_maybe or $stash->{'mojo.routed'} or croak 'Route without action and nothing to render'; } 1; @@ -262,13 +252,6 @@ Contains all available conditions. -=head2 hidden - - my $hidden = $r->hidden; - $r = $r->hidden(['attr', 'has', 'new']); - -Controller attributes and methods that are hidden from router, defaults to C, C, C and C. - =head2 namespaces my $namespaces = $r->namespaces; @@ -337,18 +320,6 @@ Match routes with L and dispatch with L. -=head2 hide - - $r = $r->hide('foo', 'bar'); - -Hide controller attributes and methods from router. - -=head2 is_hidden - - my $bool = $r->is_hidden('foo'); - -Check if controller attribute or method is hidden from router. - =head2 lookup my $route = $r->lookup('foo'); diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Sessions.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Sessions.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Sessions.pm 2021-01-17 14:57:16.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Sessions.pm 2021-06-30 13:58:00.000000000 +0000 @@ -8,9 +8,9 @@ has cookie_name => 'mojolicious'; has cookie_path => '/'; has default_expiration => 3600; -has deserialize => sub { \&Mojo::JSON::j }; +has deserialize => sub { \&_deserialize }; has samesite => 'Lax'; -has serialize => sub { \&Mojo::JSON::encode_json }; +has serialize => sub { \&_serialize }; sub load { my ($self, $c) = @_; @@ -61,6 +61,14 @@ $c->signed_cookie($self->cookie_name, $value, $options); } +sub _deserialize { Mojo::JSON::decode_json($_[0] =~ s/\}\KZ*$//r) } + +sub _serialize { + no warnings 'numeric'; + my $out = Mojo::JSON::encode_json($_[0]); + return $out . 'Z' x (1025 - length $out); +} + 1; =encoding utf8 @@ -80,7 +88,7 @@ =head1 DESCRIPTION L manages sessions based on signed cookies for L. All data gets serialized with -L and stored Base64 encoded on the client-side, but is protected from unwanted changes with a HMAC-SHA1 +L and stored Base64 encoded on the client-side, but is protected from unwanted changes with a HMAC-SHA256 signature. =head1 ATTRIBUTES diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Validator/Validation.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Validator/Validation.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Validator/Validation.pm 2021-01-17 14:57:17.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Validator/Validation.pm 2021-06-30 13:58:00.000000000 +0000 @@ -73,7 +73,7 @@ for my $cb (map { $self->validator->filters->{$_} } @filters) { @input = map { $self->$cb($name, $_) } @input; } - $self->output->{$name} = ref $input eq 'ARRAY' ? \@input : $input[0] if @input && !grep { !defined } @input; + $self->output->{$name} = @input > 1 ? \@input : $input[0] if @input && !grep { !defined } @input; return $self->topic($name); } diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Validator.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Validator.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious/Validator.pm 2021-01-17 14:57:17.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious/Validator.pm 2021-06-30 13:58:00.000000000 +0000 @@ -6,7 +6,7 @@ use Mojolicious::Validator::Validation; has checks => sub { {} }; -has filters => sub { {not_empty => \&_not_empty, trim => \&_trim} }; +has filters => sub { {comma_separated => \&_comma_separated, not_empty => \&_not_empty, trim => \&_trim} }; sub add_check { my ($self, $name, $cb) = @_; @@ -32,6 +32,8 @@ sub validation { Mojolicious::Validator::Validation->new(validator => shift) } +sub _comma_separated { defined $_[2] ? split(/\s*,\s*/, $_[2], -1) : undef } + sub _equal_to { my ($v, $name, $value, $to) = @_; return 1 unless defined(my $other = $v->input->{$to}); @@ -44,7 +46,7 @@ return 1; } -sub _not_empty { length $_[2] ? $_[2] : undef } +sub _not_empty { length $_[2] ? $_[2] : () } sub _num { my ($v, $name, $value, $min, $max) = @_; @@ -132,6 +134,12 @@ These filters are available by default. +=head2 comma_separated + + $v = $v->optional('foo', 'comma_separated'); + +Split string of comma separated values into separate values. + =head2 not_empty $v = $v->optional('foo', 'not_empty'); @@ -161,7 +169,7 @@ my $filters = $validator->filters; $validator = $validator->filters({trim => sub {...}}); -Registered filters, by default only L and L are already defined. +Registered filters, by default only L, L and L are already defined. =head1 METHODS diff -Nru libmojolicious-perl-8.71+dfsg/lib/Mojolicious.pm libmojolicious-perl-9.22+dfsg/lib/Mojolicious.pm --- libmojolicious-perl-8.71+dfsg/lib/Mojolicious.pm 2021-01-17 14:57:00.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Mojolicious.pm 2021-10-09 09:30:34.000000000 +0000 @@ -8,6 +8,7 @@ use Mojo::Home; use Mojo::Loader; use Mojo::Log; +use Mojo::Server; use Mojo::Util; use Mojo::UserAgent; use Mojolicious::Commands; @@ -27,19 +28,10 @@ has log => sub { my $self = shift; - my $mode = $self->mode; - my $log = Mojo::Log->new; - - # DEPRECATED! - my $home = $self->home; - if (-d $home->child('log') && -w _) { - $log->path($home->child('log', "$mode.log")); - Mojo::Util::deprecated(qq{Logging to "log/$mode.log" is DEPRECATED}); - } - # Reduced log output outside of development mode + my $log = Mojo::Log->new; return $log->level($ENV{MOJO_LOG_LEVEL}) if $ENV{MOJO_LOG_LEVEL}; - return $mode eq 'development' ? $log : $log->level('info'); + return $self->mode eq 'development' ? $log : $log->level('info'); }; has 'max_request_size'; has mode => sub { $ENV{MOJO_MODE} || $ENV{PLACK_ENV} || 'development' }; @@ -52,7 +44,7 @@ my $self = shift; # Warn developers about insecure default - $self->log->debug('Your secret passphrase needs to be changed'); + $self->log->trace('Your secret passphrase needs to be changed'); # Default to moniker return [$self->moniker]; @@ -63,8 +55,8 @@ has ua => sub { Mojo::UserAgent->new }; has validator => sub { Mojolicious::Validator->new }; -our $CODENAME = 'Supervillain'; -our $VERSION = '8.71'; +our $CODENAME = 'Waffle'; +our $VERSION = '9.22'; sub BUILD_DYNAMIC { my ($class, $method, $dyn_methods) = @_; @@ -119,7 +111,7 @@ # Start timer (ignore static files) my $stash = $c->stash; - $c->helpers->log->debug(sub { + $c->helpers->log->trace(sub { my $req = $c->req; my $method = $req->method; my $path = $req->url->path->to_abs_string; @@ -130,7 +122,7 @@ # Routes $plugins->emit_hook(before_routes => $c); $c->helpers->reply->not_found - unless $tx->res->code || $self->routes->dispatch($c) || $tx->res->code || $c->stash->{'mojo.rendered'}; + unless $tx->res->code || $self->routes->dispatch($c) || $tx->res->code || $stash->{'mojo.rendered'}; } sub handler { @@ -147,7 +139,7 @@ $self->plugins->emit_chain(around_dispatch => $c); # Delayed response - $c->helpers->log->debug('Nothing has been rendered, expecting delayed response') unless $c->stash->{'mojo.rendered'}; + $c->helpers->log->trace('Nothing has been rendered, expecting delayed response') unless $c->stash->{'mojo.rendered'}; } sub helper { shift->renderer->add_helper(@_) } @@ -155,7 +147,7 @@ sub hook { shift->plugins->on(@_) } sub new { - my $self = shift->SUPER::new(@_); + my $self = shift->SUPER::new((ref $_[0] ? %{shift()} : @_), @Mojo::Server::ARGS_OVERRIDE); my $home = $self->home; push @{$self->renderer->paths}, $home->child('templates')->to_string; @@ -165,11 +157,6 @@ my $controller = "@{[ref $self]}::Controller"; my $r = $self->preload_namespaces([$controller])->routes->namespaces([$controller, ref $self]); - # Hide controller attributes/methods - $r->hide(qw(app continue cookie every_cookie every_param every_signed_cookie finish helpers match on param render)); - $r->hide(qw(render_later render_maybe render_to_string rendered req res send session signed_cookie stash tx url_for)); - $r->hide(qw(write write_chunk)); - $self->plugin($_) for qw(HeaderCondition DefaultHelpers TagHelpers EPLRenderer EPRenderer); # Exception handling should be first in chain @@ -256,8 +243,7 @@ =head2 before_command -Emitted right before the application runs a command through the command line interface. Note that this hook is -B and might change without warning! +Emitted right before the application runs a command through the command line interface. $app->hook(before_command => sub ($command, $args) {...}); @@ -267,7 +253,7 @@ =head2 before_server_start Emitted right before the application server is started, for web servers that support it, which includes all the -built-in ones (except for L). +built-in ones. $app->hook(before_server_start => sub ($server, $app) {...}); @@ -409,7 +395,7 @@ $app = $app->log(Mojo::Log->new); The logging layer of your application, defaults to a L object. The level will default to either the -C environment variable, C if the L is C, or C otherwise. All messages +C environment variable, C if the L is C, or C otherwise. All messages will be written to C by default. # Log debug message @@ -455,10 +441,9 @@ =head2 preload_namespaces my $namespaces = $app->preload_namespaces; - $app = $app->preload_namespaces(['MyApp:Controller']); + $app = $app->preload_namespaces(['MyApp::Controller']); -Namespaces to preload classes from during application startup. Note that this attribute is B and might -change without warning! +Namespaces to preload classes from during application startup. =head2 renderer @@ -737,8 +722,7 @@ $app->warmup; -Preload classes from L for future use. Note that this method is B and might change -without warning! +Preload classes from L for future use. =head1 HELPERS @@ -782,15 +766,12 @@ Licensed under the MIT License, L. -=head2 Font Awesome - -Licensed under the CC-BY License, Version 4.0 L and SIL OFL, Version 1.1 -L. - =head1 CODE NAMES Every major release of L has a code name, these are the ones that have been used in the past. +9.0, C (U+1F9C7) + 8.0, C (U+1F9B9) 7.0, C (U+1F369) @@ -836,6 +817,8 @@ =over 2 +CandyAngel, C + Christopher Rasch-Olsen Raa, C Dan Book, C @@ -854,8 +837,6 @@ Abhijit Menon-Sen, C -CandyAngel, C - Glen Hinkle, C =back @@ -902,6 +883,8 @@ Andy Grundman +Andy Lester + Aristotle Pagaltzis Ashley Dev diff -Nru libmojolicious-perl-8.71+dfsg/lib/Test/Mojo.pm libmojolicious-perl-9.22+dfsg/lib/Test/Mojo.pm --- libmojolicious-perl-8.71+dfsg/lib/Test/Mojo.pm 2021-01-17 14:57:00.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/lib/Test/Mojo.pm 2021-08-09 19:24:05.000000000 +0000 @@ -21,7 +21,7 @@ has ua => sub { Mojo::UserAgent->new(insecure => 1)->ioloop(Mojo::IOLoop->singleton) }; # Silent or loud tests -$ENV{MOJO_LOG_LEVEL} ||= $ENV{HARNESS_IS_VERBOSE} ? 'debug' : 'fatal'; +$ENV{MOJO_LOG_LEVEL} ||= $ENV{HARNESS_IS_VERBOSE} ? 'trace' : 'fatal'; sub app { my ($self, $app) = @_; @@ -250,10 +250,10 @@ return $self unless my $app = shift; - my @args = @_ ? {config => {config_override => 1, %{shift()}}} : (); - return $self->app(Mojo::Server->new->build_app($app, @args)) unless ref $app; - $app = Mojo::Server->new->load_app($app) unless $app->isa('Mojolicious'); - return $self->app(@args ? $app->config($args[0]{config}) : $app); + my @cfg = @_ ? {config => {config_override => 1, %{shift()}}} : (); + return $self->app(Mojo::Server->new->build_app($app, @cfg)) unless ref $app; + return $self->app( + $app->isa('Mojolicious') ? @cfg ? $app->config($cfg[0]{config}) : $app : Mojo::Server->new->load_app($app, @cfg)); } sub options_ok { shift->_build_ok(OPTIONS => @_) } @@ -333,7 +333,7 @@ sub _attr { my ($self, $selector, $attr) = @_; - return '' unless my $e = $self->tx->res->dom->at($selector); + return undef unless my $e = $self->tx->res->dom->at($selector); return $e->attr($attr) // ''; } @@ -404,7 +404,7 @@ } sub _text { - return '' unless my $e = shift->tx->res->dom->at(shift); + return undef unless my $e = shift->tx->res->dom->at(shift); return $e->text; } @@ -457,7 +457,7 @@ $ prove -l -v $ prove -l -v t/foo.t -If it is not already defined, the C environment variable will be set to C or C, depending +If it is not already defined, the C environment variable will be set to C or C, depending on the value of the C environment variable. And to make it esier to test HTTPS/WSS web services L will be activated by default for L. diff -Nru libmojolicious-perl-8.71+dfsg/Makefile.PL libmojolicious-perl-9.22+dfsg/Makefile.PL --- libmojolicious-perl-8.71+dfsg/Makefile.PL 2021-01-17 14:56:52.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/Makefile.PL 2021-06-30 13:58:00.000000000 +0000 @@ -27,7 +27,7 @@ url => 'https://github.com/mojolicious/mojo.git', web => 'https://github.com/mojolicious/mojo', }, - x_IRC => {url => 'irc://chat.freenode.net/#mojo', web => 'https://webchat.freenode.net/#mojo'} + x_IRC => {url => 'irc://irc.libera.chat/#mojo', web => 'https://web.libera.chat/#mojo'} }, }, PREREQ_PM => {'IO::Socket::IP' => '0.37', 'Sub::Util' => '1.41'}, diff -Nru libmojolicious-perl-8.71+dfsg/MANIFEST libmojolicious-perl-9.22+dfsg/MANIFEST --- libmojolicious-perl-8.71+dfsg/MANIFEST 2021-01-17 17:05:16.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/MANIFEST 2021-10-21 11:52:15.000000000 +0000 @@ -6,6 +6,14 @@ examples/fast.pl examples/hello-template.pl examples/hello.pl +examples/login/lib/LoginApp.pm +examples/login/lib/LoginApp/Controller/Login.pm +examples/login/lib/LoginApp/Model/Users.pm +examples/login/script/login_app +examples/login/t/login.t +examples/login/templates/layouts/default.html.ep +examples/login/templates/login/index.html.ep +examples/login/templates/login/protected.html.ep examples/microhttpd.pl examples/proxy.pl examples/responses.pl @@ -36,7 +44,6 @@ lib/Mojo/Home.pm lib/Mojo/IOLoop.pm lib/Mojo/IOLoop/Client.pm -lib/Mojo/IOLoop/Delay.pm lib/Mojo/IOLoop/resources/server.crt lib/Mojo/IOLoop/resources/server.key lib/Mojo/IOLoop/Server.pm @@ -125,7 +132,6 @@ lib/Mojolicious/resources/public/mojo/bootstrap/bootstrap.css lib/Mojolicious/resources/public/mojo/bootstrap/bootstrap.js lib/Mojolicious/resources/public/mojo/failraptor.png -lib/Mojolicious/resources/public/mojo/fontawesome/fontawesome.css lib/Mojolicious/resources/public/mojo/highlight.js/highlight-mojo-dark.css lib/Mojolicious/resources/public/mojo/highlight.js/highlight.min.js lib/Mojolicious/resources/public/mojo/highlight.js/mojolicious.min.js @@ -138,21 +144,6 @@ lib/Mojolicious/resources/public/mojo/notfound.png lib/Mojolicious/resources/public/mojo/pinstripe-dark.png lib/Mojolicious/resources/public/mojo/pinstripe-light.png -lib/Mojolicious/resources/public/mojo/webfonts/fa-brands-400.eot -lib/Mojolicious/resources/public/mojo/webfonts/fa-brands-400.svg -lib/Mojolicious/resources/public/mojo/webfonts/fa-brands-400.ttf -lib/Mojolicious/resources/public/mojo/webfonts/fa-brands-400.woff -lib/Mojolicious/resources/public/mojo/webfonts/fa-brands-400.woff2 -lib/Mojolicious/resources/public/mojo/webfonts/fa-regular-400.eot -lib/Mojolicious/resources/public/mojo/webfonts/fa-regular-400.svg -lib/Mojolicious/resources/public/mojo/webfonts/fa-regular-400.ttf -lib/Mojolicious/resources/public/mojo/webfonts/fa-regular-400.woff -lib/Mojolicious/resources/public/mojo/webfonts/fa-regular-400.woff2 -lib/Mojolicious/resources/public/mojo/webfonts/fa-solid-900.eot -lib/Mojolicious/resources/public/mojo/webfonts/fa-solid-900.svg -lib/Mojolicious/resources/public/mojo/webfonts/fa-solid-900.ttf -lib/Mojolicious/resources/public/mojo/webfonts/fa-solid-900.woff -lib/Mojolicious/resources/public/mojo/webfonts/fa-solid-900.woff2 lib/Mojolicious/resources/templates/mojo/debug.html.ep lib/Mojolicious/resources/templates/mojo/exception.html.ep lib/Mojolicious/resources/templates/mojo/not_found.html.ep @@ -197,7 +188,6 @@ t/mojo/daemon.t t/mojo/daemon_ipv6_tls.t t/mojo/date.t -t/mojo/delay.t t/mojo/dom.t t/mojo/dynamic_methods.t t/mojo/eventemitter.t @@ -310,6 +300,7 @@ t/mojolicious/lib/MojoliciousTest/Controller/Foo/Bar.pm t/mojolicious/lib/MojoliciousTest/Exceptional.pm t/mojolicious/lib/MojoliciousTest/Foo.pm +t/mojolicious/lib/MojoliciousTest/Plugin/DeploymentPlugin.pm t/mojolicious/lib/MojoliciousTest/Plugin/Test/SomePlugin2.pm t/mojolicious/lib/MojoliciousTest/Plugin/UPPERCASETestPlugin.pm t/mojolicious/lib/MojoliciousTest/PODTest.pm @@ -318,7 +309,6 @@ t/mojolicious/lib/MojoliciousTest2/Foo.pm t/mojolicious/lib/MojoliciousTest3/Bar.pm t/mojolicious/lib/MojoliciousTest3/Baz.pm -t/mojolicious/lib/MojoliciousTestController.pm t/mojolicious/lib/PluginWithEmbeddedApp.pm t/mojolicious/lib/PluginWithTemplate.pm t/mojolicious/lib/SingleFileTestApp.pm diff -Nru libmojolicious-perl-8.71+dfsg/META.json libmojolicious-perl-9.22+dfsg/META.json --- libmojolicious-perl-8.71+dfsg/META.json 2021-01-17 17:05:16.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/META.json 2021-10-21 11:52:15.000000000 +0000 @@ -4,7 +4,7 @@ "Sebastian Riedel " ], "dynamic_config" : 0, - "generated_by" : "ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010", + "generated_by" : "ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010", "license" : [ "artistic_2" ], @@ -59,10 +59,10 @@ "web" : "https://github.com/mojolicious/mojo" }, "x_IRC" : { - "url" : "irc://chat.freenode.net/#mojo", - "web" : "https://webchat.freenode.net/#mojo" + "url" : "irc://irc.libera.chat/#mojo", + "web" : "https://web.libera.chat/#mojo" } }, - "version" : "8.71", - "x_serialization_backend" : "JSON::PP version 4.05" + "version" : "9.22", + "x_serialization_backend" : "JSON::PP version 4.06" } diff -Nru libmojolicious-perl-8.71+dfsg/META.yml libmojolicious-perl-9.22+dfsg/META.yml --- libmojolicious-perl-8.71+dfsg/META.yml 2021-01-17 17:05:16.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/META.yml 2021-10-21 11:52:15.000000000 +0000 @@ -7,7 +7,7 @@ configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 -generated_by: 'ExtUtils::MakeMaker version 7.58, CPAN::Meta::Converter version 2.150010' +generated_by: 'ExtUtils::MakeMaker version 7.62, CPAN::Meta::Converter version 2.150010' license: artistic_2 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -28,11 +28,11 @@ perl: '5.016' resources: IRC: - url: irc://chat.freenode.net/#mojo - web: https://webchat.freenode.net/#mojo + url: irc://irc.libera.chat/#mojo + web: https://web.libera.chat/#mojo bugtracker: https://github.com/mojolicious/mojo/issues homepage: https://mojolicious.org license: http://www.opensource.org/licenses/artistic-license-2.0 repository: https://github.com/mojolicious/mojo.git -version: '8.71' +version: '9.22' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' diff -Nru libmojolicious-perl-8.71+dfsg/README.md libmojolicious-perl-9.22+dfsg/README.md --- libmojolicious-perl-8.71+dfsg/README.md 2020-11-10 16:22:26.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/README.md 2021-06-30 13:58:00.000000000 +0000 @@ -1,7 +1,7 @@ -

diff -Nru libmojolicious-perl-8.71+dfsg/script/morbo libmojolicious-perl-9.22+dfsg/script/morbo --- libmojolicious-perl-8.71+dfsg/script/morbo 2020-06-14 16:18:32.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/script/morbo 2021-06-30 13:58:00.000000000 +0000 @@ -9,11 +9,11 @@ 'h|help' => \my $help, 'l|listen=s' => \my @listen, 'm|mode=s' => \$ENV{MOJO_MODE}, - 'v|verbose' => \$ENV{MORBO_VERBOSE}, + 'v|verbose' => \my $verbose, 'w|watch=s' => \my @watch; die extract_usage if $help || !(my $app = shift); -my $morbo = Mojo::Server::Morbo->new; +my $morbo = Mojo::Server::Morbo->new(silent => !$verbose); $morbo->daemon->listen(\@listen) if @listen; $morbo->backend->watch(\@watch) if @watch; $morbo->run($app); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/cgi.t libmojolicious-perl-9.22+dfsg/t/mojo/cgi.t --- libmojolicious-perl-8.71+dfsg/t/mojo/cgi.t 2021-01-17 16:37:42.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/cgi.t 2021-06-30 13:58:00.000000000 +0000 @@ -34,7 +34,7 @@ get '/proxy' => sub { my $c = shift; - my $reverse = join ':', $c->tx->remote_address, $c->req->url->to_abs->protocol; + my $reverse = join ':', grep {length} $c->tx->remote_address, $c->req->url->to_abs->protocol; $c->render(text => $reverse); }; @@ -155,18 +155,47 @@ is $res->json->{bar}, 'baz', 'right value'; }; +subtest 'Binding' => sub { + my @server; + app->hook( + before_server_start => sub { + my ($server, $app) = @_; + push @server, ref $server, $app->mode; + } + ); + + my $msg = ''; + local *STDOUT; + open STDOUT, '>', \$msg; + local %ENV = ( + PATH_INFO => '/', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + SERVER_PROTOCOL => 'HTTP/1.0' + ); + is(Mojolicious::Command::cgi->new(app => app)->run, 200, 'right status'); + my $res = Mojo::Message::Response->new->parse("HTTP/1.1 200 OK\x0d\x0a$msg"); + is $res->code, 200, 'right status'; + is $res->headers->status, '200 OK', 'right "Status" value'; + is $res->headers->content_length, 21, 'right "Content-Length" value'; + is $res->headers->content_type, 'text/html;charset=UTF-8', 'right "Content-Type" value'; + is $res->body, 'Your Mojo is working!', 'right content'; + is_deeply \@server, ['Mojo::Server::CGI', 'development'], 'hook has been emitted once'; +}; + subtest 'Reverse proxy' => sub { my $msg = ''; local *STDOUT; open STDOUT, '>', \$msg; local %ENV = ( - PATH_INFO => '/proxy', - REQUEST_METHOD => 'GET', - SCRIPT_NAME => '/', - HTTP_HOST => 'localhost:8080', - SERVER_PROTOCOL => 'HTTP/1.0', - 'HTTP_X_Forwarded_For' => '192.0.2.2, 192.0.2.1', - 'HTTP_X_Forwarded_Proto' => 'https' + PATH_INFO => '/proxy', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + SERVER_PROTOCOL => 'HTTP/1.0', + HTTP_X_FORWARDED_FOR => '192.0.2.2, 192.0.2.1', + HTTP_X_FORWARDED_PROTO => 'https' ); local $ENV{MOJO_REVERSE_PROXY} = 1; is(Mojolicious::Command::cgi->new(app => app)->run, 200, 'right status'); @@ -179,4 +208,53 @@ is $res->body, '192.0.2.1:https', 'right content'; }; +subtest 'Trusted proxies' => sub { + my $msg = ''; + local *STDOUT; + open STDOUT, '>', \$msg; + local %ENV = ( + PATH_INFO => '/proxy', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + REMOTE_ADDR => '127.0.0.1', + SERVER_PROTOCOL => 'HTTP/1.0', + HTTP_X_FORWARDED_FOR => '10.10.10.10, 192.0.2.2, 192.0.2.1', + HTTP_X_FORWARDED_PROTO => 'https' + ); + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8, 192.0.0.0/8'; + is(Mojolicious::Command::cgi->new(app => app)->run, 200, 'right status'); + + my $res = Mojo::Message::Response->new->parse("HTTP/1.1 200 OK\x0d\x0a$msg"); + is $res->code, 200, 'right status'; + is $res->headers->status, '200 OK', 'right "Status" value'; + is $res->headers->content_length, 17, 'right "Content-Length" value'; + is $res->headers->content_type, 'text/html;charset=UTF-8', 'right "Content-Type" value'; + is $res->body, '10.10.10.10:https', 'right content'; +}; + +subtest 'Trusted proxies (no REMOTE_ADDR)' => sub { + my $msg = ''; + local *STDOUT; + open STDOUT, '>', \$msg; + local %ENV = ( + PATH_INFO => '/proxy', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + SERVER_PROTOCOL => 'HTTP/1.0', + HTTP_X_FORWARDED_FOR => '10.10.10.10, 192.0.2.2, 192.0.2.1', + HTTP_X_FORWARDED_PROTO => 'https' + ); + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8, 192.0.0.0/8'; + is(Mojolicious::Command::cgi->new(app => app)->run, 200, 'right status'); + + my $res = Mojo::Message::Response->new->parse("HTTP/1.1 200 OK\x0d\x0a$msg"); + is $res->code, 200, 'right status'; + is $res->headers->status, '200 OK', 'right "Status" value'; + is $res->headers->content_length, 5, 'right "Content-Length" value'; + is $res->headers->content_type, 'text/html;charset=UTF-8', 'right "Content-Type" value'; + is $res->body, 'https', 'right content'; +}; + done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/daemon_ipv6_tls.t libmojolicious-perl-9.22+dfsg/t/mojo/daemon_ipv6_tls.t --- libmojolicious-perl-8.71+dfsg/t/mojo/daemon_ipv6_tls.t 2021-01-17 16:37:32.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/daemon_ipv6_tls.t 2021-06-30 13:58:00.000000000 +0000 @@ -59,7 +59,7 @@ is $tx->res->body, 'works!', 'right content'; ok !$tx->error, 'no error'; $tx = $ua->get("https://has.no.cert/"); - like $tx->error->{message}, qr/hostname verification failed/, 'right error'; + like $tx->error->{message}, qr/name/, 'right error'; }; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/daemon.t libmojolicious-perl-9.22+dfsg/t/mojo/daemon.t --- libmojolicious-perl-8.71+dfsg/t/mojo/daemon.t 2021-01-17 16:37:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/daemon.t 2021-06-30 13:58:00.000000000 +0000 @@ -9,6 +9,7 @@ use IO::Socket::INET; use Mojo::File qw(curfile path); use Mojo::IOLoop; +use Mojo::Promise; use Mojo::Log; use Mojo::Server::Daemon; use Mojo::UserAgent; @@ -213,11 +214,13 @@ subtest 'Concurrent requests' => sub { my $tx = $ua->post('/fun/' => {Expect => 'fun'} => 'foo bar baz' x 128); my ($tx2, $tx3); - my $delay = Mojo::IOLoop->delay(sub { (undef, $tx, $tx2, $tx3) = @_ }); - $ua->get('/concurrent1/' => $delay->begin); - $ua->post('/concurrent2/' => {Expect => 'fun'} => 'bar baz foo' x 128 => $delay->begin); - $ua->get('/concurrent3/' => $delay->begin); - $delay->wait; + Mojo::Promise->all( + $ua->get_p('/concurrent1/'), + $ua->post_p('/concurrent2/' => {Expect => 'fun'} => 'bar baz foo' x 128), + $ua->get_p('/concurrent3/') + )->then(sub { + ($tx, $tx2, $tx3) = map { $_->[0] } @_; + })->wait; ok $tx->is_finished, 'transaction is finished'; is $tx->res->body, 'Whatever!', 'right content'; ok !$tx->error, 'no error'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/delay.t libmojolicious-perl-9.22+dfsg/t/mojo/delay.t --- libmojolicious-perl-8.71+dfsg/t/mojo/delay.t 2021-01-17 16:37:40.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/delay.t 1970-01-01 00:00:00.000000000 +0000 @@ -1,215 +0,0 @@ -use Mojo::Base -strict; - -BEGIN { $ENV{MOJO_REACTOR} = 'Mojo::Reactor::Poll' } - -use Test::More; -use Mojo::IOLoop; -use Mojo::IOLoop::Delay; - -subtest 'Promise (all)' => sub { - my $delay = Mojo::IOLoop::Delay->new->then(sub {@_}); - my $delay2 = Mojo::IOLoop::Delay->new->then(sub {@_}); - my $delay3 = Mojo::IOLoop::Delay->new->then(sub {@_}); - my @results; - Mojo::Promise->all($delay, $delay2, $delay3)->then(sub { @results = @_ }); - $delay2->resolve('second'); - $delay3->resolve('third'); - $delay->resolve('first'); - Mojo::IOLoop->one_tick; - is_deeply \@results, [['first'], ['second'], ['third']], 'promises resolved'; -}; - -subtest 'Basic functionality' => sub { - my $delay = Mojo::IOLoop::Delay->new; - my @results; - for my $i (1, 1) { - my $end = $delay->begin; - Mojo::IOLoop->next_tick(sub { push @results, $i; $end->() }); - } - my $end = $delay->begin; - my $end2 = $delay->begin; - $end->(); - $end2->(); - $delay->wait; - is_deeply \@results, [1, 1], 'right results'; -}; - -subtest 'Argument splicing' => sub { - my $delay = Mojo::IOLoop::Delay->new; - Mojo::IOLoop->next_tick($delay->begin); - $delay->begin(1)->(1, 2, 3); - $delay->begin(1, 1)->(4, 5, 6); - $delay->begin(0, 1)->(7, 8); - $delay->begin(2)->(9, 10, 11); - $delay->begin(0, 0)->(12, 13); - $delay->begin(0, 2)->(14, 15, 16); - $delay->begin(2, 5)->(17, 18, 19, 20); - my @numbers; - $delay->steps(sub { (undef, @numbers) = @_ })->wait; - is_deeply \@numbers, [2, 3, 5, 7, 11, 14, 15, 19, 20], 'right values'; -}; - -subtest 'Steps' => sub { - my $result; - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps( - sub { - my $delay = shift; - my $end = $delay->begin; - $delay->begin->(3, 2, 1); - Mojo::IOLoop->next_tick(sub { $end->(1, 2, 3)->pass(5) }); - }, - sub { - my ($delay, @numbers) = @_; - my $end = $delay->begin; - Mojo::IOLoop->next_tick(sub { $end->(undef, @numbers, 4) }); - }, - sub { - my ($delay, @numbers) = @_; - $result = \@numbers; - } - )->wait; - is_deeply $result, [2, 3, 2, 1, 4, 5], 'right results'; -}; - -subtest 'One step' => sub { - my $result; - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps(sub { ++$result }); - $delay->begin->(); - is $result, undef, 'no result'; - Mojo::IOLoop->next_tick($delay->begin); - is $result, undef, 'no result'; - my $end = $delay->begin; - Mojo::IOLoop->next_tick(sub { $end->() }); - is $result, undef, 'no result'; - $delay->wait; - is $result, 1, 'right result'; -}; - -subtest 'One step (reverse)' => sub { - my $result; - my $delay = Mojo::IOLoop::Delay->new; - my $end = $delay->begin(0); - Mojo::IOLoop->next_tick(sub { $end->(23) }); - $delay->steps(sub { $result = pop }); - is $result, undef, 'no result'; - $delay->wait; - is $result, 23, 'right result'; -}; - -subtest 'End chain after first step' => sub { - my $result; - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps(sub { $result = 'success' }, sub { $result = 'fail' }); - $delay->wait; - is $result, 'success', 'right result'; -}; - -subtest 'End chain after third step' => sub { - my $result; - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps( - sub { Mojo::IOLoop->next_tick(shift->begin) }, - sub { - $result = 'fail'; - shift->pass; - }, - sub { $result = 'success' }, - sub { $result = 'fail' } - )->wait; - is $result, 'success', 'right result'; -}; - -subtest 'End chain after second step' => sub { - my @results; - my $delay = Mojo::IOLoop::Delay->new; - $delay->then(sub { push @results, [@_] }); - $delay->steps(sub { shift->pass(23) }, sub { shift; push @results, [@_] }, sub { push @results, 'fail' })->wait; - is_deeply \@results, [[23], [23]], 'right results'; -}; - -subtest 'Nested delays' => sub { - my $result; - my $delay = Mojo::IOLoop->delay( - sub { - my $first = shift; - my $second = Mojo::IOLoop->delay($first->begin); - Mojo::IOLoop->next_tick($second->begin); - Mojo::IOLoop->next_tick($first->begin); - my $end = $second->begin(0); - Mojo::IOLoop->next_tick(sub { $end->(1, 2, 3) }); - }, - sub { - my ($first, @numbers) = @_; - $result = \@numbers; - my $end = $first->begin; - $first->begin->(3, 2, 1); - my $end2 = $first->begin(0); - my $end3 = $first->begin(0); - $end2->(4); - $end3->(5, 6); - $first->pass(23)->pass(24); - $end->(1, 2, 3); - }, - sub { - my ($first, @numbers) = @_; - push @$result, @numbers; - } - )->wait; - is_deeply $result, [1, 2, 3, 2, 3, 2, 1, 4, 5, 6, 23, 24], 'right results'; -}; - -subtest 'Exception in first step' => sub { - my ($failed, $result); - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps(sub { die 'First step!' }, sub { $result = 'failed' })->catch(sub { $failed = shift })->wait; - like $failed, qr/^First step!/, 'right error'; - ok !$result, 'no result'; -}; - -subtest 'Exception in last step' => sub { - my $failed; - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps(sub { Mojo::IOLoop->next_tick(shift->begin) }, sub { die 'Last step!' })->catch(sub { $failed = pop }) - ->wait; - like $failed, qr/^Last step!/, 'right error'; -}; - -subtest 'Exception in second step' => sub { - my ($failed, $result); - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps( - sub { - my $end = shift->begin; - Mojo::IOLoop->next_tick(sub { - $result = 'pass'; - $end->(); - }); - }, - sub { die 'Second step!' }, - sub { $result = 'failed' } - ); - $delay->catch(sub { $failed = shift })->wait; - like $failed, qr/^Second step!/, 'right error'; - is $result, 'pass', 'right result'; -}; - -subtest 'Exception in second step (with active event)' => sub { - my ($failed, $result); - my $delay = Mojo::IOLoop::Delay->new; - $delay->steps( - sub { Mojo::IOLoop->next_tick(shift->begin) }, - sub { - Mojo::IOLoop->next_tick(sub { Mojo::IOLoop->stop }); - Mojo::IOLoop->next_tick(shift->begin); - die 'Second step!'; - }, - sub { $result = 'failed' } - )->catch(sub { $failed = shift }); - Mojo::IOLoop->start; - like $failed, qr/^Second step!/, 'right error'; - ok !$result, 'no result'; -}; - -done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/dom.t libmojolicious-perl-9.22+dfsg/t/mojo/dom.t --- libmojolicious-perl-8.71+dfsg/t/mojo/dom.t 2021-01-17 16:37:29.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/dom.t 2021-08-09 19:27:22.000000000 +0000 @@ -1320,6 +1320,36 @@ is $dom->find('div:has(:not(p)) > p')->last->all_text, 'Four', 'right text'; }; +subtest 'Text matching' => sub { + my $dom = Mojo::DOM->new(< + One<Two> +

TwoFour

+ Five SixSevenEight +

+EOF + is $dom->at(':text(ero)')->text, 'Zero', 'right text'; + is $dom->at(':text(Zero)')->text, 'Zero', 'right text'; + is $dom->at('p:text(Zero)')->text, 'Zero', 'right text'; + is $dom->at('div:text(Zero)'), undef, 'no result'; + is $dom->at('p:text(w)')->text, 'One', 'right text'; + is $dom->at(':text()')->text, 'One', 'right text'; + is $dom->at(':text(Sev)')->text, 'Seven', 'right text'; + is $dom->at(':text(/^Seven$/)')->text, 'Seven', 'right text'; + is $dom->at('p a:text(even)')->text, 'Seven', 'right text'; + is $dom->at(':text(v) :text(e)')->text, 'Seven', 'right text'; + is $dom->at(':text(eight)')->all_text, 'Five SixSevenEight', 'right text'; + is $dom->at(':text(/Ei.ht/)')->all_text, 'Five SixSevenEight', 'right text'; + is $dom->at(':text(/(?i:ei.ht)/)')->all_text, 'Five SixSevenEight', 'right text'; + is $dom->at(':text(v) :text(x)'), undef, 'no result'; + is $dom->at('div:text(x)'), undef, 'no result'; + is $dom->at(':text(three)'), undef, 'no result'; + is $dom->at(':text(/three/)'), undef, 'no result'; + is $dom->at(':text(/zero/)'), undef, 'no result'; + is $dom->at(':text(/zero/)'), undef, 'no result'; +}; + subtest 'Adding nodes' => sub { my $dom = Mojo::DOM->new(< @@ -2566,6 +2596,25 @@ is "$dom", '', 'right result'; }; +subtest 'Auto-close tag' => sub { + my $dom = Mojo::DOM->new('

'); + is "$dom", '

', 'right result'; +}; + +subtest 'No auto-close in scope' => sub { + my $dom = Mojo::DOM->new('

'); + is "$dom", '

', 'with SVG'; + $dom = Mojo::DOM->new('

'); + is "$dom", '

', 'with MathML'; +}; + +subtest 'Auto-close scope' => sub { + my $dom = Mojo::DOM->new('

'); + is "$dom", '

', 'closing tag'; + $dom = Mojo::DOM->new('

$');
+ is "$dom", '$

', 'close eof'; +}; + subtest '"image"' => sub { my $dom = Mojo::DOM->new('

test'); is $dom->at('img')->{src}, 'foo.png', 'right attribute'; @@ -2772,6 +2821,40 @@ is $dom->at('body > textarea')->text, 'C', 'right text'; }; +subtest 'Exclude " + + + + +

Mojo!

+ + + +EOF + like $dom->at('html')->all_text, qr/Hello.*Mojo!/s, 'title and div'; + unlike $dom->at('html')->all_text, qr/123/, 'no script'; + unlike $dom->at('html')->all_text, qr/456/, 'no style'; + like $dom->at('script')->text, qr/123/, 'script text'; + like $dom->at('style')->text, qr/456/, 'style text'; + + $dom = Mojo::DOM->new(< + + Hello + + + +EOF + like $dom->at('foo')->all_text, qr/Hello.*123.*456/s, 'everything'; + like $dom->at('script')->text, qr/123/, 'script text'; + like $dom->at('style')->text, qr/456/, 'style text'; +}; + subtest 'Reusing fragments' => sub { my $fragment = Mojo::DOM->new('C'); my $dom = Mojo::DOM->new('

'); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/exception.t libmojolicious-perl-9.22+dfsg/t/mojo/exception.t --- libmojolicious-perl-8.71+dfsg/t/mojo/exception.t 2021-01-17 16:37:40.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/exception.t 2021-06-30 13:58:00.000000000 +0000 @@ -165,112 +165,100 @@ subtest 'Check (string exception)' => sub { my $result; eval { die "test1\n" }; - ok check(default => sub { $result = $_ }), 'exception handled'; + ok check($@ => [default => sub { $result = $_ }]), 'exception handled'; is $result, "test1\n", 'exception arrived in handler'; $result = undef; eval { die "test2\n" }; - ok check(default => sub { $result = shift }), 'exception handled'; + ok check($@ => [default => sub { $result = shift }]), 'exception handled'; is $result, "test2\n", 'exception arrived in handler'; $result = undef; eval { die "test3\n" }; - check + check $@ => [ default => sub { $result = 'fail' }, qr/^test2/ => sub { $result = 'fail' }, qr/^test3/ => sub { $result = 'test10' }, - qr/^test4/ => sub { $result = 'fail' }; + qr/^test4/ => sub { $result = 'fail' } + ]; is $result, 'test10', 'regular expression matched'; $result = undef; - check "test4\n", + check "test4\n" => [ qr/^test3/ => sub { $result = 'fail' }, qr/^test4/ => sub { $result = 'test11' }, - qr/^test5/ => sub { $result = 'fail' }; + qr/^test5/ => sub { $result = 'fail' } + ]; is $result, 'test11', 'regular expression matched'; }; subtest 'Check (exception objects)' => sub { my $result; eval { MojoTest::X::Foo->throw('fail') }; - check + check $@ => [ default => sub { $result = 'fail' }, 'MojoTest::X::Foo' => sub { $result = 'test12' }, - 'MojoTest::X::Bar' => sub { $result = 'fail' }; + 'MojoTest::X::Bar' => sub { $result = 'fail' } + ]; is $result, 'test12', 'class matched'; $result = undef; eval { MojoTest::X::Bar->throw('fail') }; - check - 'MojoTest::X::Foo' => sub { $result = 'fail' }, - 'MojoTest::X::Bar' => sub { $result = 'test13' }; + check $@ => ['MojoTest::X::Foo' => sub { $result = 'fail' }, 'MojoTest::X::Bar' => sub { $result = 'test13' }]; is $result, 'test13', 'class matched'; $result = undef; check( - MojoTest::X::Yada->new('fail'), - qr/^MojoTest/ => sub { $result = 'fail' }, - 'MojoTest::X::Foo' => sub { $result = 'fail' }, - 'MojoTest::X::Bar' => sub { $result = 'test14' } + MojoTest::X::Yada->new('fail') => [ + qr/^MojoTest/ => sub { $result = 'fail' }, + 'MojoTest::X::Foo' => sub { $result = 'fail' }, + 'MojoTest::X::Bar' => sub { $result = 'test14' } + ] ); is $result, 'test14', 'class matched'; $result = undef; - check( - MojoTest::X::Yada->new('whatever'), - 'MojoTest::X::Foo' => sub { $result = 'fail' }, - qr/^whatever/ => sub { $result = 'test23' }, - ); + check(MojoTest::X::Yada->new('whatever') => + ['MojoTest::X::Foo' => sub { $result = 'fail' }, qr/^whatever/ => sub { $result = 'test23' }]); is $result, 'test23', 'regex matched'; }; subtest 'Check (multiple)' => sub { my $result = undef; - check( - MojoTest::X::Yada->new('whatever'), ['MojoTest::X::Foo', 'MojoTest::X::Bar'] => sub { $result = 'test15' }, - default => sub { $result = 'fail' } - ); + check(MojoTest::X::Yada->new('whatever') => + [['MojoTest::X::Foo', 'MojoTest::X::Bar'] => sub { $result = 'test15' }, default => sub { $result = 'fail' }]); is $result, 'test15', 'class matched'; $result = undef; check( - MojoTest::X::Bar->new('whatever'), ['MojoTest::X::Foo', 'MojoTest::X::Yada'] => sub { $result = 'fail' }, - ['MojoTest::X::Bar'] => sub { $result = 'test16' } + MojoTest::X::Bar->new('whatever') => [ + ['MojoTest::X::Foo', 'MojoTest::X::Yada'] => sub { $result = 'fail' }, + ['MojoTest::X::Bar'] => sub { $result = 'test16' } + ] ); is $result, 'test16', 'class matched'; }; subtest 'Check (rethrow)' => sub { eval { - check "test5\n", qr/test4/ => sub { die 'fail' }; + check "test5\n" => [qr/test4/ => sub { die 'fail' }]; }; is $@, "test5\n", 'exception has been rethrown'; }; -subtest 'Check (finally)' => sub { - my $finally; - eval { - check "test7\n", finally => sub { $finally = 'finally7' }; - }; - is $@, "test7\n", 'exception has been rethrown'; - is $finally, 'finally7', 'finally handler used'; - my $result = []; - check "test8\n", - qr/test7/ => sub { push @$result, 'fail' }, - default => sub { push @$result, $_ }, - finally => sub { push @$result, 'finally8' }; - is_deeply $result, ["test8\n", 'finally8'], 'default and finally handlers used'; - $finally = undef; - eval { - check "fail\n", - default => sub { die "test17\n" }, - finally => sub { $finally = 'finally17' }; - }; - is $@, "test17\n", 'right exception'; - is $finally, 'finally17', 'finally handler used'; -}; - subtest 'Check (nothing)' => sub { - ok !check(undef, default => sub { die 'fail' }), 'no exception'; + ok !check(undef() => [default => sub { die 'fail' }]), 'no exception'; { local $@; - ok !check(default => sub { die 'fail' }), 'no exception'; + ok !check($@ => [default => sub { die 'fail' }]), 'no exception'; } }; +subtest 'Check (bad spec)' => sub { + eval { + check test => { + default => sub { } + }; + }; + like $@, qr/Array reference of pattern\/handler pairs required to dispatch exceptions/, 'right error'; + + eval { check test => ['default']; }; + like $@, qr/Array reference of pattern\/handler pairs required to dispatch exceptions/, 'right error'; +}; + subtest 'Raise' => sub { eval { raise 'MyApp::X::Baz', 'test19' }; my $err = $@; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/headers.t libmojolicious-perl-9.22+dfsg/t/mojo/headers.t --- libmojolicious-perl-8.71+dfsg/t/mojo/headers.t 2021-01-17 16:37:30.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/headers.t 2021-08-30 10:06:26.000000000 +0000 @@ -96,6 +96,11 @@ is $headers->user_agent('foo')->user_agent, 'foo', 'right value'; is $headers->vary('foo')->vary, 'foo', 'right value'; is $headers->www_authenticate('foo')->www_authenticate, 'foo', 'right value'; + + is $headers->referrer('foo')->referrer, 'foo', 'right value'; + is $headers->referer, 'foo', 'right value'; + is $headers->referer('bar')->referer, 'bar', 'right value'; + is $headers->referrer, 'bar', 'right value'; }; subtest 'Clone' => sub { diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/hypnotoad.t libmojolicious-perl-9.22+dfsg/t/mojo/hypnotoad.t --- libmojolicious-perl-8.71+dfsg/t/mojo/hypnotoad.t 2021-01-17 16:37:41.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/hypnotoad.t 2021-08-09 16:36:17.000000000 +0000 @@ -13,8 +13,7 @@ use Mojo::Server::Hypnotoad; use Mojo::UserAgent; -# Configure -{ +subtest 'Configure' => sub { my $hypnotoad = Mojo::Server::Hypnotoad->new; $hypnotoad->prefork->app->config->{myserver} = { accepts => 13, @@ -30,6 +29,7 @@ proxy => 1, requests => 3, spare => 4, + trusted_proxies => ['127.0.0.0/8'], upgrade_timeout => 45, workers => 7 }; @@ -37,30 +37,31 @@ $hypnotoad->configure('test'); is_deeply $hypnotoad->prefork->listen, ['http://*:8080'], 'right value'; $hypnotoad->configure('myserver'); - is $hypnotoad->prefork->accepts, 13, 'right value'; - is $hypnotoad->prefork->backlog, 43, 'right value'; - is $hypnotoad->prefork->graceful_timeout, 23, 'right value'; - is $hypnotoad->prefork->heartbeat_interval, 7, 'right value'; - is $hypnotoad->prefork->heartbeat_timeout, 9, 'right value'; - is $hypnotoad->prefork->inactivity_timeout, 5, 'right value'; - is $hypnotoad->prefork->keep_alive_timeout, 3, 'right value'; - is_deeply $hypnotoad->prefork->listen, ['http://*:8081'], 'right value'; - is $hypnotoad->prefork->max_clients, 1, 'right value'; - is $hypnotoad->prefork->max_requests, 3, 'right value'; - is $hypnotoad->prefork->pid_file, '/foo/bar.pid', 'right value'; - ok $hypnotoad->prefork->reverse_proxy, 'reverse proxy enabled'; - is $hypnotoad->prefork->spare, 4, 'right value'; - is $hypnotoad->prefork->workers, 7, 'right value'; + is $hypnotoad->prefork->accepts, 13, 'right value'; + is $hypnotoad->prefork->backlog, 43, 'right value'; + is $hypnotoad->prefork->graceful_timeout, 23, 'right value'; + is $hypnotoad->prefork->heartbeat_interval, 7, 'right value'; + is $hypnotoad->prefork->heartbeat_timeout, 9, 'right value'; + is $hypnotoad->prefork->inactivity_timeout, 5, 'right value'; + is $hypnotoad->prefork->keep_alive_timeout, 3, 'right value'; + is_deeply $hypnotoad->prefork->listen, ['http://*:8081'], 'right value'; + is $hypnotoad->prefork->max_clients, 1, 'right value'; + is $hypnotoad->prefork->max_requests, 3, 'right value'; + is $hypnotoad->prefork->pid_file, '/foo/bar.pid', 'right value'; + ok $hypnotoad->prefork->reverse_proxy, 'reverse proxy enabled'; + is $hypnotoad->prefork->spare, 4, 'right value'; + is_deeply $hypnotoad->prefork->trusted_proxies, ['127.0.0.0/8'], 'right value'; + is $hypnotoad->prefork->workers, 7, 'right value'; is $hypnotoad->upgrade_timeout, 45, 'right value'; -} +}; -# Prepare script -my $dir = tempdir; -my $script = $dir->child('myapp.pl'); -my $log = $dir->child('mojo.log'); -my $port1 = Mojo::IOLoop::Server->generate_port; -my $port2 = Mojo::IOLoop::Server->generate_port; -$script->spurt(< sub { + my $dir = tempdir; + my $script = $dir->child('myapp.pl'); + my $log = $dir->child('mojo.log'); + my $port1 = Mojo::IOLoop::Server->generate_port; + my $port2 = Mojo::IOLoop::Server->generate_port; + $script->spurt(<log->level('debug'); +app->log->level('trace'); get '/hello' => {text => 'Hello Hypnotoad!'}; @@ -95,85 +96,79 @@ app->start; EOF -# Start -my $prefix = curfile->dirname->dirname->sibling('script'); -open my $start, '-|', $^X, "$prefix/hypnotoad", $script; -sleep 3; -sleep 1 while !_port($port2); -my $old = _pid(); - -# Application is alive -my $ua = Mojo::UserAgent->new; -my $tx = $ua->get("http://127.0.0.1:$port1/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; - -# Application is alive (second port) -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; - -# Same result -$tx = $ua->get("http://127.0.0.1:$port1/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; - -# Same result (second port) -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + my $prefix = curfile->dirname->dirname->sibling('script'); + open my $start, '-|', $^X, "$prefix/hypnotoad", $script; + sleep 3; + sleep 1 while !_port($port2); + my $old = _pid($dir->child('hypnotoad.pid')); + my $ua = Mojo::UserAgent->new; + + subtest 'Application is alive' => sub { + my $tx = $ua->get("http://127.0.0.1:$port1/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port1/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + }; -# Update script (broken) -$script->spurt(<<'EOF'); + $script->spurt(<<'EOF'); use Mojolicious::Lite; die if $ENV{HYPNOTOAD_PID}; app->start; EOF -open my $hot_deploy, '-|', $^X, "$prefix/hypnotoad", $script; + open my $hot_deploy, '-|', $^X, "$prefix/hypnotoad", $script; -# Wait for hot deployment to fail -while (1) { - last if $log->slurp =~ qr/Zero downtime software upgrade failed/; - sleep 1; -} - -# Connection did not get lost -$tx = $ua->get("http://127.0.0.1:$port1/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; - -# Connection did not get lost (second port) -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Hello Hypnotoad!', 'right content'; - -# Request that will be served after graceful shutdown has been initiated -$tx = $ua->build_tx(GET => "http://127.0.0.1:$port1/graceful"); -$ua->start($tx => sub { }); -Mojo::IOLoop->one_tick until $tx->req->is_finished; + while (1) { + last if $log->slurp =~ qr/Zero downtime software upgrade failed/; + sleep 1; + } + + subtest 'Connection did not get lost' => sub { + my $tx = $ua->get("http://127.0.0.1:$port1/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Hello Hypnotoad!', 'right content'; + }; -# Update script -$script->spurt(< sub { + my $tx = $ua->build_tx(GET => "http://127.0.0.1:$port1/graceful"); + $ua->start($tx => sub { }); + Mojo::IOLoop->one_tick until $tx->req->is_finished; + + $script->spurt(<log->path('$log'); @@ -190,81 +185,81 @@ } }; -app->log->level('debug'); +app->log->level('trace'); get '/hello' => sub { shift->render(text => "Hello World \$\$!") }; app->start; EOF -open $hot_deploy, '-|', $^X, "$prefix/hypnotoad", $script; + open $hot_deploy, '-|', $^X, "$prefix/hypnotoad", $script; + + while (1) { + sleep 1; + next unless my $new = _pid($dir->child('hypnotoad.pid')); + last if $new ne $old; + } -# Wait for hot deployment to finish -while (1) { - sleep 1; - next unless my $new = _pid(); - last if $new ne $old; -} - -# Request that will be served by an old worker that is still running -Mojo::IOLoop->one_tick until $tx->is_finished; -ok !$tx->keep_alive, 'connection will not be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'Graceful shutdown!', 'right content'; - -# One uncertain request that may or may not be served by the old worker -$tx = $ua->get("http://127.0.0.1:$port1/hello"); -is $tx->res->code, 200, 'right status'; -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -is $tx->res->code, 200, 'right status'; - -# Application has been reloaded -$tx = $ua->get("http://127.0.0.1:$port1/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok !$tx->keep_alive, 'connection will not be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -my $first = $tx->res->body; -like $first, qr/Hello World \d+!/, 'right content'; - -# Application has been reloaded (second port) -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok !$tx->keep_alive, 'connection will not be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, $first, 'same content'; - -# Same result -$tx = $ua->get("http://127.0.0.1:$port1/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok !$tx->keep_alive, 'connection will not be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -my $second = $tx->res->body; -isnt $first, $second, 'different content'; -like $second, qr/Hello World \d+!/, 'right content'; - -# Same result (second port) -$tx = $ua->get("http://127.0.0.1:$port2/hello"); -ok $tx->is_finished, 'transaction is finished'; -ok !$tx->keep_alive, 'connection will not be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, $second, 'same content'; - -# Stop -open my $stop, '-|', $^X, "$prefix/hypnotoad", $script, '-s'; -sleep 1 while _port($port2); - -# Check log -$log = $log->slurp; -like $log, qr/Worker \d+ started/, 'right message'; -like $log, qr/Starting zero downtime software upgrade $180 seconds$/, 'right message'; -like $log, qr/Upgrade successful, stopping $old/, 'right message'; + Mojo::IOLoop->one_tick until $tx->is_finished; + ok !$tx->keep_alive, 'connection will not be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'Graceful shutdown!', 'right content'; + }; + + subtest 'One uncertain request that may or may not be served by the old worker' => sub { + my $tx = $ua->get("http://127.0.0.1:$port1/hello"); + is $tx->res->code, 200, 'right status'; + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + is $tx->res->code, 200, 'right status'; + }; + + subtest 'Application has been reloaded' => sub { + my $tx = $ua->get("http://127.0.0.1:$port1/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok !$tx->keep_alive, 'connection will not be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + my $first = $tx->res->body; + like $first, qr/Hello World \d+!/, 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok !$tx->keep_alive, 'connection will not be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, $first, 'same content'; + + $tx = $ua->get("http://127.0.0.1:$port1/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok !$tx->keep_alive, 'connection will not be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + my $second = $tx->res->body; + isnt $first, $second, 'different content'; + like $second, qr/Hello World \d+!/, 'right content'; + + $tx = $ua->get("http://127.0.0.1:$port2/hello"); + ok $tx->is_finished, 'transaction is finished'; + ok !$tx->keep_alive, 'connection will not be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, $second, 'same content'; + }; + + open my $stop, '-|', $^X, "$prefix/hypnotoad", $script, '-s'; + sleep 1 while _port($port2); + + subtest 'Check log' => sub { + my $log = $log->slurp; + like $log, qr/Worker \d+ started/, 'right message'; + like $log, qr/Starting zero downtime software upgrade $180 seconds$/, 'right message'; + like $log, qr/Upgrade successful, stopping $old/, 'right message'; + }; +}; sub _pid { - return undef unless open my $file, '<', $dir->child('hypnotoad.pid'); + my $path = shift; + return undef unless open my $file, '<', $path; my $pid = <$file>; chomp $pid; return $pid; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/ioloop_ipv6.t libmojolicious-perl-9.22+dfsg/t/mojo/ioloop_ipv6.t --- libmojolicious-perl-8.71+dfsg/t/mojo/ioloop_ipv6.t 2021-01-17 16:37:36.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/ioloop_ipv6.t 2021-06-30 13:58:00.000000000 +0000 @@ -4,35 +4,35 @@ use Test::More; use Mojo::IOLoop::Server; +use Mojo::Promise; plan skip_all => 'set TEST_IPV6 to enable this test (developer only!)' unless $ENV{TEST_IPV6} || $ENV{TEST_ALL}; use Mojo::IOLoop; # IPv6 roundtrip -my $delay = Mojo::IOLoop->delay; my ($server, $client); -my $end = $delay->begin; -my $id = Mojo::IOLoop->server( +my $promise = Mojo::Promise->new; +my $id = Mojo::IOLoop->server( {address => '[::1]'} => sub { my ($loop, $stream) = @_; $stream->write('test' => sub { shift->write('321') }); - $stream->on(close => $end); + $stream->on(close => sub { $promise->resolve }); $stream->on(read => sub { $server .= pop }); } ); -my $port = Mojo::IOLoop->acceptor($id)->port; -my $end2 = $delay->begin; +my $port = Mojo::IOLoop->acceptor($id)->port; +my $promise2 = Mojo::Promise->new; Mojo::IOLoop->client( {address => '[::1]', port => $port} => sub { my ($loop, $err, $stream) = @_; $stream->write('tset' => sub { shift->write('123') }); - $stream->on(close => $end); + $stream->on(close => sub { $promise2->resolve }); $stream->on(read => sub { $client .= pop }); $stream->timeout(0.5); } ); -$delay->wait; +Mojo::Promise->all($promise, $promise2)->wait; is $server, 'tset123', 'right content'; is $client, 'test321', 'right content'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/ioloop.t libmojolicious-perl-9.22+dfsg/t/mojo/ioloop.t --- libmojolicious-perl-8.71+dfsg/t/mojo/ioloop.t 2021-01-17 16:37:29.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/ioloop.t 2021-06-30 13:58:00.000000000 +0000 @@ -6,9 +6,9 @@ use IO::Socket::IP; use Mojo::IOLoop; use Mojo::IOLoop::Client; -use Mojo::IOLoop::Delay; use Mojo::IOLoop::Server; use Mojo::IOLoop::Stream; +use Mojo::Promise; subtest 'Defaults' => sub { my $loop = Mojo::IOLoop->new; @@ -177,20 +177,19 @@ ); } ); - my $port = Mojo::IOLoop->acceptor($id)->port; - my $delay = Mojo::IOLoop->delay; - my $end = $delay->begin; + my $port = Mojo::IOLoop->acceptor($id)->port; + my $promise = Mojo::Promise->new; my $handle; Mojo::IOLoop->client( {port => $port} => sub { my ($loop, $err, $stream) = @_; $handle = $stream->steal_handle; - $end->(); + $promise->resolve; $stream->on(close => sub { $buffer .= 'should not happen' }); $stream->on(error => sub { $buffer .= 'should not happen either' }); } ); - $delay->wait; + $promise->wait; my $stream = Mojo::IOLoop::Stream->new($handle); is $stream->timeout, 15, 'right default'; is $stream->timeout(16)->timeout, 16, 'right timeout'; @@ -228,26 +227,26 @@ ok !$loop->acceptor($id), 'acceptor has been removed'; }; -subtest 'Removed connection (with delay)' => sub { +subtest 'Removed connection (with promise)' => sub { my $removed; - my $delay = Mojo::IOLoop->delay(sub { $removed++ }); - my $end = $delay->begin; - my $id = Mojo::IOLoop->server( + my $promise = Mojo::Promise->new; + $promise->then(sub { $removed++ }); + my $id = Mojo::IOLoop->server( (address => '127.0.0.1') => sub { my ($loop, $stream) = @_; - $stream->on(close => $end); + $stream->on(close => sub { $promise->resolve }); } ); - my $port = Mojo::IOLoop->acceptor($id)->port; - my $end2 = $delay->begin; + my $port = Mojo::IOLoop->acceptor($id)->port; + my $promise2 = Mojo::Promise->new; $id = Mojo::IOLoop->client( (port => $port) => sub { my ($loop, $err, $stream) = @_; - $stream->on(close => $end2); + $stream->on(close => sub { $promise2->resolve }); $loop->remove($id); } ); - $delay->wait; + Mojo::Promise->all($promise, $promise2)->wait; is $removed, 1, 'connection has been removed'; }; @@ -387,7 +386,6 @@ subtest 'Defaults' => sub { is(Mojo::IOLoop::Client->new->reactor, Mojo::IOLoop->singleton->reactor, 'right default'); - is(Mojo::IOLoop::Delay->new->ioloop, Mojo::IOLoop->singleton, 'right default'); is(Mojo::IOLoop::Server->new->reactor, Mojo::IOLoop->singleton->reactor, 'right default'); is(Mojo::IOLoop::Stream->new->reactor, Mojo::IOLoop->singleton->reactor, 'right default'); }; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/ioloop_tls.t libmojolicious-perl-9.22+dfsg/t/mojo/ioloop_tls.t --- libmojolicious-perl-8.71+dfsg/t/mojo/ioloop_tls.t 2021-01-17 16:37:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/ioloop_tls.t 2021-06-30 13:58:00.000000000 +0000 @@ -27,44 +27,43 @@ # openssl req -new -key bad.key -out bad.csr -subj "/C=US/CN=bad" # openssl req -x509 -days 7300 -key bad.key -in bad.csr -out bad.crt use Mojo::IOLoop; +use Mojo::Promise; # Built-in certificate (and upgraded string) my $loop = Mojo::IOLoop->new; -my $delay = $loop->delay; my $upgraded = "\x01\x00\x00\x00\x00\x00\xD0\x00\x0A\x00\x0B\x00\x00\x00\x84\x0B"; utf8::upgrade $upgraded; my ($server, $client); -my $end = $delay->begin; -my $id = $loop->server( +my $promise = Mojo::Promise->new->ioloop($loop); +my $id = $loop->server( {address => '127.0.0.1', tls => 1} => sub { my ($loop, $stream) = @_; $stream->write($upgraded => sub { shift->write('321') }); - $stream->on(close => $end); + $stream->on(close => sub { $promise->resolve }); $stream->on(read => sub { $server .= pop }); } ); -my $port = $loop->acceptor($id)->port; -my $end2 = $delay->begin; +my $port = $loop->acceptor($id)->port; +my $promise2 = Mojo::Promise->new->ioloop($loop); $loop->client( - {port => $port, tls => 1, tls_verify => 0x00} => sub { + {port => $port, tls => 1, tls_options => {SSL_verify_mode => 0x00}} => sub { my ($loop, $err, $stream) = @_; $stream->write('tset' => sub { shift->write('123') }); - $stream->on(close => $end2); + $stream->on(close => sub { $promise2->resolve }); $stream->on(read => sub { $client .= pop }); $stream->timeout(0.5); } ); -$delay->wait; +Mojo::Promise->all($promise, $promise2)->wait; is $server, 'tset123', 'right content'; is $client, "${upgraded}321", 'right content'; # Valid client certificate -$delay = Mojo::IOLoop->delay; ($server, $client) = (); my ($remove, $running, $timeout, $server_err, $server_close, $client_close); Mojo::IOLoop->remove(Mojo::IOLoop->recurring(0 => sub { $remove++ })); -$end = $delay->begin; -$id = Mojo::IOLoop->server( +$promise = Mojo::Promise->new; +$id = Mojo::IOLoop->server( address => '127.0.0.1', tls => 1, tls_ca => 't/mojo/certs/ca.crt', @@ -78,7 +77,7 @@ $stream->on( close => sub { $server_close++; - $end->(); + $promise->resolve; } ); $stream->on(error => sub { $server_err = pop }); @@ -86,27 +85,27 @@ $stream->timeout(0.5); } ); -$port = Mojo::IOLoop->acceptor($id)->port; -$end2 = $delay->begin; +$port = Mojo::IOLoop->acceptor($id)->port; +$promise2 = Mojo::Promise->new; Mojo::IOLoop->client( - port => $port, - tls => 1, - tls_cert => 't/mojo/certs/client.crt', - tls_key => 't/mojo/certs/client.key', - tls_verify => 0x00, + port => $port, + tls => 1, + tls_cert => 't/mojo/certs/client.crt', + tls_key => 't/mojo/certs/client.key', + tls_options => {SSL_verify_mode => 0x00}, sub { my ($loop, $err, $stream) = @_; $stream->write('tset' => sub { shift->write('123') }); $stream->on( close => sub { $client_close++; - $end2->(); + $promise2->resolve; } ); $stream->on(read => sub { $client .= pop }); } ); -$delay->wait; +Mojo::Promise->all($promise, $promise2)->wait; is $server, 'tset123', 'right content'; is $client, 'test321', 'right content'; is $timeout, 1, 'server emitted timeout event once'; @@ -170,11 +169,10 @@ ok $client_err, 'has error'; # Valid client and server certificates -$delay = Mojo::IOLoop->delay; ($running, $timeout, $server, $server_err, $server_close) = (); ($client, $client_close) = (); -$end = $delay->begin; -$id = Mojo::IOLoop->server( +$promise = Mojo::Promise->new; +$id = Mojo::IOLoop->server( address => '127.0.0.1', tls => 1, tls_ca => 't/mojo/certs/ca.crt', @@ -187,15 +185,15 @@ $stream->on( close => sub { $server_close++; - $end->(); + $promise->resolve; } ); $stream->on(error => sub { $server_err = pop }); $stream->on(read => sub { $server .= pop }); } ); -$port = Mojo::IOLoop->acceptor($id)->port; -$end2 = $delay->begin; +$port = Mojo::IOLoop->acceptor($id)->port; +$promise2 = Mojo::Promise->new; Mojo::IOLoop->client( port => $port, tls => 1, @@ -209,14 +207,14 @@ $stream->on( close => sub { $client_close++; - $end2->(); + $promise2->resolve; } ); $stream->on(read => sub { $client .= pop }); $stream->timeout(0.5); } ); -$delay->wait; +Mojo::Promise->all($promise, $promise2)->wait; is $server, 'tset123', 'right content'; is $client, 'test321', 'right content'; is $timeout, 1, 'server emitted timeout event once'; @@ -307,9 +305,8 @@ tls => 1, tls_ca => 't/mojo/certs/ca.crt', tls_cert => 't/mojo/certs/server.crt', - tls_ciphers => 'AES256-SHA:ALL', tls_key => 't/mojo/certs/server.key', - tls_verify => 0x00, + tls_options => {SSL_verify_mode => 0x00, SSL_cipher_list => 'AES256-SHA:ALL'}, sub { my ($loop, $stream) = @_; $stream->on(close => sub { $loop->stop }); @@ -318,11 +315,11 @@ ); $port = $loop->acceptor($id)->port; $loop->client( - port => $port, - tls => 1, - tls_cert => 't/mojo/certs/bad.crt', - tls_key => 't/mojo/certs/bad.key', - tls_verify => 0x00, + port => $port, + tls => 1, + tls_cert => 't/mojo/certs/bad.crt', + tls_key => 't/mojo/certs/bad.key', + tls_options => {SSL_verify_mode => 0x00}, sub { my ($loop, $err, $stream) = @_; $stream->timeout(0.5); @@ -348,13 +345,12 @@ tls_ca => 't/mojo/certs/ca.crt', tls_cert => 't/mojo/certs/server.crt', tls_key => 't/mojo/certs/server.key', - tls_verify => 0x01, - tls_version => 'TLSv1_2', + tls_options => {SSL_verify_mode => 0x01, SSL_version => 'TLSv1_2'}, sub { $server = 'accepted' } ); $port = Mojo::IOLoop->acceptor($id)->port; Mojo::IOLoop->client( - {port => $port, tls => 1, tls_verify => 0x00} => sub { + {port => $port, tls => 1, tls_options => {SSL_verify_mode => 0x00}} => sub { shift->stop; $client = 'connected'; $client_err = shift; @@ -369,9 +365,9 @@ plan skip_all => 'ALPN support required!' unless IO::Socket::SSL->can_alpn; my ($server_proto, $client_proto); $id = Mojo::IOLoop->server( - address => '127.0.0.1', - tls => 1, - tls_protocols => ['foo', 'bar', 'baz'], + address => '127.0.0.1', + tls => 1, + tls_options => {SSL_alpn_protocols => ['foo', 'bar', 'baz']}, sub { my ($loop, $stream) = @_; $server_proto = $stream->handle->alpn_selected; @@ -380,10 +376,9 @@ ); $port = Mojo::IOLoop->acceptor($id)->port; Mojo::IOLoop->client( - port => $port, - tls => 1, - tls_protocols => ['baz', 'bar'], - tls_verify => 0x00, + port => $port, + tls => 1, + tls_options => {SSL_alpn_protocols => ['baz', 'bar'], SSL_verify_mode => 0x00}, sub { my ($loop, $err, $stream) = @_; $client_proto = $stream->handle->alpn_selected; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/lib/Mojo/BaseTest/Base2.pm libmojolicious-perl-9.22+dfsg/t/mojo/lib/Mojo/BaseTest/Base2.pm --- libmojolicious-perl-8.71+dfsg/t/mojo/lib/Mojo/BaseTest/Base2.pm 2020-05-21 21:27:22.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/lib/Mojo/BaseTest/Base2.pm 2021-06-30 13:58:00.000000000 +0000 @@ -2,6 +2,6 @@ use Mojo::Base 'Mojo::BaseTest::Base1'; has [qw(bar baz)] => sub {2}; -has yada => 0; +has yada => 0; 1; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/log.t libmojolicious-perl-9.22+dfsg/t/mojo/log.t --- libmojolicious-perl-8.71+dfsg/t/mojo/log.t 2021-01-17 16:37:34.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/log.t 2021-07-06 20:47:42.000000000 +0000 @@ -22,7 +22,7 @@ like $content, qr/\[.*\] \[\d+\] \[fatal\] I ♥ Mojolicious/, 'right fatal message'; like $content, qr/\[.*\] \[\d+\] \[error\] This too/, 'right error message'; unlike $content, qr/\[.*\] \[\d+\] \[debug\] Does not work/, 'no debug message'; - unlike $content, qr/\[.*\] \[\d+\] \[debug\] And this\ntoo\n/, 'right debug message'; + unlike $content, qr/\[.*\] \[\d+\] \[debug\] And this too\n/, 'right debug message'; }; subtest 'Logging to STDERR' => sub { @@ -41,13 +41,13 @@ like $content, qr/\[.*\] \[error\] Just works\n/, 'right error message'; like $content, qr/\[.*\] \[fatal\] I ♥ Mojolicious\n/, 'right fatal message'; like $content, qr/\[.*\] \[debug\] Works too\n/, 'right debug message'; - like $content, qr/\[.*\] \[debug\] And this\ntoo\n/, 'right debug message'; + like $content, qr/\[.*\] \[debug\] And this too\n/, 'right debug message'; }; subtest 'Formatting' => sub { my $log = Mojo::Log->new; like $log->format->(time, 'debug', 'Test 123'), qr/^\[.*\] \[debug\] Test 123\n$/, 'right format'; - like $log->format->(time, 'debug', qw(Test 1 2 3)), qr/^\[.*\] \[debug\] Test\n1\n2\n3\n$/, 'right format'; + like $log->format->(time, 'debug', qw(Test 1 2 3)), qr/^\[.*\] \[debug\] Test 1 2 3\n$/, 'right format'; like $log->format->(time, 'error', 'I ♥ Mojolicious'), qr/^\[.*\] \[error\] I ♥ Mojolicious\n$/, 'right format'; like $log->format->(CORE::time, 'error', 'I ♥ Mojolicious'), qr/^\[.*\] \[error\] I ♥ Mojolicious\n$/, 'right format'; $log->format(sub { @@ -66,17 +66,37 @@ ok $log->short, 'short messages'; $log = Mojo::Log->new(short => 1); ok $log->short, 'short messages'; - like $log->format->(time, 'debug', 'Test 123'), qr/^<7>\[\d+\] \[d\] Test 123\n$/, 'right format'; - like $log->format->(time, 'info', 'Test 123'), qr/^<6>\[\d+\] \[i\] Test 123\n$/, 'right format'; + like $log->format->(time, 'trace', 'Test 123'), qr/^<7>\[\d+\] \[t\] Test 123\n$/, 'right format'; + like $log->format->(time, 'debug', 'Test 123'), qr/^<6>\[\d+\] \[d\] Test 123\n$/, 'right format'; + like $log->format->(time, 'info', 'Test 123'), qr/^<5>\[\d+\] \[i\] Test 123\n$/, 'right format'; like $log->format->(time, 'warn', 'Test 123'), qr/^<4>\[\d+\] \[w\] Test 123\n$/, 'right format'; like $log->format->(time, 'error', 'Test 123'), qr/^<3>\[\d+\] \[e\] Test 123\n$/, 'right format'; like $log->format->(time, 'fatal', 'Test 123'), qr/^<2>\[\d+\] \[f\] Test 123\n$/, 'right format'; - like $log->format->(time, 'debug', 'Test', '1', '2', '3'), qr/^<7>\[\d+\] \[d\] Test\n<7>1\n<7>2\n<7>3\n$/, + like $log->format->(time, 'debug', 'Test', '1', '2', '3'), qr/^<6>\[\d+\] \[d\] Test 1 2 3\n$/, 'right format'; +}; + +subtest 'Colorized log messages' => sub { + my $log = Mojo::Log->new; + ok !$log->color, 'plain messages'; + like $log->format->(time, 'debug', 'Test 123'), qr/^\[.*\] \[debug\] Test 123\n$/, 'right format'; + local $ENV{MOJO_LOG_COLOR} = 1; + $log = Mojo::Log->new; + ok $log->color, 'colored messages'; + $log = Mojo::Log->new(color => 1); + ok $log->color, 'colored messages'; + like $log->format->(time, 'debug', 'Test 123'), qr/^\[.+\] \[\d+\] \[debug\] Test 123\n$/, 'right format'; + like $log->format->(time, 'info', 'Test 123'), qr/^\[.+\] \[\d+\] \[info\] Test 123\n$/, 'right format'; + like $log->format->(time, 'warn', 'Test 123'), qr/^\e\[33m\[.+\] \[\d+\] \[warn\] Test 123\n\e\[0m$/, 'right format'; + like $log->format->(time, 'error', 'Test 123'), qr/^\e\[31m\[.+\] \[\d+\] \[error\] Test 123\n\e\[0m$/, + 'right format'; + like $log->format->(time, 'fatal', 'Test 123'), qr/^\e\[37;41m\[.+\] \[\d+\] \[fatal\] Test 123\n\e\[0m$/, 'right format'; + like $log->format->(1613484767, 'error', 'Test', '1', '2', '3'), + qr/^\e\[31m\[.+\] \[\d+\] \[error\] Test 1 2 3\n\e\[0m$/, 'right format'; }; subtest 'Events' => sub { - my $log = Mojo::Log->new; + my $log = Mojo::Log->new(level => 'trace'); my $msgs = []; $log->unsubscribe('message')->on( message => sub { @@ -84,6 +104,9 @@ push @$msgs, $level, @lines; } ); + $log->trace('Test', 1, 2, 3); + is_deeply $msgs, [qw(trace Test 1 2 3)], 'right message'; + $msgs = []; $log->debug('Test', 1, 2, 3); is_deeply $msgs, [qw(debug Test 1 2 3)], 'right message'; $msgs = []; @@ -115,7 +138,7 @@ } my $content = decode 'UTF-8', $buffer; like $content, qr/\[\d{4}-\d{2}-\d{2} \d{2}:\d{2}:\d{2}\.\d{5}\] \[$$\] \[error\] First\n/, 'right error message'; - like $content, qr/\[.*\] \[info\] Fourth\nFifth\n/, 'right info message'; + like $content, qr/\[.*\] \[info\] Fourth Fifth\n/, 'right info message'; unlike $content, qr/debug/, 'no debug message'; like $history->[0][0], qr/^[0-9.]+$/, 'right epoch time'; is $history->[0][1], 'fatal', 'right level'; @@ -126,9 +149,20 @@ ok !$history->[2], 'no more messages'; }; +subtest '"trace"' => sub { + my $log = Mojo::Log->new(); + is $log->level('trace')->level, 'trace', 'right level'; + ok $log->is_level('trace'), '"trace" log level is active'; + ok $log->is_level('debug'), '"debug" log level is active'; + ok $log->is_level('info'), '"info" log level is active'; + ok $log->is_level('warn'), '"warn" log level is active'; + ok $log->is_level('error'), '"error" log level is active'; +}; + subtest '"debug"' => sub { my $log = Mojo::Log->new; is $log->level('debug')->level, 'debug', 'right level'; + ok !$log->is_level('trace'), '"trace" log level is inactive'; ok $log->is_level('debug'), '"debug" log level is active'; ok $log->is_level('info'), '"info" log level is active'; ok $log->is_level('warn'), '"warn" log level is active'; @@ -138,6 +172,7 @@ subtest '"info"' => sub { my $log = Mojo::Log->new; is $log->level('info')->level, 'info', 'right level'; + ok !$log->is_level('trace'), '"trace" log level is inactive'; ok !$log->is_level('debug'), '"debug" log level is inactive'; ok $log->is_level('info'), '"info" log level is active'; ok $log->is_level('warn'), '"warn" log level is active'; @@ -147,6 +182,7 @@ subtest '"warn"' => sub { my $log = Mojo::Log->new; is $log->level('warn')->level, 'warn', 'right level'; + ok !$log->is_level('trace'), '"trace" log level is inactive'; ok !$log->is_level('debug'), '"debug" log level is inactive'; ok !$log->is_level('info'), '"info" log level is inactive'; ok $log->is_level('warn'), '"warn" log level is active'; @@ -156,6 +192,7 @@ subtest '"error"' => sub { my $log = Mojo::Log->new; is $log->level('error')->level, 'error', 'right level'; + ok !$log->is_level('trace'), '"trace" log level is inactive'; ok !$log->is_level('debug'), '"debug" log level is inactive'; ok !$log->is_level('info'), '"info" log level is inactive'; ok !$log->is_level('warn'), '"warn" log level is inactive'; @@ -165,6 +202,7 @@ subtest '"fatal"' => sub { my $log = Mojo::Log->new; is $log->level('fatal')->level, 'fatal', 'right level'; + ok !$log->is_level('trace'), '"trace" log level is inactive'; ok !$log->is_level('debug'), '"debug" log level is inactive'; ok !$log->is_level('info'), '"info" log level is inactive'; ok !$log->is_level('warn'), '"warn" log level is inactive'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/morbo.t libmojolicious-perl-9.22+dfsg/t/mojo/morbo.t --- libmojolicious-perl-8.71+dfsg/t/mojo/morbo.t 2021-01-17 16:37:22.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/morbo.t 2021-06-30 13:58:00.000000000 +0000 @@ -9,7 +9,7 @@ use Mojo::File qw(curfile); use lib curfile->sibling('lib')->to_string; -use IO::Socket::INET; +use IO::Socket::INET (); use Mojo::File qw(tempdir); use Mojo::IOLoop::Server; use Mojo::Server::Morbo::Backend; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/prefork.t libmojolicious-perl-9.22+dfsg/t/mojo/prefork.t --- libmojolicious-perl-8.71+dfsg/t/mojo/prefork.t 2021-01-17 16:37:22.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/prefork.t 2021-08-09 16:36:35.000000000 +0000 @@ -11,126 +11,130 @@ use Mojo::Server::Prefork; use Mojo::UserAgent; -# Manage and clean up PID file -my $prefork = Mojo::Server::Prefork->new; -my $dir = tempdir; -ok $prefork->pid_file, 'has default path'; -my $file = $dir->child('prefork.pid'); -$prefork->pid_file($file); -ok !$prefork->check_pid, 'no process id'; -$prefork->ensure_pid_file(-23); -ok -e $file, 'file exists'; -is path($file)->slurp, "-23\n", 'right process id'; -ok !$prefork->check_pid, 'no process id'; -ok !-e $file, 'file has been cleaned up'; -$prefork->ensure_pid_file($$); -ok -e $file, 'file exists'; -is path($file)->slurp, "$$\n", 'right process id'; -is $prefork->check_pid, $$, 'right process id'; -undef $prefork; -ok !-e $file, 'file has been cleaned up'; - -# Bad PID file -my $bad = curfile->sibling('does_not_exist', 'test.pid'); -$prefork = Mojo::Server::Prefork->new(pid_file => $bad); -$prefork->app->log->level('debug')->unsubscribe('message'); -my $log = ''; -my $cb = $prefork->app->log->on(message => sub { $log .= pop }); -eval { $prefork->ensure_pid_file($$) }; -like $@, qr/Can't create process id file/, 'right error'; -unlike $log, qr/Creating process id file/, 'right message'; -like $log, qr/Can't create process id file/, 'right message'; -$prefork->app->log->unsubscribe(message => $cb); - -# Multiple workers and graceful shutdown -my $port = Mojo::IOLoop::Server::->generate_port; -$prefork = Mojo::Server::Prefork->new(heartbeat_interval => 0.5, listen => ["http://*:$port"], pid_file => $file); -$prefork->unsubscribe('request'); -$prefork->on( - request => sub { - my ($prefork, $tx) = @_; - $tx->res->code(200)->body('just works!'); - $tx->resume; - } -); -is $prefork->workers, 4, 'start with four workers'; -my (@spawn, @reap, $worker, $tx, $graceful); -$prefork->on(spawn => sub { push @spawn, pop }); -$prefork->on( - heartbeat => sub { - my ($prefork, $pid) = @_; - $worker = $pid; - return if $prefork->healthy < 4; - $tx = Mojo::UserAgent->new->get("http://127.0.0.1:$port"); - kill 'QUIT', $$; - } -); -$prefork->on(reap => sub { push @reap, pop }); -$prefork->on(finish => sub { $graceful = pop }); -$prefork->app->log->level('debug')->unsubscribe('message'); -$log = ''; -$cb = $prefork->app->log->on(message => sub { $log .= pop }); -is $prefork->healthy, 0, 'no healthy workers'; -my @server; -$prefork->app->hook( - before_server_start => sub { - my ($server, $app) = @_; - push @server, $server->workers, $app->mode; - } -); -$prefork->run; -is_deeply \@server, [4, 'development'], 'hook has been emitted once'; -is scalar @spawn, 4, 'four workers spawned'; -is scalar @reap, 4, 'four workers reaped'; -ok !!grep { $worker eq $_ } @spawn, 'worker has a heartbeat'; -ok $graceful, 'server has been stopped gracefully'; -is_deeply [sort @spawn], [sort @reap], 'same process ids'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'just works!', 'right content'; -like $log, qr/Listening at/, 'right message'; -like $log, qr/Manager $$ started/, 'right message'; -like $log, qr/Creating process id file/, 'right message'; -like $log, qr/Stopping worker $spawn[0] gracefully $120 seconds$/, 'right message'; -like $log, qr/Worker $spawn[0] stopped/, 'right message'; -like $log, qr/Manager $$ stopped/, 'right message'; -$prefork->app->log->unsubscribe(message => $cb); - -# Process id file -is $prefork->check_pid, $$, 'right process id'; -my $pid = $prefork->pid_file; -ok -e $pid, 'process id file has been created'; -undef $prefork; -ok !-e $pid, 'process id file has been removed'; - -# One worker and immediate shutdown -$port = Mojo::IOLoop::Server->generate_port; -$prefork - = Mojo::Server::Prefork->new(accepts => 500, heartbeat_interval => 0.5, listen => ["http://*:$port"], workers => 1); -$prefork->unsubscribe('request'); -$prefork->on( - request => sub { - my ($prefork, $tx) = @_; - $tx->res->code(200)->body('works too!'); - $tx->resume; - } -); -my $count = $tx = $graceful = undef; -@spawn = @reap = (); -$prefork->on(spawn => sub { push @spawn, pop }); -$prefork->once( - heartbeat => sub { - $tx = Mojo::UserAgent->new->get("http://127.0.0.1:$port"); - kill 'TERM', $$; - } -); -$prefork->on(reap => sub { push @reap, pop }); -$prefork->on(finish => sub { $graceful = pop }); -$prefork->run; -is $prefork->ioloop->max_accepts, 500, 'right value'; -is scalar @spawn, 1, 'one worker spawned'; -is scalar @reap, 1, 'one worker reaped'; -ok !$graceful, 'server has been stopped immediately'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'works too!', 'right content'; +subtest 'Manage and clean up PID file' => sub { + my $prefork = Mojo::Server::Prefork->new; + my $dir = tempdir; + ok $prefork->pid_file, 'has default path'; + my $file = $dir->child('prefork.pid'); + $prefork->pid_file($file); + ok !$prefork->check_pid, 'no process id'; + $prefork->ensure_pid_file(-23); + ok -e $file, 'file exists'; + is path($file)->slurp, "-23\n", 'right process id'; + ok !$prefork->check_pid, 'no process id'; + ok !-e $file, 'file has been cleaned up'; + $prefork->ensure_pid_file($$); + ok -e $file, 'file exists'; + is path($file)->slurp, "$$\n", 'right process id'; + is $prefork->check_pid, $$, 'right process id'; + undef $prefork; + ok !-e $file, 'file has been cleaned up'; +}; + +subtest 'Bad PID file' => sub { + my $bad = curfile->sibling('does_not_exist', 'test.pid'); + my $prefork = Mojo::Server::Prefork->new(pid_file => $bad); + $prefork->app->log->level('trace')->unsubscribe('message'); + my $log = ''; + my $cb = $prefork->app->log->on(message => sub { $log .= pop }); + eval { $prefork->ensure_pid_file($$) }; + like $@, qr/Can't create process id file/, 'right error'; + unlike $log, qr/Creating process id file/, 'right message'; + like $log, qr/Can't create process id file/, 'right message'; + $prefork->app->log->unsubscribe(message => $cb); +}; + +subtest 'Multiple workers and graceful shutdown' => sub { + my $dir = tempdir; + my $file = $dir->child('prefork.pid'); + my $port = Mojo::IOLoop::Server::->generate_port; + my $prefork = Mojo::Server::Prefork->new(heartbeat_interval => 0.5, listen => ["http://*:$port"], pid_file => $file); + $prefork->unsubscribe('request'); + $prefork->on( + request => sub { + my ($prefork, $tx) = @_; + $tx->res->code(200)->body('just works!'); + $tx->resume; + } + ); + is $prefork->workers, 4, 'start with four workers'; + my (@spawn, @reap, $worker, $tx, $graceful); + $prefork->on(spawn => sub { push @spawn, pop }); + $prefork->on( + heartbeat => sub { + my ($prefork, $pid) = @_; + $worker = $pid; + return if $prefork->healthy < 4; + $tx = Mojo::UserAgent->new->get("http://127.0.0.1:$port"); + kill 'QUIT', $$; + } + ); + $prefork->on(reap => sub { push @reap, pop }); + $prefork->on(finish => sub { $graceful = pop }); + $prefork->app->log->level('trace')->unsubscribe('message'); + my $log = ''; + my $cb = $prefork->app->log->on(message => sub { $log .= pop }); + is $prefork->healthy, 0, 'no healthy workers'; + my @server; + $prefork->app->hook( + before_server_start => sub { + my ($server, $app) = @_; + push @server, $server->workers, $app->mode; + } + ); + $prefork->run; + is_deeply \@server, [4, 'development'], 'hook has been emitted once'; + is scalar @spawn, 4, 'four workers spawned'; + is scalar @reap, 4, 'four workers reaped'; + ok !!grep { $worker eq $_ } @spawn, 'worker has a heartbeat'; + ok $graceful, 'server has been stopped gracefully'; + is_deeply [sort @spawn], [sort @reap], 'same process ids'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'just works!', 'right content'; + like $log, qr/Listening at/, 'right message'; + like $log, qr/Manager $$ started/, 'right message'; + like $log, qr/Creating process id file/, 'right message'; + like $log, qr/Stopping worker $spawn[0] gracefully $120 seconds$/, 'right message'; + like $log, qr/Worker $spawn[0] stopped/, 'right message'; + like $log, qr/Manager $$ stopped/, 'right message'; + $prefork->app->log->unsubscribe(message => $cb); + + is $prefork->check_pid, $$, 'right process id'; + my $pid = $prefork->pid_file; + ok -e $pid, 'process id file has been created'; + undef $prefork; + ok !-e $pid, 'process id file has been removed'; +}; + +subtest 'One worker and immediate shutdown' => sub { + my $port = Mojo::IOLoop::Server->generate_port; + my $prefork + = Mojo::Server::Prefork->new(accepts => 500, heartbeat_interval => 0.5, listen => ["http://*:$port"], workers => 1); + my (@spawn, @reap, $tx, $graceful, $count); + $prefork->unsubscribe('request'); + $prefork->on( + request => sub { + my ($prefork, $tx) = @_; + $tx->res->code(200)->body('works too!'); + $tx->resume; + } + ); + $prefork->on(spawn => sub { push @spawn, pop }); + $prefork->once( + heartbeat => sub { + $tx = Mojo::UserAgent->new->get("http://127.0.0.1:$port"); + kill 'TERM', $$; + } + ); + $prefork->on(reap => sub { push @reap, pop }); + $prefork->on(finish => sub { $graceful = pop }); + $prefork->run; + is $prefork->ioloop->max_accepts, 500, 'right value'; + is scalar @spawn, 1, 'one worker spawned'; + is scalar @reap, 1, 'one worker reaped'; + ok !$graceful, 'server has been stopped immediately'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'works too!', 'right content'; +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/promise_async_await.t libmojolicious-perl-9.22+dfsg/t/mojo/promise_async_await.t --- libmojolicious-perl-8.71+dfsg/t/mojo/promise_async_await.t 2021-01-17 16:37:22.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/promise_async_await.t 2021-08-13 15:10:20.000000000 +0000 @@ -7,7 +7,7 @@ BEGIN { plan skip_all => 'set TEST_ASYNC_AWAIT to enable this test (developer only!)' unless $ENV{TEST_ASYNC_AWAIT} || $ENV{TEST_ALL}; - plan skip_all => 'Future::AsyncAwait 0.36+ required for this test!' unless Mojo::Base->ASYNC; + plan skip_all => 'Future::AsyncAwait 0.52+ required for this test!' unless Mojo::Base->ASYNC; } use Mojo::Base -async_await; @@ -105,37 +105,50 @@ my $t = Test::Mojo->new; -# Basic async/await -my $promise = test_one(); -isa_ok $promise, 'Mojo::Promise', 'right class'; -my $tx; -$promise->then(sub { $tx = shift })->catch(sub { warn @_ }); -$promise->wait; -is $tx->res->body, 'works!', 'right content'; - -# Multiple awaits -my $text; -test_two(' ')->then(sub { $text = shift })->catch(sub { warn @_ })->wait; -is $text, 'also works!', 'right content'; - -# Application with async/await action -$t->get_ok('/three')->content_is('this works too!'); - -# Exception handling and async/await -$t->get_ok('/four')->status_is(500)->content_like(qr/this went perfectly/); - -# Runaway exception -$t->get_ok('/five')->status_is(500)->content_like(qr/runaway too/); - -# Async function body returning a promise -$text = undef; -test_three(1)->then(sub { $text = shift })->catch(sub { warn @_ })->wait; -is $text, 'value', 'right content'; -$text = undef; -test_three(0)->then(sub { warn @_ })->catch(sub { $text = shift })->wait; -is $text, 'value', 'right content'; +subtest 'Basic async/await' => sub { + my $promise = test_one(); + isa_ok $promise, 'Mojo::Promise', 'right class'; + my $tx; + $promise->then(sub { $tx = shift })->catch(sub { warn @_ }); + $promise->wait; + is $tx->res->body, 'works!', 'right content'; +}; + +subtest 'Multiple awaits' => sub { + my $text; + test_two(' ')->then(sub { $text = shift })->catch(sub { warn @_ })->wait; + is $text, 'also works!', 'right content'; +}; + +subtest 'Application with async/await action' => sub { + $t->get_ok('/three')->content_is('this works too!'); +}; + +subtest 'Exception handling and async/await' => sub { + $t->get_ok('/four')->status_is(500)->content_like(qr/this went perfectly/); +}; + +subtest 'Runaway exception' => sub { + $t->get_ok('/five')->status_is(500)->content_like(qr/runaway too/); +}; + +subtest 'Async function body returning a promise' => sub { + my $text; + test_three(1)->then(sub { $text = shift })->catch(sub { warn @_ })->wait; + is $text, 'value', 'right content'; + $text = undef; + test_three(0)->then(sub { warn @_ })->catch(sub { $text = shift })->wait; + is $text, 'value', 'right content'; +}; + +subtest 'Async WebSocket' => sub { + $t->websocket_ok('/six')->send_ok('test')->message_ok->message_is('One: test Two: test')->finish_ok; +}; -# Async WebSocket -$t->websocket_ok('/six')->send_ok('test')->message_ok->message_is('One: test Two: test')->finish_ok; +# Top-level await +is scalar await Mojo::Promise->resolve('works'), 'works', 'top-level await resolved'; +is_deeply [await Mojo::Promise->resolve('just', 'works')], ['just', 'works'], 'top-level await resolved'; +eval { await Mojo::Promise->reject('works too') }; +like $@, qr/works too/, 'top-level await rejected'; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/promise.t libmojolicious-perl-9.22+dfsg/t/mojo/promise.t --- libmojolicious-perl-8.71+dfsg/t/mojo/promise.t 2021-01-17 16:37:35.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/promise.t 2021-06-30 13:58:00.000000000 +0000 @@ -160,16 +160,47 @@ is_deeply \@results, ['finally1', 'finally2'], 'promise not resolved'; }; -subtest 'Resolved nested with finally' => sub { +subtest 'Promise returned by finally' => sub { + my $loop = Mojo::IOLoop->new; + my $promise = Mojo::Promise->new->ioloop($loop); + my $promise2 = Mojo::Promise->new->ioloop($loop); + my @results; + my $promise3 = $promise->finally(sub { + $loop->next_tick(sub { $promise2->resolve }); + return $promise2; + })->finally(sub { @results = ('finally') }); + $promise->resolve('pass'); + $promise3->wait; + is_deeply \@results, ['finally'], 'promise already resolved'; +}; + +subtest 'Promise returned by finally' => sub { my $promise = Mojo::Promise->new; my $promise2 = Mojo::Promise->new; my @results; - $promise->finally(sub {$promise2})->finally(sub { @results = ('finally') }); + my $promise3 = $promise->finally(sub { + Mojo::IOLoop->next_tick(sub { $promise2->resolve }); + return $promise2; + })->finally(sub { @results = ('finally') }); $promise->resolve('pass'); - Mojo::IOLoop->one_tick; + $promise3->wait; is_deeply \@results, ['finally'], 'promise already resolved'; }; +subtest 'Promise returned by finally (rejected)' => sub { + my $promise = Mojo::Promise->new; + my $promise2 = Mojo::Promise->new; + my (@results, @errors); + my $promise3 = $promise->finally(sub { + Mojo::IOLoop->next_tick(sub { $promise2->reject('works') }); + return $promise2; + })->then(sub { @results = @_ }, sub { @errors = @_ }); + $promise->resolve('failed'); + $promise3->wait; + is_deeply \@results, [], 'promises not resolved'; + is_deeply \@errors, ['works'], 'promises rejected'; +}; + subtest 'Exception in finally' => sub { my $promise = Mojo::Promise->new; my @results; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/proxy.t libmojolicious-perl-9.22+dfsg/t/mojo/proxy.t --- libmojolicious-perl-8.71+dfsg/t/mojo/proxy.t 2021-01-17 16:37:34.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/proxy.t 2021-08-13 19:07:33.000000000 +0000 @@ -4,7 +4,7 @@ use Mojo::UserAgent::Proxy; # Proxy detection -{ +subtest 'Proxy detection with uppercase variable names' => sub { my $proxy = Mojo::UserAgent::Proxy->new; local $ENV{HTTP_PROXY} = 'http://127.0.0.1'; local $ENV{HTTPS_PROXY} = 'http://127.0.0.1:8080'; @@ -19,10 +19,18 @@ ok !$proxy->is_needed('dummy.mojolicious.org'), 'no proxy needed'; ok $proxy->is_needed('icious.org'), 'proxy needed'; ok $proxy->is_needed('localhost'), 'proxy needed'; - ($ENV{HTTP_PROXY}, $ENV{HTTPS_PROXY}, $ENV{NO_PROXY}) = (); +}; + +subtest 'Proxy detection with lowercase variable names' => sub { + local $ENV{HTTP_PROXY}; + local $ENV{HTTPS_PROXY}; + local $ENV{NO_PROXY}; + local $ENV{http_proxy} = 'proxy.example.com'; local $ENV{https_proxy} = 'tunnel.example.com'; local $ENV{no_proxy} = 'localhost,localdomain,foo.com,example.com'; + + my $proxy = Mojo::UserAgent::Proxy->new; $proxy->detect; is_deeply $proxy->not, ['localhost', 'localdomain', 'foo.com', 'example.com'], 'right list'; is $proxy->http, 'proxy.example.com', 'right proxy'; @@ -35,6 +43,6 @@ ok !$proxy->is_needed('example.com'), 'no proxy needed'; ok !$proxy->is_needed('www.example.com'), 'no proxy needed'; ok $proxy->is_needed('www.example.com.com'), 'proxy needed'; -} +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/psgi.t libmojolicious-perl-9.22+dfsg/t/mojo/psgi.t --- libmojolicious-perl-8.71+dfsg/t/mojo/psgi.t 2021-01-17 16:37:37.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/psgi.t 2021-06-30 13:58:00.000000000 +0000 @@ -29,7 +29,7 @@ get '/proxy' => sub { my $c = shift; - my $reverse = join ':', $c->tx->remote_address, $c->req->url->to_abs->protocol; + my $reverse = join ':', grep {length} $c->tx->remote_address, $c->req->url->to_abs->protocol; $c->render(text => $reverse); }; @@ -207,13 +207,86 @@ subtest 'Reverse proxy' => sub { my $env = { + CONTENT_LENGTH => 0, + PATH_INFO => '/proxy', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + SERVER_PROTOCOL => 'HTTP/1.1', + HTTP_X_FORWARDED_FOR => '192.0.2.2, 192.0.2.1', + HTTP_X_FORWARDED_PROTO => 'https', + 'psgi.version' => [1, 0], + 'psgi.url_scheme' => 'http', + 'psgi.input' => *STDIN, + 'psgi.errors' => *STDERR, + 'psgi.multithread' => 0, + 'psgi.multiprocess' => 1, + 'psgi.run_once' => 0 + }; + my ($app, $res); + { + local $ENV{MOJO_REVERSE_PROXY} = 1; + $app = Mojolicious::Command::psgi->new(app => app)->run; + $res = $app->($env); + } + is $res->[0], 200, 'right status'; + my %headers = @{$res->[1]}; + is $headers{'Content-Length'}, 15, 'right "Content-Length" value'; + is $headers{'Content-Type'}, 'text/html;charset=UTF-8', 'right "Content-Type" value'; + my $body = ''; + while (defined(my $chunk = $res->[2]->getline)) { $body .= $chunk } + is $body, '192.0.2.1:https', 'right content'; + is $ENV{MOJO_HELLO}, undef, 'finish event has not been emitted'; + $res->[2]->close; + is delete $ENV{MOJO_HELLO}, 'world', 'finish event has been emitted'; +}; + +subtest 'Trusted proxies' => sub { + my $env = { + CONTENT_LENGTH => 0, + PATH_INFO => '/proxy', + REQUEST_METHOD => 'GET', + SCRIPT_NAME => '/', + HTTP_HOST => 'localhost:8080', + REMOTE_ADDR => '127.0.0.1', + SERVER_PROTOCOL => 'HTTP/1.1', + HTTP_X_FORWARDED_FOR => '10.10.10.10, 192.0.2.2, 192.0.2.1', + HTTP_X_FORWARDED_PROTO => 'https', + 'psgi.version' => [1, 0], + 'psgi.url_scheme' => 'http', + 'psgi.input' => *STDIN, + 'psgi.errors' => *STDERR, + 'psgi.multithread' => 0, + 'psgi.multiprocess' => 1, + 'psgi.run_once' => 0 + }; + my ($app, $res); + { + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8, 192.0.0.0/8'; + $app = Mojolicious::Command::psgi->new(app => app)->run; + $res = $app->($env); + } + is $res->[0], 200, 'right status'; + my %headers = @{$res->[1]}; + is $headers{'Content-Length'}, 17, 'right "Content-Length" value'; + is $headers{'Content-Type'}, 'text/html;charset=UTF-8', 'right "Content-Type" value'; + my $body = ''; + while (defined(my $chunk = $res->[2]->getline)) { $body .= $chunk } + is $body, '10.10.10.10:https', 'right content'; + is $ENV{MOJO_HELLO}, undef, 'finish event has not been emitted'; + $res->[2]->close; + is delete $ENV{MOJO_HELLO}, 'world', 'finish event has been emitted'; +}; + +subtest 'Trusted proxies (no REMOTE_ADDR)' => sub { + my $env = { CONTENT_LENGTH => 0, PATH_INFO => '/proxy', REQUEST_METHOD => 'GET', SCRIPT_NAME => '/', HTTP_HOST => 'localhost:8080', SERVER_PROTOCOL => 'HTTP/1.1', - 'HTTP_X_Forwarded_For' => '192.0.2.2, 192.0.2.1', + 'HTTP_X_Forwarded_For' => '10.10.10.10, 192.0.2.2, 192.0.2.1', 'HTTP_X_Forwarded_Proto' => 'https', 'psgi.version' => [1, 0], 'psgi.url_scheme' => 'http', @@ -225,17 +298,17 @@ }; my ($app, $res); { - local $ENV{MOJO_REVERSE_PROXY} = 1; + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8, 192.0.0.0/8'; $app = Mojolicious::Command::psgi->new(app => app)->run; $res = $app->($env); } is $res->[0], 200, 'right status'; my %headers = @{$res->[1]}; - is $headers{'Content-Length'}, 15, 'right "Content-Length" value'; + is $headers{'Content-Length'}, 5, 'right "Content-Length" value'; is $headers{'Content-Type'}, 'text/html;charset=UTF-8', 'right "Content-Type" value'; my $body = ''; while (defined(my $chunk = $res->[2]->getline)) { $body .= $chunk } - is $body, '192.0.2.1:https', 'right content'; + is $body, 'https', 'right content'; is $ENV{MOJO_HELLO}, undef, 'finish event has not been emitted'; $res->[2]->close; is delete $ENV{MOJO_HELLO}, 'world', 'finish event has been emitted'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/request.t libmojolicious-perl-9.22+dfsg/t/mojo/request.t --- libmojolicious-perl-8.71+dfsg/t/mojo/request.t 2021-01-17 16:37:37.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/request.t 2021-06-30 13:58:00.000000000 +0000 @@ -1255,6 +1255,21 @@ ok $req->is_finished, 'request is finished'; }; +subtest 'Build HTTP 1.1 POST request without body' => sub { + my $req = Mojo::Message::Request->new; + $req->method('POST'); + $req->url->parse('http://127.0.0.1/foo/bar'); + $req = Mojo::Message::Request->new->parse($req->to_string); + is $req->method, 'POST', 'right method'; + is $req->version, '1.1', 'right version'; + is $req->url, '/foo/bar', 'right URL'; + is $req->url->to_abs, 'http://127.0.0.1/foo/bar', 'right absolute URL'; + is $req->headers->host, '127.0.0.1', 'right "Host" value'; + is $req->headers->content_length, 0, 'right "Content-Length" value'; + is $req->body, '', 'no content'; + ok $req->is_finished, 'request is finished'; +}; + subtest 'Build WebSocket handshake request' => sub { my $req = Mojo::Message::Request->new; my $finished = undef; @@ -1275,7 +1290,7 @@ is $req->headers->connection, 'Upgrade', 'right "Connection" value'; is $req->headers->upgrade, 'websocket', 'right "Upgrade" value'; is $req->headers->host, 'example.com', 'right "Host" value'; - is $req->headers->content_length, 0, 'right "Content-Length" value'; + is $req->headers->content_length, undef, 'no "Content-Length" value'; is $req->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Key" value'; is $req->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; is $req->body, '', 'no content'; @@ -1302,7 +1317,7 @@ is $req->headers->connection, 'Upgrade', 'right "Connection" value'; is $req->headers->upgrade, 'websocket', 'right "Upgrade" value'; is $req->headers->host, 'example.com', 'right "Host" value'; - is $req->headers->content_length, 0, 'right "Content-Length" value'; + is $req->headers->content_length, undef, 'no "Content-Length" value'; is $req->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Key" value'; is $req->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; is $req->body, '', 'no content'; @@ -1316,7 +1331,7 @@ is $clone->headers->connection, 'Upgrade', 'right "Connection" value'; is $clone->headers->upgrade, 'websocket', 'right "Upgrade" value'; is $clone->headers->host, 'example.com', 'right "Host" value'; - is $req->headers->content_length, 0, 'right "Content-Length" value'; + is $req->headers->content_length, undef, 'no "Content-Length" value'; is $clone->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Key" value'; is $clone->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; is $clone->body, '', 'no content'; @@ -1344,7 +1359,7 @@ is $req->headers->connection, 'Upgrade', 'right "Connection" value'; is $req->headers->upgrade, 'websocket', 'right "Upgrade" value'; is $req->headers->host, 'example.com', 'right "Host" value'; - is $req->headers->content_length, 0, 'right "Content-Length" value'; + is $req->headers->content_length, undef, 'no "Content-Length" value'; is $req->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Key" value'; is $req->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; is $req->body, '', 'no content'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/response.t libmojolicious-perl-9.22+dfsg/t/mojo/response.t --- libmojolicious-perl-8.71+dfsg/t/mojo/response.t 2021-01-17 16:37:23.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/response.t 2021-08-09 19:24:05.000000000 +0000 @@ -9,218 +9,228 @@ use Mojo::Message::Response; use Mojo::Util qw(encode gzip); -# Defaults -my $res = Mojo::Message::Response->new; -is $res->max_message_size, 2147483648, 'right default'; - -# Common status codes -$res = Mojo::Message::Response->new; -is $res->code(100)->default_message, 'Continue', 'right message'; -is $res->code(101)->default_message, 'Switching Protocols', 'right message'; -is $res->code(102)->default_message, 'Processing', 'right message'; -is $res->code(103)->default_message, 'Early Hints', 'right message'; -is $res->code(200)->default_message, 'OK', 'right message'; -is $res->code(201)->default_message, 'Created', 'right message'; -is $res->code(202)->default_message, 'Accepted', 'right message'; -is $res->code(203)->default_message, 'Non-Authoritative Information', 'right message'; -is $res->code(204)->default_message, 'No Content', 'right message'; -is $res->code(205)->default_message, 'Reset Content', 'right message'; -is $res->code(206)->default_message, 'Partial Content', 'right message'; -is $res->code(207)->default_message, 'Multi-Status', 'right message'; -is $res->code(208)->default_message, 'Already Reported', 'right message'; -is $res->code(226)->default_message, 'IM Used', 'right message'; -is $res->code(300)->default_message, 'Multiple Choices', 'right message'; -is $res->code(301)->default_message, 'Moved Permanently', 'right message'; -is $res->code(302)->default_message, 'Found', 'right message'; -is $res->code(303)->default_message, 'See Other', 'right message'; -is $res->code(304)->default_message, 'Not Modified', 'right message'; -is $res->code(305)->default_message, 'Use Proxy', 'right message'; -is $res->code(307)->default_message, 'Temporary Redirect', 'right message'; -is $res->code(308)->default_message, 'Permanent Redirect', 'right message'; -is $res->code(400)->default_message, 'Bad Request', 'right message'; -is $res->code(401)->default_message, 'Unauthorized', 'right message'; -is $res->code(402)->default_message, 'Payment Required', 'right message'; -is $res->code(403)->default_message, 'Forbidden', 'right message'; -is $res->code(404)->default_message, 'Not Found', 'right message'; -is $res->code(405)->default_message, 'Method Not Allowed', 'right message'; -is $res->code(406)->default_message, 'Not Acceptable', 'right message'; -is $res->code(407)->default_message, 'Proxy Authentication Required', 'right message'; -is $res->code(408)->default_message, 'Request Timeout', 'right message'; -is $res->code(409)->default_message, 'Conflict', 'right message'; -is $res->code(410)->default_message, 'Gone', 'right message'; -is $res->code(411)->default_message, 'Length Required', 'right message'; -is $res->code(412)->default_message, 'Precondition Failed', 'right message'; -is $res->code(413)->default_message, 'Request Entity Too Large', 'right message'; -is $res->code(414)->default_message, 'Request-URI Too Long', 'right message'; -is $res->code(415)->default_message, 'Unsupported Media Type', 'right message'; -is $res->code(416)->default_message, 'Request Range Not Satisfiable', 'right message'; -is $res->code(417)->default_message, 'Expectation Failed', 'right message'; -is $res->code(418)->default_message, "I'm a teapot", 'right message'; -is $res->code(421)->default_message, 'Misdirected Request', 'right message'; -is $res->code(422)->default_message, 'Unprocessable Entity', 'right message'; -is $res->code(423)->default_message, 'Locked', 'right message'; -is $res->code(424)->default_message, 'Failed Dependency', 'right message'; -is $res->code(425)->default_message, 'Too Early', 'right message'; -is $res->code(426)->default_message, 'Upgrade Required', 'right message'; -is $res->code(428)->default_message, 'Precondition Required', 'right message'; -is $res->code(429)->default_message, 'Too Many Requests', 'right message'; -is $res->code(431)->default_message, 'Request Header Fields Too Large', 'right message'; -is $res->code(451)->default_message, 'Unavailable For Legal Reasons', 'right message'; -is $res->code(500)->default_message, 'Internal Server Error', 'right message'; -is $res->code(501)->default_message, 'Not Implemented', 'right message'; -is $res->code(502)->default_message, 'Bad Gateway', 'right message'; -is $res->code(503)->default_message, 'Service Unavailable', 'right message'; -is $res->code(504)->default_message, 'Gateway Timeout', 'right message'; -is $res->code(505)->default_message, 'HTTP Version Not Supported', 'right message'; -is $res->code(506)->default_message, 'Variant Also Negotiates', 'right message'; -is $res->code(507)->default_message, 'Insufficient Storage', 'right message'; -is $res->code(508)->default_message, 'Loop Detected', 'right message'; -is $res->code(509)->default_message, 'Bandwidth Limit Exceeded', 'right message'; -is $res->code(510)->default_message, 'Not Extended', 'right message'; -is $res->code(511)->default_message, 'Network Authentication Required', 'right message'; -is $res->default_message(100), 'Continue', 'right message'; - -# Status code ranges -ok $res->code(101)->is_info, 'is in range'; -ok $res->code(199)->is_info, 'is in range'; -ok $res->code(200)->is_success, 'is in range'; -ok $res->code(202)->is_success, 'is in range'; -ok $res->code(299)->is_success, 'is in range'; -ok $res->code(301)->is_redirect, 'is in range'; -ok $res->code(399)->is_redirect, 'is in range'; -ok $res->code(401)->is_client_error, 'is in range'; -ok $res->code(499)->is_client_error, 'is in range'; -ok $res->code(400)->is_error, 'is in range'; -ok $res->code(599)->is_error, 'is in range'; -ok $res->code(501)->is_server_error, 'is in range'; -ok $res->code(599)->is_server_error, 'is in range'; -ok !$res->code(200)->is_info, 'not in range'; -ok !$res->code(199)->is_success, 'not in range'; -ok !$res->code(300)->is_success, 'not in range'; -ok !$res->code(200)->is_redirect, 'not in range'; -ok !$res->code(200)->is_error, 'not in range'; -ok !$res->code(200)->is_client_error, 'not in range'; -ok !$res->code(200)->is_server_error, 'not in range'; -ok !$res->code(undef)->is_success, 'no range'; - -# Status code and message -$res = Mojo::Message::Response->new; -is $res->code, undef, 'no status'; -is $res->default_message, 'Not Found', 'right default message'; -is $res->message, undef, 'no message'; -$res->message('Test'); -is $res->message, 'Test', 'right message'; -$res->code(500); -is $res->code, 500, 'right status'; -is $res->message, 'Test', 'right message'; -is $res->default_message, 'Internal Server Error', 'right default message'; -$res = Mojo::Message::Response->new; -is $res->code(400)->default_message, 'Bad Request', 'right default message'; -$res = Mojo::Message::Response->new; -is $res->code(1)->default_message, '', 'empty default message'; - -# Parse HTTP 1.1 response start-line, no headers and body -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a\x0d\x0a"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; - -# Parse HTTP 1.1 response start-line, no headers and body (small chunks) -$res = Mojo::Message::Response->new; -$res->parse('H'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('T'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('T'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('P'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('/'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('1'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('.'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('1'); -ok !$res->is_finished, 'response is not finished'; -$res->parse(' '); -ok !$res->is_finished, 'response is not finished'; -$res->parse('2'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('0'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('0'); -ok !$res->is_finished, 'response is not finished'; -$res->parse(' '); -ok !$res->is_finished, 'response is not finished'; -$res->parse('O'); -ok !$res->is_finished, 'response is not finished'; -$res->parse('K'); -ok !$res->is_finished, 'response is not finished'; -$res->parse("\x0d"); -ok !$res->is_finished, 'response is not finished'; -$res->parse("\x0a"); -ok !$res->is_finished, 'response is not finished'; -$res->parse("\x0d"); -ok !$res->is_finished, 'response is not finished'; -$res->parse("\x0a"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; - -# Parse HTTP 1.1 response start-line, no headers and body (no message) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200\x0d\x0a\x0d\x0a"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 200, 'right status'; -is $res->message, undef, 'no message'; -is $res->version, '1.1', 'right version'; - -# Parse HTTP 1.0 response start-line and headers but no body -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 404 Damn it\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Content-Length: 0\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -is $res->code, 404, 'right status'; -is $res->message, 'Damn it', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, 0, 'right "Content-Length" value'; - -# Parse full HTTP 1.0 response -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Content-Length: 27\x0d\x0a\x0d\x0a"); -$res->parse("Hello World!\n1234\nlalalala\n"); -ok $res->is_finished, 'response is finished'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, 27, 'right "Content-Length" value'; -is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; - -# Parse full HTTP 1.0 response (keep-alive) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); -$res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); -$res->parse("HTTP/1.0 200 OK\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->body, '', 'no content'; -is $res->content->leftovers, "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a", 'next response in leftovers'; +subtest 'Defaults' => sub { + my $res = Mojo::Message::Response->new; + is $res->max_message_size, 2147483648, 'right default'; +}; + +subtest 'Common status codes' => sub { + my $res = Mojo::Message::Response->new; + is $res->code(100)->default_message, 'Continue', 'right message'; + is $res->code(101)->default_message, 'Switching Protocols', 'right message'; + is $res->code(102)->default_message, 'Processing', 'right message'; + is $res->code(103)->default_message, 'Early Hints', 'right message'; + is $res->code(200)->default_message, 'OK', 'right message'; + is $res->code(201)->default_message, 'Created', 'right message'; + is $res->code(202)->default_message, 'Accepted', 'right message'; + is $res->code(203)->default_message, 'Non-Authoritative Information', 'right message'; + is $res->code(204)->default_message, 'No Content', 'right message'; + is $res->code(205)->default_message, 'Reset Content', 'right message'; + is $res->code(206)->default_message, 'Partial Content', 'right message'; + is $res->code(207)->default_message, 'Multi-Status', 'right message'; + is $res->code(208)->default_message, 'Already Reported', 'right message'; + is $res->code(226)->default_message, 'IM Used', 'right message'; + is $res->code(300)->default_message, 'Multiple Choices', 'right message'; + is $res->code(301)->default_message, 'Moved Permanently', 'right message'; + is $res->code(302)->default_message, 'Found', 'right message'; + is $res->code(303)->default_message, 'See Other', 'right message'; + is $res->code(304)->default_message, 'Not Modified', 'right message'; + is $res->code(305)->default_message, 'Use Proxy', 'right message'; + is $res->code(307)->default_message, 'Temporary Redirect', 'right message'; + is $res->code(308)->default_message, 'Permanent Redirect', 'right message'; + is $res->code(400)->default_message, 'Bad Request', 'right message'; + is $res->code(401)->default_message, 'Unauthorized', 'right message'; + is $res->code(402)->default_message, 'Payment Required', 'right message'; + is $res->code(403)->default_message, 'Forbidden', 'right message'; + is $res->code(404)->default_message, 'Not Found', 'right message'; + is $res->code(405)->default_message, 'Method Not Allowed', 'right message'; + is $res->code(406)->default_message, 'Not Acceptable', 'right message'; + is $res->code(407)->default_message, 'Proxy Authentication Required', 'right message'; + is $res->code(408)->default_message, 'Request Timeout', 'right message'; + is $res->code(409)->default_message, 'Conflict', 'right message'; + is $res->code(410)->default_message, 'Gone', 'right message'; + is $res->code(411)->default_message, 'Length Required', 'right message'; + is $res->code(412)->default_message, 'Precondition Failed', 'right message'; + is $res->code(413)->default_message, 'Request Entity Too Large', 'right message'; + is $res->code(414)->default_message, 'Request-URI Too Long', 'right message'; + is $res->code(415)->default_message, 'Unsupported Media Type', 'right message'; + is $res->code(416)->default_message, 'Request Range Not Satisfiable', 'right message'; + is $res->code(417)->default_message, 'Expectation Failed', 'right message'; + is $res->code(418)->default_message, "I'm a teapot", 'right message'; + is $res->code(421)->default_message, 'Misdirected Request', 'right message'; + is $res->code(422)->default_message, 'Unprocessable Entity', 'right message'; + is $res->code(423)->default_message, 'Locked', 'right message'; + is $res->code(424)->default_message, 'Failed Dependency', 'right message'; + is $res->code(425)->default_message, 'Too Early', 'right message'; + is $res->code(426)->default_message, 'Upgrade Required', 'right message'; + is $res->code(428)->default_message, 'Precondition Required', 'right message'; + is $res->code(429)->default_message, 'Too Many Requests', 'right message'; + is $res->code(431)->default_message, 'Request Header Fields Too Large', 'right message'; + is $res->code(451)->default_message, 'Unavailable For Legal Reasons', 'right message'; + is $res->code(500)->default_message, 'Internal Server Error', 'right message'; + is $res->code(501)->default_message, 'Not Implemented', 'right message'; + is $res->code(502)->default_message, 'Bad Gateway', 'right message'; + is $res->code(503)->default_message, 'Service Unavailable', 'right message'; + is $res->code(504)->default_message, 'Gateway Timeout', 'right message'; + is $res->code(505)->default_message, 'HTTP Version Not Supported', 'right message'; + is $res->code(506)->default_message, 'Variant Also Negotiates', 'right message'; + is $res->code(507)->default_message, 'Insufficient Storage', 'right message'; + is $res->code(508)->default_message, 'Loop Detected', 'right message'; + is $res->code(509)->default_message, 'Bandwidth Limit Exceeded', 'right message'; + is $res->code(510)->default_message, 'Not Extended', 'right message'; + is $res->code(511)->default_message, 'Network Authentication Required', 'right message'; + is $res->default_message(100), 'Continue', 'right message'; +}; + +subtest 'Status code ranges' => sub { + my $res = Mojo::Message::Response->new; + ok $res->code(101)->is_info, 'is in range'; + ok $res->code(199)->is_info, 'is in range'; + ok $res->code(200)->is_success, 'is in range'; + ok $res->code(202)->is_success, 'is in range'; + ok $res->code(299)->is_success, 'is in range'; + ok $res->code(301)->is_redirect, 'is in range'; + ok $res->code(399)->is_redirect, 'is in range'; + ok $res->code(401)->is_client_error, 'is in range'; + ok $res->code(499)->is_client_error, 'is in range'; + ok $res->code(400)->is_error, 'is in range'; + ok $res->code(599)->is_error, 'is in range'; + ok $res->code(501)->is_server_error, 'is in range'; + ok $res->code(599)->is_server_error, 'is in range'; + ok !$res->code(200)->is_info, 'not in range'; + ok !$res->code(199)->is_success, 'not in range'; + ok !$res->code(300)->is_success, 'not in range'; + ok !$res->code(200)->is_redirect, 'not in range'; + ok !$res->code(200)->is_error, 'not in range'; + ok !$res->code(200)->is_client_error, 'not in range'; + ok !$res->code(200)->is_server_error, 'not in range'; + ok !$res->code(undef)->is_success, 'no range'; +}; + +subtest 'Status code and message' => sub { + my $res = Mojo::Message::Response->new; + is $res->code, undef, 'no status'; + is $res->default_message, 'Not Found', 'right default message'; + is $res->message, undef, 'no message'; + $res->message('Test'); + is $res->message, 'Test', 'right message'; + $res->code(500); + is $res->code, 500, 'right status'; + is $res->message, 'Test', 'right message'; + is $res->default_message, 'Internal Server Error', 'right default message'; + $res = Mojo::Message::Response->new; + is $res->code(400)->default_message, 'Bad Request', 'right default message'; + $res = Mojo::Message::Response->new; + is $res->code(1)->default_message, '', 'empty default message'; +}; + +subtest 'Parse HTTP 1.1 response start-line, no headers and body' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a\x0d\x0a"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; +}; + +subtest 'Parse HTTP 1.1 response start-line, no headers and body (small chunks)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse('H'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('T'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('T'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('P'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('/'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('1'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('.'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('1'); + ok !$res->is_finished, 'response is not finished'; + $res->parse(' '); + ok !$res->is_finished, 'response is not finished'; + $res->parse('2'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('0'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('0'); + ok !$res->is_finished, 'response is not finished'; + $res->parse(' '); + ok !$res->is_finished, 'response is not finished'; + $res->parse('O'); + ok !$res->is_finished, 'response is not finished'; + $res->parse('K'); + ok !$res->is_finished, 'response is not finished'; + $res->parse("\x0d"); + ok !$res->is_finished, 'response is not finished'; + $res->parse("\x0a"); + ok !$res->is_finished, 'response is not finished'; + $res->parse("\x0d"); + ok !$res->is_finished, 'response is not finished'; + $res->parse("\x0a"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; +}; + +subtest 'Parse HTTP 1.1 response start-line, no headers and body (no message)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200\x0d\x0a\x0d\x0a"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 200, 'right status'; + is $res->message, undef, 'no message'; + is $res->version, '1.1', 'right version'; +}; + +subtest 'Parse HTTP 1.0 response start-line and headers but no body' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 404 Damn it\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Content-Length: 0\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + is $res->code, 404, 'right status'; + is $res->message, 'Damn it', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, 0, 'right "Content-Length" value'; +}; -# Parse full HTTP 1.0 response (no limit) -{ +subtest 'Parse full HTTP 1.0 response' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Content-Length: 27\x0d\x0a\x0d\x0a"); + $res->parse("Hello World!\n1234\nlalalala\n"); + ok $res->is_finished, 'response is finished'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, 27, 'right "Content-Length" value'; + is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; +}; + +subtest 'Parse full HTTP 1.0 response (keep-alive)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); + $res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); + $res->parse("HTTP/1.0 200 OK\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->body, '', 'no content'; + is $res->content->leftovers, "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a", 'next response in leftovers'; +}; + +subtest 'Parse full HTTP 1.0 response (no limit)' => sub { local $ENV{MOJO_MAX_MESSAGE_SIZE} = 0; - $res = Mojo::Message::Response->new; + my $res = Mojo::Message::Response->new; is $res->max_message_size, 0, 'right size'; $res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); $res->parse("Content-Type: text/plain\x0d\x0a"); @@ -234,145 +244,153 @@ is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; is $res->headers->content_length, 27, 'right "Content-Length" value'; is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; -} +}; -# Parse broken start-line -$res = Mojo::Message::Response->new; -$res->parse("12345\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -is $res->error->{message}, 'Bad response start-line', 'right error'; - -# Parse full HTTP 1.0 response (missing Content-Length) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Connection: close\x0d\x0a\x0d\x0a"); -$res->parse("Hello World!\n1234\nlalalala\n"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, undef, 'no "Content-Length" value'; -is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; - -# Parse full HTTP 1.0 response (missing Content-Length and Connection) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a\x0d\x0a"); -$res->parse("Hello World!\n1"); -$res->parse("234\nlala"); -$res->parse("lala\n"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, undef, 'no "Content-Length" value'; -is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; - -# Parse full HTTP 1.1 response (missing Content-Length) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 500 Internal Server Error\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Connection: close\x0d\x0a\x0d\x0a"); -$res->parse("Hello World!\n1234\nlalalala\n"); -ok !$res->is_finished, 'response is not finished'; -ok !$res->is_empty, 'response is not empty'; -ok !$res->content->skip_body, 'body has not been skipped'; -ok $res->content->relaxed, 'relaxed response'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, undef, 'no "Content-Length" value'; -is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; - -# Parse full HTTP 1.1 response (broken Content-Length) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Content-Length: 123test\x0d\x0a\x0d\x0a"); -$res->parse('Hello World!'); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_length, '123test', 'right "Content-Length" value'; -is $res->body, '', 'no content'; -is $res->content->leftovers, 'Hello World!', 'content in leftovers'; - -# Parse full HTTP 1.1 response (100 Continue) -$res = Mojo::Message::Response->new; -$res->content->on(body => sub { shift->headers->header('X-Body' => 'one') }); -$res->on(progress => sub { shift->headers->header('X-Progress' => 'two') }); -$res->on(finish => sub { shift->headers->header('X-Finish' => 'three') }); -$res->parse("HTTP/1.1 100 Continue\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -ok $res->is_empty, 'response is empty'; -ok $res->content->skip_body, 'body has been skipped'; -is $res->code, 100, 'right status'; -is $res->message, 'Continue', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_length, undef, 'no "Content-Length" value'; -is $res->headers->header('X-Body'), 'one', 'right "X-Body" value'; -is $res->headers->header('X-Progress'), 'two', 'right "X-Progress" value'; -is $res->headers->header('X-Finish'), 'three', 'right "X-Finish" value'; -is $res->body, '', 'no content'; - -# Parse full HTTP 1.1 response (304 Not Modified) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 304 Not Modified\x0d\x0a"); -$res->parse("Content-Type: text/html\x0d\x0a"); -$res->parse("Content-Length: 9000\x0d\x0a"); -$res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -ok $res->is_empty, 'response is empty'; -ok $res->content->skip_body, 'body has been skipped'; -is $res->code, 304, 'right status'; -is $res->message, 'Not Modified', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/html', 'right "Content-Type" value'; -is $res->headers->content_length, 9000, 'right "Content-Length" value'; -is $res->headers->connection, 'keep-alive', 'right "Connection" value'; -is $res->body, '', 'no content'; - -# Parse full HTTP 1.1 response (204 No Content) -$res = Mojo::Message::Response->new; -$res->content->on(body => sub { shift->headers->header('X-Body' => 'one') }); -$res->on(finish => sub { shift->headers->header('X-Finish' => 'two') }); -$res->parse("HTTP/1.1 204 No Content\x0d\x0a"); -$res->parse("Content-Type: text/html\x0d\x0a"); -$res->parse("Content-Length: 9001\x0d\x0a"); -$res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -ok $res->is_empty, 'response is empty'; -ok $res->content->skip_body, 'body has been skipped'; -is $res->code, 204, 'right status'; -is $res->message, 'No Content', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/html', 'right "Content-Type" value'; -is $res->headers->content_length, 9001, 'right "Content-Length" value'; -is $res->headers->connection, 'keep-alive', 'right "Connection" value'; -is $res->headers->header('X-Body'), 'one', 'right "X-Body" value'; -is $res->headers->header('X-Finish'), 'two', 'right "X-Finish" value'; -is $res->body, '', 'no content'; - -# Parse HTTP 1.1 response (413 error in one big chunk) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 413 Request Entity Too Large\x0d\x0a" - . "Connection: Close\x0d\x0a" - . "Date: Tue, 09 Feb 2010 16:34:51 GMT\x0d\x0a" - . "Server: Mojolicious (Perl)\x0d\x0a\x0d\x0a"); -ok !$res->is_finished, 'response is not finished'; -is $res->code, 413, 'right status'; -is $res->message, 'Request Entity Too Large', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_length, undef, 'right "Content-Length" value'; +subtest 'Parse broken start-line' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("12345\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + is $res->error->{message}, 'Bad response start-line', 'right error'; +}; + +subtest 'Parse full HTTP 1.0 response (missing Content-Length)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Connection: close\x0d\x0a\x0d\x0a"); + $res->parse("Hello World!\n1234\nlalalala\n"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, undef, 'no "Content-Length" value'; + is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; +}; + +subtest 'Parse full HTTP 1.0 response (missing Content-Length and Connection)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 500 Internal Server Error\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a\x0d\x0a"); + $res->parse("Hello World!\n1"); + $res->parse("234\nlala"); + $res->parse("lala\n"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, undef, 'no "Content-Length" value'; + is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; +}; + +subtest 'Parse full HTTP 1.1 response (missing Content-Length)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 500 Internal Server Error\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Connection: close\x0d\x0a\x0d\x0a"); + $res->parse("Hello World!\n1234\nlalalala\n"); + ok !$res->is_finished, 'response is not finished'; + ok !$res->is_empty, 'response is not empty'; + ok !$res->content->skip_body, 'body has not been skipped'; + ok $res->content->relaxed, 'relaxed response'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, undef, 'no "Content-Length" value'; + is $res->body, "Hello World!\n1234\nlalalala\n", 'right content'; +}; + +subtest 'Parse full HTTP 1.1 response (broken Content-Length)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Content-Length: 123test\x0d\x0a\x0d\x0a"); + $res->parse('Hello World!'); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_length, '123test', 'right "Content-Length" value'; + is $res->body, '', 'no content'; + is $res->content->leftovers, 'Hello World!', 'content in leftovers'; +}; + +subtest 'Parse full HTTP 1.1 response (100 Continue)' => sub { + my $res = Mojo::Message::Response->new; + $res->content->on(body => sub { shift->headers->header('X-Body' => 'one') }); + $res->on(progress => sub { shift->headers->header('X-Progress' => 'two') }); + $res->on(finish => sub { shift->headers->header('X-Finish' => 'three') }); + $res->parse("HTTP/1.1 100 Continue\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + ok $res->is_empty, 'response is empty'; + ok $res->content->skip_body, 'body has been skipped'; + is $res->code, 100, 'right status'; + is $res->message, 'Continue', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_length, undef, 'no "Content-Length" value'; + is $res->headers->header('X-Body'), 'one', 'right "X-Body" value'; + is $res->headers->header('X-Progress'), 'two', 'right "X-Progress" value'; + is $res->headers->header('X-Finish'), 'three', 'right "X-Finish" value'; + is $res->body, '', 'no content'; +}; + +subtest 'Parse full HTTP 1.1 response (304 Not Modified)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 304 Not Modified\x0d\x0a"); + $res->parse("Content-Type: text/html\x0d\x0a"); + $res->parse("Content-Length: 9000\x0d\x0a"); + $res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + ok $res->is_empty, 'response is empty'; + ok $res->content->skip_body, 'body has been skipped'; + is $res->code, 304, 'right status'; + is $res->message, 'Not Modified', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/html', 'right "Content-Type" value'; + is $res->headers->content_length, 9000, 'right "Content-Length" value'; + is $res->headers->connection, 'keep-alive', 'right "Connection" value'; + is $res->body, '', 'no content'; +}; + +subtest 'Parse full HTTP 1.1 response (204 No Content)' => sub { + my $res = Mojo::Message::Response->new; + $res->content->on(body => sub { shift->headers->header('X-Body' => 'one') }); + $res->on(finish => sub { shift->headers->header('X-Finish' => 'two') }); + $res->parse("HTTP/1.1 204 No Content\x0d\x0a"); + $res->parse("Content-Type: text/html\x0d\x0a"); + $res->parse("Content-Length: 9001\x0d\x0a"); + $res->parse("Connection: keep-alive\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + ok $res->is_empty, 'response is empty'; + ok $res->content->skip_body, 'body has been skipped'; + is $res->code, 204, 'right status'; + is $res->message, 'No Content', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/html', 'right "Content-Type" value'; + is $res->headers->content_length, 9001, 'right "Content-Length" value'; + is $res->headers->connection, 'keep-alive', 'right "Connection" value'; + is $res->headers->header('X-Body'), 'one', 'right "X-Body" value'; + is $res->headers->header('X-Finish'), 'two', 'right "X-Finish" value'; + is $res->body, '', 'no content'; +}; + +subtest 'Parse HTTP 1.1 response (413 error in one big chunk)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 413 Request Entity Too Large\x0d\x0a" + . "Connection: Close\x0d\x0a" + . "Date: Tue, 09 Feb 2010 16:34:51 GMT\x0d\x0a" + . "Server: Mojolicious (Perl)\x0d\x0a\x0d\x0a"); + ok !$res->is_finished, 'response is not finished'; + is $res->code, 413, 'right status'; + is $res->message, 'Request Entity Too Large', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_length, undef, 'right "Content-Length" value'; +}; -# Parse HTTP 1.1 chunked response (exceeding limit) -{ +subtest 'Parse HTTP 1.1 chunked response (exceeding limit)' => sub { local $ENV{MOJO_MAX_BUFFER_SIZE} = 12; - $res = Mojo::Message::Response->new; + my $res = Mojo::Message::Response->new; is $res->content->max_buffer_size, 12, 'right size'; $res->parse("HTTP/1.1 200 OK\x0d\x0a"); $res->parse("Content-Type: text/plain\x0d\x0a"); @@ -387,12 +405,11 @@ is $res->message, 'OK', 'right message'; is $res->version, '1.1', 'right version'; is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -} +}; -# Parse HTTP 1.1 multipart response (exceeding limit) -{ +subtest 'Parse HTTP 1.1 multipart response (exceeding limit)' => sub { local $ENV{MOJO_MAX_BUFFER_SIZE} = 12; - $res = Mojo::Message::Response->new; + my $res = Mojo::Message::Response->new; is $res->content->max_buffer_size, 12, 'right size'; $res->parse("HTTP/1.1 200 OK\x0d\x0a"); $res->parse("Content-Length: 420\x0d\x0a"); @@ -409,12 +426,11 @@ is $res->version, '1.1', 'right version'; is $res->headers->content_type, 'multipart/form-data; boundary=----------0xKhTmLbOuNdArY', 'right "Content-Type" value'; -} +}; -# Parse HTTP 1.1 gzip compressed response (garbage bytes exceeding limit) -{ +subtest 'Parse HTTP 1.1 gzip compressed response (garbage bytes exceeding limit)' => sub { local $ENV{MOJO_MAX_BUFFER_SIZE} = 12; - $res = Mojo::Message::Response->new; + my $res = Mojo::Message::Response->new; is $res->content->max_buffer_size, 12, 'right size'; $res->parse("HTTP/1.1 200 OK\x0d\x0a"); $res->parse("Content-Length: 1000\x0d\x0a"); @@ -430,638 +446,673 @@ is $res->message, 'OK', 'right message'; is $res->version, '1.1', 'right version'; is $res->body, '', 'no content'; -} +}; + +subtest 'Parse HTTP 1.1 chunked response' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 500 Internal Server Error\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Transfer-Encoding: chunked\x0d\x0a\x0d\x0a"); + $res->parse("4\x0d\x0a"); + $res->parse("abcd\x0d\x0a"); + $res->parse("9\x0d\x0a"); + $res->parse("abcdefghi\x0d\x0a"); + $res->parse("0\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + is $res->code, 500, 'right status'; + is $res->message, 'Internal Server Error', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, 13, 'right "Content-Length" value'; + is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; + is $res->body_size, 13, 'right size'; +}; + +subtest 'Parse HTTP 1.1 multipart response' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Content-Length: 420\x0d\x0a"); + $res->parse('Content-Type: multipart/form-data; bo'); + $res->parse("undary=----------0xKhTmLbOuNdArY\x0d\x0a\x0d\x0a"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse("Content-Disposition: form-data; name=\"text1\"\x0d\x0a"); + $res->parse("\x0d\x0ahallo welt test123\n"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse("Content-Disposition: form-data; name=\"text2\"\x0d\x0a"); + $res->parse("\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse('Content-Disposition: form-data; name="upload"; file'); + $res->parse("name=\"hello.pl\"\x0d\x0a\x0d\x0a"); + $res->parse("Content-Type: application/octet-stream\x0d\x0a\x0d\x0a"); + $res->parse("#!/usr/bin/perl\n\n"); + $res->parse("use strict;\n"); + $res->parse("use warnings;\n\n"); + $res->parse("print \"Hello World :)\\n\"\n"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY--"); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'multipart/form-data; boundary=----------0xKhTmLbOuNdArY', + 'right "Content-Type" value'; + ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; + ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; + ok !$res->content->parts->[2]->is_multipart, 'no multipart content'; + is $res->content->parts->[0]->asset->slurp, "hallo welt test123\n", 'right content'; + + my $dir = tempdir; + my $file = $dir->child('multipart.html'); + eval { $res->save_to($file) }; + like $@, qr/^Multipart content cannot be saved to files/, 'right error'; +}; + +subtest 'Parse HTTP 1.1 chunked multipart response with leftovers (at once)' => sub { + my $res = Mojo::Message::Response->new; + my $multipart + = "HTTP/1.1 200 OK\x0d\x0a" + . "Transfer-Encoding: chunked\x0d\x0a" + . 'Content-Type: multipart/form-data; bo' + . "undary=----------0xKhTmLbOuNdArY\x0d\x0a\x0d\x0a" + . "19f\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" + . "Content-Disposition: form-data; name=\"text1\"\x0d\x0a" + . "\x0d\x0ahallo welt test123\n" + . "\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" + . "Content-Disposition: form-data; name=\"text2\"\x0d\x0a" + . "\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" + . 'Content-Disposition: form-data; name="upload"; file' + . "name=\"hello.pl\"\x0d\x0a" + . "Content-Type: application/octet-stream\x0d\x0a\x0d\x0a" + . "#!/usr/bin/perl\n\n" + . "use strict;\n" + . "use warnings;\n\n" + . "print \"Hello World :)\\n\"\n" + . "\x0d\x0a------------0xKhTmLbOuNdA" + . "r\x0d\x0a3\x0d\x0aY--\x0d\x0a" + . "0\x0d\x0a\x0d\x0a" + . "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a"; + $res->parse($multipart); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'multipart/form-data; boundary=----------0xKhTmLbOuNdArY', + 'right "Content-Type" value'; + is $res->headers->content_length, 418, 'right "Content-Length" value'; + is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; + is $res->body_size, 418, 'right size'; + ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; + ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; + ok !$res->content->parts->[2]->is_multipart, 'no multipart content'; + is $res->content->parts->[0]->asset->slurp, "hallo welt test123\n", 'right content'; + is $res->upload('upload')->filename, 'hello.pl', 'right filename'; + ok !$res->upload('upload')->asset->is_file, 'stored in memory'; + is $res->upload('upload')->asset->size, 69, 'right size'; + is $res->content->parts->[2]->headers->content_type, 'application/octet-stream', 'right "Content-Type" value'; + is $res->content->leftovers, "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a", 'next response in leftovers'; +}; + +subtest 'Parse HTTP 1.1 chunked multipart response (in multiple small chunks)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Transfer-Encoding: chunked\x0d\x0a"); + $res->parse('Content-Type: multipart/parallel; boundary=AAA; charset=utf-8'); + $res->parse("\x0d\x0a\x0d\x0a"); + $res->parse("7\x0d\x0a"); + $res->parse("--AAA\x0d\x0a"); + $res->parse("\x0d\x0a1a\x0d\x0a"); + $res->parse("Content-Type: image/jpeg\x0d\x0a"); + $res->parse("\x0d\x0a16\x0d\x0a"); + $res->parse("Content-ID: 600050\x0d\x0a\x0d\x0a"); + $res->parse("\x0d"); + $res->parse("\x0a6"); + $res->parse("\x0d\x0aabcd\x0d\x0a"); + $res->parse("\x0d\x0a7\x0d\x0a"); + $res->parse("--AAA\x0d\x0a"); + $res->parse("\x0d\x0a1a\x0d\x0a"); + $res->parse("Content-Type: image/jpeg\x0d\x0a"); + $res->parse("\x0d\x0a16\x0d\x0a"); + $res->parse("Content-ID: 600051\x0d\x0a\x0d\x0a"); + $res->parse("\x0d\x0a6\x0d\x0a"); + $res->parse("efgh\x0d\x0a"); + $res->parse("\x0d\x0a7\x0d\x0a"); + $res->parse('--AAA--'); + ok !$res->is_finished, 'response is not finished'; + $res->parse("\x0d\x0a0\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'multipart/parallel; boundary=AAA; charset=utf-8', 'right "Content-Type" value'; + is $res->headers->content_length, 129, 'right "Content-Length" value'; + is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; + is $res->body_size, 129, 'right size'; + ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; + ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; + is $res->content->parts->[0]->asset->slurp, 'abcd', 'right content'; + is $res->content->parts->[0]->headers->content_type, 'image/jpeg', 'right "Content-Type" value'; + is $res->content->parts->[0]->headers->header('Content-ID'), 600050, 'right "Content-ID" value'; + is $res->content->parts->[1]->asset->slurp, 'efgh', 'right content'; + is $res->content->parts->[1]->headers->content_type, 'image/jpeg', 'right "Content-Type" value'; + is $res->content->parts->[1]->headers->header('Content-ID'), 600051, 'right "Content-ID" value'; +}; -# Parse HTTP 1.1 chunked response -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 500 Internal Server Error\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Transfer-Encoding: chunked\x0d\x0a\x0d\x0a"); -$res->parse("4\x0d\x0a"); -$res->parse("abcd\x0d\x0a"); -$res->parse("9\x0d\x0a"); -$res->parse("abcdefghi\x0d\x0a"); -$res->parse("0\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -is $res->code, 500, 'right status'; -is $res->message, 'Internal Server Error', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, 13, 'right "Content-Length" value'; -is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; -is $res->body_size, 13, 'right size'; - -# Parse HTTP 1.1 multipart response -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Content-Length: 420\x0d\x0a"); -$res->parse('Content-Type: multipart/form-data; bo'); -$res->parse("undary=----------0xKhTmLbOuNdArY\x0d\x0a\x0d\x0a"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse("Content-Disposition: form-data; name=\"text1\"\x0d\x0a"); -$res->parse("\x0d\x0ahallo welt test123\n"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse("Content-Disposition: form-data; name=\"text2\"\x0d\x0a"); -$res->parse("\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse('Content-Disposition: form-data; name="upload"; file'); -$res->parse("name=\"hello.pl\"\x0d\x0a\x0d\x0a"); -$res->parse("Content-Type: application/octet-stream\x0d\x0a\x0d\x0a"); -$res->parse("#!/usr/bin/perl\n\n"); -$res->parse("use strict;\n"); -$res->parse("use warnings;\n\n"); -$res->parse("print \"Hello World :)\\n\"\n"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY--"); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'multipart/form-data; boundary=----------0xKhTmLbOuNdArY', 'right "Content-Type" value'; -ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; -ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; -ok !$res->content->parts->[2]->is_multipart, 'no multipart content'; -is $res->content->parts->[0]->asset->slurp, "hallo welt test123\n", 'right content'; -my $dir = tempdir; -my $file = $dir->child('multipart.html'); -eval { $res->save_to($file) }; -like $@, qr/^Multipart content cannot be saved to files/, 'right error'; - -# Parse HTTP 1.1 chunked multipart response with leftovers (at once) -$res = Mojo::Message::Response->new; -my $multipart - = "HTTP/1.1 200 OK\x0d\x0a" - . "Transfer-Encoding: chunked\x0d\x0a" - . 'Content-Type: multipart/form-data; bo' - . "undary=----------0xKhTmLbOuNdArY\x0d\x0a\x0d\x0a" - . "19f\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" - . "Content-Disposition: form-data; name=\"text1\"\x0d\x0a" - . "\x0d\x0ahallo welt test123\n" - . "\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" - . "Content-Disposition: form-data; name=\"text2\"\x0d\x0a" - . "\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a" - . 'Content-Disposition: form-data; name="upload"; file' - . "name=\"hello.pl\"\x0d\x0a" - . "Content-Type: application/octet-stream\x0d\x0a\x0d\x0a" - . "#!/usr/bin/perl\n\n" - . "use strict;\n" - . "use warnings;\n\n" - . "print \"Hello World :)\\n\"\n" - . "\x0d\x0a------------0xKhTmLbOuNdA" - . "r\x0d\x0a3\x0d\x0aY--\x0d\x0a" - . "0\x0d\x0a\x0d\x0a" - . "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a"; -$res->parse($multipart); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'multipart/form-data; boundary=----------0xKhTmLbOuNdArY', 'right "Content-Type" value'; -is $res->headers->content_length, 418, 'right "Content-Length" value'; -is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; -is $res->body_size, 418, 'right size'; -ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; -ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; -ok !$res->content->parts->[2]->is_multipart, 'no multipart content'; -is $res->content->parts->[0]->asset->slurp, "hallo welt test123\n", 'right content'; -is $res->upload('upload')->filename, 'hello.pl', 'right filename'; -ok !$res->upload('upload')->asset->is_file, 'stored in memory'; -is $res->upload('upload')->asset->size, 69, 'right size'; -is $res->content->parts->[2]->headers->content_type, 'application/octet-stream', 'right "Content-Type" value'; -is $res->content->leftovers, "HTTP/1.0 200 OK\x0d\x0a\x0d\x0a", 'next response in leftovers'; - -# Parse HTTP 1.1 chunked multipart response (in multiple small chunks) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Transfer-Encoding: chunked\x0d\x0a"); -$res->parse('Content-Type: multipart/parallel; boundary=AAA; charset=utf-8'); -$res->parse("\x0d\x0a\x0d\x0a"); -$res->parse("7\x0d\x0a"); -$res->parse("--AAA\x0d\x0a"); -$res->parse("\x0d\x0a1a\x0d\x0a"); -$res->parse("Content-Type: image/jpeg\x0d\x0a"); -$res->parse("\x0d\x0a16\x0d\x0a"); -$res->parse("Content-ID: 600050\x0d\x0a\x0d\x0a"); -$res->parse("\x0d"); -$res->parse("\x0a6"); -$res->parse("\x0d\x0aabcd\x0d\x0a"); -$res->parse("\x0d\x0a7\x0d\x0a"); -$res->parse("--AAA\x0d\x0a"); -$res->parse("\x0d\x0a1a\x0d\x0a"); -$res->parse("Content-Type: image/jpeg\x0d\x0a"); -$res->parse("\x0d\x0a16\x0d\x0a"); -$res->parse("Content-ID: 600051\x0d\x0a\x0d\x0a"); -$res->parse("\x0d\x0a6\x0d\x0a"); -$res->parse("efgh\x0d\x0a"); -$res->parse("\x0d\x0a7\x0d\x0a"); -$res->parse('--AAA--'); -ok !$res->is_finished, 'response is not finished'; -$res->parse("\x0d\x0a0\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'multipart/parallel; boundary=AAA; charset=utf-8', 'right "Content-Type" value'; -is $res->headers->content_length, 129, 'right "Content-Length" value'; -is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; -is $res->body_size, 129, 'right size'; -ok !$res->content->parts->[0]->is_multipart, 'no multipart content'; -ok !$res->content->parts->[1]->is_multipart, 'no multipart content'; -is $res->content->parts->[0]->asset->slurp, 'abcd', 'right content'; -is $res->content->parts->[0]->headers->content_type, 'image/jpeg', 'right "Content-Type" value'; -is $res->content->parts->[0]->headers->header('Content-ID'), 600050, 'right "Content-ID" value'; -is $res->content->parts->[1]->asset->slurp, 'efgh', 'right content'; -is $res->content->parts->[1]->headers->content_type, 'image/jpeg', 'right "Content-Type" value'; -is $res->content->parts->[1]->headers->header('Content-ID'), 600051, 'right "Content-ID" value'; - -# Parse HTTP 1.1 multipart response with missing boundary -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Content-Length: 420\x0d\x0a"); -$res->parse("Content-Type: multipart/form-data; bo\x0d\x0a\x0d\x0a"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse("Content-Disposition: form-data; name=\"text1\"\x0d\x0a"); -$res->parse("\x0d\x0ahallo welt test123\n"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse("Content-Disposition: form-data; name=\"text2\"\x0d\x0a"); -$res->parse("\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); -$res->parse('Content-Disposition: form-data; name="upload"; file'); -$res->parse("name=\"hello.pl\"\x0d\x0a\x0d\x0a"); -$res->parse("Content-Type: application/octet-stream\x0d\x0a\x0d\x0a"); -$res->parse("#!/usr/bin/perl\n\n"); -$res->parse("use strict;\n"); -$res->parse("use warnings;\n\n"); -$res->parse("print \"Hello World :)\\n\"\n"); -$res->parse("\x0d\x0a------------0xKhTmLbOuNdArY--"); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'multipart/form-data; bo', 'right "Content-Type" value'; -ok !$res->content->is_multipart, 'no multipart content'; -like $res->content->asset->slurp, qr/hallo welt/, 'right content'; - -# Parse HTTP 1.1 gzip compressed response -my $uncompressed = 'abc' x 1000; -my $compressed = gzip $uncompressed; -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Content-Length: @{[length $compressed]}\x0d\x0a"); -$res->parse("Content-Encoding: GZip\x0d\x0a\x0d\x0a"); -ok $res->content->is_compressed, 'content is compressed'; -is $res->content->progress, 0, 'right progress'; -$res->parse(substr($compressed, 0, 1)); -is $res->content->progress, 1, 'right progress'; -$res->parse(substr($compressed, 1, length($compressed))); -is $res->content->progress, length($compressed), 'right progress'; -ok !$res->content->is_compressed, 'content is not compressed anymore'; -ok $res->is_finished, 'response is finished'; -ok !$res->error, 'no error'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, length($uncompressed), 'right "Content-Length" value'; -is $res->headers->content_encoding, undef, 'no "Content-Encoding" value'; -is $res->body, $uncompressed, 'right content'; - -# Parse HTTP 1.1 chunked gzip compressed response -$uncompressed = 'abc' x 1000; -$compressed = undef; -$compressed = gzip $uncompressed; -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Content-Encoding: gzip\x0d\x0a"); -$res->parse("Transfer-Encoding: chunked\x0d\x0a\x0d\x0a"); -ok $res->content->is_chunked, 'content is chunked'; -ok $res->content->is_compressed, 'content is compressed'; -$res->parse("1\x0d\x0a"); -$res->parse(substr($compressed, 0, 1)); -$res->parse("\x0d\x0a"); -$res->parse(sprintf('%x', length($compressed) - 1)); -$res->parse("\x0d\x0a"); -$res->parse(substr($compressed, 1, length($compressed) - 1)); -$res->parse("\x0d\x0a"); -$res->parse("0\x0d\x0a\x0d\x0a"); -ok !$res->content->is_chunked, 'content is not chunked anymore'; -ok !$res->content->is_compressed, 'content is not compressed anymore'; -ok $res->is_finished, 'response is finished'; -ok !$res->error, 'no error'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, length($uncompressed), 'right "Content-Length" value'; -is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; -is $res->headers->content_encoding, undef, 'no "Content-Encoding" value'; -is $res->body, $uncompressed, 'right content'; - -# Build HTTP 1.1 response start-line with minimal headers -$res = Mojo::Message::Response->new; -$res->code(404); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, '404', 'right status'; -is $res->message, 'Not Found', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; -is $res->headers->content_length, 0, 'right "Content-Length" value'; - -# Build HTTP 1.1 response start-line with minimal headers (strange message) -$res = Mojo::Message::Response->new; -$res->code(404); -$res->message('Looks-0k!@ ;\':" #$%^<>,.\\o/ &*()'); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, '404', 'right status'; -is $res->message, 'Looks-0k!@ ;\':" #$%^<>,.\\o/ &*()', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; -is $res->headers->content_length, 0, 'right "Content-Length" value'; - -# Build HTTP 1.1 response start-line and header -$res = Mojo::Message::Response->new; -$res->code(200); -$res->headers->connection('keep-alive'); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, '200', 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->connection, 'keep-alive', 'right "Connection" value'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; - -# Build full HTTP 1.1 response -$res = Mojo::Message::Response->new; -$res->code(200); -$res->headers->connection('keep-alive'); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res->body("Hello World!\n"); -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, '200', 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->connection, 'keep-alive', 'right "Connection" value'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; -is $res->headers->content_length, '13', 'right "Content-Length" value'; -is $res->body, "Hello World!\n", 'right content'; - -# Build HTTP 1.1 response parts with progress -$res = Mojo::Message::Response->new; -my ($finished, $state, $progress); -$res->on(finish => sub { $finished = shift->is_finished }); -$res->on( - progress => sub { - my ($res, $part, $offset) = @_; - $state = $part; - $progress += $offset; +subtest 'Parse HTTP 1.1 multipart response with missing boundary' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Content-Length: 420\x0d\x0a"); + $res->parse("Content-Type: multipart/form-data; bo\x0d\x0a\x0d\x0a"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse("Content-Disposition: form-data; name=\"text1\"\x0d\x0a"); + $res->parse("\x0d\x0ahallo welt test123\n"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse("Content-Disposition: form-data; name=\"text2\"\x0d\x0a"); + $res->parse("\x0d\x0a\x0d\x0a------------0xKhTmLbOuNdArY\x0d\x0a"); + $res->parse('Content-Disposition: form-data; name="upload"; file'); + $res->parse("name=\"hello.pl\"\x0d\x0a\x0d\x0a"); + $res->parse("Content-Type: application/octet-stream\x0d\x0a\x0d\x0a"); + $res->parse("#!/usr/bin/perl\n\n"); + $res->parse("use strict;\n"); + $res->parse("use warnings;\n\n"); + $res->parse("print \"Hello World :)\\n\"\n"); + $res->parse("\x0d\x0a------------0xKhTmLbOuNdArY--"); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'multipart/form-data; bo', 'right "Content-Type" value'; + ok !$res->content->is_multipart, 'no multipart content'; + like $res->content->asset->slurp, qr/hallo welt/, 'right content'; +}; + +subtest 'Parse HTTP 1.1 gzip compressed response' => sub { + my $uncompressed = 'abc' x 1000; + my $compressed = gzip $uncompressed; + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Content-Length: @{[length $compressed]}\x0d\x0a"); + $res->parse("Content-Encoding: GZip\x0d\x0a\x0d\x0a"); + ok $res->content->is_compressed, 'content is compressed'; + is $res->content->progress, 0, 'right progress'; + $res->parse(substr($compressed, 0, 1)); + is $res->content->progress, 1, 'right progress'; + $res->parse(substr($compressed, 1, length($compressed))); + is $res->content->progress, length($compressed), 'right progress'; + ok !$res->content->is_compressed, 'content is not compressed anymore'; + ok $res->is_finished, 'response is finished'; + ok !$res->error, 'no error'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, length($uncompressed), 'right "Content-Length" value'; + is $res->headers->content_encoding, undef, 'no "Content-Encoding" value'; + is $res->body, $uncompressed, 'right content'; +}; + +subtest 'Parse HTTP 1.1 chunked gzip compressed response' => sub { + my $uncompressed = 'abc' x 1000; + my $compressed = undef; + $compressed = gzip $uncompressed; + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Content-Encoding: gzip\x0d\x0a"); + $res->parse("Transfer-Encoding: chunked\x0d\x0a\x0d\x0a"); + ok $res->content->is_chunked, 'content is chunked'; + ok $res->content->is_compressed, 'content is compressed'; + $res->parse("1\x0d\x0a"); + $res->parse(substr($compressed, 0, 1)); + $res->parse("\x0d\x0a"); + $res->parse(sprintf('%x', length($compressed) - 1)); + $res->parse("\x0d\x0a"); + $res->parse(substr($compressed, 1, length($compressed) - 1)); + $res->parse("\x0d\x0a"); + $res->parse("0\x0d\x0a\x0d\x0a"); + ok !$res->content->is_chunked, 'content is not chunked anymore'; + ok !$res->content->is_compressed, 'content is not compressed anymore'; + ok $res->is_finished, 'response is finished'; + ok !$res->error, 'no error'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, length($uncompressed), 'right "Content-Length" value'; + is $res->headers->transfer_encoding, undef, 'no "Transfer-Encoding" value'; + is $res->headers->content_encoding, undef, 'no "Content-Encoding" value'; + is $res->body, $uncompressed, 'right content'; +}; + +subtest 'Build HTTP 1.1 response start-line with minimal headers' => sub { + my $res = Mojo::Message::Response->new; + $res->code(404); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, '404', 'right status'; + is $res->message, 'Not Found', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; + is $res->headers->content_length, 0, 'right "Content-Length" value'; +}; + +subtest 'Build HTTP 1.1 response start-line with minimal headers (strange message)' => sub { + my $res = Mojo::Message::Response->new; + $res->code(404); + $res->message('Looks-0k!@ ;\':" #$%^<>,.\\o/ &*()'); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, '404', 'right status'; + is $res->message, 'Looks-0k!@ ;\':" #$%^<>,.\\o/ &*()', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; + is $res->headers->content_length, 0, 'right "Content-Length" value'; +}; + +subtest 'Build HTTP 1.1 response start-line and header' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + $res->headers->connection('keep-alive'); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, '200', 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->connection, 'keep-alive', 'right "Connection" value'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; +}; + +subtest 'Build full HTTP 1.1 response' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + $res->headers->connection('keep-alive'); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res->body("Hello World!\n"); + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, '200', 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->connection, 'keep-alive', 'right "Connection" value'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; + is $res->headers->content_length, '13', 'right "Content-Length" value'; + is $res->body, "Hello World!\n", 'right content'; +}; + +subtest 'Build HTTP 1.1 response parts with progress' => sub { + my $res = Mojo::Message::Response->new; + my ($finished, $state, $progress); + $res->on(finish => sub { $finished = shift->is_finished }); + $res->on( + progress => sub { + my ($res, $part, $offset) = @_; + $state = $part; + $progress += $offset; + } + ); + $res->code(200); + $res->headers->connection('keep-alive'); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res->body("Hello World!\n"); + ok !$state, 'no state'; + ok !$progress, 'no progress'; + ok !$finished, 'not finished'; + ok $res->build_start_line, 'built start-line'; + is $state, 'start_line', 'made progress on start_line'; + ok $progress, 'made progress'; + $progress = 0; + ok !$finished, 'not finished'; + ok $res->build_headers, 'built headers'; + is $state, 'headers', 'made progress on headers'; + ok $progress, 'made progress'; + $progress = 0; + ok !$finished, 'not finished'; + ok $res->build_body, 'built body'; + is $state, 'body', 'made progress on headers'; + ok $progress, 'made progress'; + ok $finished, 'finished'; +}; + +subtest 'Build HTTP 1.1 response with dynamic content' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + $res->content->write_chunk( + 'Hello ' => sub { + shift->write_chunk(undef, sub { shift->write_chunk('World!')->write_chunk('') }); + } + ); + ok $res->content->is_dynamic, 'dynamic content'; + $res = Mojo::Message::Response->new->parse($res->to_string); + ok !$res->content->is_dynamic, 'no dynamic content'; + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->content_length, '12', 'right "Content-Length" value'; + is $res->body, 'Hello World!', 'right content'; +}; + +subtest 'Build HTTP 1.1 multipart response' => sub { + my $res = Mojo::Message::Response->new; + $res->content(Mojo::Content::MultiPart->new); + $res->code(200); + $res->headers->content_type('multipart/mixed; boundary=7am1X'); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + push @{$res->content->parts}, Mojo::Content::Single->new(asset => Mojo::Asset::File->new); + $res->content->parts->[-1]->asset->add_chunk('Hallo Welt lalalalalala!'); + my $content = Mojo::Content::Single->new; + $content->asset->add_chunk("lala\nfoobar\nperl rocks\n"); + $content->headers->content_type('text/plain'); + push @{$res->content->parts}, $content; + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; + is $res->headers->content_length, '110', 'right "Content-Length" value'; + is $res->headers->content_type, 'multipart/mixed; boundary=7am1X', 'right "Content-Type" value'; + is $res->content->parts->[0]->asset->slurp, 'Hallo Welt lalalalalala!', 'right content'; + is $res->content->parts->[1]->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->content->parts->[1]->asset->slurp, "lala\nfoobar\nperl rocks\n", 'right content'; +}; + +subtest 'Parse response with cookie' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 200 OK\x0d\x0a"); + $res->parse("Content-Type: text/plain\x0d\x0a"); + $res->parse("Content-Length: 27\x0d\x0a"); + $res->parse("Set-Cookie: foo=bar; path=/test\x0d\x0a\x0d\x0a"); + $res->parse("Hello World!\n1234\nlalalala\n"); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.0', 'right version'; + is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; + is $res->headers->content_length, 27, 'right "Content-Length" value'; + is $res->headers->set_cookie, 'foo=bar; path=/test', 'right "Set-Cookie" value'; + my $cookies = $res->cookies; + is $cookies->[0]->name, 'foo', 'right name'; + is $cookies->[0]->value, 'bar', 'right value'; + is $cookies->[0]->path, '/test', 'right path'; + is $res->cookie('foo')->value, 'bar', 'right value'; + is $res->cookie('foo')->path, '/test', 'right path'; +}; + +subtest 'Parse WebSocket handshake response' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 101 Switching Protocols\x0d\x0a"); + $res->parse("Upgrade: websocket\x0d\x0a"); + $res->parse("Connection: Upgrade\x0d\x0a"); + $res->parse("Sec-WebSocket-Accept: abcdef=\x0d\x0a"); + $res->parse("Sec-WebSocket-Protocol: sample\x0d\x0a\x0d\x0a"); + ok $res->is_finished, 'response is finished'; + ok $res->is_empty, 'response is empty'; + ok $res->content->skip_body, 'body has been skipped'; + is $res->code, 101, 'right status'; + is $res->message, 'Switching Protocols', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; + is $res->headers->connection, 'Upgrade', 'right "Connection" value'; + is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; + is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; + is $res->body, '', 'no content'; + ok !defined $res->headers->content_length, '"Content-Length" does not exist'; +}; + +subtest 'Parse WebSocket handshake response (with frame)' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 101 Switching Protocols\x0d\x0a"); + $res->parse("Upgrade: websocket\x0d\x0a"); + $res->parse("Connection: Upgrade\x0d\x0a"); + $res->parse("Sec-WebSocket-Accept: abcdef=\x0d\x0a"); + $res->parse("Sec-WebSocket-Protocol: sample\x0d\x0a"); + $res->parse("\x0d\x0a\x81\x08\x77\x68\x61\x74\x65\x76\x65\x72"); + ok $res->is_finished, 'response is finished'; + ok $res->is_empty, 'response is empty'; + ok $res->content->skip_body, 'body has been skipped'; + is $res->code, 101, 'right status'; + is $res->message, 'Switching Protocols', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; + is $res->headers->connection, 'Upgrade', 'right "Connection" value'; + is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; + is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; + is $res->body, '', 'no content'; + is $res->content->leftovers, "\x81\x08\x77\x68\x61\x74\x65\x76\x65\x72", 'frame in leftovers'; + ok !defined $res->headers->content_length, '"Content-Length" does not exist'; +}; + +subtest 'Build WebSocket handshake response' => sub { + my $res = Mojo::Message::Response->new; + $res->code(101); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res->headers->upgrade('websocket'); + $res->headers->connection('Upgrade'); + $res->headers->sec_websocket_accept('abcdef='); + $res->headers->sec_websocket_protocol('sample'); + $res = Mojo::Message::Response->new->parse($res->to_string); + ok $res->is_finished, 'response is finished'; + is $res->code, '101', 'right status'; + is $res->message, 'Switching Protocols', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->headers->connection, 'Upgrade', 'right "Connection" value'; + is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; + ok !defined $res->headers->content_length, '"Content-Length" does not exist'; + is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; + is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; + is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; + is $res->body, '', 'no content'; + ok !defined $res->headers->content_length, '"Content-Length" does not exist'; +}; + +subtest 'Build and parse HTTP 1.1 response with 3 cookies' => sub { + my $res = Mojo::Message::Response->new; + $res->code(404); + $res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); + $res->cookies({name => 'foo', value => 'bar', path => '/foobar'}, + {name => 'bar', value => 'baz', path => '/test/23'}); + $res->cookies({name => 'baz', value => 'yada', path => '/foobar'}); + ok !!$res->to_string, 'message built'; + my $res2 = Mojo::Message::Response->new; + $res2->parse($res->to_string); + ok $res2->is_finished, 'response is finished'; + is $res2->code, 404, 'right status'; + is $res2->version, '1.1', 'right version'; + is $res2->headers->content_length, 0, 'right "Content-Length" value'; + ok defined $res2->cookie('foo'), 'cookie "foo" exists'; + ok defined $res2->cookie('bar'), 'cookie "bar" exists'; + ok defined $res2->cookie('baz'), 'cookie "baz" exists'; + ok !defined $res2->cookie('yada'), 'cookie "yada" does not exist'; + is $res2->cookie('foo')->path, '/foobar', 'right path'; + is $res2->cookie('foo')->value, 'bar', 'right value'; + is $res2->cookie('bar')->path, '/test/23', 'right path'; + is $res2->cookie('bar')->value, 'baz', 'right value'; + is $res2->cookie('baz')->path, '/foobar', 'right path'; + is $res2->cookie('baz')->value, 'yada', 'right value'; +}; + +subtest 'Build chunked response body' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + my $invocant; + $res->content->write_chunk('hello!' => sub { $invocant = shift }); + $res->content->write_chunk('hello world!')->write_chunk(''); + ok $res->content->is_chunked, 'chunked content'; + ok $res->content->is_dynamic, 'dynamic content'; + is $res->build_body, "6\x0d\x0ahello!\x0d\x0ac\x0d\x0ahello world!\x0d\x0a0\x0d\x0a\x0d\x0a", 'right format'; + isa_ok $invocant, 'Mojo::Content::Single', 'right invocant'; +}; + +subtest 'Build dynamic response body' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + my $invocant; + $res->content->write('hello!' => sub { $invocant = shift }); + $res->content->write('hello world!')->write(''); + ok !$res->content->is_chunked, 'no chunked content'; + ok $res->content->is_dynamic, 'dynamic content'; + is $res->build_body, "hello!hello world!", 'right format'; + isa_ok $invocant, 'Mojo::Content::Single', 'right invocant'; +}; + +subtest 'Build response with callback (make sure it is called)' => sub { + my $res = Mojo::Message::Response->new; + $res->code(200); + $res->headers->content_length(10); + $res->content->write('lala' => sub { die "Body callback was called properly\n" }); + $res->get_body_chunk(0); + eval { $res->get_body_chunk(3) }; + is $@, "Body callback was called properly\n", 'right error'; +}; + +subtest 'Build response with callback (consistency calls)' => sub { + my $res = Mojo::Message::Response->new; + my $body = 'I is here'; + $res->headers->content_length(length($body)); + my $cb = sub { shift->write(substr($body, pop, 1), __SUB__) }; + $res->content->write('' => $cb); + my $full = ''; + my $count = 0; + my $offset = 0; + + while (1) { + my $chunk = $res->get_body_chunk($offset); + last unless $chunk; + $full .= $chunk; + $offset = length($full); + $count++; } -); -$res->code(200); -$res->headers->connection('keep-alive'); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res->body("Hello World!\n"); -ok !$state, 'no state'; -ok !$progress, 'no progress'; -ok !$finished, 'not finished'; -ok $res->build_start_line, 'built start-line'; -is $state, 'start_line', 'made progress on start_line'; -ok $progress, 'made progress'; -$progress = 0; -ok !$finished, 'not finished'; -ok $res->build_headers, 'built headers'; -is $state, 'headers', 'made progress on headers'; -ok $progress, 'made progress'; -$progress = 0; -ok !$finished, 'not finished'; -ok $res->build_body, 'built body'; -is $state, 'body', 'made progress on headers'; -ok $progress, 'made progress'; -ok $finished, 'finished'; - -# Build HTTP 1.1 response with dynamic content -$res = Mojo::Message::Response->new; -$res->code(200); -$res->content->write_chunk( - 'Hello ' => sub { - shift->write_chunk(undef, sub { shift->write_chunk('World!')->write_chunk('') }); + $res->fix_headers; + is $res->headers->connection, undef, 'no "Connection" value'; + ok $res->content->is_dynamic, 'dynamic content'; + is $count, length($body), 'right length'; + is $full, $body, 'right content'; +}; + +subtest 'Build response with callback (no Content-Length header)' => sub { + my $res = Mojo::Message::Response->new; + my $body = 'I is here'; + my $cb; + $cb = sub { shift->write(substr($body, pop, 1), $cb) }; + $res->content->write('' => $cb); + $res->fix_headers; + my $full = ''; + my $count = 0; + my $offset = 0; + + while (1) { + my $chunk = $res->get_body_chunk($offset); + last unless $chunk; + $full .= $chunk; + $offset = length($full); + $count++; } -); -ok $res->content->is_dynamic, 'dynamic content'; -$res = Mojo::Message::Response->new->parse($res->to_string); -ok !$res->content->is_dynamic, 'no dynamic content'; -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->content_length, '12', 'right "Content-Length" value'; -is $res->body, 'Hello World!', 'right content'; - -# Build HTTP 1.1 multipart response -$res = Mojo::Message::Response->new; -$res->content(Mojo::Content::MultiPart->new); -$res->code(200); -$res->headers->content_type('multipart/mixed; boundary=7am1X'); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -push @{$res->content->parts}, Mojo::Content::Single->new(asset => Mojo::Asset::File->new); -$res->content->parts->[-1]->asset->add_chunk('Hallo Welt lalalalalala!'); -my $content = Mojo::Content::Single->new; -$content->asset->add_chunk("lala\nfoobar\nperl rocks\n"); -$content->headers->content_type('text/plain'); -push @{$res->content->parts}, $content; -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; -is $res->headers->content_length, '110', 'right "Content-Length" value'; -is $res->headers->content_type, 'multipart/mixed; boundary=7am1X', 'right "Content-Type" value'; -is $res->content->parts->[0]->asset->slurp, 'Hallo Welt lalalalalala!', 'right content'; -is $res->content->parts->[1]->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->content->parts->[1]->asset->slurp, "lala\nfoobar\nperl rocks\n", 'right content'; - -# Parse response with cookie -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 200 OK\x0d\x0a"); -$res->parse("Content-Type: text/plain\x0d\x0a"); -$res->parse("Content-Length: 27\x0d\x0a"); -$res->parse("Set-Cookie: foo=bar; path=/test\x0d\x0a\x0d\x0a"); -$res->parse("Hello World!\n1234\nlalalala\n"); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.0', 'right version'; -is $res->headers->content_type, 'text/plain', 'right "Content-Type" value'; -is $res->headers->content_length, 27, 'right "Content-Length" value'; -is $res->headers->set_cookie, 'foo=bar; path=/test', 'right "Set-Cookie" value'; -my $cookies = $res->cookies; -is $cookies->[0]->name, 'foo', 'right name'; -is $cookies->[0]->value, 'bar', 'right value'; -is $cookies->[0]->path, '/test', 'right path'; -is $res->cookie('foo')->value, 'bar', 'right value'; -is $res->cookie('foo')->path, '/test', 'right path'; - -# Parse WebSocket handshake response -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 101 Switching Protocols\x0d\x0a"); -$res->parse("Upgrade: websocket\x0d\x0a"); -$res->parse("Connection: Upgrade\x0d\x0a"); -$res->parse("Sec-WebSocket-Accept: abcdef=\x0d\x0a"); -$res->parse("Sec-WebSocket-Protocol: sample\x0d\x0a\x0d\x0a"); -ok $res->is_finished, 'response is finished'; -ok $res->is_empty, 'response is empty'; -ok $res->content->skip_body, 'body has been skipped'; -is $res->code, 101, 'right status'; -is $res->message, 'Switching Protocols', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; -is $res->headers->connection, 'Upgrade', 'right "Connection" value'; -is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; -is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; -is $res->body, '', 'no content'; -ok !defined $res->headers->content_length, '"Content-Length" does not exist'; - -# Parse WebSocket handshake response (with frame) -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 101 Switching Protocols\x0d\x0a"); -$res->parse("Upgrade: websocket\x0d\x0a"); -$res->parse("Connection: Upgrade\x0d\x0a"); -$res->parse("Sec-WebSocket-Accept: abcdef=\x0d\x0a"); -$res->parse("Sec-WebSocket-Protocol: sample\x0d\x0a"); -$res->parse("\x0d\x0a\x81\x08\x77\x68\x61\x74\x65\x76\x65\x72"); -ok $res->is_finished, 'response is finished'; -ok $res->is_empty, 'response is empty'; -ok $res->content->skip_body, 'body has been skipped'; -is $res->code, 101, 'right status'; -is $res->message, 'Switching Protocols', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; -is $res->headers->connection, 'Upgrade', 'right "Connection" value'; -is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; -is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; -is $res->body, '', 'no content'; -is $res->content->leftovers, "\x81\x08\x77\x68\x61\x74\x65\x76\x65\x72", 'frame in leftovers'; -ok !defined $res->headers->content_length, '"Content-Length" does not exist'; - -# Build WebSocket handshake response -$res = Mojo::Message::Response->new; -$res->code(101); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res->headers->upgrade('websocket'); -$res->headers->connection('Upgrade'); -$res->headers->sec_websocket_accept('abcdef='); -$res->headers->sec_websocket_protocol('sample'); -$res = Mojo::Message::Response->new->parse($res->to_string); -ok $res->is_finished, 'response is finished'; -is $res->code, '101', 'right status'; -is $res->message, 'Switching Protocols', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->headers->connection, 'Upgrade', 'right "Connection" value'; -is $res->headers->date, 'Sun, 17 Aug 2008 16:27:35 GMT', 'right "Date" value'; -ok !defined $res->headers->content_length, '"Content-Length" does not exist'; -is $res->headers->upgrade, 'websocket', 'right "Upgrade" value'; -is $res->headers->sec_websocket_accept, 'abcdef=', 'right "Sec-WebSocket-Accept" value'; -is $res->headers->sec_websocket_protocol, 'sample', 'right "Sec-WebSocket-Protocol" value'; -is $res->body, '', 'no content'; -ok !defined $res->headers->content_length, '"Content-Length" does not exist'; - -# Build and parse HTTP 1.1 response with 3 cookies -$res = Mojo::Message::Response->new; -$res->code(404); -$res->headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); -$res->cookies({name => 'foo', value => 'bar', path => '/foobar'}, {name => 'bar', value => 'baz', path => '/test/23'}); -$res->cookies({name => 'baz', value => 'yada', path => '/foobar'}); -ok !!$res->to_string, 'message built'; -my $res2 = Mojo::Message::Response->new; -$res2->parse($res->to_string); -ok $res2->is_finished, 'response is finished'; -is $res2->code, 404, 'right status'; -is $res2->version, '1.1', 'right version'; -is $res2->headers->content_length, 0, 'right "Content-Length" value'; -ok defined $res2->cookie('foo'), 'cookie "foo" exists'; -ok defined $res2->cookie('bar'), 'cookie "bar" exists'; -ok defined $res2->cookie('baz'), 'cookie "baz" exists'; -ok !defined $res2->cookie('yada'), 'cookie "yada" does not exist'; -is $res2->cookie('foo')->path, '/foobar', 'right path'; -is $res2->cookie('foo')->value, 'bar', 'right value'; -is $res2->cookie('bar')->path, '/test/23', 'right path'; -is $res2->cookie('bar')->value, 'baz', 'right value'; -is $res2->cookie('baz')->path, '/foobar', 'right path'; -is $res2->cookie('baz')->value, 'yada', 'right value'; - -# Build chunked response body -$res = Mojo::Message::Response->new; -$res->code(200); -my $invocant; -$res->content->write_chunk('hello!' => sub { $invocant = shift }); -$res->content->write_chunk('hello world!')->write_chunk(''); -ok $res->content->is_chunked, 'chunked content'; -ok $res->content->is_dynamic, 'dynamic content'; -is $res->build_body, "6\x0d\x0ahello!\x0d\x0ac\x0d\x0ahello world!\x0d\x0a0\x0d\x0a\x0d\x0a", 'right format'; -isa_ok $invocant, 'Mojo::Content::Single', 'right invocant'; - -# Build dynamic response body -$res = Mojo::Message::Response->new; -$res->code(200); -$invocant = undef; -$res->content->write('hello!' => sub { $invocant = shift }); -$res->content->write('hello world!')->write(''); -ok !$res->content->is_chunked, 'no chunked content'; -ok $res->content->is_dynamic, 'dynamic content'; -is $res->build_body, "hello!hello world!", 'right format'; -isa_ok $invocant, 'Mojo::Content::Single', 'right invocant'; - -# Build response with callback (make sure it's called) -$res = Mojo::Message::Response->new; -$res->code(200); -$res->headers->content_length(10); -$res->content->write('lala' => sub { die "Body callback was called properly\n" }); -$res->get_body_chunk(0); -eval { $res->get_body_chunk(3) }; -is $@, "Body callback was called properly\n", 'right error'; - -# Build response with callback (consistency calls) -$res = Mojo::Message::Response->new; -my $body = 'I is here'; -$res->headers->content_length(length($body)); -my $cb = sub { shift->write(substr($body, pop, 1), __SUB__) }; -$res->content->write('' => $cb); -my $full = ''; -my $count = 0; -my $offset = 0; - -while (1) { - my $chunk = $res->get_body_chunk($offset); - last unless $chunk; - $full .= $chunk; - $offset = length($full); - $count++; -} -$res->fix_headers; -is $res->headers->connection, undef, 'no "Connection" value'; -ok $res->content->is_dynamic, 'dynamic content'; -is $count, length($body), 'right length'; -is $full, $body, 'right content'; - -# Build response with callback (no Content-Length header) -$res = Mojo::Message::Response->new; -$body = 'I is here'; -$cb = sub { shift->write(substr($body, pop, 1), $cb) }; -$res->content->write('' => $cb); -$res->fix_headers; -$full = ''; -$count = 0; -$offset = 0; - -while (1) { - my $chunk = $res->get_body_chunk($offset); - last unless $chunk; - $full .= $chunk; - $offset = length($full); - $count++; -} -is $res->headers->connection, 'close', 'right "Connection" value'; -ok $res->content->is_dynamic, 'dynamic content'; -is $count, length($body), 'right length'; -is $full, $body, 'right content'; - -# Body -$res = Mojo::Message::Response->new; -$res->body('hi there!'); -ok !$res->content->asset->is_file, 'stored in memory'; -ok !$res->content->asset->auto_upgrade, 'no upgrade'; -is $res->body, 'hi there!', 'right content'; -$res->body(''); -is $res->body, '', 'no content'; -$res->body('hi there!'); -is $res->body, 'hi there!', 'right content'; -$res->body(0); -is $res->body, 0, 'right content'; -is $res->body('hello!')->body, 'hello!', 'right content'; -$res->content(Mojo::Content::MultiPart->new); -$res->body('hi!'); -is $res->body, 'hi!', 'right content'; - -# Text -$res = Mojo::Message::Response->new; -my $snowman = encode 'UTF-8', '☃'; -is $res->body($snowman)->text, '☃', 'right content'; -is $res->body($snowman)->dom->text, '☃', 'right text'; -$res = Mojo::Message::Response->new; -my $yatta = encode 'shift_jis', 'やった'; -is $res->body($yatta)->text, $yatta, 'right content'; -$res->headers->content_type('text/plain;charset=shift_jis'); -is $res->body($yatta)->text, 'やった', 'right content'; -is $res->body($yatta)->dom->text, 'やった', 'right text'; + is $res->headers->connection, 'close', 'right "Connection" value'; + ok $res->content->is_dynamic, 'dynamic content'; + is $count, length($body), 'right length'; + is $full, $body, 'right content'; +}; -# Body exceeding memory limit (no upgrade) -{ - local $ENV{MOJO_MAX_MEMORY_SIZE} = 8; +subtest 'Body' => sub { + my $res = Mojo::Message::Response->new; + $res->body('hi there!'); + ok !$res->content->asset->is_file, 'stored in memory'; + ok !$res->content->asset->auto_upgrade, 'no upgrade'; + is $res->body, 'hi there!', 'right content'; + $res->body(''); + is $res->body, '', 'no content'; + $res->body('hi there!'); + is $res->body, 'hi there!', 'right content'; + $res->body(0); + is $res->body, 0, 'right content'; + is $res->body('hello!')->body, 'hello!', 'right content'; + $res->content(Mojo::Content::MultiPart->new); + $res->body('hi!'); + is $res->body, 'hi!', 'right content'; +}; + +subtest 'Text' => sub { + my $res = Mojo::Message::Response->new; + my $snowman = encode 'UTF-8', '☃'; + is $res->body($snowman)->text, '☃', 'right content'; + is $res->body($snowman)->dom->text, '☃', 'right text'; $res = Mojo::Message::Response->new; + my $yatta = encode 'shift_jis', 'やった'; + is $res->body($yatta)->text, $yatta, 'right content'; + $res->headers->content_type('text/plain;charset=shift_jis'); + is $res->body($yatta)->text, 'やった', 'right content'; + is $res->body($yatta)->dom->text, 'やった', 'right text'; +}; + +subtest 'Body exceeding memory limit (no upgrade)' => sub { + local $ENV{MOJO_MAX_MEMORY_SIZE} = 8; + my $res = Mojo::Message::Response->new; $res->body('hi there!'); is $res->body, 'hi there!', 'right content'; is $res->content->asset->max_memory_size, 8, 'right size'; is $res->content->asset->size, 9, 'right size'; ok !$res->content->asset->is_file, 'stored in memory'; -} +}; -# Parse response and extract JSON data -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0a"); -$res->parse("Content-Type: application/json\x0a"); -$res->parse("Content-Length: 27\x0a\x0a"); -$res->parse(encode_json({foo => 'bar', baz => [1, 2, 3]})); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is_deeply $res->json, {foo => 'bar', baz => [1, 2, 3]}, 'right JSON data'; -is $res->json('/foo'), 'bar', 'right result'; -is $res->json('/baz/1'), 2, 'right result'; -is_deeply $res->json('/baz'), [1, 2, 3], 'right result'; -$res->json->{baz}[1] = 4; -is_deeply $res->json('/baz'), [1, 4, 3], 'right result'; - -# Parse response and extract HTML -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.1 200 OK\x0a"); -$res->parse("Content-Type: text/html\x0a"); -$res->parse("Content-Length: 51\x0a\x0a"); -$res->parse('

foobar baz

'); -ok $res->is_finished, 'response is finished'; -is $res->code, 200, 'right status'; -is $res->message, 'OK', 'right message'; -is $res->version, '1.1', 'right version'; -is $res->dom->at('p')->text, 'foo', 'right value'; -is $res->dom->at('p > a')->text, 'bar', 'right value'; -is $res->dom('p')->first->text, 'foo', 'right value'; -is_deeply $res->dom('p > a')->map('text')->to_array, [qw(bar baz)], 'right values'; -my @text = $res->dom('a')->map(content => 'yada')->first->root->find('p > a')->map('text')->each; -is_deeply \@text, [qw(yada yada)], 'right values'; -is_deeply $res->dom('p > a')->map('text')->to_array, [qw(yada yada)], 'right values'; -@text = $res->dom->find('a')->map(content => 'test')->first->root->find('p > a')->map('text')->each; -is_deeply \@text, [qw(test test)], 'right values'; -is_deeply $res->dom->find('p > a')->map('text')->to_array, [qw(test test)], 'right values'; -$file = $dir->child('single.html'); -is $res->save_to($file)->body, '

foobar baz

', 'right content'; -is $file->slurp, '

foobar baz

', 'right content'; - -# Build DOM from response with charset -$res = Mojo::Message::Response->new; -$res->parse("HTTP/1.0 200 OK\x0a"); -$res->parse("Content-Type: application/atom+xml; charset=UTF-8; type=feed\x0a"); -$res->parse("\x0a"); -$res->body('

foo bar baz

'); -ok !$res->is_finished, 'response is not finished'; -is $res->headers->content_type, 'application/atom+xml; charset=UTF-8; type=feed', 'right "Content-Type" value'; -ok $res->dom, 'dom built'; -$count = 0; -$res->dom('a')->each(sub { $count++ }); -is $count, 2, 'all anchors found'; +subtest 'Parse response and extract JSON data' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0a"); + $res->parse("Content-Type: application/json\x0a"); + $res->parse("Content-Length: 27\x0a\x0a"); + $res->parse(encode_json({foo => 'bar', baz => [1, 2, 3]})); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is_deeply $res->json, {foo => 'bar', baz => [1, 2, 3]}, 'right JSON data'; + is $res->json('/foo'), 'bar', 'right result'; + is $res->json('/baz/1'), 2, 'right result'; + is_deeply $res->json('/baz'), [1, 2, 3], 'right result'; + $res->json->{baz}[1] = 4; + is_deeply $res->json('/baz'), [1, 4, 3], 'right result'; +}; + +subtest 'Parse response and extract HTML' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.1 200 OK\x0a"); + $res->parse("Content-Type: text/html\x0a"); + $res->parse("Content-Length: 51\x0a\x0a"); + $res->parse('

foobar baz

'); + ok $res->is_finished, 'response is finished'; + is $res->code, 200, 'right status'; + is $res->message, 'OK', 'right message'; + is $res->version, '1.1', 'right version'; + is $res->dom->at('p')->text, 'foo', 'right value'; + is $res->dom->at('p > a')->text, 'bar', 'right value'; + is $res->dom('p')->first->text, 'foo', 'right value'; + is_deeply $res->dom('p > a')->map('text')->to_array, [qw(bar baz)], 'right values'; + my @text = $res->dom('a')->map(content => 'yada')->first->root->find('p > a')->map('text')->each; + is_deeply \@text, [qw(yada yada)], 'right values'; + is_deeply $res->dom('p > a')->map('text')->to_array, [qw(yada yada)], 'right values'; + @text = $res->dom->find('a')->map(content => 'test')->first->root->find('p > a')->map('text')->each; + is_deeply \@text, [qw(test test)], 'right values'; + is_deeply $res->dom->find('p > a')->map('text')->to_array, [qw(test test)], 'right values'; + + my $dir = tempdir; + my $file = $dir->child('single.html'); + is $res->save_to($file)->body, '

foobar baz

', 'right content'; + is $file->slurp, '

foobar baz

', 'right content'; +}; + +subtest 'Build DOM from response with charset' => sub { + my $res = Mojo::Message::Response->new; + $res->parse("HTTP/1.0 200 OK\x0a"); + $res->parse("Content-Type: application/atom+xml; charset=UTF-8; type=feed\x0a"); + $res->parse("\x0a"); + $res->body('

foo bar baz

'); + ok !$res->is_finished, 'response is not finished'; + is $res->headers->content_type, 'application/atom+xml; charset=UTF-8; type=feed', 'right "Content-Type" value'; + ok $res->dom, 'dom built'; + my $count = 0; + $res->dom('a')->each(sub { $count++ }); + is $count, 2, 'all anchors found'; +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/roles.t libmojolicious-perl-9.22+dfsg/t/mojo/roles.t --- libmojolicious-perl-8.71+dfsg/t/mojo/roles.t 2021-01-17 16:37:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/roles.t 2021-08-09 19:24:05.000000000 +0000 @@ -52,72 +52,84 @@ use Mojo::DOM; use Mojo::File; -# Plain class -my $obj = Mojo::RoleTest->new(name => 'Ted'); -is $obj->name, 'Ted', 'attribute'; -is $obj->hello, 'hello Ted', 'method'; - -# Empty roles -my $fred = Mojo::RoleTest->with_roles()->new(name => 'Fred'); -is $fred->name, 'Fred', 'attribute'; -is $fred->hello, 'hello Fred', 'method'; - -# Empty object roles -my $obj_empty = $obj->with_roles(); -is $obj_empty->name, 'Ted', 'attribute'; -is $obj_empty->hello, 'hello Ted', 'method'; - -# Single role -my $obj2 = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::LOUD')->new; -is $obj2->hello, 'HEY! BOB!!!', 'role method'; -is $obj2->yell, 'HEY!', 'another role method'; - -# Single role (shorthand) -my $obj4 = Mojo::RoleTest->with_roles('+LOUD')->new; -is $obj4->hello, 'HEY! BOB!!!', 'role method'; -is $obj4->yell, 'HEY!', 'another role method'; - -# Multiple roles -my $obj3 = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::quiet', 'Mojo::RoleTest::Role::LOUD')->new(name => 'Joel'); -is $obj3->name, 'Joel', 'base attribute'; -is $obj3->whisper, 'psst, joel', 'method from first role'; -$obj3->prefix('psssst, '); -is $obj3->whisper, 'psssst, joel', 'method from first role'; -is $obj3->hello, 'HEY! JOEL!!!', 'method from second role'; - -# Multiple roles (shorthand) -my $obj5 = Mojo::RoleTest->with_roles('+quiet', '+LOUD')->new(name => 'Joel'); -is $obj5->name, 'Joel', 'base attribute'; -is $obj5->whisper, 'psst, joel', 'method from first role'; -is $obj5->hello, 'HEY! JOEL!!!', 'method from second role'; - -# Multiple roles (mixed) -my $obj6 = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::quiet', '+LOUD')->new(name => 'Joel'); -is $obj6->name, 'Joel', 'base attribute'; -is $obj6->whisper, 'psst, joel', 'method from first role'; -is $obj6->hello, 'HEY! JOEL!!!', 'method from second role'; - -# Multiple object roles (mixed) -my $obj7 = Mojo::RoleTest->new(name => 'Joel')->with_roles('Mojo::RoleTest::Role::quiet', '+LOUD'); -is $obj7->name, 'Joel', 'base attribute'; -is $obj7->whisper, 'psst, joel', 'method from first role'; -is $obj7->hello, 'HEY! JOEL!!!', 'method from second role'; - -# Multiple Mojo::Base roles -my $obj8 = Mojo::RoleTest->with_roles('+quiet', 'Mojo::RoleTest::Hello')->new(name => 'Joel'); -is $obj8->name, 'Joel', 'base attribute'; -is $obj8->whisper, 'psst, joel', 'method from first role'; -is $obj8->hello, 'hello mojo!', 'method from second role'; - -# Classes that are not subclasses of Mojo::Base -my $stream = Mojo::ByteStream->with_roles('Mojo::RoleTest::Hello')->new; -is $stream->hello, 'hello mojo!', 'right result'; -my $c = Mojo::Collection->with_roles('Mojo::RoleTest::Hello')->new; -is $c->hello, 'hello mojo!', 'right result'; -my $dom = Mojo::DOM->with_roles('Mojo::RoleTest::Hello')->new; -is $dom->hello, 'hello mojo!', 'right result'; -my $file = Mojo::File->with_roles('Mojo::RoleTest::Hello')->new; -is $file->hello, 'hello mojo!', 'right result'; +subtest 'Plain class' => sub { + my $obj = Mojo::RoleTest->new(name => 'Ted'); + is $obj->name, 'Ted', 'attribute'; + is $obj->hello, 'hello Ted', 'method'; +}; + +subtest 'Empty roles' => sub { + my $fred = Mojo::RoleTest->with_roles()->new(name => 'Fred'); + is $fred->name, 'Fred', 'attribute'; + is $fred->hello, 'hello Fred', 'method'; +}; + +subtest 'Empty object roles' => sub { + my $obj = Mojo::RoleTest->new(name => 'Ted'); + my $obj_empty = $obj->with_roles(); + is $obj_empty->name, 'Ted', 'attribute'; + is $obj_empty->hello, 'hello Ted', 'method'; +}; + +subtest 'Single role' => sub { + my $obj = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::LOUD')->new; + is $obj->hello, 'HEY! BOB!!!', 'role method'; + is $obj->yell, 'HEY!', 'another role method'; +}; + +subtest 'Single role (shorthand)' => sub { + my $obj = Mojo::RoleTest->with_roles('+LOUD')->new; + is $obj->hello, 'HEY! BOB!!!', 'role method'; + is $obj->yell, 'HEY!', 'another role method'; +}; + +subtest 'Multiple roles' => sub { + my $obj + = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::quiet', 'Mojo::RoleTest::Role::LOUD')->new(name => 'Joel'); + is $obj->name, 'Joel', 'base attribute'; + is $obj->whisper, 'psst, joel', 'method from first role'; + $obj->prefix('psssst, '); + is $obj->whisper, 'psssst, joel', 'method from first role'; + is $obj->hello, 'HEY! JOEL!!!', 'method from second role'; +}; + +subtest 'Multiple roles (shorthand)' => sub { + my $obj = Mojo::RoleTest->with_roles('+quiet', '+LOUD')->new(name => 'Joel'); + is $obj->name, 'Joel', 'base attribute'; + is $obj->whisper, 'psst, joel', 'method from first role'; + is $obj->hello, 'HEY! JOEL!!!', 'method from second role'; +}; + +subtest 'Multiple roles (mixed)' => sub { + my $obj = Mojo::RoleTest->with_roles('Mojo::RoleTest::Role::quiet', '+LOUD')->new(name => 'Joel'); + is $obj->name, 'Joel', 'base attribute'; + is $obj->whisper, 'psst, joel', 'method from first role'; + is $obj->hello, 'HEY! JOEL!!!', 'method from second role'; +}; + +subtest 'Multiple object roles (mixed)' => sub { + my $obj = Mojo::RoleTest->new(name => 'Joel')->with_roles('Mojo::RoleTest::Role::quiet', '+LOUD'); + is $obj->name, 'Joel', 'base attribute'; + is $obj->whisper, 'psst, joel', 'method from first role'; + is $obj->hello, 'HEY! JOEL!!!', 'method from second role'; +}; + +subtest 'Multiple Mojo::Base roles' => sub { + my $obj = Mojo::RoleTest->with_roles('+quiet', 'Mojo::RoleTest::Hello')->new(name => 'Joel'); + is $obj->name, 'Joel', 'base attribute'; + is $obj->whisper, 'psst, joel', 'method from first role'; + is $obj->hello, 'hello mojo!', 'method from second role'; +}; + +subtest 'Classes that are not subclasses of Mojo::Base' => sub { + my $stream = Mojo::ByteStream->with_roles('Mojo::RoleTest::Hello')->new; + is $stream->hello, 'hello mojo!', 'right result'; + my $c = Mojo::Collection->with_roles('Mojo::RoleTest::Hello')->new; + is $c->hello, 'hello mojo!', 'right result'; + my $dom = Mojo::DOM->with_roles('Mojo::RoleTest::Hello')->new; + is $dom->hello, 'hello mojo!', 'right result'; + my $file = Mojo::File->with_roles('Mojo::RoleTest::Hello')->new; + is $file->hello, 'hello mojo!', 'right result'; +}; done_testing(); - diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/signatures.t libmojolicious-perl-9.22+dfsg/t/mojo/signatures.t --- libmojolicious-perl-8.71+dfsg/t/mojo/signatures.t 2021-01-17 16:37:35.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/signatures.t 2021-06-30 13:58:00.000000000 +0000 @@ -31,4 +31,9 @@ like $@, qr/Unsupported flag: -unsupported/, 'right error'; }; +subtest 'Secret feature' => sub { + my $foo = {bar => [1, 2, 3]}; + is_deeply [$foo->{bar}->@*], [1, 2, 3], 'right structure'; +}; + done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/subprocess.t libmojolicious-perl-9.22+dfsg/t/mojo/subprocess.t --- libmojolicious-perl-8.71+dfsg/t/mojo/subprocess.t 2021-01-17 16:37:41.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/subprocess.t 2021-08-13 19:07:33.000000000 +0000 @@ -12,255 +12,264 @@ use Mojo::Promise; use Mojo::File qw(tempfile); -# Huge result -my ($fail, $result, @start); -my $subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->on(spawn => sub { push @start, shift->pid }); -$subprocess->run( - sub { shift->pid . $$ . ('x' x 100000) }, - sub { - my ($subprocess, $err, $two) = @_; - $fail = $err; - $result .= $two; - } -); -$result = $$; -ok !$subprocess->pid, 'no process id available yet'; -is $subprocess->exit_code, undef, 'no exit code'; -Mojo::IOLoop->start; -ok $subprocess->pid, 'process id available'; -is $subprocess->exit_code, 0, 'zero exit code'; -ok !$fail, 'no error'; -is $result, $$ . 0 . $subprocess->pid . ('x' x 100000), 'right result'; -is_deeply \@start, [$subprocess->pid], 'spawn event has been emitted once'; - -# Custom event loop -($fail, $result) = (); -my $loop = Mojo::IOLoop->new; -$loop->subprocess( - sub {'♥'}, - sub { - my ($subprocess, $err, @results) = @_; - $fail = $err; - $result = \@results; - } -); -$loop->start; -ok !$fail, 'no error'; -is_deeply $result, ['♥'], 'right structure'; - -# Multiple return values -($fail, $result) = (); -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->run( - sub { return '♥', [{two => 2}], 3 }, - sub { - my ($subprocess, $err, @results) = @_; - $fail = $err; - $result = \@results; - } -); -Mojo::IOLoop->start; -ok !$fail, 'no error'; -is_deeply $result, ['♥', [{two => 2}], 3], 'right structure'; - -# Promises -$result = []; -$subprocess = Mojo::IOLoop::Subprocess->new; -is $subprocess->exit_code, undef, 'no exit code'; -$subprocess->run_p(sub { return '♥', [{two => 2}], 3 })->then(sub { $result = [@_] })->wait; -is_deeply $result, ['♥', [{two => 2}], 3], 'right structure'; -$fail = undef; -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->run_p(sub { die 'Whatever' })->catch(sub { $fail = shift })->wait; -is $subprocess->exit_code, 0, 'zero exit code'; -like $fail, qr/Whatever/, 'right error'; -$result = []; -Mojo::IOLoop->subprocess->run_p(sub { return '♥' })->then(sub { $result = [@_] })->wait; -is_deeply $result, ['♥'], 'right structure'; - -# Event loop in subprocess -($fail, $result) = (); -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->run( - sub { - my $result; - Mojo::IOLoop->next_tick(sub { $result = 23 }); - Mojo::IOLoop->start; - return $result; - }, - sub { - my ($subprocess, $err, $twenty_three) = @_; - $fail = $err; - $result = $twenty_three; - } -); -Mojo::IOLoop->start; -ok !$fail, 'no error'; -is $result, 23, 'right result'; - -# Event loop in subprocess (already running event loop) -($fail, $result) = (); -Mojo::IOLoop->next_tick(sub { - Mojo::IOLoop->subprocess( +subtest 'Huge result' => sub { + my ($fail, $result, @start); + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->on(spawn => sub { push @start, shift->pid }); + $subprocess->run( + sub { shift->pid . $$ . ('x' x 100000) }, + sub { + my ($subprocess, $err, $two) = @_; + $fail = $err; + $result .= $two; + } + ); + + $result = $$; + ok !$subprocess->pid, 'no process id available yet'; + is $subprocess->exit_code, undef, 'no exit code'; + Mojo::IOLoop->start; + ok $subprocess->pid, 'process id available'; + is $subprocess->exit_code, 0, 'zero exit code'; + ok !$fail, 'no error'; + is $result, $$ . 0 . $subprocess->pid . ('x' x 100000), 'right result'; + is_deeply \@start, [$subprocess->pid], 'spawn event has been emitted once'; +}; + +subtest 'Custom event loop' => sub { + my ($fail, $result); + my $loop = Mojo::IOLoop->new; + $loop->subprocess( + sub {'♥'}, + sub { + my ($subprocess, $err, @results) = @_; + $fail = $err; + $result = \@results; + } + ); + $loop->start; + ok !$fail, 'no error'; + is_deeply $result, ['♥'], 'right structure'; +}; + +subtest 'Multiple return values' => sub { + my ($fail, $result); + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run( + sub { return '♥', [{two => 2}], 3 }, + sub { + my ($subprocess, $err, @results) = @_; + $fail = $err; + $result = \@results; + } + ); + Mojo::IOLoop->start; + ok !$fail, 'no error'; + is_deeply $result, ['♥', [{two => 2}], 3], 'right structure'; +}; + +subtest 'Promises' => sub { + my $result = []; + my $subprocess = Mojo::IOLoop::Subprocess->new; + is $subprocess->exit_code, undef, 'no exit code'; + $subprocess->run_p(sub { return '♥', [{two => 2}], 3 })->then(sub { $result = [@_] })->wait; + is_deeply $result, ['♥', [{two => 2}], 3], 'right structure'; + my $fail; + $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run_p(sub { die 'Whatever' })->catch(sub { $fail = shift })->wait; + is $subprocess->exit_code, 0, 'zero exit code'; + like $fail, qr/Whatever/, 'right error'; + $result = []; + Mojo::IOLoop->subprocess->run_p(sub { return '♥' })->then(sub { $result = [@_] })->wait; + is_deeply $result, ['♥'], 'right structure'; +}; + +subtest 'Event loop in subprocess' => sub { + my ($fail, $result); + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run( sub { my $result; - my $promise = Mojo::Promise->new; - $promise->then(sub { $result = shift }); - Mojo::IOLoop->next_tick(sub { $promise->resolve(25) }); - $promise->wait; + Mojo::IOLoop->next_tick(sub { $result = 23 }); + Mojo::IOLoop->start; return $result; }, sub { - my ($subprocess, $err, $twenty_five) = @_; + my ($subprocess, $err, $twenty_three) = @_; $fail = $err; - $result = $twenty_five; + $result = $twenty_three; } ); -}); -Mojo::IOLoop->start; -ok !$fail, 'no error'; -is $result, 25, 'right result'; - -# Concurrent subprocesses -($fail, $result) = (); -Mojo::IOLoop->delay( - sub { - my $delay = shift; - Mojo::IOLoop->subprocess(sub {1}, $delay->begin); - Mojo::IOLoop->subprocess->run(sub {2}, $delay->begin); - }, - sub { - my ($delay, $err1, $result1, $err2, $result2) = @_; - $fail = $err1 || $err2; - $result = [$result1, $result2]; - } -)->wait; -ok !$fail, 'no error'; -is_deeply $result, [1, 2], 'right structure'; - -# No result -($fail, $result) = (); -Mojo::IOLoop::Subprocess->new->run( - sub {return}, - sub { - my ($subprocess, $err, @results) = @_; - $fail = $err; - $result = \@results; - } -); -Mojo::IOLoop->start; -ok !$fail, 'no error'; -is_deeply $result, [], 'right structure'; - -# Stream inherited from previous subprocesses -($fail, $result) = (); -my $delay = Mojo::IOLoop->delay; -my $me = $$; -for (0 .. 1) { - my $end = $delay->begin; + Mojo::IOLoop->start; + ok !$fail, 'no error'; + is $result, 23, 'right result'; +}; + +subtest 'Event loop in subprocess (already running event loop)' => sub { + my ($fail, $result); + Mojo::IOLoop->next_tick(sub { + Mojo::IOLoop->subprocess( + sub { + my $result; + my $promise = Mojo::Promise->new; + $promise->then(sub { $result = shift }); + Mojo::IOLoop->next_tick(sub { $promise->resolve(25) }); + $promise->wait; + return $result; + }, + sub { + my ($subprocess, $err, $twenty_five) = @_; + $fail = $err; + $result = $twenty_five; + } + ); + }); + Mojo::IOLoop->start; + ok !$fail, 'no error'; + is $result, 25, 'right result'; +}; + +subtest 'Concurrent subprocesses' => sub { + my ($fail, $result); + my $promise = Mojo::IOLoop->subprocess->run_p(sub {1}); + my $promise2 = Mojo::IOLoop->subprocess->run_p(sub {2}); + Mojo::Promise->all($promise, $promise2)->then(sub { + $result = [map { $_->[0] } @_]; + })->catch(sub { $fail = shift })->wait; + ok !$fail, 'no error'; + is_deeply $result, [1, 2], 'right structure'; +}; + +subtest 'No result' => sub { + my ($fail, $result); + Mojo::IOLoop::Subprocess->new->run( + sub {return}, + sub { + my ($subprocess, $err, @results) = @_; + $fail = $err; + $result = \@results; + } + ); + Mojo::IOLoop->start; + ok !$fail, 'no error'; + is_deeply $result, [], 'right structure'; +}; + +subtest 'Stream inherited from previous subprocesses' => sub { + my ($fail, $result); + my @promises; + my $me = $$; + for (0 .. 1) { + push @promises, my $promise = Mojo::Promise->new; + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run( + sub { 1 + 1 }, + sub { + my ($subprocess, $err, $two) = @_; + $fail ||= $err; + push @$result, $two; + is $me, $$, 'we are the parent'; + $promise->resolve; + } + ); + } + Mojo::Promise->all(@promises)->wait; + ok !$fail, 'no error'; + is_deeply $result, [2, 2], 'right structure'; +}; + +subtest 'Exception' => sub { + my $fail; + Mojo::IOLoop::Subprocess->new->run( + sub { die 'Whatever' }, + sub { + my ($subprocess, $err) = @_; + $fail = $err; + } + ); + Mojo::IOLoop->start; + like $fail, qr/Whatever/, 'right error'; +}; + +subtest 'Non-zero exit status' => sub { + my $fail; + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run( + sub { exit 3 }, + sub { + my ($subprocess, $err) = @_; + $fail = $err; + } + ); + Mojo::IOLoop->start; + is $subprocess->exit_code, 3, 'right exit code'; + like $fail, qr/offset 0/, 'right error'; +}; + +subtest 'Serialization error' => sub { + my $fail; my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->deserialize(sub { die 'Whatever' }); $subprocess->run( sub { 1 + 1 }, sub { - my ($subprocess, $err, $two) = @_; - $fail ||= $err; - push @$result, $two; - is $me, $$, 'we are the parent'; - $end->(); - } - ); -} -$delay->wait; -ok !$fail, 'no error'; -is_deeply $result, [2, 2], 'right structure'; - -# Exception -$fail = undef; -Mojo::IOLoop::Subprocess->new->run( - sub { die 'Whatever' }, - sub { - my ($subprocess, $err) = @_; - $fail = $err; - } -); -Mojo::IOLoop->start; -like $fail, qr/Whatever/, 'right error'; - -# Non-zero exit status -$fail = undef; -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->run( - sub { exit 3 }, - sub { - my ($subprocess, $err) = @_; - $fail = $err; - } -); -Mojo::IOLoop->start; -is $subprocess->exit_code, 3, 'right exit code'; -like $fail, qr/offset 0/, 'right error'; - -# Serialization error -$fail = undef; -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->deserialize(sub { die 'Whatever' }); -$subprocess->run( - sub { 1 + 1 }, - sub { - my ($subprocess, $err) = @_; - $fail = $err; - } -); -Mojo::IOLoop->start; -like $fail, qr/Whatever/, 'right error'; - -# Progress -($fail, $result) = (undef, undef); -my @progress; -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->run( - sub { - my $s = shift; - $s->progress(20); - $s->progress({percentage => 45}); - $s->progress({percentage => 90}, {long_data => [1 .. 1e5]}); - 'yay'; - }, - sub { - my ($subprocess, $err, @res) = @_; - $fail = $err; - $result = \@res; - } -); -$subprocess->on( - progress => sub { - my ($subprocess, @args) = @_; - push @progress, \@args; - } -); -Mojo::IOLoop->start; -ok !$fail, 'no error'; -is_deeply $result, ['yay'], 'correct result'; -is_deeply \@progress, [[20], [{percentage => 45}], [{percentage => 90}, {long_data => [1 .. 1e5]}]], 'correct progress'; - -# Cleanup -($fail, $result) = (); -my $file = tempfile; -my $called = 0; -$subprocess = Mojo::IOLoop::Subprocess->new; -$subprocess->on(cleanup => sub { $file->spurt(shift->serialize->({test => ++$called})) }); -$subprocess->run( - sub {'Hello Mojo!'}, - sub { - my ($subprocess, $err, $hello) = @_; - $fail = $err; - $result = $hello; - } -); -Mojo::IOLoop->start; -is_deeply $subprocess->deserialize->($file->slurp), {test => 1}, 'cleanup event emitted once'; -ok !$fail, 'no error'; -is $result, 'Hello Mojo!', 'right result'; + my ($subprocess, $err) = @_; + $fail = $err; + } + ); + Mojo::IOLoop->start; + like $fail, qr/Whatever/, 'right error'; +}; + +subtest 'Progress' => sub { + my ($fail, $result); + my @progress; + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->run( + sub { + my $s = shift; + $s->progress(20); + $s->progress({percentage => 45}); + $s->progress({percentage => 90}, {long_data => [1 .. 1e5]}); + 'yay'; + }, + sub { + my ($subprocess, $err, @res) = @_; + $fail = $err; + $result = \@res; + } + ); + $subprocess->on( + progress => sub { + my ($subprocess, @args) = @_; + push @progress, \@args; + } + ); + Mojo::IOLoop->start; + ok !$fail, 'no error'; + is_deeply $result, ['yay'], 'correct result'; + is_deeply \@progress, [[20], [{percentage => 45}], [{percentage => 90}, {long_data => [1 .. 1e5]}]], + 'correct progress'; +}; + +subtest 'Cleanup' => sub { + my ($fail, $result); + my $file = tempfile; + my $called = 0; + my $subprocess = Mojo::IOLoop::Subprocess->new; + $subprocess->on(cleanup => sub { $file->spurt(shift->serialize->({test => ++$called})) }); + $subprocess->run( + sub {'Hello Mojo!'}, + sub { + my ($subprocess, $err, $hello) = @_; + $fail = $err; + $result = $hello; + } + ); + Mojo::IOLoop->start; + is_deeply $subprocess->deserialize->($file->slurp), {test => 1}, 'cleanup event emitted once'; + ok !$fail, 'no error'; + is $result, 'Hello Mojo!', 'right result'; +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/template.t libmojolicious-perl-9.22+dfsg/t/mojo/template.t --- libmojolicious-perl-8.71+dfsg/t/mojo/template.t 2021-01-17 16:38:09.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/template.t 2021-06-30 13:58:00.000000000 +0000 @@ -578,13 +578,13 @@ subtest 'End and begin in the same perl line' => sub { my $concat = 'no warnings "redefine"; sub concat { $_[0]->() . $_[1]->() }'; my $mt = Mojo::Template->new(prepend => $concat); - my $output = $mt->render(<<' EOF'); + my $output = $mt->render(<<'EOF'); %= concat begin 1 % end, begin 2 % end - EOF +EOF is $output, " \n 1\n 2\n", 'end, begin'; }; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/tls.t libmojolicious-perl-9.22+dfsg/t/mojo/tls.t --- libmojolicious-perl-8.71+dfsg/t/mojo/tls.t 2021-01-17 16:37:24.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/tls.t 2021-06-30 13:58:00.000000000 +0000 @@ -9,49 +9,57 @@ plan skip_all => 'IO::Socket::SSL 2.009+ required for this test!' unless Mojo::IOLoop::TLS->can_tls; use Mojo::IOLoop; +use Mojo::Promise; use Socket; -# Built-in certificate -socketpair(my $client_sock, my $server_sock, AF_UNIX, SOCK_STREAM, PF_UNSPEC) or die "Couldn't create socket pair: $!"; -$client_sock->blocking(0); -$server_sock->blocking(0); -my $delay = Mojo::IOLoop->delay; -my $server = Mojo::IOLoop::TLS->new($server_sock); -$server->once(upgrade => $delay->begin); -$server->once(error => sub { warn pop }); -$server->negotiate({server => 1}); -my $client = Mojo::IOLoop::TLS->new($client_sock); -$client->once(upgrade => $delay->begin); -$client->once(error => sub { warn pop }); -$client->negotiate(tls_verify => 0x00); -my ($client_result, $server_result); -$delay->then(sub { ($server_result, $client_result) = @_ }); -$delay->wait; -is ref $client_result, 'IO::Socket::SSL', 'right class'; -is ref $server_result, 'IO::Socket::SSL', 'right class'; +subtest 'Built-in certificate' => sub { + socketpair(my $client_sock, my $server_sock, AF_UNIX, SOCK_STREAM, PF_UNSPEC) + or die "Couldn't create socket pair: $!"; + $client_sock->blocking(0); + $server_sock->blocking(0); + my $promise = Mojo::Promise->new; + my $promise2 = Mojo::Promise->new; + my $server = Mojo::IOLoop::TLS->new($server_sock); + $server->once(upgrade => sub { $promise->resolve(pop) }); + $server->once(error => sub { warn pop }); + $server->negotiate({server => 1}); + my $client = Mojo::IOLoop::TLS->new($client_sock); + $client->once(upgrade => sub { $promise2->resolve(pop) }); + $client->once(error => sub { warn pop }); + $client->negotiate(tls_options => {SSL_verify_mode => 0x00}); + my ($client_result, $server_result); + Mojo::Promise->all($promise, $promise2)->then(sub { + ($server_result, $client_result) = map { $_->[0] } @_; + })->wait; + is ref $client_result, 'IO::Socket::SSL', 'right class'; + is ref $server_result, 'IO::Socket::SSL', 'right class'; +}; -# Built-in certificate (custom event loop and cipher) -my $loop = Mojo::IOLoop->new; -socketpair(my $client_sock2, my $server_sock2, AF_UNIX, SOCK_STREAM, PF_UNSPEC) - or die "Couldn't create socket pair: $!"; -$client_sock2->blocking(0); -$server_sock2->blocking(0); -$delay = $loop->delay; -$server = Mojo::IOLoop::TLS->new($server_sock2)->reactor($loop->reactor); -$server->once(upgrade => $delay->begin); -$server->once(error => sub { warn pop }); -$server->negotiate(server => 1, tls_ciphers => 'AES256-SHA:ALL'); -$client = Mojo::IOLoop::TLS->new($client_sock2)->reactor($loop->reactor); -$client->once(upgrade => $delay->begin); -$client->once(error => sub { warn pop }); -$client->negotiate(tls_verify => 0x00); -$client_result = $server_result = undef; -$delay->then(sub { ($server_result, $client_result) = @_ }); -$delay->wait; -is ref $client_result, 'IO::Socket::SSL', 'right class'; -is ref $server_result, 'IO::Socket::SSL', 'right class'; -my $expect = $server_result->get_sslversion eq 'TLSv1_3' ? 'TLS_AES_256_GCM_SHA384' : 'AES256-SHA'; -is $client_result->get_cipher, $expect, "$expect has been negotiatied"; -is $server_result->get_cipher, $expect, "$expect has been negotiatied"; +subtest 'Built-in certificate (custom event loop and cipher)' => sub { + my $loop = Mojo::IOLoop->new; + socketpair(my $client_sock2, my $server_sock2, AF_UNIX, SOCK_STREAM, PF_UNSPEC) + or die "Couldn't create socket pair: $!"; + $client_sock2->blocking(0); + $server_sock2->blocking(0); + my $promise = Mojo::Promise->new->ioloop($loop); + my $promise2 = Mojo::Promise->new->ioloop($loop); + my $server = Mojo::IOLoop::TLS->new($server_sock2)->reactor($loop->reactor); + $server->once(upgrade => sub { $promise->resolve(pop) }); + $server->once(error => sub { warn pop }); + $server->negotiate(server => 1, tls_options => {SSL_cipher_list => 'AES256-SHA:ALL'}); + my $client = Mojo::IOLoop::TLS->new($client_sock2)->reactor($loop->reactor); + $client->once(upgrade => sub { $promise2->resolve(pop) }); + $client->once(error => sub { warn pop }); + $client->negotiate(tls_options => {SSL_verify_mode => 0x00}); + my ($client_result, $server_result); + Mojo::Promise->all($promise, $promise2)->then(sub { + ($server_result, $client_result) = map { $_->[0] } @_; + })->wait; + is ref $client_result, 'IO::Socket::SSL', 'right class'; + is ref $server_result, 'IO::Socket::SSL', 'right class'; + my $expect = $server_result->get_sslversion eq 'TLSv1_3' ? 'TLS_AES_256_GCM_SHA384' : 'AES256-SHA'; + is $client_result->get_cipher, $expect, "$expect has been negotiatied"; + is $server_result->get_cipher, $expect, "$expect has been negotiatied"; +}; done_testing; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/transactor.t libmojolicious-perl-9.22+dfsg/t/mojo/transactor.t --- libmojolicious-perl-8.71+dfsg/t/mojo/transactor.t 2021-01-17 16:37:38.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/transactor.t 2021-06-30 13:58:00.000000000 +0000 @@ -259,6 +259,22 @@ is $tx->req->content->parts->[1], undef, 'no more parts'; }; +subtest 'Multipart form with custom Content-Disposition header' => sub { + my $tx = $t->tx(POST => 'http://example.com/foo' => form => + {mytext => {file => __FILE__, 'Content-Disposition' => 'form-data; name="works"'}}); + is $tx->req->url->to_abs, 'http://example.com/foo', 'right URL'; + is $tx->req->method, 'POST', 'right method'; + is $tx->req->headers->content_type, 'multipart/form-data', 'right "Content-Type" value'; + unlike $tx->req->content->parts->[0]->headers->content_disposition, qr/"transactor.t"/, + 'different "Content-Disposition" value'; + is $tx->req->content->parts->[0]->headers->content_disposition, 'form-data; name="works"', + 'right "Content-Disposition" value'; + like $tx->req->content->parts->[0]->asset->slurp, qr/mytext/, 'right part'; + ok $tx->req->content->parts->[0]->asset->is_file, 'stored in file'; + ok !$tx->req->content->parts->[0]->headers->header('file'), 'no "file" header'; + is $tx->req->content->parts->[1], undef, 'no more parts'; +}; + subtest 'Multipart form with asset and custom content type' => sub { my $tx = $t->tx(POST => 'http://example.com/foo' => {'Content-Type' => 'multipart/mojo-form'} => form => {mytext => {file => Mojo::Asset::File->new(path => __FILE__)}}); @@ -372,8 +388,9 @@ is $tx->req->headers->content_type, undef, 'no "Content-Type" value'; like $tx->req->content->parts->[0]->asset->slurp, qr/mytext/, 'right part'; ok $tx->req->content->parts->[0]->asset->is_file, 'stored in file'; - ok !$tx->req->content->parts->[0]->headers->header('file'), 'no "file" header'; - is $tx->req->content->parts->[0]->headers->dnt, 1, 'right "DNT" header'; + is $tx->req->content->parts->[0]->headers->header('file'), undef, 'no "file" header'; + is $tx->req->content->parts->[0]->headers->content_disposition, undef, 'no "Content-Disposition" value'; + is $tx->req->content->parts->[0]->headers->dnt, 1, 'right "DNT" header'; is $tx->req->content->parts->[1], undef, 'no more parts'; }; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_online.t libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_online.t --- libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_online.t 2021-01-17 16:37:41.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_online.t 2021-06-30 13:58:00.000000000 +0000 @@ -24,209 +24,221 @@ $c->render(text => $c->tx->remote_address); }; -# Make sure user agents dont taint the ioloop my $loop = Mojo::IOLoop->singleton; my $ua = Mojo::UserAgent->new; -my ($id, $code); -$ua->get( - 'http://metacpan.org' => sub { - my ($ua, $tx) = @_; - $id = $tx->connection; - $code = $tx->res->code; - $loop->stop; - } -); -$loop->start; -$ua = undef; -$loop->timer(0.25 => sub { shift->stop }); -$loop->start; -ok !$loop->stream($id), 'loop not tainted'; -is $code, 301, 'right status'; -# Fresh user agent +subtest 'Make sure user agents dont taint the ioloop' => sub { + my ($id, $code); + $ua->get( + 'http://metacpan.org' => sub { + my ($ua, $tx) = @_; + $id = $tx->connection; + $code = $tx->res->code; + $loop->stop; + } + ); + $loop->start; + $ua = undef; + $loop->timer(0.25 => sub { shift->stop }); + $loop->start; + ok !$loop->stream($id), 'loop not tainted'; + is $code, 301, 'right status'; +}; + $ua = Mojo::UserAgent->new; -# Local address -$ua->server->app(app); -my $sock = IO::Socket::INET->new(PeerAddr => 'mojolicious.org', PeerPort => 80); -my $address = $sock->sockhost; -isnt $address, '127.0.0.1', 'different address'; -$ua->local_address('127.0.0.1')->max_connections(0); -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'; +subtest 'Local address' => sub { + $ua->server->app(app); + my $sock = IO::Socket::INET->new(PeerAddr => 'mojolicious.org', PeerPort => 80); + my $address = $sock->sockhost; + isnt $address, '127.0.0.1', 'different address'; + $ua->max_connections(0)->socket_options->{LocalAddr} = '127.0.0.1'; + 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->socket_options->{LocalAddr} = $address; + is $ua->get('/remote_address')->res->body, $address, 'right address'; +}; -# Fresh user agent $ua = Mojo::UserAgent->new; - -# Connection refused my $port = Mojo::IOLoop::Server->generate_port; -$tx = $ua->build_tx(GET => "http://127.0.0.1:$port"); -$ua->start($tx); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->error, 'has error'; - -# Connection refused (IPv4) -$tx = $ua->build_tx(GET => "http://127.0.0.1:$port"); -$ua->start($tx); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->error, 'has error'; - -# Connection refused (IPv6) -$tx = $ua->build_tx(GET => "http://[::1]:$port"); -$ua->start($tx); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->error, 'has error'; - -# Host does not exist -$tx = $ua->build_tx(GET => 'http://cdeabcdeffoobarnonexisting.com'); -$ua->start($tx); -ok $tx->is_finished, 'transaction is finished'; -ok $tx->error, 'has error'; -# Fresh user agent again +subtest 'Connection refused' => sub { + my $tx = $ua->build_tx(GET => "http://127.0.0.1:$port"); + $ua->start($tx); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->error, 'has error'; +}; + +subtest 'Connection refused (IPv4)' => sub { + my $tx = $ua->build_tx(GET => "http://127.0.0.1:$port"); + $ua->start($tx); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->error, 'has error'; +}; + +subtest 'Connection refused (IPv6)' => sub { + my $tx = $ua->build_tx(GET => "http://[::1]:$port"); + $ua->start($tx); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->error, 'has error'; +}; + +subtest 'Host does not exist' => sub { + my $tx = $ua->build_tx(GET => 'http://cdeabcdeffoobarnonexisting.com'); + $ua->start($tx); + ok $tx->is_finished, 'transaction is finished'; + ok $tx->error, 'has error'; +}; + $ua = Mojo::UserAgent->new; -# Keep-alive -$ua->get('http://mojolicious.org' => sub { Mojo::IOLoop->singleton->stop }); -Mojo::IOLoop->singleton->start; -my $kept_alive; -$ua->get( - 'http://mojolicious.org' => sub { - my ($ua, $tx) = @_; - Mojo::IOLoop->singleton->stop; - $kept_alive = $tx->kept_alive; - } -); -Mojo::IOLoop->singleton->start; -ok $kept_alive, 'connection was kept alive'; - -# Nested keep-alive -my @kept_alive; -$ua->get( - 'http://mojolicious.org' => sub { - my ($ua, $tx) = @_; - push @kept_alive, $tx->kept_alive; - $ua->get( - 'http://mojolicious.org' => sub { - my ($ua, $tx) = @_; - push @kept_alive, $tx->kept_alive; - $ua->get( - 'http://mojolicious.org' => sub { - my ($ua, $tx) = @_; - push @kept_alive, $tx->kept_alive; - Mojo::IOLoop->singleton->stop; - } - ); - } - ); - } -); -Mojo::IOLoop->singleton->start; -is_deeply \@kept_alive, [1, 1, 1], 'connections kept alive'; +subtest 'Keep-alive' => sub { + $ua->get('http://mojolicious.org' => sub { Mojo::IOLoop->singleton->stop }); + Mojo::IOLoop->singleton->start; + my $kept_alive; + $ua->get( + 'http://mojolicious.org' => sub { + my ($ua, $tx) = @_; + Mojo::IOLoop->singleton->stop; + $kept_alive = $tx->kept_alive; + } + ); + Mojo::IOLoop->singleton->start; + ok $kept_alive, 'connection was kept alive'; +}; + +subtest 'Nested keep-alive' => sub { + my @kept_alive; + $ua->get( + 'http://mojolicious.org' => sub { + my ($ua, $tx) = @_; + push @kept_alive, $tx->kept_alive; + $ua->get( + 'http://mojolicious.org' => sub { + my ($ua, $tx) = @_; + push @kept_alive, $tx->kept_alive; + $ua->get( + 'http://mojolicious.org' => sub { + my ($ua, $tx) = @_; + push @kept_alive, $tx->kept_alive; + Mojo::IOLoop->singleton->stop; + } + ); + } + ); + } + ); + Mojo::IOLoop->singleton->start; + is_deeply \@kept_alive, [1, 1, 1], 'connections kept alive'; +}; -# Fresh user agent again $ua = Mojo::UserAgent->new; -# Custom non-keep-alive request -$tx = Mojo::Transaction::HTTP->new; -$tx->req->method('GET'); -$tx->req->url->parse('http://metacpan.org'); -$tx->req->headers->connection('close'); -$ua->start($tx); -ok $tx->is_finished, 'transaction is finished'; -is $tx->res->code, 301, 'right status'; -like $tx->res->headers->connection, qr/close/i, 'right "Connection" header'; - -# One-liner -is g('mojolicious.org')->code, 200, 'right status'; -is h('mojolicious.org')->code, 200, 'right status'; -is h('mojolicious.org')->body, '', 'no content'; -is p('mojolicious.org/lalalala')->code, 404, 'right status'; -is g('http://mojolicious.org')->code, 200, 'right status'; -my $res = p('https://metacpan.org/search' => form => {q => 'mojolicious'}); -like $res->body, qr/Mojolicious/, 'right content'; -is $res->code, 200, 'right status'; - -# Simple request -$tx = $ua->get('metacpan.org'); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'http://metacpan.org', 'right url'; -is $tx->res->code, 301, 'right status'; - -# Simple keep-alive requests -$tx = $ua->get('https://www.wikipedia.org'); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'https://www.wikipedia.org', 'right url'; -is $tx->req->body, '', 'no content'; -is $tx->res->code, 200, 'right status'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok !$tx->kept_alive, 'connection was not kept alive'; -$tx = $ua->get('https://www.wikipedia.org'); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'https://www.wikipedia.org', 'right url'; -is $tx->res->code, 200, 'right status'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; -$tx = $ua->get('https://www.wikipedia.org'); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'https://www.wikipedia.org', 'right url'; -is $tx->res->code, 200, 'right status'; -ok $tx->keep_alive, 'connection will be kept alive'; -ok $tx->kept_alive, 'connection was kept alive'; - -# Simple HTTPS request -$tx = $ua->get('https://metacpan.org'); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'https://metacpan.org', 'right url'; -is $tx->res->code, 200, 'right status'; +subtest 'Custom non-keep-alive request' => sub { + my $tx = Mojo::Transaction::HTTP->new; + $tx->req->method('GET'); + $tx->req->url->parse('http://metacpan.org'); + $tx->req->headers->connection('close'); + $ua->start($tx); + ok $tx->is_finished, 'transaction is finished'; + is $tx->res->code, 301, 'right status'; + like $tx->res->headers->connection, qr/close/i, 'right "Connection" header'; +}; + +subtest 'One-liner' => sub { + is g('mojolicious.org')->code, 200, 'right status'; + is h('mojolicious.org')->code, 200, 'right status'; + is h('mojolicious.org')->body, '', 'no content'; + is p('mojolicious.org/lalalala')->code, 404, 'right status'; + is g('http://mojolicious.org')->code, 200, 'right status'; + my $res = p('https://metacpan.org/search' => form => {q => 'mojolicious'}); + like $res->body, qr/Mojolicious/, 'right content'; + is $res->code, 200, 'right status'; +}; + +subtest 'Simple request' => sub { + my $tx = $ua->get('metacpan.org'); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'http://metacpan.org', 'right url'; + is $tx->res->code, 301, 'right status'; +}; + +subtest 'Simple keep-alive requests' => sub { + my $tx = $ua->get('https://www.wikipedia.org'); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'https://www.wikipedia.org', 'right url'; + is $tx->req->body, '', 'no content'; + is $tx->res->code, 200, 'right status'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok !$tx->kept_alive, 'connection was not kept alive'; + $tx = $ua->get('https://www.wikipedia.org'); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'https://www.wikipedia.org', 'right url'; + is $tx->res->code, 200, 'right status'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; + $tx = $ua->get('https://www.wikipedia.org'); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'https://www.wikipedia.org', 'right url'; + is $tx->res->code, 200, 'right status'; + ok $tx->keep_alive, 'connection will be kept alive'; + ok $tx->kept_alive, 'connection was kept alive'; +}; + +subtest 'Simple HTTPS request' => sub { + my $tx = $ua->get('https://metacpan.org'); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'https://metacpan.org', 'right url'; + is $tx->res->code, 200, 'right status'; +}; -# Fresh user agent again $ua = Mojo::UserAgent->new; -# Simple keep-alive form POST -$tx = $ua->post('https://metacpan.org/search' => form => {q => 'mojolicious'}); -is $tx->req->method, 'POST', 'right method'; -is $tx->req->url, 'https://metacpan.org/search', 'right url'; -is $tx->req->headers->content_length, 13, 'right content length'; -is $tx->req->body, 'q=mojolicious', 'right content'; -like $tx->res->body, qr/Mojolicious/, 'right content'; -is $tx->res->code, 200, 'right status'; -ok $tx->keep_alive, 'connection will be kept alive'; -$tx = $ua->post('https://metacpan.org/search' => form => {q => 'mojolicious'}); -is $tx->req->method, 'POST', 'right method'; -is $tx->req->url, 'https://metacpan.org/search', 'right url'; -is $tx->req->headers->content_length, 13, 'right content length'; -is $tx->req->body, 'q=mojolicious', 'right content'; -like $tx->res->body, qr/Mojolicious/, 'right content'; -is $tx->res->code, 200, 'right status'; -ok $tx->kept_alive, 'connection was kept alive'; -ok $tx->local_address, 'has local address'; -ok $tx->local_port > 0, 'has local port'; -ok $tx->original_remote_address, 'has original remote address'; -ok $tx->remote_address, 'has remote address'; -ok $tx->remote_port > 0, 'has remote port'; - -# Simple request with redirect -$ua->max_redirects(3); -$tx = $ua->get('http://wikipedia.org/wiki/Perl'); -$ua->max_redirects(0); -is $tx->req->method, 'GET', 'right method'; -is $tx->req->url, 'https://en.wikipedia.org/wiki/Perl', 'right url'; -is $tx->res->code, 200, 'right status'; -is $tx->previous->req->method, 'GET', 'right method'; -is $tx->previous->req->url, 'https://www.wikipedia.org/wiki/Perl', 'right url'; -is $tx->previous->res->code, 301, 'right status'; -is $tx->redirects->[-1]->req->method, 'GET', 'right method'; -is $tx->redirects->[-1]->req->url, 'https://www.wikipedia.org/wiki/Perl', 'right url'; -is $tx->redirects->[-1]->res->code, 301, 'right status'; - -# Connect timeout (non-routable address) -$tx = $ua->connect_timeout(0.5)->get('192.0.2.1'); -ok $tx->is_finished, 'transaction is finished'; -is $tx->error->{message}, 'Connect timeout', 'right error'; -$ua->connect_timeout(3); +subtest 'Simple keep-alive form POST' => sub { + my $tx = $ua->post('https://metacpan.org/search' => form => {q => 'mojolicious'}); + is $tx->req->method, 'POST', 'right method'; + is $tx->req->url, 'https://metacpan.org/search', 'right url'; + is $tx->req->headers->content_length, 13, 'right content length'; + is $tx->req->body, 'q=mojolicious', 'right content'; + like $tx->res->body, qr/Mojolicious/, 'right content'; + is $tx->res->code, 200, 'right status'; + ok $tx->keep_alive, 'connection will be kept alive'; + $tx = $ua->post('https://metacpan.org/search' => form => {q => 'mojolicious'}); + is $tx->req->method, 'POST', 'right method'; + is $tx->req->url, 'https://metacpan.org/search', 'right url'; + is $tx->req->headers->content_length, 13, 'right content length'; + is $tx->req->body, 'q=mojolicious', 'right content'; + like $tx->res->body, qr/Mojolicious/, 'right content'; + is $tx->res->code, 200, 'right status'; + ok $tx->kept_alive, 'connection was kept alive'; + ok $tx->local_address, 'has local address'; + ok $tx->local_port > 0, 'has local port'; + ok $tx->original_remote_address, 'has original remote address'; + ok $tx->remote_address, 'has remote address'; + ok $tx->remote_port > 0, 'has remote port'; +}; + +subtest 'Simple request with redirect' => sub { + $ua->max_redirects(3); + my $tx = $ua->get('http://wikipedia.org/wiki/Perl'); + $ua->max_redirects(0); + is $tx->req->method, 'GET', 'right method'; + is $tx->req->url, 'https://en.wikipedia.org/wiki/Perl', 'right url'; + is $tx->res->code, 200, 'right status'; + is $tx->previous->req->method, 'GET', 'right method'; + is $tx->previous->req->url, 'https://www.wikipedia.org/wiki/Perl', 'right url'; + is $tx->previous->res->code, 301, 'right status'; + is $tx->redirects->[-1]->req->method, 'GET', 'right method'; + is $tx->redirects->[-1]->req->url, 'https://www.wikipedia.org/wiki/Perl', 'right url'; + is $tx->redirects->[-1]->res->code, 301, 'right status'; +}; + +subtest 'Connect timeout (non-routable address)' => sub { + my $tx = $ua->connect_timeout(0.5)->get('192.0.2.1'); + ok $tx->is_finished, 'transaction is finished'; + is $tx->error->{message}, 'Connect timeout', 'right error'; + $ua->connect_timeout(3); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_socks.t libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_socks.t --- libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_socks.t 2021-01-17 16:37:26.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_socks.t 2021-08-09 19:27:48.000000000 +0000 @@ -99,67 +99,76 @@ } ); -# Failed authentication with SOCKS proxy -my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); -$ua->proxy->http("socks://foo:baz\@127.0.0.1:$port"); -my $tx = $ua->get('/'); -ok $tx->error, 'has error'; - -# Simple request with SOCKS proxy -$ua->proxy->http("socks://foo:bar\@127.0.0.1:$port"); -$tx = $ua->get('/'); -ok !$tx->error, 'no error'; -ok !$tx->kept_alive, 'kept connection not alive'; -ok $tx->keep_alive, 'keep connection alive'; -is $tx->res->code, 200, 'right status'; -is $tx->req->headers->proxy_authorization, undef, 'no "Proxy-Authorization" value'; -is $tx->res->body, $last, 'right content'; -isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); - -# Keep alive request with SOCKS proxy -my $before = $last; -$tx = $ua->get('/'); -ok !$tx->error, 'no error'; -ok $tx->kept_alive, 'kept connection alive'; -ok $tx->keep_alive, 'keep connection alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, $last, 'right content'; -is $before, $last, 'same port'; -isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); - -# WebSocket with SOCKS proxy -my ($result, $id); -$ua->websocket( - '/echo' => sub { - my ($ua, $tx) = @_; - $id = $tx->connection; - $tx->on(message => sub { $result = pop; Mojo::IOLoop->stop }); - $tx->send('test'); - } -); -Mojo::IOLoop->start; -is $result, $last, 'right result'; -isnt(Mojo::IOLoop->stream($id)->handle->sockport, $last, 'different ports'); - -# HTTPS request with SOCKS proxy -$ua->proxy->https("socks://foo:bar\@127.0.0.1:$port"); -$ua->server->url('https'); -$tx = $ua->get('/secure'); -ok !$tx->error, 'no error'; -ok !$tx->kept_alive, 'kept connection not alive'; -ok $tx->keep_alive, 'keep connection alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, "https:$last", 'right content'; -isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); - -# Disabled SOCKS proxy -$ua->server->url('http'); -$ua->proxy->http("socks://foo:baz\@127.0.0.1:$port"); -$tx = $ua->build_tx(GET => '/'); -$tx->req->via_proxy(0); -$tx = $ua->start($tx); -ok !$tx->error, 'no error'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, $tx->local_port, 'right content'; +subtest 'Failed authentication with SOCKS proxy' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); + $ua->proxy->http("socks://foo:baz\@127.0.0.1:$port"); + my $tx = $ua->get('/'); + ok $tx->error, 'has error'; +}; + +subtest 'Simple request with SOCKS proxy' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); + $ua->proxy->http("socks://foo:bar\@127.0.0.1:$port"); + my $tx = $ua->get('/'); + ok !$tx->error, 'no error'; + ok !$tx->kept_alive, 'kept connection not alive'; + ok $tx->keep_alive, 'keep connection alive'; + is $tx->res->code, 200, 'right status'; + is $tx->req->headers->proxy_authorization, undef, 'no "Proxy-Authorization" value'; + is $tx->res->body, $last, 'right content'; + isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); + + my $before = $last; + $tx = $ua->get('/'); + ok !$tx->error, 'no error'; + ok $tx->kept_alive, 'kept connection alive'; + ok $tx->keep_alive, 'keep connection alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, $last, 'right content'; + is $before, $last, 'same port'; + isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); +}; + +subtest 'WebSocket with SOCKS proxy' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); + $ua->proxy->http("socks://foo:bar\@127.0.0.1:$port"); + my ($result, $id); + $ua->websocket( + '/echo' => sub { + my ($ua, $tx) = @_; + $id = $tx->connection; + $tx->on(message => sub { $result = pop; Mojo::IOLoop->stop }); + $tx->send('test'); + } + ); + Mojo::IOLoop->start; + is $result, $last, 'right result'; + isnt(Mojo::IOLoop->stream($id)->handle->sockport, $last, 'different ports'); +}; + +subtest 'HTTPS request with SOCKS proxy' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); + $ua->proxy->https("socks://foo:bar\@127.0.0.1:$port"); + $ua->server->url('https'); + my $tx = $ua->get('/secure'); + ok !$tx->error, 'no error'; + ok !$tx->kept_alive, 'kept connection not alive'; + ok $tx->keep_alive, 'keep connection alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, "https:$last", 'right content'; + isnt(Mojo::IOLoop->stream($tx->connection)->handle->sockport, $last, 'different ports'); +}; + +subtest 'Disabled SOCKS proxy' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton, insecure => 1); + $ua->server->url('http'); + $ua->proxy->http("socks://foo:baz\@127.0.0.1:$port"); + my $tx = $ua->build_tx(GET => '/'); + $tx->req->via_proxy(0); + $tx = $ua->start($tx); + ok !$tx->error, 'no error'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, $tx->local_port, 'right content'; +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/user_agent.t libmojolicious-perl-9.22+dfsg/t/mojo/user_agent.t --- libmojolicious-perl-8.71+dfsg/t/mojo/user_agent.t 2021-01-17 16:37:43.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/user_agent.t 2021-08-09 16:36:45.000000000 +0000 @@ -8,6 +8,7 @@ use Test::More; use Mojo::IOLoop; use Mojo::Message::Request; +use Mojo::Promise; use Mojo::Server::Daemon; use Mojo::UserAgent; use Mojo::UserAgent::Server; @@ -15,7 +16,7 @@ use Mojolicious::Lite; # Silence -app->log->level('debug')->unsubscribe('message'); +app->log->level('trace')->unsubscribe('message'); get '/' => {text => 'works!'}; @@ -510,7 +511,7 @@ ok $tx->keep_alive, 'keep connection alive'; is $tx->res->code, 200, 'right status'; is $tx->res->body, 'works!', 'right content'; -$ua->ioloop->delay->timer(1)->wait; +Mojo::Promise->new->ioloop($ua->ioloop)->timer(1)->wait; $tx = $ua->get("http://127.0.0.1:$port"); ok !$tx->kept_alive, 'kept connection not alive'; ok $tx->keep_alive, 'keep connection alive'; @@ -733,16 +734,10 @@ # Connection limit $ua = Mojo::UserAgent->new(max_connections => 2); $result = undef; -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; +my @txs = map { $ua->get_p('/') } 1 .. 5; +Mojo::Promise->all(@txs)->then(sub { + $result = [grep {defined} map { Mojo::IOLoop->stream($_->connection) } map { $_->[0] } @_]; +})->wait; is scalar @$result, 2, 'two active connections'; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_tls.t libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_tls.t --- libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_tls.t 2021-01-17 16:37:42.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_tls.t 2021-08-13 19:07:33.000000000 +0000 @@ -18,78 +18,84 @@ get '/' => {text => 'works!'}; -# Web server with valid certificates -my $daemon = Mojo::Server::Daemon->new(app => app, ioloop => Mojo::IOLoop->singleton, silent => 1); -my $listen - = 'https://127.0.0.1' - . '?cert=t/mojo/certs/server.crt' - . '&key=t/mojo/certs/server.key' - . '&ca=t/mojo/certs/ca.crt&verify=0x03'; -my $port = $daemon->listen([$listen])->start->ports->[0]; - -# No certificate -my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); -my $tx = $ua->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; -$tx = $ua->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; -$tx = $ua->ca('t/mojo/certs/ca.crt')->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; -$tx = $ua->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; - -# Valid certificates -$ua->ca('t/mojo/certs/ca.crt')->cert('t/mojo/certs/client.crt')->key('t/mojo/certs/client.key'); -$tx = $ua->get("https://127.0.0.1:$port"); -ok !$tx->error, 'no error'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'works!', 'right content'; - -# Valid certificates (env) -$ua = Mojo::UserAgent->new(ioloop => $ua->ioloop); -{ - local $ENV{MOJO_CA_FILE} = 't/mojo/certs/ca.crt'; - local $ENV{MOJO_CERT_FILE} = 't/mojo/certs/client.crt'; - local $ENV{MOJO_KEY_FILE} = 't/mojo/certs/client.key'; - local $ENV{MOJO_INSECURE} = 0; +subtest 'Web server with valid certificates' => sub { + my $daemon = Mojo::Server::Daemon->new(app => app, ioloop => Mojo::IOLoop->singleton, silent => 1); + my $listen + = 'https://127.0.0.1' + . '?cert=t/mojo/certs/server.crt' + . '&key=t/mojo/certs/server.key' + . '&ca=t/mojo/certs/ca.crt&verify=0x03'; + my $port = $daemon->listen([$listen])->start->ports->[0]; + + subtest 'No certificate' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); + my $tx = $ua->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + $tx = $ua->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + $tx = $ua->ca('t/mojo/certs/ca.crt')->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + $tx = $ua->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + }; + + subtest 'Valid certificates' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); + $ua->ca('t/mojo/certs/ca.crt')->cert('t/mojo/certs/client.crt')->key('t/mojo/certs/client.key'); + my $tx = $ua->get("https://127.0.0.1:$port"); + ok !$tx->error, 'no error'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'works!', 'right content'; + }; + + subtest 'Valid certificates (env)' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); + local $ENV{MOJO_CA_FILE} = 't/mojo/certs/ca.crt'; + local $ENV{MOJO_CERT_FILE} = 't/mojo/certs/client.crt'; + local $ENV{MOJO_KEY_FILE} = 't/mojo/certs/client.key'; + local $ENV{MOJO_INSECURE} = 0; + my $tx = $ua->get("https://127.0.0.1:$port"); + is $ua->ca, 't/mojo/certs/ca.crt', 'right path'; + is $ua->cert, 't/mojo/certs/client.crt', 'right path'; + is $ua->key, 't/mojo/certs/client.key', 'right path'; + is $ua->insecure, 0, 'secure'; + ok !$tx->error, 'no error'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'works!', 'right content'; + }; + + subtest 'Invalid certificate' => sub { + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); + $ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); + my $tx = $ua->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + }; +}; + + +subtest 'Web server with valid certificates and no verification' => sub { + my $daemon = Mojo::Server::Daemon->new(app => app, ioloop => Mojo::IOLoop->singleton, silent => 1); + my $listen + = 'https://127.0.0.1' + . '?cert=t/mojo/certs/server.crt' + . '&key=t/mojo/certs/server.key' + . '&ca=t/mojo/certs/ca.crt' + . '&ciphers=AES256-SHA:ALL' + . '&verify=0x00' + . '&version=TLSv1'; + my $port = $daemon->listen([$listen])->start->ports->[0]; + + # Invalid certificate + my $ua = Mojo::UserAgent->new(ioloop => Mojo::IOLoop->singleton); + $ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); + my $tx = $ua->get("https://127.0.0.1:$port"); + ok $tx->error, 'has error'; + $ua = Mojo::UserAgent->new(ioloop => $ua->ioloop, insecure => 1); + $ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); $tx = $ua->get("https://127.0.0.1:$port"); - is $ua->ca, 't/mojo/certs/ca.crt', 'right path'; - is $ua->cert, 't/mojo/certs/client.crt', 'right path'; - is $ua->key, 't/mojo/certs/client.key', 'right path'; - is $ua->insecure, 0, 'secure'; ok !$tx->error, 'no error'; - is $tx->res->code, 200, 'right status'; - is $tx->res->body, 'works!', 'right content'; -} - -# Invalid certificate -$ua = Mojo::UserAgent->new(ioloop => $ua->ioloop); -$ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); -$tx = $ua->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; - -# Web server with valid certificates and no verification -$daemon = Mojo::Server::Daemon->new(app => app, ioloop => Mojo::IOLoop->singleton, silent => 1); -$listen - = 'https://127.0.0.1' - . '?cert=t/mojo/certs/server.crt' - . '&key=t/mojo/certs/server.key' - . '&ca=t/mojo/certs/ca.crt' - . '&ciphers=AES256-SHA:ALL' - . '&verify=0x00' - . '&version=TLSv1'; -$port = $daemon->listen([$listen])->start->ports->[0]; - -# Invalid certificate -$ua = Mojo::UserAgent->new(ioloop => $ua->ioloop); -$ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); -$tx = $ua->get("https://127.0.0.1:$port"); -ok $tx->error, 'has error'; -$ua = Mojo::UserAgent->new(ioloop => $ua->ioloop, insecure => 1); -$ua->cert('t/mojo/certs/bad.crt')->key('t/mojo/certs/bad.key'); -$tx = $ua->get("https://127.0.0.1:$port"); -ok !$tx->error, 'no error'; -is $ua->ioloop->stream($tx->connection)->handle->get_cipher, 'AES256-SHA', 'AES256-SHA has been negotiatied'; -is $ua->ioloop->stream($tx->connection)->handle->get_sslversion, 'TLSv1', 'TLSv1 has been negotiatied'; + is $ua->ioloop->stream($tx->connection)->handle->get_cipher, 'AES256-SHA', 'AES256-SHA has been negotiatied'; + is $ua->ioloop->stream($tx->connection)->handle->get_sslversion, 'TLSv1', 'TLSv1 has been negotiatied'; +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_unix.t libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_unix.t --- libmojolicious-perl-8.71+dfsg/t/mojo/user_agent_unix.t 2021-01-17 16:37:31.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/user_agent_unix.t 2021-08-13 19:07:33.000000000 +0000 @@ -51,76 +51,83 @@ my $fd = fileno $daemon->ioloop->acceptor($daemon->acceptors->[0])->handle; like $ENV{MOJO_REUSE}, qr/^unix:\Q$test\E:\Q$fd\E/, 'file descriptor can be reused'; -# Root my $ua = Mojo::UserAgent->new(ioloop => $daemon->ioloop); -my $tx = $ua->get("http+unix://$encoded/"); -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, '/', 'right content'; -$tx = $ua->get("http+unix://$encoded/"); -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, '/', 'right content'; - -# Connection information -$tx = $ua->get("http+unix://$encoded/info"); -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'None:None:None:None', 'right content'; - -# WebSocket -my $result; -$ua->websocket( - "ws+unix://$encoded/echo" => sub { - my ($ua, $tx) = @_; - $tx->on(finish => sub { Mojo::IOLoop->stop }); - $tx->on(message => sub { shift->finish; $result = shift }); - $tx->send('roundtrip works!'); - } -); -Mojo::IOLoop->start; -is $result, "$test: roundtrip works!", 'right result'; - -# WebSocket again -$result = undef; -$ua->websocket( - "ws+unix://$encoded/echo" => sub { - my ($ua, $tx) = @_; - $tx->on(finish => sub { Mojo::IOLoop->stop }); - $tx->on(message => sub { shift->finish; $result = shift }); - $tx->send('roundtrip works!'); - } -); -Mojo::IOLoop->start; -is $result, "$test: roundtrip works!", 'right result'; - -# WebSocket with proxy -my $proxy = $dir->child('proxy.sock'); -my $encoded_proxy = url_escape $proxy; -my $id = Mojo::TestConnectProxy::proxy({path => "$proxy"}, {path => "$test"}); -$result = undef; -$ua->proxy->http("http+unix://$encoded_proxy"); -$ua->websocket( - 'ws://example.com/echo' => sub { - my ($ua, $tx) = @_; - $tx->on(finish => sub { Mojo::IOLoop->stop }); - $tx->on(message => sub { shift->finish; $result = shift }); - $tx->send('roundtrip works!'); - } -); -Mojo::IOLoop->start; -is $result, 'example.com: roundtrip works!', 'right result'; -Mojo::IOLoop->remove($id); - -# Proxy -$ua->proxy->http("http+unix://$encoded"); -$tx = $ua->get('http://example.com'); -ok !$tx->kept_alive, 'connection was not kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'http://example.com', 'right content'; -$tx = $ua->get('http://example.com'); -ok $tx->kept_alive, 'connection was kept alive'; -is $tx->res->code, 200, 'right status'; -is $tx->res->body, 'http://example.com', 'right content'; + +subtest 'Root' => sub { + my $tx = $ua->get("http+unix://$encoded/"); + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, '/', 'right content'; + $tx = $ua->get("http+unix://$encoded/"); + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, '/', 'right content'; +}; + +subtest 'Connection information' => sub { + my $tx = $ua->get("http+unix://$encoded/info"); + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'None:None:None:None', 'right content'; +}; + +subtest 'WebSocket' => sub { + my $result; + $ua->websocket( + "ws+unix://$encoded/echo" => sub { + my ($ua, $tx) = @_; + $tx->on(finish => sub { Mojo::IOLoop->stop }); + $tx->on(message => sub { shift->finish; $result = shift }); + $tx->send('roundtrip works!'); + } + ); + Mojo::IOLoop->start; + is $result, "$test: roundtrip works!", 'right result'; +}; + +subtest 'WebSocket again' => sub { + my $result; + $ua->websocket( + "ws+unix://$encoded/echo" => sub { + my ($ua, $tx) = @_; + $tx->on(finish => sub { Mojo::IOLoop->stop }); + $tx->on(message => sub { shift->finish; $result = shift }); + $tx->send('roundtrip works!'); + } + ); + Mojo::IOLoop->start; + is $result, "$test: roundtrip works!", 'right result'; +}; + +subtest 'WebSocket with proxy' => sub { + my $proxy = $dir->child('proxy.sock'); + my $encoded_proxy = url_escape $proxy; + my $id = Mojo::TestConnectProxy::proxy({path => "$proxy"}, {path => "$test"}); + my $result; + $ua->proxy->http("http+unix://$encoded_proxy"); + $ua->websocket( + 'ws://example.com/echo' => sub { + my ($ua, $tx) = @_; + $tx->on(finish => sub { Mojo::IOLoop->stop }); + $tx->on(message => sub { shift->finish; $result = shift }); + $tx->send('roundtrip works!'); + } + ); + Mojo::IOLoop->start; + is $result, 'example.com: roundtrip works!', 'right result'; + Mojo::IOLoop->remove($id); +}; + +subtest 'Proxy' => sub { + $ua->proxy->http("http+unix://$encoded"); + my $tx = $ua->get('http://example.com'); + ok !$tx->kept_alive, 'connection was not kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'http://example.com', 'right content'; + $tx = $ua->get('http://example.com'); + ok $tx->kept_alive, 'connection was kept alive'; + is $tx->res->code, 200, 'right status'; + is $tx->res->body, 'http://example.com', 'right content'; +}; # Cleanup undef $daemon; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/util.t libmojolicious-perl-9.22+dfsg/t/mojo/util.t --- libmojolicious-perl-8.71+dfsg/t/mojo/util.t 2021-01-17 16:37:39.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/util.t 2021-06-30 13:58:00.000000000 +0000 @@ -10,9 +10,9 @@ use Mojo::Util qw(b64_decode b64_encode camelize class_to_file class_to_path decamelize decode dumper encode), qw(extract_usage getopt gunzip gzip hmac_sha1_sum html_unescape html_attr_unescape humanize_bytes md5_bytes md5_sum), - qw(monkey_patch punycode_decode punycode_encode quote scope_guard secure_compare sha1_bytes sha1_sum slugify), - qw(split_cookie_header split_header steady_time tablify term_escape trim unindent unquote url_escape url_unescape), - qw(xml_escape xor_encode); + qw(monkey_patch network_contains punycode_decode punycode_encode quote scope_guard secure_compare sha1_bytes), + qw(sha1_sum slugify split_cookie_header split_header steady_time tablify term_escape trim unindent unquote), + qw(url_escape url_unescape xml_escape xor_encode); subtest 'camelize' => sub { is camelize('foo_bar_baz'), 'FooBarBaz', 'right camelized result'; @@ -479,6 +479,78 @@ is subname(MojoMonkeyTest->can('bar')), 'MojoMonkeyTest::bar', 'right name'; }; +subtest 'network_contains' => sub { + ok !network_contains('10.0.0.0/8', ''), 'empty address'; + ok !network_contains('', '10.10.10.10'), 'empty network'; + ok !network_contains('foo', '10.10.10.10'), 'invalid v4 network'; + ok !network_contains('10.10.10.10', 'foo'), 'invalid v4 address'; + ok !network_contains('foo:', '::'), 'invalid v6 network'; + ok !network_contains('::', 'foo:'), 'invalid v6 address'; + ok !network_contains('::/96', '192.168.0.1'), 'v6 network, v4 address'; + ok !network_contains('10.10.10.10/32', '::'), 'v4 network, v6 address'; + + ok network_contains('192.168.0.1/33', '192.168.0.1'), 'oversize v4 mask'; + ok network_contains('::/130', '::'), 'oversize v6 mask'; + + ok network_contains('0.0.0.0/0', '0.0.0.0'), 'v4 network contains addresss'; + ok network_contains('0.0.0.0/0', '255.255.255.255'), 'v4 network contains addresss'; + ok network_contains('192.168.0.0/24', '192.168.0.1'), 'v4 network contains addresss'; + ok network_contains('10.10.10.8/30', '10.10.10.11'), 'v4 network contains addresss'; + ok network_contains('10.10.10.8/30', '10.10.10.8'), 'v4 network contains addresss'; + ok network_contains('10.10.10.8/31', '10.10.10.9'), 'v4 network contains addresss'; + ok network_contains('10.0.0.0/8', '10.255.255.255'), 'v4 network contains addresss'; + ok network_contains('255.255.255.255/32', '255.255.255.255'), 'v4 network contains addresss'; + ok network_contains('10.10.10.8/29', '10.10.10.10'), 'v4 network contains addresss'; + ok network_contains('127.0.0.1', '127.0.0.1'), 'v4 network contains addresss'; + + ok !network_contains('0.0.0.0/32', '0.0.0.1'), 'v4 network does not contain address'; + ok !network_contains('192.168.1.0/24', '192.168.0.1'), 'v4 network does not contain address'; + ok !network_contains('10.10.0.8/29', '10.10.10.8'), 'v4 network does not contain address'; + ok !network_contains('10.10.10.8/29', '10.10.10.7'), 'v4 network does not contain address'; + ok !network_contains('10.10.10.8/29', '10.10.10.16'), 'v4 network does not contain address'; + ok !network_contains('10.0.0.0/9', '10.255.255.255'), 'v4 network does not contain address'; + ok !network_contains('10.10.10.8/29', '10.10.10.19'), 'v4 network does not contain address'; + ok !network_contains('127.0.0.1', '127.0.0.2'), 'v4 network does not contain address'; + ok !network_contains('10.0.0.1/8', '10.0.0.2'), 'v4 network does not contain address'; + + ok network_contains('::/128', '::'), 'v6 network contains addresss'; + ok network_contains('::/0', '::'), 'v6 network contains addresss'; + ok network_contains('::1', '::1'), 'v6 network contains addresss'; + ok network_contains('::/0', 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff'), 'v6 network contains addresss'; + ok network_contains('1:2:3:4:5:6:0::/96', '1:2:3:4:5:6:8000:8'), 'v6 network contains addresss'; + ok network_contains('1:2:3:4:5:6:8000::/112', '1:2:3:4:5:6:8000:F1'), 'v6 network contains addresss'; + ok network_contains('1:2:3:4:5:6:8000:20/123', '1:2:3:4:5:6:8000:3F'), 'v6 network contains addresss'; + ok network_contains('ff:ff:ff:ff:ff:ff:8000::/127', 'ff:ff:ff:ff:ff:ff:8000:0'), 'v6 network contains addresss'; + ok network_contains('ff:ff:ff:ff:ff:ff:8000::/127', 'ff:ff:ff:ff:ff:ff:8000:1'), 'v6 network contains addresss'; + ok network_contains('::1', '::1'), 'v6 network contains addresss'; + ok network_contains('::1/128', '::1'), 'v6 network contains addresss'; + ok network_contains('a0:a0:a0:a0::/64', 'a0:a0:a0:a0:1::1'), 'v6 network contains addresss'; + ok network_contains('a0::/16', 'a0:b0:a0:a0:1::1'), 'v6 network contains addresss'; + ok network_contains('a000::/8', 'a0ff:dd0:1234:a0:1::1'), 'v6 network contains addresss'; + ok network_contains('::ffff:0:0/96', '::ffff:10.10.10.10'), 'v6 network contains addresss'; + ok network_contains('::ffff:127.0.0.0/120', '::ffff:127.0.0.255'), 'v6 network contains addresss'; + ok network_contains('::ffff:10.10.10.8/127', '::ffff:10.10.10.9'), 'v6 network contains addresss'; + + ok !network_contains('::1/0', '::'), 'v6 network does not contain address'; + ok !network_contains('::1', '::2'), 'v6 network does not contain address'; + ok !network_contains('1::/0', 'ffff:ffff:ffff:ffff:ffff:ffff:ffff:ffff'), 'v6 network does not contain address'; + ok !network_contains('1:2:3:4:5:6:0::/96', '1:2:3:4:5:7:8000:8'), 'v6 network does not contain address'; + ok !network_contains('1:2:3:4:5:6:8000::/112', '1:2:3:4:5:6:8001:F1'), 'v6 network does not contain address'; + ok !network_contains('1:2:3:4:5:6:8000:20/123', '1:2:3:4:5:6:8000:40'), 'v6 network does not contain address'; + ok !network_contains('ff:ff:ff:ff:ff:ff:8000::/127', 'ff:ff:ff:ff:ff:ff:8000:4'), + 'v6 network does not contain address'; + ok !network_contains('ff:ff:ff:ff:ff:ff:8000::/127', 'ff:ff:ff:ff:ff:ff:7FFF:0'), + 'v6 network does not contain address'; + ok !network_contains('::1', '1::1'), 'v6 network does not contain address'; + ok !network_contains('::1/128', '::11'), 'v6 network does not contain address'; + ok !network_contains('a0:a0:a0:a0::/64', 'a0:a0:a0:a1:1::1'), 'v6 network does not contain address'; + ok !network_contains('a0::/16', 'a1:b0:a0:a0:1::1'), 'v6 network does not contain address'; + ok !network_contains('a000::/8', 'b0ff:dd0:1234:a0:1::1'), 'v6 network does not contain address'; + ok !network_contains('::ffff:0:0/96', '::fffe:0a0a:0a0a'), 'v6 network does not contain address'; + ok !network_contains('::ffff:127.0.0.0/120', '::ffff:127.0.1.255'), 'v6 network does not contain address'; + ok !network_contains('::ffff:10.10.10.8/127', '::ffff:10.10.10.12'), 'v6 network does not contain address'; +}; + subtest 'tablify' => sub { is tablify([["f\r\no o\r\n", 'bar']]), "fo o bar\n", 'right result'; is tablify([[" foo", ' b a r']]), " foo b a r\n", 'right result'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojo/websocket.t libmojolicious-perl-9.22+dfsg/t/mojo/websocket.t --- libmojolicious-perl-8.71+dfsg/t/mojo/websocket.t 2021-01-17 16:37:25.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojo/websocket.t 2021-08-09 16:36:54.000000000 +0000 @@ -17,7 +17,7 @@ } # Silence -app->log->level('debug')->unsubscribe('message'); +app->log->level('trace')->unsubscribe('message'); # Avoid exception template app->renderer->paths->[0] = app->home->child('public'); @@ -238,10 +238,9 @@ is $result, 'test0test1', 'right result'; # Concurrent subrequests -my $delay = Mojo::IOLoop->delay; ($code, $result) = (); my ($code2, $result2); -my $end = $delay->begin; +my $promise = Mojo::Promise->new; $ua->websocket( '/subreq' => sub { my ($ua, $tx) = @_; @@ -253,19 +252,19 @@ $tx->finish if $msg eq 'test1'; } ); - $tx->on(finish => sub { $end->() }); + $tx->on(finish => sub { $promise->resolve }); } ); -my $end2 = $delay->begin; +my $promise2 = Mojo::Promise->new; $ua->websocket( '/subreq' => sub { my ($ua, $tx) = @_; $code2 = $tx->res->code; $tx->on(message => sub { $result2 .= pop }); - $tx->on(finish => sub { $end2->() }); + $tx->on(finish => sub { $promise2->resolve }); } ); -$delay->wait; +Mojo::Promise->all($promise, $promise2)->wait; is $code, 101, 'right status'; is $result, 'test0test1', 'right result'; is $code2, 101, 'right status'; @@ -389,7 +388,7 @@ $ua->websocket( '/close' => sub { my ($ua, $tx) = @_; - $tx->on(finish => sub { $status = pop; Mojo::IOLoop->stop }); + $tx->on(finish => sub { (undef, $status, undef) = @_; Mojo::IOLoop->stop }); $tx->send('test1'); } ); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/app.t 2021-01-17 16:37:49.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/app.t 2021-08-09 19:24:05.000000000 +0000 @@ -20,13 +20,19 @@ use Mojolicious; use Mojolicious::Controller; -# Missing config file -{ +subtest 'Missing config file' => sub { eval { Test::Mojo->new('MojoliciousConfigTest')->app }; like $@, qr/mojolicious_config_test.conf" missing/, 'right error'; local $ENV{MOJO_MODE} = 'whatever'; is(Test::Mojo->new('MojoliciousConfigTest')->app->config->{it}, 'works', 'right result'); -} +}; + +subtest 'Bad deployment plugins' => sub { + eval { Test::Mojo->new('MojoliciousTest')->app->plugin(Config => {default => {plugins => 'fail'}}) }; + like $@, qr/Configuration value "plugins" is not an array reference/, 'right error'; + eval { Test::Mojo->new('MojoliciousTest')->app->plugin(Config => {default => {plugins => ['fail']}}) }; + like $@, qr/Configuration value "plugins" contains an entry that is not a hash reference/, 'right error'; +}; # Mode detection { @@ -45,18 +51,27 @@ my $app = Mojolicious->new(home => Mojo::Home->new(@path)); is $app->home, path(@path), 'right home directory'; -# Config override -my $t = Test::Mojo->new('MojoliciousTest'); -ok !$t->app->config->{config_override}, 'no override'; -ok !$t->app->config->{foo}, 'no value'; -$t = Test::Mojo->new('MojoliciousTest', {foo => 'bar'}); -ok $t->app->config->{config_override}, 'override'; -is $t->app->config->{foo}, 'bar', 'right value'; -$t = Test::Mojo->new(MojoliciousTest->new, {foo => 'baz'}); -ok $t->app->config->{config_override}, 'override'; -is $t->app->config->{foo}, 'baz', 'right value'; +subtest 'Config override' => sub { + my $t = Test::Mojo->new('MojoliciousTest'); + ok !$t->app->config->{config_override}, 'no override'; + ok !$t->app->config->{foo}, 'no value'; + $t = Test::Mojo->new('MojoliciousTest', {foo => 'bar'}); + ok $t->app->config->{config_override}, 'override'; + is $t->app->config->{foo}, 'bar', 'right value'; + $t = Test::Mojo->new(MojoliciousTest->new, {foo => 'baz'}); + ok $t->app->config->{config_override}, 'override'; + is $t->app->config->{foo}, 'baz', 'right value'; + + my $app = Mojolicious->new; + $t = Test::Mojo->new($app); + ok !$t->app->config->{config_override}, 'no override'; + ok !$t->app->config->{foo}, 'no value'; + $t = Test::Mojo->new($app, {foo => 'bar'}); + ok $t->app->config->{config_override}, 'override'; + is $t->app->config->{foo}, 'bar', 'right value'; +}; -$t = Test::Mojo->new('MojoliciousTest'); +my $t = Test::Mojo->new('MojoliciousTest'); subtest 'Preload namespaces' => sub { is_deeply $t->app->preload_namespaces, ['MojoliciousTest::Controller'], 'right namespaces'; @@ -65,8 +80,8 @@ # Application is already available is $t->app->routes->find('something')->to_string, '/test4/:something', 'right pattern'; -is $t->app->routes->find('test3')->pattern->defaults->{namespace}, 'MojoliciousTestController', 'right namespace'; -is $t->app->routes->find('withblock')->pattern->defaults->{controller}, 'foo', 'right controller'; +is $t->app->routes->find('test3')->pattern->defaults->{namespace}, 'MojoliciousTest2::Foo', 'right namespace'; +is $t->app->routes->find('withblock')->pattern->defaults->{controller}, 'foo', 'right controller'; is ref $t->app->routes->find('something'), 'Mojolicious::Routes::Route', 'right class'; is ref $t->app->routes->find('something')->root, 'Mojolicious::Routes', 'right class'; is $t->app->sessions->cookie_domain, '.example.com', 'right domain'; @@ -98,44 +113,37 @@ eval { Mojolicious::Route::missing() }; like $@, qr/^Undefined subroutine &Mojolicious::Route::missing called/, 'right error'; -# Hidden controller attributes and methods -$t->app->routes->hide('bar'); -ok !$t->app->routes->is_hidden('foo'), 'not hidden'; -ok $t->app->routes->is_hidden('bar'), 'is hidden'; -ok $t->app->routes->is_hidden('_foo'), 'is hidden'; -ok $t->app->routes->is_hidden('AUTOLOAD'), 'is hidden'; -ok $t->app->routes->is_hidden('DESTROY'), 'is hidden'; -ok $t->app->routes->is_hidden('FOO_BAR'), 'is hidden'; -ok $t->app->routes->is_hidden('app'), 'is hidden'; -ok $t->app->routes->is_hidden('attr'), 'is hidden'; -ok $t->app->routes->is_hidden('continue'), 'is hidden'; -ok $t->app->routes->is_hidden('cookie'), 'is hidden'; -ok $t->app->routes->is_hidden('every_cookie'), 'is hidden'; -ok $t->app->routes->is_hidden('every_param'), 'is hidden'; -ok $t->app->routes->is_hidden('every_signed_cookie'), 'is hidden'; -ok $t->app->routes->is_hidden('finish'), 'is hidden'; -ok $t->app->routes->is_hidden('has'), 'is hidden'; -ok $t->app->routes->is_hidden('helpers'), 'is hidden'; -ok $t->app->routes->is_hidden('match'), 'is hidden'; -ok $t->app->routes->is_hidden('new'), 'is hidden'; -ok $t->app->routes->is_hidden('on'), 'is hidden'; -ok $t->app->routes->is_hidden('param'), 'is hidden'; -ok $t->app->routes->is_hidden('render'), 'is hidden'; -ok $t->app->routes->is_hidden('render_later'), 'is hidden'; -ok $t->app->routes->is_hidden('render_maybe'), 'is hidden'; -ok $t->app->routes->is_hidden('render_to_string'), 'is hidden'; -ok $t->app->routes->is_hidden('rendered'), 'is hidden'; -ok $t->app->routes->is_hidden('req'), 'is hidden'; -ok $t->app->routes->is_hidden('res'), 'is hidden'; -ok $t->app->routes->is_hidden('send'), 'is hidden'; -ok $t->app->routes->is_hidden('session'), 'is hidden'; -ok $t->app->routes->is_hidden('signed_cookie'), 'is hidden'; -ok $t->app->routes->is_hidden('stash'), 'is hidden'; -ok $t->app->routes->is_hidden('tap'), 'is hidden'; -ok $t->app->routes->is_hidden('tx'), 'is hidden'; -ok $t->app->routes->is_hidden('url_for'), 'is hidden'; -ok $t->app->routes->is_hidden('write'), 'is hidden'; -ok $t->app->routes->is_hidden('write_chunk'), 'is hidden'; +subtest 'Reserved stash value' => sub { + ok !$t->app->routes->is_reserved('foo'), 'not reserved'; + ok $t->app->routes->is_reserved('action'), 'is reserved'; + ok $t->app->routes->is_reserved('app'), 'is reserved'; + ok $t->app->routes->is_reserved('cb'), 'is reserved'; + ok $t->app->routes->is_reserved('controller'), 'is reserved'; + ok $t->app->routes->is_reserved('data'), 'is reserved'; + ok $t->app->routes->is_reserved('extends'), 'is reserved'; + ok $t->app->routes->is_reserved('format'), 'is reserved'; + ok $t->app->routes->is_reserved('handler'), 'is reserved'; + ok $t->app->routes->is_reserved('inline'), 'is reserved'; + ok $t->app->routes->is_reserved('json'), 'is reserved'; + ok $t->app->routes->is_reserved('layout'), 'is reserved'; + ok $t->app->routes->is_reserved('namespace'), 'is reserved'; + ok $t->app->routes->is_reserved('path'), 'is reserved'; + ok $t->app->routes->is_reserved('status'), 'is reserved'; + ok $t->app->routes->is_reserved('template'), 'is reserved'; + ok $t->app->routes->is_reserved('text'), 'is reserved'; + ok $t->app->routes->is_reserved('variant'), 'is reserved'; +}; + +subtest 'Reserved stash value (in placeholder)' => sub { + eval { $t->app->routes->any('/:controller') }; + like $@, qr/Route pattern "\/:controller" contains a reserved stash value/, 'right error'; + eval { $t->app->routes->any('/:action') }; + like $@, qr/Route pattern "\/:action" contains a reserved stash value/, 'right error'; + eval { $t->app->routes->any('/foo/:text') }; + like $@, qr/Route pattern "\/foo\/:text" contains a reserved stash value/, 'right error'; + eval { $t->app->routes->any('/foo/') }; + like $@, qr/Route pattern "\/foo\/" contains a reserved stash value/, 'right error'; +}; # Unknown hooks ok !$t->app->plugins->emit_chain('does_not_exist'), 'hook has been emitted'; @@ -157,15 +165,17 @@ is $t->app->start(qw(test_command --to)), 'works too!', 'right result'; # Plugin::Test::SomePlugin2::register (security violation) -$t->get_ok('/plugin-test-some_plugin2/register')->status_isnt(500)->status_is(404) - ->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/)->content_like(qr/Page Not Found/); +$t->get_ok('/plugin-test-some_plugin2/register')->status_isnt(404)->status_is(500) + ->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/) + ->content_like(qr/Class "MojoliciousTest::Plugin::Test::SomePlugin2" is not a controller/); # Plugin::Test::SomePlugin2::register (security violation again) -$t->app->log->level('debug')->unsubscribe('message'); +$t->app->log->level('trace')->unsubscribe('message'); my $log = ''; my $cb = $t->app->log->on(message => sub { $log .= pop }); -$t->get_ok('/plugin-test-some_plugin2/register')->status_isnt(500)->status_is(404) - ->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/)->content_like(qr/Page Not Found/); +$t->get_ok('/plugin-test-some_plugin2/register')->status_isnt(404)->status_is(500) + ->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/) + ->content_like(qr/Class "MojoliciousTest::Plugin::Test::SomePlugin2" is not a controller/); like $log, qr/Class "MojoliciousTest::Plugin::Test::SomePlugin2" is not a controller/, 'right message'; $t->app->log->unsubscribe(message => $cb); @@ -186,13 +196,14 @@ ->content_like(qr/fun/, 'with description')->content_unlike(qr/boring/) ->content_unlike(qr/boring/, 'with description')->element_exists('p')->element_exists('p', 'with description') ->element_exists_not('b')->element_exists_not('b', 'with description')->text_is('p', 'Have fun!') - ->text_is('p', 'Have fun!', 'with description')->text_isnt('p', 'Have')->text_isnt('p', 'Have', 'with description') - ->text_like('p', qr/fun/)->text_like('p', qr/fun/, 'with description')->text_unlike('p', qr/boring/) - ->text_unlike('p', qr/boring/, 'with description'); + ->text_is('p', 'Have fun!', 'with description')->text_is('notfound', undef)->text_isnt('p', 'Have') + ->text_isnt('p', 'Have', 'with description')->text_like('p', qr/fun/)->text_like('p', qr/fun/, 'with description') + ->text_unlike('p', qr/boring/)->text_unlike('p', qr/boring/, 'with description'); # Foo::joy (testing HTML attributes in template) $t->get_ok('/fun/joy')->status_is(200)->attr_is('p.joy', 'style', 'background-color: darkred;') ->attr_is('p.joy', 'style', 'background-color: darkred;', 'with description')->attr_is('p.joy', 'data-foo', '0') + ->attr_is('p.joy', 'data-empty', '')->attr_is('notfound', 'style', undef) ->attr_isnt('p.joy', 'style', 'float: left;')->attr_isnt('p.joy', 'style', 'float: left;', 'with description') ->attr_like('p.joy', 'style', qr/color/)->attr_like('p.joy', 'style', qr/color/, 'with description') ->attr_unlike('p.joy', 'style', qr/^float/)->attr_unlike('p.joy', 'style', qr/^float/, 'with description'); @@ -200,18 +211,11 @@ # Foo::baz (missing action without template) $log = ''; $cb = $t->app->log->on(message => sub { $log .= pop }); -$t->get_ok('/foo/baz')->status_is(404)->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/) - ->content_like(qr/Page Not Found/); +$t->get_ok('/foo/baz')->status_is(500)->header_is(Server => 'Mojolicious (Perl)')->content_unlike(qr/Something/) + ->content_like(qr/Route without action and nothing to render/); like $log, qr/Action not found in controller/, 'right message'; $t->app->log->unsubscribe(message => $cb); -# Foo::render (action not allowed) -$log = ''; -$cb = $t->app->log->on(message => sub { $log .= pop }); -$t->get_ok('/foo/render')->status_is(404)->header_is(Server => 'Mojolicious (Perl)')->content_like(qr/Page Not Found/); -like $log, qr/Action "render" is not allowed/, 'right message'; -$t->app->log->unsubscribe(message => $cb); - # Foo::yada (action-less template) $t->get_ok('/foo/yada')->status_is(200)->header_is(Server => 'Mojolicious (Perl)') ->content_like(qr/look ma! no action!/); @@ -288,7 +292,8 @@ ->content_is('/test4/42'); $t->post_ok('/somethingtest?_method=PUT' => {'X-Test' => 'Hi there!'})->status_is(200) ->header_is(Server => 'Mojolicious (Perl)')->content_is('/test4/42'); -$t->get_ok('/somethingtest?_method=PUT' => {'X-Test' => 'Hi there!'})->status_is(404); +$t->get_ok('/somethingtest?_method=PUT' => {'X-Test' => 'Hi there!'})->status_is(500) + ->content_like(qr/Controller "MojoliciousTest::Somethingtest" does not exist/); # Foo::url_for_missing $t->get_ok('/something_missing' => {'X-Test' => 'Hi there!'})->status_is(200) @@ -312,12 +317,12 @@ ->header_is(Server => 'Mojolicious (Perl)')->content_like(qr!/test2!); # MojoliciousTestController::index -$t->get_ok('/test3' => {'X-Test' => 'Hi there!'})->status_is(200)->header_is('X-Bender' => 'Bite my shiny metal ass!') - ->header_is(Server => 'Mojolicious (Perl)')->content_like(qr/No class works!/); +$t->get_ok('/test3' => {'X-Test' => 'Hi there!'})->status_is(500)->header_is(Server => 'Mojolicious (Perl)') + ->content_like(qr/Namespace "MojoliciousTest2::Foo" requires a controller/); -# MojoliciousTestController::index (only namespace) -$t->get_ok('/test5' => {'X-Test' => 'Hi there!'})->status_is(200)->header_is('X-Bender' => 'Bite my shiny metal ass!') - ->header_is(Server => 'Mojolicious (Perl)')->content_is('/test5'); +# MojoliciousTest::Foo::Bar (no action) +$t->get_ok('/test1' => {'X-Test' => 'Hi there!'})->status_is(500)->header_is(Server => 'Mojolicious (Perl)') + ->content_like(qr/Controller "MojoliciousTest::Controller::Foo::Bar" requires an action/); # MojoliciousTestController::index (no namespace) $t->get_ok('/test6' => {'X-Test' => 'Hi there!'})->status_is(200)->header_is('X-Bender' => 'Bite my shiny metal ass!') @@ -350,7 +355,7 @@ # Static directory /another $log = ''; $cb = $t->app->log->on(message => sub { $log .= pop }); -$t->get_ok('/another')->status_is(404)->header_is(Server => 'Mojolicious (Perl)'); +$t->get_ok('/another')->status_is(500)->header_is(Server => 'Mojolicious (Perl)'); like $log, qr/Controller "MojoliciousTest::Another" does not exist/, 'right message'; $t->app->log->unsubscribe(message => $cb); @@ -427,7 +432,7 @@ { # Check default development mode log level local $ENV{MOJO_LOG_LEVEL}; - is(Mojolicious->new->log->level, 'debug', 'right log level'); + is(Mojolicious->new->log->level, 'trace', 'right log level'); # Check non-development mode log level is(Mojolicious->new->mode('test')->log->level, 'info', 'right log level'); @@ -483,7 +488,7 @@ ->header_is(Server => 'Mojolicious (Perl)')->content_is('/foo/routes'); # SingleFileTestApp::Redispatch::handler -$t->app->log->level('debug')->unsubscribe('message'); +$t->app->log->level('trace')->unsubscribe('message'); $log = ''; $cb = $t->app->log->on(message => sub { $log .= pop }); $t->get_ok('/redispatch')->status_is(200)->header_is(Server => 'Mojolicious (Perl)')->content_is('Redispatch!'); @@ -500,6 +505,12 @@ $t->get_ok('/redispatch/secret?rly=1')->status_is(200)->header_is(Server => 'Mojolicious (Perl)') ->content_is('Secret!'); +subtest 'Override deployment plugins' => sub { + my $t = Test::Mojo->new('SingleFileTestApp', + {plugins => [{'MojoliciousTest::Plugin::DeploymentPlugin' => {name => 'override_helper'}}]}); + is $t->app->override_helper, 'deployment plugins work!', 'right value'; +}; + $t = Test::Mojo->new('MojoliciousTest'); # MojoliciousTestController::Foo::plugin_upper_case @@ -518,7 +529,7 @@ $t->get_ok('/staged')->status_is(200)->header_is(Server => 'Mojolicious (Perl)')->content_is('Go away!'); # MojoliciousTestController::Foo::suspended -$t->app->log->level('debug')->unsubscribe('message'); +$t->app->log->level('trace')->unsubscribe('message'); $log = ''; $cb = $t->app->log->on(message => sub { $log .= pop }); $t->get_ok('/suspended')->status_is(200)->header_is(Server => 'Mojolicious (Perl)') diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/charset_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/charset_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/charset_lite_app.t 2021-01-17 16:37:52.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/charset_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -27,7 +27,7 @@ } ); -get '/' => 'index'; +get '/' => [format => [$yatta]] => {format => undef} => 'index'; post '/' => sub { my $c = shift; @@ -82,7 +82,7 @@ $t->get_ok('/')->status_is(200)->content_type_like(qr/Shift_JIS/)->content_like(qr/$yatta/); # Unicode format -$t->get_ok("/.$yatta")->status_is(404); +$t->get_ok("/.$yatta")->status_is(500)->content_like(qr/Route without action and nothing to render/); # Send and receive raw Shift_JIS octets (like browsers do) $t->post_ok('/data', $yatta_sjis)->status_is(200)->content_is($yatta_sjis); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/commands.t libmojolicious-perl-9.22+dfsg/t/mojolicious/commands.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/commands.t 2021-01-17 16:37:49.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/commands.t 2021-06-30 13:58:00.000000000 +0000 @@ -162,6 +162,22 @@ $commands->run('help'); } like $buffer, qr/Usage: APPLICATION COMMAND \[OPTIONS\]/, 'right output'; +$buffer = ''; +{ + open my $handle, '>', \$buffer; + local *STDOUT = $handle; + local $ENV{HARNESS_ACTIVE} = 0; + $commands->run('--help'); +} +like $buffer, qr/Usage: APPLICATION COMMAND \[OPTIONS\]/, 'right output'; +$buffer = ''; +{ + open my $handle, '>', \$buffer; + local *STDOUT = $handle; + local $ENV{HARNESS_ACTIVE} = 0; + $commands->run('-h'); +} +like $buffer, qr/Usage: APPLICATION COMMAND \[OPTIONS\]/, 'right output'; # get require Mojolicious::Command::get; @@ -244,19 +260,56 @@ } like $buffer, qr/Unknown option: unknown/, 'right output'; -# daemon -require Mojolicious::Command::daemon; -my $daemon = Mojolicious::Command::daemon->new; -ok $daemon->description, 'has a description'; -like $daemon->usage, qr/daemon/, 'has usage information'; -$buffer = ''; -{ - open my $handle, '>', \$buffer; - local *STDERR = $handle; - eval { $daemon->run('--unknown') }; - like $@, qr/Usage: APPLICATION daemon/, 'unknown option'; -} -like $buffer, qr/Unknown option: unknown/, 'right output'; +subtest 'daemon' => sub { + require Mojolicious::Command::daemon; + + subtest 'Description' => sub { + my $command = Mojolicious::Command::daemon->new; + ok $command->description, 'has a description'; + like $command->usage, qr/daemon/, 'has usage information'; + }; + + subtest 'Unknown option' => sub { + my $command = Mojolicious::Command::daemon->new; + $buffer = ''; + { + open my $handle, '>', \$buffer; + local *STDERR = $handle; + eval { $command->run('--unknown') }; + like $@, qr/Usage: APPLICATION daemon/, 'unknown option'; + } + like $buffer, qr/Unknown option: unknown/, 'right output'; + }; + + subtest 'Proxy boolean' => sub { + my $command = Mojolicious::Command::daemon->new; + my $daemon = $command->build_server('-p'); + ok $daemon->reverse_proxy, 'right value'; + is_deeply $daemon->trusted_proxies, [], 'right value'; + }; + + subtest 'Trusted proxies' => sub { + my $command = Mojolicious::Command::daemon->new; + my $daemon = $command->build_server('-p', '127.0.0.0/8', '-p', '10.0.0.0/8'); + ok $daemon->reverse_proxy, 'right value'; + is_deeply $daemon->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; + + subtest 'Trusted proxies from environment' => sub { + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8,10.0.0.0/8'; + my $command = Mojolicious::Command::daemon->new; + my $daemon = $command->build_server; + ok $daemon->reverse_proxy, 'right value'; + is_deeply $daemon->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; + + subtest 'Proxy boolean and trusted' => sub { + my $command = Mojolicious::Command::daemon->new; + my $daemon = $command->build_server('-p', '-p', '127.0.0.0/8', '-p', '10.0.0.0/8'); + ok $daemon->reverse_proxy, 'right value'; + is_deeply $daemon->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; +}; # eval require Mojolicious::Command::eval; @@ -426,19 +479,56 @@ ok $inflate->description, 'has a description'; like $inflate->usage, qr/inflate/, 'has usage information'; -# prefork -require Mojolicious::Command::prefork; -my $prefork = Mojolicious::Command::prefork->new; -ok $prefork->description, 'has a description'; -like $prefork->usage, qr/prefork/, 'has usage information'; -$buffer = ''; -{ - open my $handle, '>', \$buffer; - local *STDERR = $handle; - eval { $prefork->run('--unknown') }; - like $@, qr/Usage: APPLICATION prefork/, 'unknown option'; -} -like $buffer, qr/Unknown option: unknown/, 'right output'; +subtest 'prefork' => sub { + require Mojolicious::Command::prefork; + + subtest 'Description' => sub { + my $command = Mojolicious::Command::prefork->new; + ok $command->description, 'has a description'; + like $command->usage, qr/prefork/, 'has usage information'; + }; + + subtest 'Unknown option' => sub { + my $command = Mojolicious::Command::prefork->new; + $buffer = ''; + { + open my $handle, '>', \$buffer; + local *STDERR = $handle; + eval { $command->run('--unknown') }; + like $@, qr/Usage: APPLICATION prefork/, 'unknown option'; + } + like $buffer, qr/Unknown option: unknown/, 'right output'; + }; + + subtest 'Proxy boolean' => sub { + my $command = Mojolicious::Command::prefork->new; + my $prefork = $command->build_server('-p'); + ok $prefork->reverse_proxy, 'right value'; + is_deeply $prefork->trusted_proxies, [], 'right value'; + }; + + subtest 'Trusted proxies' => sub { + my $command = Mojolicious::Command::prefork->new; + my $prefork = $command->build_server('-p', '127.0.0.0/8', '-p', '10.0.0.0/8'); + ok $prefork->reverse_proxy, 'right value'; + is_deeply $prefork->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; + + subtest 'Trusted proxies from environment' => sub { + local $ENV{MOJO_TRUSTED_PROXIES} = '127.0.0.0/8,10.0.0.0/8'; + my $command = Mojolicious::Command::prefork->new; + my $prefork = $command->build_server; + ok $prefork->reverse_proxy, 'right value'; + is_deeply $prefork->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; + + subtest 'Proxy boolean and trusted' => sub { + my $command = Mojolicious::Command::prefork->new; + my $prefork = $command->build_server('-p', '-p', '127.0.0.0/8', '-p', '10.0.0.0/8'); + ok $prefork->reverse_proxy, 'right value'; + is_deeply $prefork->trusted_proxies, ['127.0.0.0/8', '10.0.0.0/8'], 'right value'; + }; +}; # psgi require Mojolicious::Command::psgi; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/dispatcher_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/dispatcher_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/dispatcher_lite_app.t 2021-01-17 16:37:46.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/dispatcher_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -122,49 +122,62 @@ my $t = Test::Mojo->new; -# Normal route -$t->get_ok('/')->status_is(200)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate')->content_is('works'); - -# Normal static file -$t->get_ok('/test.txt')->status_is(200)->header_is('Cache-Control' => 'max-age=3600, must-revalidate') - ->content_is("Normal static file!\n"); - -# Override static file -$t->get_ok('/hello.txt')->status_is(200)->content_is('Custom static file works!'); - -# render_later from before_dispatch -$t->get_ok('/hello-delay.txt')->status_is(200)->content_is('Delayed!'); - -# Custom dispatcher -$t->get_ok('/custom?a=works+too')->status_is(205)->content_is('works too'); - -# Static file -$t->get_ok('/res.txt')->status_is(200)->header_is('Cache-Control' => 'max-age=3600, must-revalidate') - ->content_is("Static response!\n"); - -# Custom response -$t->get_ok('/res.txt?route=1')->status_is(202)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') - ->content_is('Custom response!'); - -# Conditional response -$t->get_ok('/res.txt?route=1&res=1')->status_is(201)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') - ->content_is('Conditional response!'); - -# Another custom dispatcher -$t->get_ok('/custom_too')->status_is(200)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') - ->content_is('this works too'); - -# First wrapper -$t->get_ok('/wrap')->status_is(200)->content_is('Wrapped!'); - -# Second wrapper -$t->get_ok('/wrap/again')->status_is(200)->content_is('Wrapped again!'); - -# Internal redirect to root -$t->get_ok('/not_found')->status_is(200)->content_is('works'); - -# Internal redirect to second wrapper -$t->get_ok('/not_found?wrap=1')->status_is(200)->content_is('Wrapped again!'); +subtest 'Normal route' => sub { + $t->get_ok('/')->status_is(200)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate')->content_is('works'); +}; + +subtest 'Normal static file' => sub { + $t->get_ok('/test.txt')->status_is(200)->header_is('Cache-Control' => 'max-age=3600, must-revalidate') + ->content_is("Normal static file!\n"); +}; + +subtest 'Override static file' => sub { + $t->get_ok('/hello.txt')->status_is(200)->content_is('Custom static file works!'); +}; + +subtest 'render_later from before_dispatch' => sub { + $t->get_ok('/hello-delay.txt')->status_is(200)->content_is('Delayed!'); +}; + +subtest 'Custom dispatcher' => sub { + $t->get_ok('/custom?a=works+too')->status_is(205)->content_is('works too'); +}; + +subtest 'Static file' => sub { + $t->get_ok('/res.txt')->status_is(200)->header_is('Cache-Control' => 'max-age=3600, must-revalidate') + ->content_is("Static response!\n"); +}; + +subtest ' Custom response' => sub { + $t->get_ok('/res.txt?route=1')->status_is(202)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') + ->content_is('Custom response!'); +}; + +subtest 'Conditional response' => sub { + $t->get_ok('/res.txt?route=1&res=1')->status_is(201)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') + ->content_is('Conditional response!'); +}; + +subtest 'Another custom dispatcher' => sub { + $t->get_ok('/custom_too')->status_is(200)->header_isnt('Cache-Control' => 'max-age=3600, must-revalidate') + ->content_is('this works too'); +}; + +subtest 'First wrapper' => sub { + $t->get_ok('/wrap')->status_is(200)->content_is('Wrapped!'); +}; + +subtest 'Second wrapper' => sub { + $t->get_ok('/wrap/again')->status_is(200)->content_is('Wrapped again!'); +}; + +subtest 'Internal redirect to root' => sub { + $t->get_ok('/not_found')->status_is(200)->content_is('works'); +}; + +subtest 'Internal redirect to second wrapper' => sub { + $t->get_ok('/not_found?wrap=1')->status_is(200)->content_is('Wrapped again!'); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/embedded_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/embedded_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/embedded_app.t 2021-01-17 16:37:53.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/embedded_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -36,57 +36,74 @@ my $t = Test::Mojo->new; -# Normal request -$t->get_ok('/hello')->status_is(200)->content_is("Hello from the main app!\n"); - -# Session -$t->get_ok('/primary')->status_is(200)->content_is(1); -$t->get_ok('/primary')->status_is(200)->content_is(2); - -# Session in external app -$t->get_ok('/x/1/secondary')->status_is(200)->content_is(11); - -# Session again -$t->get_ok('/primary')->status_is(200)->content_is(3); - -# Session in external app again -$t->get_ok('/x/1/secondary')->status_is(200)->content_is(22); - -# External app -$t->get_ok('/x/1')->status_is(200)->content_is('too%21'); - -# Static file from external app -$t->get_ok('/x/1/index.html')->status_is(200)->content_is("External static file!\n"); - -# External app with different prefix -$t->get_ok('/x/1/test')->status_is(200)->content_is('works%21'); - -# External app with Unicode prefix -$t->get_ok('/x/♥')->status_is(200)->content_is('too%21'); - -# Static file from external app with Unicode prefix -$t->get_ok('/x/♥/index.html')->status_is(200)->content_is("External static file!\n"); - -# External app with Unicode prefix again -$t->get_ok('/x/♥/test')->status_is(200)->content_is('works%21'); - -# External app with domain -$t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is('too%21'); - -# Static file from external app with domain -$t->get_ok('/index.html' => {Host => 'mojolicious.org'})->status_is(200)->content_is("External static file!\n"); - -# External app with domain again -$t->get_ok('/test' => {Host => 'mojolicious.org'})->status_is(200)->content_is('works%21'); - -# External app with a bit of everything -$t->get_ok('/♥/123/' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is('too%21'); - -# Static file from external app with a bit of everything -$t->get_ok('/♥/123/index.html' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is("External static file!\n"); - -# External app with a bit of everything again -$t->get_ok('/♥/123/test' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is('works%21'); +subtest 'Normal request' => sub { + $t->get_ok('/hello')->status_is(200)->content_is("Hello from the main app!\n"); +}; + +subtest 'Session' => sub { + $t->get_ok('/primary')->status_is(200)->content_is(1); + $t->get_ok('/primary')->status_is(200)->content_is(2); +}; + +subtest 'Session in external app' => sub { + $t->get_ok('/x/1/secondary')->status_is(200)->content_is(11); +}; + +subtest 'Session again' => sub { + $t->get_ok('/primary')->status_is(200)->content_is(3); +}; + +subtest 'Session in external app again' => sub { + $t->get_ok('/x/1/secondary')->status_is(200)->content_is(22); +}; + +subtest 'External app' => sub { + $t->get_ok('/x/1')->status_is(200)->content_is('too%21'); +}; + +subtest 'Static file from external app' => sub { + $t->get_ok('/x/1/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'External app with different prefix' => sub { + $t->get_ok('/x/1/test')->status_is(200)->content_is('works%21'); +}; + +subtest 'External app with Unicode prefix' => sub { + $t->get_ok('/x/♥')->status_is(200)->content_is('too%21'); +}; + +subtest 'Static file from external app with Unicode prefix' => sub { + $t->get_ok('/x/♥/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'External app with Unicode prefix again' => sub { + $t->get_ok('/x/♥/test')->status_is(200)->content_is('works%21'); +}; + +subtest 'External app with domain' => sub { + $t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is('too%21'); +}; + +subtest 'Static file from external app with domain' => sub { + $t->get_ok('/index.html' => {Host => 'mojolicious.org'})->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'External app with domain again' => sub { + $t->get_ok('/test' => {Host => 'mojolicious.org'})->status_is(200)->content_is('works%21'); +}; + +subtest 'External app with a bit of everything' => sub { + $t->get_ok('/♥/123/' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is('too%21'); +}; + +subtest 'Static file from external app with a bit of everything' => sub { + $t->get_ok('/♥/123/index.html' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'External app with a bit of everything again' => sub { + $t->get_ok('/♥/123/test' => {Host => 'test.foo-bar.de'})->status_is(200)->content_is('works%21'); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/embedded_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/embedded_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/embedded_lite_app.t 2021-01-17 16:37:54.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/embedded_lite_app.t 2021-08-09 16:37:25.000000000 +0000 @@ -101,7 +101,7 @@ get('/basic')->partial(1)->to(MyTestApp::Basic->new, test => 'lalala'); -get '/third/*path' => {app => 'MyTestApp::Test2', name => 'third embedded', path => '/'}; +get('/third' => {app => 'MyTestApp::Test2', name => 'third embedded'})->partial(1); app->routes->any('/hello')->partial(1)->to(TestApp::app())->to(name => 'embedded'); @@ -111,53 +111,68 @@ my $t = Test::Mojo->new; -# PluginWithEmbeddedApp -$t->get_ok('/plugin/foo')->status_is(200)->content_is('plugin works!'); +subtest 'PluginWithEmbeddedApp' => sub { + $t->get_ok('/plugin/foo')->status_is(200)->content_is('plugin works!'); +}; + +subtest 'main' => sub { + $t->get_ok('/hello')->status_is(200)->content_is("Hello from the main app!\n"); +}; + +subtest 'TestApp' => sub { + $t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (1) app!'); +}; + +subtest 'TestApp again' => sub { + $t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (2) app!'); +}; + +subtest 'TestApp again' => sub { + $t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (3) app!'); +}; + +subtest 'MyTestApp::Test1' => sub { + $t->get_ok('/bye/bye')->status_is(200)->content_is('Hello from the embedded (1) app!second embedded! success!'); +}; + +subtest 'MyTestApp::Test1 with different prefix' => sub { + $t->get_ok('/bar/bye')->status_is(200)->content_is('Hello from the embedded (2) app!third embedded! success!'); +}; + +subtest 'MyTestApp::Test1 with yet another prefix' => sub { + $t->get_ok('/baz/bye')->status_is(200)->content_is('Hello from the embedded (3) app!fourth embedded! success!'); +}; + +subtest '::Test1 without prefix' => sub { + $t->get_ok('/yada')->status_is(200)->content_is('yada fifth embedded works!'); +}; + +subtest '404 from MyTestApp::Test1' => sub { + $t->get_ok('/yada/yada')->status_is(404); +}; + +subtest 'MyTestApp::Test1 with a long prefix' => sub { + $t->get_ok('/yada/yada/yada')->status_is(200)->content_is('yada sixth embedded works!'); +}; + +subtest 'MyTestApp::Basic' => sub { + $t->get_ok('/basic')->status_is(200)->content_is('Hello lalala!'); +}; + +subtest 'MyTestApp::Test2' => sub { + $t->get_ok('/third')->status_is(200)->content_is('Bye from the third embedded app! /third!'); +}; + +subtest 'EmbeddedTestApp' => sub { + $t->get_ok('/just/works')->status_is(200)->content_is("It is working!\n"); +}; + +subtest 'EmbeddedTestApp again' => sub { + $t->get_ok('/just/works/too')->status_is(200)->content_is("It just works!\n"); +}; -# main -$t->get_ok('/hello')->status_is(200)->content_is("Hello from the main app!\n"); - -# TestApp -$t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (1) app!'); - -# TestApp again -$t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (2) app!'); - -# TestApp again -$t->get_ok('/hello/hello')->status_is(200)->content_is('Hello from the embedded (3) app!'); - -# MyTestApp::Test1 -$t->get_ok('/bye/bye')->status_is(200)->content_is('Hello from the embedded (1) app!second embedded! success!'); - -# MyTestApp::Test1 with different prefix -$t->get_ok('/bar/bye')->status_is(200)->content_is('Hello from the embedded (2) app!third embedded! success!'); - -# MyTestApp::Test1 with yet another prefix -$t->get_ok('/baz/bye')->status_is(200)->content_is('Hello from the embedded (3) app!fourth embedded! success!'); - -# MyTestApp::Test1 without prefix -$t->get_ok('/yada')->status_is(200)->content_is('yada fifth embedded works!'); - -# 404 from MyTestApp::Test1 -$t->get_ok('/yada/yada')->status_is(404); - -# MyTestApp::Test1 with a long prefix -$t->get_ok('/yada/yada/yada')->status_is(200)->content_is('yada sixth embedded works!'); - -# MyTestApp::Basic -$t->get_ok('/basic')->status_is(200)->content_is('Hello lalala!'); - -# MyTestApp::Test2 -$t->get_ok('/third')->status_is(200)->content_is('Bye from the third embedded app! /third!'); - -# EmbeddedTestApp -$t->get_ok('/just/works')->status_is(200)->content_is("It is working!\n"); - -# EmbeddedTestApp again -$t->get_ok('/just/works/too')->status_is(200)->content_is("It just works!\n"); - -# Template from myapp.pl -$t->get_ok('/x/1/')->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl' => sub { + $t->get_ok('/x/1/')->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -167,9 +182,10 @@ EOF +}; -# Template from myapp.pl (no trailing slash) -$t->get_ok('/x/1')->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl (no trailing slash)' => sub { + $t->get_ok('/x/1')->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -179,27 +195,34 @@ EOF +}; -# Static file from myapp.pl -$t->get_ok('/x/1/index.html')->status_is(200)->content_is("External static file!\n"); - -# Echo from myapp.pl -$t->get_ok('/x/1/echo')->status_is(200)->content_is('echo: nothing!'); - -# Stream from myapp.pl -$t->get_ok('/x/1/stream')->status_is(200)->content_is('hello!'); - -# URL from myapp.pl -$t->get_ok('/x/1/url/☃')->status_is(200)->content_is('/x/1/url/%E2%98%83.json -> /x/1/%E2%98%83/stream!'); - -# Route to template from myapp.pl -$t->get_ok('/x/1/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); - -# Missing template from myapp.pl -$t->get_ok('/x/1/template/does_not_exist')->status_is(404); +subtest 'Static file from myapp.pl' => sub { + $t->get_ok('/x/1/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'Echo from myapp.pl' => sub { + $t->get_ok('/x/1/echo')->status_is(200)->content_is('echo: nothing!'); +}; + +subtest 'Stream from myapp.pl' => sub { + $t->get_ok('/x/1/stream')->status_is(200)->content_is('hello!'); +}; + +subtest 'URL from myapp.pl' => sub { + $t->get_ok('/x/1/url/☃')->status_is(200)->content_is('/x/1/url/%E2%98%83.json -> /x/1/%E2%98%83/stream!'); +}; + +subtest 'Route to template from myapp.pl' => sub { + $t->get_ok('/x/1/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); +}; + +subtest 'Missing template from myapp.pl' => sub { + $t->get_ok('/x/1/template/does_not_exist')->status_is(500)->content_like(qr/Server Error/); +}; -# Template from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/')->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/')->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -209,9 +232,10 @@ EOF +}; -# Template from myapp.pl with Unicode prefix (no trailing slash) -$t->get_ok('/x/♥')->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with Unicode prefix (no trailing slash)' => sub { + $t->get_ok('/x/♥')->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -221,58 +245,75 @@ EOF +}; -# Static file from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/index.html')->status_is(200)->content_is("External static file!\n"); - -# Echo from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/echo')->status_is(200)->content_is('echo: works 2!'); - -# Stream from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/stream')->status_is(200)->content_is('hello!'); - -# URL from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/url/☃')->status_is(200) - ->content_is('/x/%E2%99%A5/url/%E2%98%83.json -> /x/%E2%99%A5/%E2%98%83/stream!'); - -# Route to template from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); - -# Missing template from myapp.pl with Unicode prefix -$t->get_ok('/x/♥/template/does_not_exist')->status_is(404); - -# A little bit of everything from myapp2.pl -$t->get_ok('/y/1')->status_is(200)->content_is("myapp2\nworks 4!\nInsecure too!"); +subtest 'Static file from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'Echo from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/echo')->status_is(200)->content_is('echo: works 2!'); +}; + +subtest 'Stream from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/stream')->status_is(200)->content_is('hello!'); +}; + +subtest 'URL from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/url/☃')->status_is(200) + ->content_is('/x/%E2%99%A5/url/%E2%98%83.json -> /x/%E2%99%A5/%E2%98%83/stream!'); +}; + +subtest 'Route to template from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); +}; + +subtest 'Missing template from myapp.pl with Unicode prefix' => sub { + $t->get_ok('/x/♥/template/does_not_exist')->status_is(500)->content_like(qr/Server Error/); +}; + +subtest 'A little bit of everything from myapp2.pl' => sub { + $t->get_ok('/y/1')->status_is(200)->content_is("myapp2\nworks 4!\nInsecure too!"); +}; + +subtest 'Route to template from myapp.pl again (helpers sharing the same name)' => sub { + $t->get_ok('/x/1/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); +}; + +subtest 'Caching helper from myapp2.pl' => sub { + $t->get_ok('/y/1/cached?cache=foo')->status_is(200)->content_is('foo'); +}; + +subtest 'Caching helper with cached value from myapp2.pl' => sub { + $t->get_ok('/y/1/cached?cache=fail')->status_is(200)->content_is('foo'); +}; + +subtest '404 from myapp2.pl' => sub { + $t->get_ok('/y/1/2')->status_is(404); +}; + +subtest 'myapp2.pl with Unicode prefix' => sub { + $t->get_ok('/y/♥')->status_is(200)->content_is("myapp2\nworks 3!\nInsecure too!"); +}; + +subtest 'Caching helper from myapp2.pl with Unicode prefix' => sub { + $t->get_ok('/y/♥/cached?cache=bar')->status_is(200)->content_is('bar'); +}; + +subtest 'Caching helper with cached value from myapp2.pl with Unicode prefix' => sub { + $t->get_ok('/y/♥/cached?cache=fail')->status_is(200)->content_is('bar'); +}; + +subtest '404 from myapp2.pl with Unicode prefix' => sub { + $t->get_ok('/y/♥/2')->status_is(404); +}; + +subtest 'main' => sub { + $t->get_ok('/host')->status_is(200)->content_is('main application!'); +}; -# Route to template from myapp.pl again (helpers sharing the same name) -$t->get_ok('/x/1/template/menubar')->status_is(200)->content_is("myapp\nworks ♥!Insecure!Insecure!\n"); - -# Caching helper from myapp2.pl -$t->get_ok('/y/1/cached?cache=foo')->status_is(200)->content_is('foo'); - -# Caching helper with cached value from myapp2.pl -$t->get_ok('/y/1/cached?cache=fail')->status_is(200)->content_is('foo'); - -# 404 from myapp2.pl -$t->get_ok('/y/1/2')->status_is(404); - -# myapp2.pl with Unicode prefix -$t->get_ok('/y/♥')->status_is(200)->content_is("myapp2\nworks 3!\nInsecure too!"); - -# Caching helper from myapp2.pl with Unicode prefix -$t->get_ok('/y/♥/cached?cache=bar')->status_is(200)->content_is('bar'); - -# Caching helper with cached value from myapp2.pl with Unicode prefix -$t->get_ok('/y/♥/cached?cache=fail')->status_is(200)->content_is('bar'); - -# 404 from myapp2.pl with Unicode prefix -$t->get_ok('/y/♥/2')->status_is(404); - -# main -$t->get_ok('/host')->status_is(200)->content_is('main application!'); - -# Template from myapp.pl with domain -$t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with domain' => sub { + $t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -282,13 +323,15 @@ EOF +}; -# Host from myapp.pl with domain -$t->get_ok('/host' => {Host => 'mojolicious.org'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('mojolicious.org'); +subtest 'Host from myapp.pl with domain' => sub { + $t->get_ok('/host' => {Host => 'mojolicious.org'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('mojolicious.org'); +}; -# Template from myapp.pl with domain again -$t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with domain again' => sub { + $t->get_ok('/' => {Host => 'mojolicious.org'})->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -298,13 +341,15 @@ EOF +}; -# Host from myapp.pl with domain again -$t->get_ok('/host' => {Host => 'mojolicious.org'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('mojolicious.org'); +subtest 'Host from myapp.pl with domain again' => sub { + $t->get_ok('/host' => {Host => 'mojolicious.org'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('mojolicious.org'); +}; -# Template from myapp.pl with wildcard domain -$t->get_ok('/' => {Host => 'example.com'})->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with wildcard domain' => sub { + $t->get_ok('/' => {Host => 'example.com'})->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -314,21 +359,25 @@ EOF +}; -# Host from myapp.pl with wildcard domain -$t->get_ok('/host' => {Host => 'ExAmPlE.CoM'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('ExAmPlE.CoM'); - -# Host from myapp.pl with wildcard domain again -$t->get_ok('/host' => {Host => 'www.example.com'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('www.example.com'); - -# Host from myapp.pl with wildcard domain again -$t->get_ok('/host' => {Host => 'foo.bar.example.com'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('foo.bar.example.com'); +subtest 'Host from myapp.pl with wildcard domain' => sub { + $t->get_ok('/host' => {Host => 'ExAmPlE.CoM'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('ExAmPlE.CoM'); +}; + +subtest 'Host from myapp.pl with wildcard domain again' => sub { + $t->get_ok('/host' => {Host => 'www.example.com'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('www.example.com'); +}; + +subtest 'Host from myapp.pl with wildcard domain again' => sub { + $t->get_ok('/host' => {Host => 'foo.bar.example.com'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('foo.bar.example.com'); +}; -# Template from myapp.pl with wildcard domain and Unicode prefix -$t->get_ok('/♥/123/' => {Host => 'foo-bar.de'})->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl with wildcard domain and Unicode prefix' => sub { + $t->get_ok('/♥/123/' => {Host => 'foo-bar.de'})->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -338,37 +387,66 @@ EOF +}; -# Host from myapp.pl with wildcard domain and Unicode prefix -$t->get_ok('/♥/123/host' => {Host => 'foo-bar.de'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('foo-bar.de'); - -# Echo from myapp.pl with wildcard domain and Unicode prefix -$t->get_ok('/♥/123/echo' => {Host => 'foo-bar.de'})->status_is(200)->content_is('echo: works 3!'); - -# Host from myapp.pl with wildcard domain and Unicode prefix again -$t->get_ok('/♥/123/host' => {Host => 'www.foo-bar.de'})->status_is(200)->header_is('X-Message' => 'it works!') - ->content_is('www.foo-bar.de'); - -# Host from myapp.pl with wildcard domain and Unicode prefix again -$t->get_ok('/♥/123/echo' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('echo: works 3!'); - -# Text from myapp.pl with wildcard domain and Unicode prefix -$t->get_ok('/♥/123/one' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('One'); - -# Another text from myapp.pl with wildcard domain and Unicode prefix -$t->get_ok('/♥/123/one/two' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('Two'); - -# Invalid domain -$t->get_ok('/' => {Host => 'mojoliciousxorg'})->status_is(404); - -# Another invalid domain -$t->get_ok('/' => {Host => 'www.kraihxcom'})->status_is(404); +subtest 'Host from myapp.pl with wildcard domain and Unicode prefix' => sub { + $t->get_ok('/♥/123/host' => {Host => 'foo-bar.de'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('foo-bar.de'); +}; + +subtest 'Echo from myapp.pl with wildcard domain and Unicode prefix' => sub { + $t->get_ok('/♥/123/echo' => {Host => 'foo-bar.de'})->status_is(200)->content_is('echo: works 3!'); +}; + +subtest 'Host from myapp.pl with wildcard domain and Unicode prefix again' => sub { + $t->get_ok('/♥/123/host' => {Host => 'www.foo-bar.de'})->status_is(200)->header_is('X-Message' => 'it works!') + ->content_is('www.foo-bar.de'); +}; + +subtest 'Host from myapp.pl with wildcard domain and Unicode prefix again' => sub { + $t->get_ok('/♥/123/echo' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('echo: works 3!'); +}; + +subtest 'Text from myapp.pl with wildcard domain and Unicode prefix' => sub { + $t->get_ok('/♥/123/one' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('One'); +}; + +subtest 'Another text from myapp.pl with wildcard domain and Unicode prefix' => sub { + $t->get_ok('/♥/123/one/two' => {Host => 'www.foo-bar.de'})->status_is(200)->content_is('Two'); +}; + +subtest 'Invalid domain' => sub { + $t->get_ok('/' => {Host => 'mojoliciousxorg'})->status_is(404); +}; + +subtest 'Another invalid domain' => sub { + $t->get_ok('/' => {Host => 'www.kraihxcom'})->status_is(404); +}; + +subtest 'Embedded WebSocket' => sub { + $t->websocket_ok('/x/♥/url_for')->send_ok('ws_test') + ->message_ok->message_like(qr!^ws://127\.0\.0\.1:\d+/x/%E2%99%A5/url_for$!)->send_ok('index') + ->message_ok->message_like(qr!^http://127\.0\.0\.1:\d+/x/%E2%99%A5$!)->finish_ok; +}; + +subtest 'Template from myapp.pl (shared logger)' => sub { + $t->app->log->level('trace')->unsubscribe('message'); + my $log = ''; + my $cb = $t->app->log->on(message => sub { $log .= pop }); + $t->get_ok('/x/1')->status_is(200)->content_is(<<'EOF'); +myapp +works ♥!Insecure!Insecure! -# Embedded WebSocket -$t->websocket_ok('/x/♥/url_for')->send_ok('ws_test') - ->message_ok->message_like(qr!^ws://127\.0\.0\.1:\d+/x/%E2%99%A5/url_for$!)->send_ok('index') - ->message_ok->message_like(qr!^http://127\.0\.0\.1:\d+/x/%E2%99%A5$!)->finish_ok; +too!works!!!Mojolicious::Plugin::Config::Sandbox +Test + +EOF + like $log, qr/Routing to application "Mojolicious::Lite"/, 'right message'; + like $log, qr/Rendering cached template "menubar.html.ep" from DATA section/, 'right message'; + $t->app->log->unsubscribe(message => $cb); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/exception_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/exception_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/exception_lite_app.t 2021-01-17 16:37:48.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/exception_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -25,7 +25,7 @@ # Custom rendering for missing "txt" template hook before_render => sub { my ($c, $args) = @_; - return unless ($args->{template} // '') eq 'not_found'; + return unless ($args->{template} // '') eq 'exception.development'; my $stash = $c->stash; my $exception = $stash->{snapshot}{exception}; $args->{text} = "Missing template, $exception." if $args->{format} eq 'txt'; @@ -51,11 +51,11 @@ get '/dead_template'; -get '/dead_template_too'; +get '/dead_template_too' => [format => ['xml']]; -get '/dead_handler' => {handler => 'dead'}; +get '/dead_handler' => [format => ['xml']] => {handler => 'dead'}; -get '/dead_action_epl' => {handler => 'epl'} => sub { +get '/dead_action_epl' => [format => ['xml']] => {handler => 'epl'} => sub { die "dead action epl!\n"; }; @@ -63,7 +63,7 @@ get '/dead_template_with_layout'; -get '/dead_action' => sub { die "dead action!\n" }; +get '/dead_action' => [format => ['xml', 'json']] => {format => undef} => sub { die "dead action!\n" }; get '/double_dead_action_☃' => sub { eval { die 'double dead action!' }; @@ -76,11 +76,11 @@ $c->render(text => $@->{foo} || 'failed'); }; -get '/missing_template' => {exception => 'whatever'}; +get '/missing_template' => [format => ['xml', 'json', 'txt']] => {exception => 'whatever', format => undef}; get '/missing_template/too' => sub { my $c = shift; - $c->render('does_not_exist') or $c->res->headers->header('X-Not-Found' => 1); + $c->render('does_not_exist'); }; get '/missing_helper' => sub { shift->missing_helper }; @@ -250,28 +250,28 @@ }; subtest 'Missing template' => sub { - $t->get_ok('/missing_template')->status_is(404)->content_type_is('text/html;charset=UTF-8') - ->content_like(qr/Page Not Found/); + $t->get_ok('/missing_template')->status_is(500)->content_type_is('text/html;charset=UTF-8') + ->content_like(qr/Route without action and nothing to render/); }; subtest 'Missing template with different format' => sub { - $t->get_ok('/missing_template.xml')->status_is(404)->content_type_is('application/xml') - ->content_is("bad\n"); + $t->get_ok('/missing_template.xml')->status_is(500)->content_type_is('application/xml') + ->content_is("bad\n"); }; subtest 'Missing template with unsupported format' => sub { - $t->get_ok('/missing_template.json')->status_is(404)->content_type_is('text/html;charset=UTF-8') - ->content_like(qr/Page Not Found/); + $t->get_ok('/missing_template.json')->status_is(500)->content_type_is('text/html;charset=UTF-8') + ->content_like(qr/Route without action and nothing to render/); }; subtest 'Missing template with custom rendering' => sub { - $t->get_ok('/missing_template.txt')->status_is(404)->content_type_is('text/plain;charset=UTF-8') + $t->get_ok('/missing_template.txt')->status_is(500)->content_type_is('text/plain;charset=UTF-8') ->content_is('Missing template, whatever.'); }; subtest 'Missing template (failed rendering)' => sub { - $t->get_ok('/missing_template/too')->status_is(404)->header_is('X-Not-Found' => 1) - ->content_type_is('text/html;charset=UTF-8')->content_like(qr/Page Not Found/); + $t->get_ok('/missing_template/too')->status_is(500)->content_type_is('text/html;charset=UTF-8') + ->content_like(qr/Could not render a response/); }; subtest 'Missing helper (correct context)' => sub { @@ -299,23 +299,6 @@ $t->get_ok('/mojo/bootstrap/bootstrap.js')->status_is(200)->content_type_is('application/javascript'); $t->get_ok('/mojo/bootstrap/bootstrap.css')->status_is(200)->content_type_is('text/css'); - $t->get_ok('/mojo/fontawesome/fontawesome.css')->status_is(200)->content_type_is('text/css'); - $t->get_ok('/mojo/webfonts/fa-brands-400.eot')->status_is(200)->content_type_is('application/octet-stream'); - $t->get_ok('/mojo/webfonts/fa-brands-400.svg')->status_is(200)->content_type_is('image/svg+xml'); - $t->get_ok('/mojo/webfonts/fa-brands-400.ttf')->status_is(200)->content_type_is('font/ttf'); - $t->get_ok('/mojo/webfonts/fa-brands-400.woff')->status_is(200)->content_type_is('font/woff'); - $t->get_ok('/mojo/webfonts/fa-brands-400.woff2')->status_is(200)->content_type_is('font/woff2'); - $t->get_ok('/mojo/webfonts/fa-regular-400.eot')->status_is(200)->content_type_is('application/octet-stream'); - $t->get_ok('/mojo/webfonts/fa-regular-400.svg')->status_is(200)->content_type_is('image/svg+xml'); - $t->get_ok('/mojo/webfonts/fa-regular-400.ttf')->status_is(200)->content_type_is('font/ttf'); - $t->get_ok('/mojo/webfonts/fa-regular-400.woff')->status_is(200)->content_type_is('font/woff'); - $t->get_ok('/mojo/webfonts/fa-regular-400.woff2')->status_is(200)->content_type_is('font/woff2'); - $t->get_ok('/mojo/webfonts/fa-solid-900.eot')->status_is(200)->content_type_is('application/octet-stream'); - $t->get_ok('/mojo/webfonts/fa-solid-900.svg')->status_is(200)->content_type_is('image/svg+xml'); - $t->get_ok('/mojo/webfonts/fa-solid-900.ttf')->status_is(200)->content_type_is('font/ttf'); - $t->get_ok('/mojo/webfonts/fa-solid-900.woff')->status_is(200)->content_type_is('font/woff'); - $t->get_ok('/mojo/webfonts/fa-solid-900.woff2')->status_is(200)->content_type_is('font/woff2'); - $t->get_ok('/mojo/failraptor.png')->status_is(200)->content_type_is('image/png'); $t->get_ok('/mojo/logo.png')->status_is(200)->content_type_is('image/png'); $t->get_ok('/mojo/logo-white.png')->status_is(200)->content_type_is('image/png'); @@ -347,11 +330,8 @@ % layout 'green'; % die 'dead template with layout!'; -@@ exception.xml.ep +@@ exception.development.xml.ep bad -@@ not_found.development.xml.ep -bad - @@ dead_helper.html.ep % dead_helper; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/external/myapp.pl libmojolicious-perl-9.22+dfsg/t/mojolicious/external/myapp.pl --- libmojolicious-perl-8.71+dfsg/t/mojolicious/external/myapp.pl 2020-06-14 16:18:32.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/external/myapp.pl 2021-06-30 13:58:00.000000000 +0000 @@ -9,7 +9,8 @@ helper same_name => sub {'myapp'}; # Load plugin -plugin 'Config'; +my $config = plugin 'Config'; +my $one = $config->{one}; # Message condition app->routes->add_condition( @@ -22,6 +23,8 @@ get '/' => 'index'; +get '/startup' => {text => $one}; + get '/echo' => sub { my $c = shift; $c->render(text => 'echo: ' . ($c->stash('message') || 'nothing!')); @@ -51,7 +54,10 @@ get '/one/two' => {text => 'Two'}; -get '/template/:template'; +get '/template/:foo' => sub { + my $c = shift; + $c->render($c->param('foo')); +}; websocket '/url_for' => sub { my $c = shift; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/external/templates/index.html.ep libmojolicious-perl-9.22+dfsg/t/mojolicious/external/templates/index.html.ep --- libmojolicious-perl-8.71+dfsg/t/mojolicious/external/templates/index.html.ep 2020-06-14 16:18:32.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/external/templates/index.html.ep 2021-06-30 13:58:00.000000000 +0000 @@ -1,5 +1,5 @@ %= include 'menubar' -<%= config->{works} . stash('also') . stash('in') %> +<%= config->{works} . (stash('also') // '*') . (stash('in') // '?') %> %= link_to Test => '/' %= form_for '/☃' => begin %= submit_button '☃' diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/external_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/external_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/external_app.t 2021-01-17 16:37:51.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/external_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -14,28 +14,35 @@ my $t = Test::Mojo->new('MyApp'); -# Text from config file -$t->get_ok('/')->status_is(200)->content_is('too%21'); - -# Static file -$t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); - -# More text from config file -$t->get_ok('/test')->status_is(200)->content_is('works%21'); +subtest 'Text from config file' => sub { + $t->get_ok('/')->status_is(200)->content_is('too%21'); +}; + +subtest 'Static file' => sub { + $t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'More text from config file' => sub { + $t->get_ok('/test')->status_is(200)->content_is('works%21'); +}; # Config override $t = Test::Mojo->new(MyApp => {whatever => 'override!', works => 'override two!'}); -# Text from config override -$t->get_ok('/')->status_is(200)->content_is('override two!'); - -# Static file again -$t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); - -# More text from config override -$t->get_ok('/test')->status_is(200)->content_is('override!'); - -# Config stash value from template -$t->get_ok('/inline')->status_is(200)->content_is('override!'); +subtest 'Text from config override' => sub { + $t->get_ok('/')->status_is(200)->content_is('override two!'); +}; + +subtest 'Static file again' => sub { + $t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'More text from config override' => sub { + $t->get_ok('/test')->status_is(200)->content_is('override!'); +}; + +subtest 'Config stash value from template' => sub { + $t->get_ok('/inline')->status_is(200)->content_is('override!'); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/external_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/external_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/external_lite_app.t 2021-01-17 16:37:56.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/external_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -12,8 +12,8 @@ my $t = Test::Mojo->new(curfile->sibling('external', 'myapp.pl')); -# Template from myapp.pl -$t->get_ok('/')->status_is(200)->content_is(<<'EOF'); +subtest 'Template from myapp.pl' => sub { + $t->get_ok('/')->status_is(200)->content_is(<<'EOF'); myapp works ♥!Insecure!Insecure! @@ -23,17 +23,47 @@ EOF +}; -# Static file from myapp.pl -$t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); +subtest 'Static file from myapp.pl' => sub { + $t->get_ok('/index.html')->status_is(200)->content_is("External static file!\n"); +}; + +subtest 'Echo from myapp.pl' => sub { + $t->get_ok('/echo')->status_is(200)->content_is('echo: nothing!'); +}; + +subtest 'Chunked response from myapp.pl' => sub { + $t->get_ok('/stream')->status_is(200)->content_is('hello!'); +}; + +subtest 'URL generated by myapp.pl' => sub { + $t->get_ok('/url/☃')->status_is(200)->content_is('/url/%E2%98%83.json -> /%E2%98%83/stream!'); +}; + +subtest 'Config value at startup time' => sub { + $t->get_ok('/startup')->status_is(200)->content_is('Insecure!'); +}; + +# Config override +$t = Test::Mojo->new(curfile->sibling('external', 'myapp.pl'), + {one => 'override!', two => 'go!', just => 'yada', works => 'override two!'}); -# Echo from myapp.pl -$t->get_ok('/echo')->status_is(200)->content_is('echo: nothing!'); +subtest 'Template from myapp.pl with config override' => sub { + $t->get_ok('/')->status_is(200)->content_is(<<'EOF'); +myapp +yadaoverride!go! -# Chunked response from myapp.pl -$t->get_ok('/stream')->status_is(200)->content_is('hello!'); +override two!*? +Test + +EOF +}; -# URL generated by myapp.pl -$t->get_ok('/url/☃')->status_is(200)->content_is('/url/%E2%98%83.json -> /%E2%98%83/stream!'); +subtest 'Config override at startup time' => sub { + $t->get_ok('/startup')->status_is(200)->content_is('override!'); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/group_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/group_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/group_lite_app.t 2021-01-17 16:37:56.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/group_lite_app.t 2021-08-09 16:37:31.000000000 +0000 @@ -162,7 +162,7 @@ return !!0; }; - get '/authgroup' => {text => "You're ok."}; + get '/authgroup' => [format => ['txt']] => {text => "You're ok.", format => undef}; }; get '/noauthgroup' => {inline => 'Whatever <%= $foo %>.'}; @@ -198,10 +198,10 @@ ->content_is("two\nthree\none\ntwo\nfive\nsix\nfour\nfive\n"); # Missing action behind bridge -$t->get_ok('/missing')->status_is(404)->content_is("Oops!\n"); +$t->get_ok('/missing')->status_is(500)->content_like(qr/Route without action and nothing to render/); # Suspended bridge -$t->app->log->level('debug')->unsubscribe('message'); +$t->app->log->level('trace')->unsubscribe('message'); my $log = ''; my $cb = $t->app->log->on(message => sub { $log .= pop }); $t->get_ok('/suspended?ok=1')->status_is(200)->header_is(Server => 'Mojolicious (Perl)')->content_is('suspended!'); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_lite_app.json libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_lite_app.json --- libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_lite_app.json 2020-05-21 21:27:22.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_lite_app.json 2021-06-30 13:58:00.000000000 +0000 @@ -1,5 +1,14 @@ { %# Just a comment "foo": "bar", - "utf": "утф" + "utf": "утф", + "plugins": [ + {"MojoliciousTest::Plugin::DeploymentPlugin": {}}, + { + "MojoliciousTest::Plugin::DeploymentPlugin": { + "name": "another_helper", + "message": "works too!" + } + } + ] } diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_lite_app.t 2021-01-17 16:37:53.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -7,7 +7,10 @@ use Test::Mojo; use Test::More; + use Mojo::File qw(curfile); +use lib curfile->sibling('lib')->to_string; + use Mojolicious::Lite; subtest 'Default' => sub { @@ -40,6 +43,8 @@ is app->config('absolute'), 'works too!', 'right value'; is app->config('absolute_dev'), 'dev works too!', 'right value'; is app->config('it'), 'works', 'right value'; + is app->deployment_helper, 'deployment plugins work!', 'right value'; + is app->another_helper, 'works too!', 'right value'; }; get '/' => 'index'; diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_mode_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_mode_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/json_config_mode_lite_app.t 2021-01-17 16:37:55.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/json_config_mode_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -16,8 +16,9 @@ my $t = Test::Mojo->new; -# Template with config information -$t->get_ok('/')->status_is(200)->content_like(qr/bazfoo/); +subtest 'Template with config information' => sub { + $t->get_ok('/')->status_is(200)->content_like(qr/bazfoo/); +}; done_testing(); diff -Nru libmojolicious-perl-8.71+dfsg/t/mojolicious/layouted_lite_app.t libmojolicious-perl-9.22+dfsg/t/mojolicious/layouted_lite_app.t --- libmojolicious-perl-8.71+dfsg/t/mojolicious/layouted_lite_app.t 2021-01-17 16:37:50.000000000 +0000 +++ libmojolicious-perl-9.22+dfsg/t/mojolicious/layouted_lite_app.t 2021-06-30 13:58:00.000000000 +0000 @@ -101,7 +101,7 @@ get '/data' => {data => 0}; -get '/variants' => {layout => 'variants'} => sub { +get '/variants' => [format => ['txt']] => {layout => 'variants', format => undef} => sub { my $c = shift; $c->stash->{variant} = $c->param('device'); $c->render('variants'); @@ -109,135 +109,178 @@ my $t = Test::Mojo->new; -# "0" content reassignment -my $c = $t->app->build_controller; -$c->content(foo => '0'); -is $c->content('foo'), '0', 'right content'; -$c->content(foo => '1'); -is $c->content('foo'), '0', 'right content'; - -# Template with layout -$t->get_ok('/works')->status_is(200)->content_type_is('text/html;charset=UTF-8') - ->content_is("DefaultJust worksThis