@@ -1,5 +1,34 @@
This file documents the revision history for Perl extension Mojo.
+0.999913 2009-11-24 00:00:00
+ - Added automatic content decoding to content helpers in Test::Mojo.
+ - Added json test helper to Test::Mojo.
+ - Added the ability to reset a test session in Test::Mojo.
+ (yuki-kimoto)
+ - Fixed Mojolicious::Renderer to always default to rendering a 404
+ error.
+ - Fixed a cookiejar bug and added tests. (yuki-kimoto)
+
+0.999912 2009-11-24 00:00:00
+ - Improved ioloop performance. (gbarr)
+
+0.999911 2009-11-14 00:00:00
+ - Added template inheritance to Mojolicious.
+ - Added block and capturing support to Mojo::Template.
+ - Added trimming support to Mojo::Template.
+ - Added new testing framework for Mojo and Mojolicious applications.
+ (yuki-kimoto)
+ - Added redirect support to Mojo::Client. (acajou)
+ - Added cookie jar to Mojo::Client. (acajou)
+ - Excluded Mojo::ByteStream objects from auto escaping.
+ - Updated Mojolicious::Lite tutorial.
+ - Fixed a case where routes captures got false positives.
+ - Fixed literal name handling in Mojo::JSON. (rsp)
+ - Fixed unicode detection in Mojo::JSON. (rsp)
+ - Fixed multiple small bugs in Mojo::JSON. (rsp)
+ - Fixed Mojolicious default app tests. (yuki-kimoto)
+ - Fixed Mojo::Server::FCGI compatibility.
+
0.999910 2009-11-14 00:00:00
- Fixed url_for without endpoint bug.
- Fixed BOM handling in Mojo::JSON. (rsp)
@@ -26,6 +26,7 @@ lib/Mojo/Content/Single.pm
lib/Mojo/Cookie.pm
lib/Mojo/Cookie/Request.pm
lib/Mojo/Cookie/Response.pm
+lib/Mojo/CookieJar.pm
lib/Mojo/Date.pm
lib/Mojo/Exception.pm
lib/Mojo/Filter.pm
@@ -74,6 +75,7 @@ lib/MojoX/Routes.pm
lib/MojoX/Routes/Match.pm
lib/MojoX/Routes/Pattern.pm
lib/MojoX/Types.pm
+lib/Test/Mojo.pm
lib/Test/Mojo/Server.pm
LICENSE
Makefile.PL
@@ -98,6 +100,7 @@ t/mojo/bytestream.t
t/mojo/cgi.t
t/mojo/client.t
t/mojo/cookie.t
+t/mojo/cookiejar.t
t/mojo/daemon.t
t/mojo/daemon_prefork.t
t/mojo/date.t
@@ -1,6 +1,6 @@
--- #YAML:1.0
name: Mojo
-version: 0.999910
+version: 0.999913
abstract: Web Framework
author:
- Sebastian Riedel <sri@cpan.org>
@@ -8,6 +8,7 @@ use warnings;
use base 'Mojo::Base';
use bytes;
+use Mojo::CookieJar;
use Mojo::IOLoop;
use Mojo::Server;
use Mojo::Transaction::Pipeline;
@@ -17,8 +18,10 @@ use Socket;
__PACKAGE__->attr([qw/app default_cb/]);
__PACKAGE__->attr([qw/continue_timeout max_keep_alive_connections/] => 5);
-__PACKAGE__->attr(ioloop => sub { Mojo::IOLoop->new });
+__PACKAGE__->attr(cookie_jar => sub { Mojo::CookieJar->new });
+__PACKAGE__->attr(ioloop => sub { Mojo::IOLoop->new });
__PACKAGE__->attr(keep_alive_timeout => 15);
+__PACKAGE__->attr(max_redirects => 0);
__PACKAGE__->attr([qw/_app_queue _cache/] => sub { [] });
__PACKAGE__->attr(_connections => sub { {} });
@@ -51,19 +54,6 @@ sub post { shift->_build_tx('POST', @_) }
sub process {
my $self = shift;
- # Weaken
- weaken $self;
-
- # Connect callback
- $self->ioloop->connect_cb(
- sub {
- my ($loop, $id) = @_;
-
- # Connected
- $self->_connect($id);
- }
- );
-
# Queue transactions
$self->queue(@_) if @_;
@@ -103,7 +93,7 @@ sub _app_process {
while (my $queued = shift @{$self->_app_queue}) {
# Transaction
- my $client = $queued->[0];
+ my $client = $queued->{tx};
# App
my $app = $self->app;
@@ -157,11 +147,35 @@ sub _app_process {
# Spin
while (1) { last if $self->_app_spin($client, $server, $daemon) }
+ # Cookies to the jar
+ $self->_store_cookies($client);
+
+ # Redirect?
+ my $r = $queued->{redirects} || 0;
+ my $max = $self->max_redirects;
+ if ($r < $max && (my $tx = $self->_redirect($client))) {
+
+ # Queue redirected request
+ my $h = $queued->{history} || [];
+ push @$h, $client;
+ my $new = {
+ cb => $queued->{cb},
+ history => $h,
+ redirects => $r + 1,
+ tx => $tx
+ };
+ push @{$self->_app_queue}, $new;
+ }
+
# Callback
- my $cb = $queued->[1] || $self->default_cb;
+ else {
+
+ # Get callback
+ my $cb = $queued->{cb} || $self->default_cb;
- # Execute callback
- $self->$cb($client) if $cb;
+ # Execute callback
+ $self->$cb($client, $queued->{history}) if $cb;
+ }
}
return $self;
@@ -334,32 +348,97 @@ sub _error {
$self->_finish($id);
}
+sub _fetch_cookies {
+ my ($self, $tx) = @_;
+
+ # Shortcut
+ return unless $self->cookie_jar;
+
+ # Pipeline
+ if ($tx->is_pipeline) {
+ $_->req->cookies($self->cookie_jar->find($_->req->url))
+ for @{$tx->active};
+ }
+
+ # Single
+ else { $tx->req->cookies($self->cookie_jar->find($tx->req->url)) }
+}
+
sub _finish {
my ($self, $id) = @_;
+ # Connection
+ my $c = $self->_connections->{$id};
+
# Transaction
- my $tx = $self->_connections->{$id}->{tx};
+ my $tx = $c->{tx};
+
+ # Redirects
+ my $r = $c->{redirects} || 0;
- # Get callback
- my $cb = $self->_connections->{$id}->{cb} || $self->default_cb;
+ # History
+ my $h = $c->{history} || [];
+
+ # Drop old connection so we can reuse it
+ $self->_drop($id);
# Transaction still in progress
if ($tx) {
- # Callback
- $self->$cb($tx) if $cb && $tx;
+ # Cookies to the jar
+ $self->_store_cookies($tx);
# Counter
- $self->_queued($self->_queued - 1) if $tx;
- }
+ $self->_queued($self->_queued - 1);
- # Drop
- $self->_drop($id);
+ # Redirect?
+ my $max = $self->max_redirects;
+ if ($r < $max && (my $new = $self->_redirect($tx))) {
+
+ # Queue redirected request
+ my $nid = $self->_queue($new, $c->{cb});
+
+ # Create new conenction
+ my $nc = $self->_connections->{$nid};
+ push @$h, $tx;
+ $nc->{history} = $h;
+ $nc->{redirects} = $r + 1;
+
+ # Done
+ return;
+ }
+
+ # Callback
+ else {
+
+ # Get callback
+ my $cb = $c->{cb} || $self->default_cb;
+
+ # Callback
+ $self->$cb($tx, $c->{history}) if $cb;
+ }
+ }
# Stop ioloop
$self->ioloop->stop if $self->_finite && !$self->_queued;
}
+sub _fix_cookies {
+ my ($self, $tx, @cookies) = @_;
+
+ # Fix
+ for my $cookie (@cookies) {
+
+ # Domain
+ $cookie->domain($tx->req->url->host) unless $cookie->domain;
+
+ # Path
+ $cookie->path($tx->req->url->path) unless $cookie->path;
+ }
+
+ return @cookies;
+}
+
sub _hup {
my ($self, $loop, $id) = @_;
@@ -377,8 +456,13 @@ sub _hup {
sub _queue {
my ($self, $tx, $cb) = @_;
+ # Cookies from the jar
+ $self->_fetch_cookies($tx);
+
# Add to app queue
- push @{$self->_app_queue}, [$tx, $cb] and return if $self->app;
+ push @{$self->_app_queue}, {cb => $cb, redirects => 0, tx => $tx}
+ and return
+ if $self->app;
# Info
my $info = $tx->client_info;
@@ -386,6 +470,17 @@ sub _queue {
my $port = $info->{port};
my $scheme = $info->{scheme};
+ # Weaken
+ weaken $self;
+
+ # Connect callback
+ my $connected = sub {
+ my ($loop, $id) = @_;
+
+ # Connected
+ $self->_connect($id);
+ };
+
# Cached connection
my $id;
if ($id = $self->_withdraw("$scheme:$host:$port")) {
@@ -413,7 +508,11 @@ sub _queue {
: inet_ntoa(inet_aton($host));
# Connect
- $id = $self->ioloop->connect(address => $address, port => $port);
+ $id = $self->ioloop->connect(
+ address => $address,
+ port => $port,
+ cb => $connected
+ );
# Error
unless (defined $id) {
@@ -428,7 +527,6 @@ sub _queue {
}
# Weaken
- weaken $self;
weaken $tx;
# State change callback
@@ -447,6 +545,8 @@ sub _queue {
# Counter
$self->_queued($self->_queued + 1);
+
+ return $id;
}
sub _read {
@@ -466,6 +566,47 @@ sub _read {
else { $self->_drop($id) }
}
+sub _redirect {
+ my ($self, $tx) = @_;
+
+ # Code
+ return unless $tx->res->is_status_class('300');
+ return if $tx->res->code == 305;
+
+ # Location
+ return unless my $location = $tx->res->headers->location;
+
+ # Method
+ my $method = $tx->req->method;
+ $method = 'GET' unless $method =~ /^GET|HEAD$/i;
+
+ # New transaction
+ my $new = Mojo::Transaction::Single->new;
+ $new->req->method($method);
+ $new->req->url->parse($location);
+
+ return $new;
+}
+
+sub _store_cookies {
+ my ($self, $tx) = @_;
+
+ # Shortcut
+ return unless $self->cookie_jar;
+
+ # Pipeline
+ if ($tx->is_pipeline) {
+ $self->cookie_jar->add($self->_fix_cookies($_, @{$_->res->cookies}))
+ for @{$tx->finished};
+ }
+
+ # Single
+ else {
+ $self->cookie_jar->add(
+ $self->_fix_cookies($tx, @{$tx->res->cookies}));
+ }
+}
+
sub _withdraw {
my ($self, $name) = @_;
@@ -544,6 +685,11 @@ L<Mojo::Client> implements the following attributes.
my $timeout = $client->continue_timeout;
$client = $client->continue_timeout(5);
+=head2 C<cookie_jar>
+
+ my $cookie_jar = $client->cookie_jar;
+ $client = $client->cookie_jar(Mojo::CookieJar->new);
+
=head2 C<default_cb>
my $cb = $client->default_cb;
@@ -564,6 +710,11 @@ L<Mojo::Client> implements the following attributes.
my $max_keep_alive_connections = $client->max_keep_alive_connections;
$client = $client->max_keep_alive_connections(5);
+=head2 C<max_redirects>
+
+ my $max_redirects = $client->max_redirects;
+ $client = $client->max_redirects(3);
+
=head1 METHODS
L<Mojo::Client> inherits all methods from L<Mojo::Base> and implements the
@@ -68,6 +68,7 @@ sub run {
'queue=i' => sub { $daemon->listen_queue_size($_[1]) },
'requests=i' => sub { $daemon->max_keep_alive_requests($_[1]) },
'servers=i' => sub { $daemon->max_servers($_[1]) },
+ 'start=i' => sub { $daemon->start_servers($_[1]) },
'user=s' => sub { $daemon->user($_[1]) }
);
@@ -8,6 +8,9 @@ use warnings;
use base 'Mojo::Cookie';
use Mojo::ByteStream 'b';
+use Mojo::Date;
+
+__PACKAGE__->attr([qw/comment domain httponly max_age port secure/]);
# Regex
my $FIELD_RE = qr/
@@ -25,6 +28,14 @@ my $FIELD_RE = qr/
/xmsi;
my $FLAG_RE = qr/(?:Secure|HttpOnly)/i;
+sub expires {
+ my ($self, $expires) = @_;
+ if (defined $expires) {
+ $self->{expires} = Mojo::Date->new($expires) unless ref $expires;
+ }
+ return $self->{expires};
+}
+
# Remember the time he ate my goldfish?
# And you lied and said I never had goldfish.
# Then why did I have the bowl Bart? Why did I have the bowl?
@@ -109,7 +120,43 @@ L<Mojo::Cookie::Response> is a generic container for HTTP response cookies.
=head1 ATTRIBUTES
-L<Mojo::Cookie::Response> inherits all attributes from L<Mojo::Cookie>.
+L<Mojo::Cookie::Response> inherits all attributes from L<Mojo::Cookie> and
+implements the followign new ones.
+
+=head2 C<comment>
+
+ my $comment = $cookie->comment;
+ $cookie = $cookie->comment('test 123');
+
+=head2 C<domain>
+
+ my $domain = $cookie->domain;
+ $cookie = $cookie->domain('localhost');
+
+=head2 C<expires>
+
+ my $expires = $cookie->expires;
+ $cookie = $cookie->expires(time + 60);
+
+=head2 C<httponly>
+
+ my $httponly = $cookie->httponly;
+ $cookie = $cookie->httponly(1);
+
+=head2 C<max_age>
+
+ my $max_age = $cookie->max_age;
+ $cookie = $cookie->max_age(60);
+
+=head2 C<port>
+
+ my $port = $cookie->port;
+ $cookie = $cookie->port('80 8080');
+
+=head2 C<secure>
+
+ my $secure = $cookie->secure;
+ $cookie = $cookie->secure(1);
=head1 METHODS
@@ -10,11 +10,8 @@ use overload '""' => sub { shift->to_string }, fallback => 1;
use Carp 'croak';
use Mojo::ByteStream 'b';
-use Mojo::Date;
-__PACKAGE__->attr(
- [qw/comment domain httponly max_age name path port secure value version/]
-);
+__PACKAGE__->attr([qw/name path value version/]);
# Regex
my $COOKIE_SEPARATOR_RE = qr/^\s*\,\s*/;
@@ -35,14 +32,6 @@ my $VALUE_RE = qr/
# My Homer is not a communist.
# He may be a liar, a pig, an idiot, a communist, but he is not a porn star.
-sub expires {
- my ($self, $expires) = @_;
- if (defined $expires) {
- $self->{expires} = Mojo::Date->new($expires) unless ref $expires;
- }
- return $self->{expires};
-}
-
sub to_string { croak 'Method "to_string" not implemented by subclass' }
sub _tokenize {
@@ -110,31 +99,6 @@ L<Mojo::Cookie> is a cookie base class.
L<Mojo::Cookie> implements the following attributes.
-=head2 C<comment>
-
- my $comment = $cookie->comment;
- $cookie = $cookie->comment('test 123');
-
-=head2 C<domain>
-
- my $domain = $cookie->domain;
- $cookie = $cookie->domain('localhost');
-
-=head2 C<expires>
-
- my $expires = $cookie->expires;
- $cookie = $cookie->expires(time + 60);
-
-=head2 C<httponly>
-
- my $httponly = $cookie->httponly;
- $cookie = $cookie->httponly(1);
-
-=head2 C<max_age>
-
- my $max_age = $cookie->max_age;
- $cookie = $cookie->max_age(60);
-
=head2 C<name>
my $name = $cookie->name;
@@ -145,16 +109,6 @@ L<Mojo::Cookie> implements the following attributes.
my $path = $cookie->path;
$cookie = $cookie->path('/test');
-=head2 C<port>
-
- my $port = $cookie->port;
- $cookie = $cookie->port('80 8080');
-
-=head2 C<secure>
-
- my $secure = $cookie->secure;
- $cookie = $cookie->secure(1);
-
=head2 C<value>
my $value = $cookie->value;
@@ -0,0 +1,160 @@
+# Copyright (C) 2008-2009, Sebastian Riedel
+
+package Mojo::CookieJar;
+
+use strict;
+use warnings;
+
+use base 'Mojo::Base';
+use bytes;
+
+use Mojo::Cookie::Request;
+
+__PACKAGE__->attr(max_cookie_size => 4096);
+
+__PACKAGE__->attr(_jar => sub { {} });
+__PACKAGE__->attr(_size => 0);
+
+# I can't help but feel this is all my fault.
+# It was those North Korean fortune cookies - they were so insulting.
+# "You are a coward."
+# Nobody wants to hear that after a nice meal.
+# Marge, you can't keep blaming yourself.
+# Just blame yourself once, then move on.
+sub add {
+ my ($self, @cookies) = @_;
+
+ # Add cookies
+ for my $cookie (@cookies) {
+
+ # Unique cookie id
+ my $domain = $cookie->domain;
+ my $path = $cookie->path;
+ my $name = $cookie->name;
+
+ # Convert max age to expires
+ $cookie->expires($cookie->max_age + time) if $cookie->max_age;
+
+ # Default to session cookie
+ $cookie->max_age(0) unless $cookie->expires || $cookie->max_age;
+
+ # Cookie too big
+ next if length $cookie->value > $self->max_cookie_size;
+
+ # Initialize
+ $self->_jar->{$domain} ||= [];
+
+ # Check if we already have the same cookie
+ my @new;
+ for my $old (@{$self->_jar->{$domain}}) {
+
+ # Unique cookie id
+ my $opath = $old->path;
+ my $oname = $old->name;
+
+ push @new, $old unless $opath eq $path && $oname eq $name;
+ }
+
+ # Add
+ push @new, $cookie;
+ $self->_jar->{$domain} = \@new;
+ }
+
+ return $self;
+}
+
+sub find {
+ my ($self, $url) = @_;
+
+ # Pattern
+ my $domain = $url->host;
+ my $path = $url->path || '/';
+
+ # Shortcut
+ return unless $domain;
+
+ # Find
+ my @found;
+ while ($domain =~ /[^\.]+\.[^\.]+$/) {
+
+ # Nothing
+ next unless my $jar = $self->_jar->{$domain};
+
+ # Look inside
+ my @new;
+ for my $cookie (@$jar) {
+
+ # Session cookie?
+ my $session =
+ defined $cookie->max_age && $cookie->max_age > 0 ? 1 : 0;
+ if ($cookie->expires || !$session) {
+
+ # Expired
+ next if $cookie->expires && time > $cookie->expires->epoch;
+ }
+
+ # Port
+ my $port = $url->port || 80;
+ next if $cookie->port && $port != $cookie->port;
+
+ # Path
+ my $cpath = $cookie->path;
+ push @found,
+ Mojo::Cookie::Request->new(
+ name => $cookie->name,
+ value => $cookie->value,
+ path => $cookie->path,
+ version => $cookie->version
+ ) if $path =~ /^$cpath/;
+
+ # Not expired
+ push @new, $cookie;
+ }
+ $self->_jar->{$domain} = \@new;
+ }
+
+ # Remove leading dot or part
+ continue { $domain =~ s/^(?:\.|[^\.]+)// }
+
+ return @found;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Mojo::CookieJar - CookieJar
+
+=head1 SYNOPSIS
+
+ use Mojo::CookieJar;
+ my $jar = Mojo::CookieJar->new;
+
+=head1 DESCRIPTION
+
+L<Mojo::CookieJar> is a minimalistic cookie jar for HTTP user agents.
+
+=head1 ATTRIBUTES
+
+L<Mojo::CookieJar> implements the following attributes.
+
+=head2 C<max_cookie_size>
+
+ my $max_cookie_size = $jar->max_cookie_size;
+ $jar = $jar->max_cookie_size(4096);
+
+=head1 METHODS
+
+L<Mojo::CookieJar> inherits all methods from L<Mojo::Base> and implements the
+following new ones.
+
+=head2 C<add>
+
+ $jar = $jar->add(@cookies);
+
+=head2 C<find>
+
+ my @cookies = $jar->find($url);
+
+=cut
diff --git a/var/tmp/source/KRAIH/Mojo-0.999910/Mojo-0.999910/lib/Mojo/Exception.pm b/var/tmp/source/KRAIH/Mojo-0.999913/Mojo-0.999913/lib/Mojo/Exception.pm
old mode 100755
new mode 100644
@@ -16,22 +16,22 @@ use Mojo::Buffer;
use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 4096;
__PACKAGE__->attr(
- [qw/accept_cb connect_cb lock_cb unlock_cb/] => sub {
+ [qw/accept_cb lock_cb unlock_cb/] => sub {
sub {1}
}
);
__PACKAGE__->attr([qw/accept_timeout connect_timeout/] => 5);
-__PACKAGE__->attr([qw/clients servers/] => 0);
+__PACKAGE__->attr([qw/clients servers connecting/] => 0);
__PACKAGE__->attr(max_clients => 1000);
__PACKAGE__->attr(timeout => '0.25');
-__PACKAGE__->attr([qw/_accepted _connecting/] => sub { [] });
-__PACKAGE__->attr(_connections => sub { {} });
-__PACKAGE__->attr(_poll => sub { IO::Poll->new });
+__PACKAGE__->attr(_accepted => sub { [] });
+__PACKAGE__->attr(_connections => sub { {} });
+__PACKAGE__->attr(_poll => sub { IO::Poll->new });
__PACKAGE__->attr([qw/_listen _running/]);
# Singleton
-my $LOOP;
+our $LOOP;
# Instantiate singleton
sub new { $LOOP ||= shift->SUPER::new(@_) }
@@ -55,8 +55,20 @@ sub connect {
my $sin = sockaddr_in($args->{port} || 80, inet_aton($args->{address}));
$socket->connect($sin);
- # Connecting
- push @{$self->_connecting}, [$socket, time];
+ # Add connection
+ $self->_connections->{$socket} = {
+ buffer => Mojo::Buffer->new,
+ socket => $socket,
+ connect_cb => $args->{cb},
+ connecting => 1,
+ connect_start => time
+ };
+
+ # Connecting counter
+ $self->connecting($self->connecting + 1);
+
+ # Add socket to poll
+ $self->writing("$socket");
return "$socket";
}
@@ -79,6 +91,10 @@ sub drop {
$self->servers($self->servers - 1)
if $self->_connections->{$id}->{server};
+ # Connecting counter
+ $self->connecting($self->connecting - 1)
+ if $self->_connections->{$id}->{connecting};
+
# Socket
if (my $socket = $self->_connections->{$id}->{socket}) {
@@ -251,41 +267,43 @@ sub _connect {
my $self = shift;
# Connecting
- my @connecting;
- for my $connect (@{$self->_connecting}) {
+ my $c = $self->_connections;
+ for my $id (keys %$c) {
+
+ # Connecting?
+ my $connect = $c->{$id};
+ next unless $connect->{connecting};
# New socket
- my $socket = $connect->[0];
+ my $socket = $connect->{socket};
# Not yet connected
if (!$socket->connected) {
# Timeout
- $self->_error("$socket", 'Connect timeout.') and next
- if time - $connect->[1] > $self->connect_timeout;
+ if (time - $connect->{connect_start} > $self->connect_timeout) {
+ $self->_error("$socket", 'Connect timeout.');
+ $self->drop($id);
+ }
- # Another try
- push @connecting, $connect;
}
# Connected
else {
- # Add connection
- $self->_connections->{$socket} =
- {buffer => Mojo::Buffer->new, server => 1, socket => $socket};
+ # Connected counter
+ $connect->{connecting} = 0;
+ $self->connecting($self->connecting - 1);
# Server counter
+ $connect->{server} = 1;
$self->servers($self->servers + 1);
# Connect callback
- $self->connect_cb->($self, "$socket");
-
- # Add socket to poll
- $self->writing("$socket");
+ my $cb = $connect->{connect_cb};
+ $self->$cb("$socket") if $cb;
}
}
- $self->_connecting(\@connecting);
}
sub _error {
@@ -413,14 +431,14 @@ sub _spin {
$self->_accept;
# Connect
- $self->_connect;
+ $self->_connect if $self->connecting;
# Prepare
$self->_prepare;
# Nothing to do
return $self->_running(0)
- unless $poll->handles || $self->_listen || @{$self->_connecting};
+ unless $poll->handles || $self->_listen || $self->connecting;
# Poll
$poll->poll($self->timeout);
@@ -441,9 +459,12 @@ sub _spin {
sub _write {
my ($self, $id) = @_;
- # Conenction
+ # Connection
my $c = $self->_connections->{$id};
+ # Connect has just completed
+ return if $c->{connecting};
+
# Buffer
my $buffer = $c->{buffer};
@@ -546,16 +567,16 @@ L<Mojo::IOLoop> implements the following attributes.
my $clients = $loop->clients;
$loop = $loop->clients(25);
-=head2 C<connect_cb>
-
- my $cb = $loop->connect_cb;
- $loop = $loop->connect_cb(sub { ... });
-
=head2 C<connect_timeout>
my $timeout = $loop->connect_timeout;
$loop = $loop->connect_timeout(5);
+=head2 C<connecting>
+
+ my $connecting = $loop->connecting;
+ $loop = $loop->connecting(25);
+
=head2 C<lock_cb>
my $cb = $loop->lock_cb;
@@ -592,8 +613,16 @@ following new ones.
=head2 C<connect>
- my $c = $loop->connect(address => '127.0.0.1', port => 3000);
- my $c = $loop->connect({address => '127.0.0.1', port => 3000});
+ my $c = $loop->connect(
+ address => '127.0.0.1',
+ port => 3000,
+ cb => sub {...}
+ );
+ my $c = $loop->connect({
+ address => '127.0.0.1',
+ port => 3000,
+ cb => sub {...}
+ });
=head2 C<connection_timeout>
@@ -11,6 +11,10 @@ use Mojo::ByteStream 'b';
__PACKAGE__->attr('error');
+# Literal names
+our $FALSE = Mojo::JSON::_Bool->new(0);
+our $TRUE = Mojo::JSON::_Bool->new(1);
+
# Regex
my $WHITESPACE_RE = qr/[\x20\x09\x0a\x0d]*/;
my $ARRAY_BEGIN_RE = qr/^$WHITESPACE_RE\[/;
@@ -72,18 +76,27 @@ my $REVERSE_ESCAPE = {};
for my $key (keys %$ESCAPE) { $REVERSE_ESCAPE->{$ESCAPE->{$key}} = $key }
# Byte order marks
-my $BOM = {
- "\357\273\277" => 'UTF-8',
- "\376\377" => 'UTF-16BE',
- "\377\376" => 'UTF-16LE',
- "\377\376\0\0" => 'UTF-32LE',
- "\0\0\376\377" => 'UTF-32BE'
+my $BOM_RE = qr/
+ (?:
+ \357\273\277 # UTF-8
+ |
+ \377\376\0\0 # UTF-32LE
+ |
+ \0\0\376\377 # UTF-32BE
+ |
+ \376\377 # UTF-16BE
+ |
+ \377\376 # UTF-16LE
+ )
+/x;
+
+# Unicode encoding detection
+my $UTF_PATTERNS = {
+ "\0\0\0[^\0]" => 'UTF-32BE',
+ "\0[^\0]\0[^\0]" => 'UTF-16BE',
+ "[^\0]\0\0\0" => 'UTF-32LE',
+ "[^\0]\0[^\0]\0" => 'UTF-16LE'
};
-my $BOM_RE;
-{
- my $bom = join '|', reverse sort keys %$BOM;
- $BOM_RE = qr/^($bom)/;
-}
# Hey...That's not the wallet inspector...
sub decode {
@@ -95,13 +108,21 @@ sub decode {
# Cleanup
$self->error(undef);
+ # Remove BOM
+ $string =~ s/$BOM_RE//g;
+
# Detect and decode unicode
my $encoding = 'UTF-8';
- if ($string =~ s/$BOM_RE//) { $encoding = $BOM->{$1} }
+ for my $pattern (keys %$UTF_PATTERNS) {
+ if ($string =~ /^$pattern/) {
+ $encoding = $UTF_PATTERNS->{$pattern};
+ last;
+ }
+ }
$string = b($string)->decode($encoding)->to_string;
# Decode
- my $result = $self->_decode_values(\$string);
+ my $result = $self->_decode_structure(\$string);
# Exception
return if $self->error;
@@ -125,6 +146,10 @@ sub encode {
return b($string)->encode('UTF-8')->to_string;
}
+sub false {$FALSE}
+
+sub true {$TRUE}
+
sub _decode_array {
my ($self, $ref) = @_;
@@ -233,42 +258,53 @@ sub _decode_string {
return;
}
+sub _decode_structure {
+ my ($self, $ref) = @_;
+
+ # Object
+ if ($$ref =~ s/$OBJECT_BEGIN_RE//) {
+ return [$self->_decode_object($ref)];
+ }
+
+ # Array
+ elsif ($$ref =~ s/$ARRAY_BEGIN_RE//) {
+ return [$self->_decode_array($ref)];
+ }
+
+ # Nothing
+ return;
+}
+
sub _decode_values {
my ($self, $ref) = @_;
# Number
- if (my $number = $self->_decode_number($ref)) { return [$number] }
+ if (defined(my $number = $self->_decode_number($ref))) {
+ return [$number];
+ }
# String
- elsif (my $string = $self->_decode_string($ref)) { return [$string] }
+ elsif (defined(my $string = $self->_decode_string($ref))) {
+ return [$string];
+ }
# Name
elsif (my $name = $self->_decode_names($ref)) {
# "false"
- if ($name eq 'false') { $name = undef }
+ if ($name eq 'false') { $name = $FALSE }
# "null"
- elsif ($name eq 'null') { $name = '0 but true' }
+ elsif ($name eq 'null') { $name = undef }
# "true"
- elsif ($name eq 'true') { $name = '\1' }
+ elsif ($name eq 'true') { $name = $TRUE }
return [$name];
}
- # Object
- elsif ($$ref =~ s/$OBJECT_BEGIN_RE//) {
- return [$self->_decode_object($ref)];
- }
-
- # Array
- elsif ($$ref =~ s/$ARRAY_BEGIN_RE//) {
- return [$self->_decode_array($ref)];
- }
-
- # Nothing
- return;
+ # Object or array
+ return $self->_decode_structure($ref);
}
sub _encode_array {
@@ -324,17 +360,17 @@ sub _encode_values {
return $self->_encode_object($value) if $ref eq 'HASH';
}
+ # "null"
+ return 'null' unless defined $value;
+
# "false"
- return 'false' unless defined $value;
+ return 'false' if ref $value eq 'Mojo::JSON::_Bool' && !$value;
# "true"
- return 'true' if $value eq '\1';
-
- # "null"
- return 'null' if $value eq '0 but true';
+ return 'true' if ref $value eq 'Mojo::JSON::_Bool' && $value;
# Number
- return $value if $value =~ /$NUMBER_RE/;
+ return $value if $value =~ /$NUMBER_RE$/;
# String
return $self->_encode_string($value);
@@ -385,6 +421,22 @@ sub _exception {
$self->error(qq/$error near $context./) and return;
}
+# Emulate boolean type
+package Mojo::JSON::_Bool;
+
+use strict;
+use warnings;
+
+use base 'Mojo::Base';
+use overload (
+ '0+' => sub { $_[0]->_value },
+ '""' => sub { $_[0]->_value },
+);
+
+__PACKAGE__->attr('_value');
+
+sub new { shift->SUPER::new(_value => shift) }
+
1;
__END__
@@ -410,14 +462,15 @@ not blessed references.
[1, -2, 3] -> [1, -2, 3]
{"foo": "bar"} -> {foo => 'bar'}
-Literal names will be translated to and from a similar Perl value.
+Literal names will be translated to and from L<Mojo::JSON> constants or a
+similar native Perl value.
- true -> '\1'
- false -> undef
- null -> '0 but true'
+ true -> Mojo::JSON->true
+ false -> Mojo::JSON->false
+ null -> undef
-Decoding UTF-16 (LE/BE) and UTF-32 (LE/BE) will be handled transparently by
-detecting the byte order mark, encoding will only generate UTF-8.
+Decoding UTF-16 (LE/BE) and UTF-32 (LE/BE) will be handled transparently,
+encoding will only generate UTF-8.
=head1 ATTRIBUTES
@@ -442,4 +495,14 @@ following new ones.
my $string = $json->encode({foo => 'bar'});
+=head2 C<false>
+
+ my $false = Mojo::JSON->false;
+ my $false = $json->false;
+
+=head2 C<true>
+
+ my $true = Mojo::JSON->true;
+ my $true = $json->true;
+
=cut
@@ -50,6 +50,32 @@ use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 4096;
# Lisa, tell your mother to get off my case.
# Uhhh, dad, Lisa's the one you're not talking to.
# Bart, go to your room.
+sub accept_lock {
+ my ($self, $blocking) = @_;
+
+ # Idle
+ if ($blocking) {
+ $self->_child_write->syswrite("$$ idle\n")
+ or croak "Can't write to parent: $!";
+ }
+
+ # Lock
+ my $lock =
+ $blocking
+ ? flock($self->_lock, LOCK_EX)
+ : flock($self->_lock, LOCK_EX | LOCK_NB);
+
+ # Busy
+ if ($lock) {
+ $self->_child_write->syswrite("$$ busy\n")
+ or croak "Can't write to parent: $!";
+ }
+
+ return $lock;
+}
+
+sub accept_unlock { flock(shift->_lock, LOCK_UN) }
+
sub child { shift->ioloop->start }
sub daemonize {
@@ -77,34 +103,10 @@ sub parent {
my $self = shift;
# Lock callback
- $self->ioloop->lock_cb(
- sub {
- my ($loop, $blocking) = @_;
-
- # Idle
- if ($blocking) {
- $self->_child_write->syswrite("$$ idle\n")
- or croak "Can't write to parent: $!";
- }
-
- # Lock
- my $lock =
- $blocking
- ? flock($self->_lock, LOCK_EX)
- : flock($self->_lock, LOCK_EX | LOCK_NB);
-
- # Busy
- if ($lock) {
- $self->_child_write->syswrite("$$ busy\n")
- or croak "Can't write to parent: $!";
- }
-
- return $lock;
- }
- );
+ $self->ioloop->lock_cb(sub { $self->accept_lock($_[1]) });
# Unlock callback
- $self->ioloop->unlock_cb(sub { flock($self->_lock, LOCK_UN) });
+ $self->ioloop->unlock_cb(sub { $self->accept_unlock });
# Prepare ioloop
$self->prepare_ioloop;
@@ -437,6 +439,14 @@ L<Mojo::Server::Daemon> and implements the following new ones.
L<Mojo::Server::Daemon::Prefork> inherits all methods from
L<Mojo::Server::Daemon> and implements the following new ones.
+=head2 C<accept_lock>
+
+ my $lock = $daemon->accept_lock($blocking);
+
+=head2 C<accept_unlock>
+
+ $daemon->accept_unlock;
+
=head2 C<child>
$daemon->child;
@@ -17,21 +17,39 @@ use constant CHUNK_SIZE => $ENV{MOJO_CHUNK_SIZE} || 4096;
__PACKAGE__->attr([qw/auto_escape compiled namespace/]);
__PACKAGE__->attr([qw/append code prepend/] => '');
+__PACKAGE__->attr(capture_end => '}');
+__PACKAGE__->attr(capture_start => '{');
__PACKAGE__->attr(comment_mark => '#');
__PACKAGE__->attr(encoding => 'UTF-8');
__PACKAGE__->attr(escape_mark => '=');
__PACKAGE__->attr(expression_mark => '=');
__PACKAGE__->attr(line_start => '%');
+__PACKAGE__->attr(tag_start => '<%');
+__PACKAGE__->attr(tag_end => '%>');
__PACKAGE__->attr(template => '');
__PACKAGE__->attr(tree => sub { [] });
-__PACKAGE__->attr(tag_start => '<%');
-__PACKAGE__->attr(tag_end => '%>');
+__PACKAGE__->attr(trim_mark => '=');
+
+# Escape helper
+my $ESCAPE = <<'EOF';
+no strict 'refs'; no warnings 'redefine';
+sub escape;
+*escape = sub {
+ my $v = shift;
+ ref $v && ref $v eq 'Mojo::ByteStream'
+ ? "$v"
+ : Mojo::ByteStream->new($v)->xml_escape->to_string;
+};
+use strict; use warnings;
+EOF
+$ESCAPE =~ s/\n//g;
sub build {
my $self = shift;
# Compile
my @lines;
+ my $cpst;
for my $line (@{$self->tree}) {
# New line
@@ -41,8 +59,20 @@ sub build {
my $value = $line->[$j + 1];
# Need to fix line ending?
+ $value ||= '';
my $newline = chomp $value;
+ # Capture end
+ if ($type eq 'cpen') {
+
+ # End block
+ $lines[-1] .= '$_M }';
+
+ # No following code
+ my $next = $line->[$j + 3];
+ $lines[-1] .= ';' if !defined $next || $next =~ /^\s*$/;
+ }
+
# Text
if ($type eq 'text') {
@@ -62,27 +92,38 @@ sub build {
# Escaped
my $a = $self->auto_escape;
if (($type eq 'escp' && !$a) || ($type eq 'expr' && $a)) {
- $lines[-1] .= "\$_M .= escape +$value;";
+ $lines[-1] .= "\$_M .= escape";
+ $lines[-1] .= " +$value" if length $value;
}
# Raw
- else { $lines[-1] .= "\$_M .= $value;" }
+ else { $lines[-1] .= "\$_M .= $value" }
+
+ # Append semicolon
+ $lines[-1] .= ';' unless $cpst;
+ }
+
+ # Capture started
+ if ($cpst) {
+ $lines[-1] .= $cpst;
+ $cpst = undef;
+ }
+
+ # Capture start
+ if ($type eq 'cpst') {
+
+ # Start block
+ $cpst = " do { my \$_M = ''; ";
}
}
}
- # Escape helper
- my $escape = q/no strict 'refs'; no warnings 'redefine'; sub escape; /;
- $escape .= q/*escape = sub { Mojo::ByteStream->new($_[0])->xml_escape->/;
- $escape .= q/to_string };/;
- $escape .= q/use strict; use warnings;/;
-
# Wrap
my $prepend = $self->prepend;
my $append = $self->append;
my $namespace = $self->namespace || ref $self;
$lines[0] ||= '';
- $lines[0] = qq/package $namespace; sub { my \$_M = ''; $escape; $prepend;/
+ $lines[0] = qq/package $namespace; sub { my \$_M = ''; $ESCAPE; $prepend;/
. $lines[0];
$lines[-1] .= qq/$append; return \$_M; };/;
@@ -146,56 +187,91 @@ sub parse {
delete $self->{tree};
# Tags
- my $line_start = quotemeta $self->line_start;
- my $tag_start = quotemeta $self->tag_start;
- my $tag_end = quotemeta $self->tag_end;
- my $cmnt_mark = quotemeta $self->comment_mark;
- my $escp_mark = quotemeta $self->escape_mark;
- my $expr_mark = quotemeta $self->expression_mark;
+ my $line_start = quotemeta $self->line_start;
+ my $tag_start = quotemeta $self->tag_start;
+ my $tag_end = quotemeta $self->tag_end;
+ my $cmnt = quotemeta $self->comment_mark;
+ my $escp = quotemeta $self->escape_mark;
+ my $expr = quotemeta $self->expression_mark;
+ my $trim = quotemeta $self->trim_mark;
+ my $capture_start = quotemeta $self->capture_start;
+ my $capture_end = quotemeta $self->capture_end;
my $mixed_re = qr/
(
- $tag_start$expr_mark$escp_mark # Escaped expression
+ $tag_start$capture_end$expr$escp # Escaped expression (end)
|
- $tag_start$expr_mark # Expression
+ $tag_start$capture_start$expr$escp # Escaped expression (start)
|
- $tag_start$cmnt_mark # Comment
+ $tag_start$expr$escp # Escaped expression
|
- $tag_start # Code
+ $tag_start$capture_end$expr # Expression (end)
|
- $tag_end # End
+ $tag_start$capture_start$expr # Expression (start)
+ |
+ $tag_start$expr # Expression
+ |
+ $tag_start$capture_end$cmnt # Comment (end)
+ |
+ $tag_start$capture_start$cmnt # Comment (start)
+ |
+ $tag_start$cmnt # Comment
+ |
+ $tag_start$capture_end # Code (end)
+ |
+ $tag_start$capture_start # Code (start)
+ |
+ $tag_start # Code
+ |
+ $trim$tag_end # Trim end
+ |
+ $tag_end # End
)
/x;
+ my $token_capture_re =
+ qr/^($tag_start|$tag_end)($capture_end|$capture_start)/;
+
# Tokenize
my $state = 'text';
my $multiline_expression = 0;
+ my @capture_token;
+ my $trimming = 0;
for my $line (split /\n/, $tmpl) {
-
- # Perl line without return value
- if ($line =~ /^$line_start\s+(.+)$/) {
- push @{$self->tree}, ['code', $1];
- $multiline_expression = 0;
- next;
+ my @capture;
+
+ # Perl line with capture end or start
+ if ($line =~ /^$line_start($capture_end|$capture_start)/) {
+ my $capture = $1;
+ $line =~ s/^($line_start)$capture/$1/;
+ @capture =
+ ("\\$capture" eq $capture_end ? 'cpen' : 'cpst', undef);
}
# Perl line with return value that needs to be escaped
- if ($line =~ /^$line_start$expr_mark$escp_mark\s+(.+)$/) {
- push @{$self->tree}, ['escp', $1];
+ if ($line =~ /^$line_start$expr$escp(.+)?$/) {
+ push @{$self->tree}, [@capture, 'escp', $1];
$multiline_expression = 0;
next;
}
# Perl line with return value
- if ($line =~ /^$line_start$expr_mark\s+(.+)$/) {
- push @{$self->tree}, ['expr', $1];
+ if ($line =~ /^$line_start$expr(.+)?$/) {
+ push @{$self->tree}, [@capture, 'expr', $1];
$multiline_expression = 0;
next;
}
# Comment line, dummy token needed for line count
- if ($line =~ /^$line_start$cmnt_mark\s+(.+)$/) {
- push @{$self->tree}, [];
+ if ($line =~ /^$line_start$cmnt(.+)?$/) {
+ push @{$self->tree}, [@capture];
+ $multiline_expression = 0;
+ next;
+ }
+
+ # Perl line without return value
+ if ($line =~ /^$line_start(.+)?$/) {
+ push @{$self->tree}, [@capture, 'code', $1];
$multiline_expression = 0;
next;
}
@@ -223,11 +299,36 @@ sub parse {
my @token;
for my $token (split /$mixed_re/, $line) {
- # Garbage
- next unless $token;
+ # Done trimming
+ $trimming = 0 if $trimming && $state ne 'text';
+
+ # Perl token with capture end or start
+ if ($token =~ /$token_capture_re/) {
+ my $tag = $1;
+ my $capture = $2;
+ $token =~ s/^($tag)$capture/$tag/;
+ @capture_token =
+ ("\\$capture" eq $capture_end ? 'cpen' : 'cpst', undef);
+ }
# End
- if ($token =~ /^$tag_end$/) {
+ if ($token =~ /^$tag_end|($trim$tag_end)$/) {
+
+ # Trim previous text
+ if ($1) {
+ $trimming = 1;
+
+ # Trim current line
+ unless ($self->_trim_line(\@token, 4)) {
+
+ # Trim previous lines
+ for my $l (reverse @{$self->tree}) {
+ last if $self->_trim_line($l);
+ }
+ }
+ }
+
+ # Back to business as usual
$state = 'text';
$multiline_expression = 0;
}
@@ -236,21 +337,33 @@ sub parse {
elsif ($token =~ /^$tag_start$/) { $state = 'code' }
# Comment
- elsif ($token =~ /^$tag_start$cmnt_mark$/) { $state = 'cmnt' }
+ elsif ($token =~ /^$tag_start$cmnt$/) { $state = 'cmnt' }
# Expression
- elsif ($token =~ /^$tag_start$expr_mark$/) {
+ elsif ($token =~ /^$tag_start$expr$/) {
$state = 'expr';
}
# Expression that needs to be escaped
- elsif ($token =~ /^$tag_start$expr_mark$escp_mark$/) {
+ elsif ($token =~ /^$tag_start$expr$escp$/) {
$state = 'escp';
}
# Value
else {
+ # Trimming
+ if ($trimming) {
+ if ($token =~ s/^(\s+)//) {
+
+ # Convert whitespace text to line noise
+ push @token, 'code', $1;
+
+ # Done with trimming
+ $trimming = 0 if length $token;
+ }
+ }
+
# Comments are ignored
next if $state eq 'cmnt';
@@ -260,7 +373,8 @@ sub parse {
$multiline_expression = 1 if $state eq 'expr';
# Store value
- push @token, $state, $token;
+ push @token, @capture_token, $state, $token;
+ @capture_token = ();
}
}
push @{$self->tree}, \@token;
@@ -338,6 +452,37 @@ sub render_to_file {
return $self->_write_file($path, $output);
}
+sub _trim_line {
+ my ($self, $line, $offset) = @_;
+
+ # Walk line backwards
+ $offset ||= 2;
+ for (my $j = @$line - $offset; $j >= 0; $j -= 2) {
+
+ # Skip capture start
+ next if $line->[$j] eq 'cpst';
+
+ # Only trim text
+ return 1 unless $line->[$j] eq 'text';
+
+ # Trim
+ my $value = $line->[$j + 1];
+ if ($line->[$j + 1] =~ s/(\s+)$//) {
+
+ # Value
+ $value = $line->[$j + 1];
+
+ # Convert whitespace text to line noise
+ splice @$line, $j, 0, 'code', $1;
+ }
+
+ # Text left
+ return 1 if length $value;
+ }
+
+ return;
+}
+
sub _write_file {
my ($self, $path, $output) = @_;
@@ -396,14 +541,38 @@ Like preprocessing a config file, generating text from heredocs and stuff
like that.
<% Inline Perl %>
- <%= Perl expression, replaced with result %>
- <%== Perl expression, replaced with XML escaped result %>
+ <%= Perl expression, replaced with result or XML escaped result
+ (depending on auto_escape attribute) %>
+ <%== Perl expression, replaced with result or XML escaped result
+ (depending on auto_escape attribute) %>
<%# Comment, useful for debugging %>
% Perl line
- %= Perl expression line, replaced with result
- %== Perl expression line, replaced with XML escaped result
+ %= Perl expression line, replaced with result or XML escaped result
+ (depending on auto_escape attribute)
+ %== Perl expression line, replaced with result or XML escaped result
+ (depending on auto_escape attribute)
%# Comment line, useful for debugging
+Whitespace characters around tags can be trimmed with a special tag ending.
+
+ <%= All whitespace characters around this expression will be trimmed =%>
+
+L<Mojo::ByteStream> objects are excluded from automatic escaping.
+You can capture the result of a whole template block for reuse later.
+
+ <%{ my $result = %>
+ This will be assigned.
+ <%}%>
+ <%{= my $result = %>
+ This will be assigned and passed through.
+ <%}%>
+ %{ my $result =
+ This will be assigned.
+ %}
+ %{= my $result =
+ This will be assigned and passed through.
+ %}
+
L<Mojo::Template> templates work just like Perl subs (actually they get
compiled to a Perl sub internally).
That means you can access arguments simply via C<@_>.
@@ -483,6 +652,16 @@ L<Mojo::Template> implements the following attributes.
my $code = $mt->append;
$mt = $mt->append('warn "Processed template"');
+=head2 C<capture_end>
+
+ my $capture_end = $mt->capture_end;
+ $mt = $mt->capture_end('}');
+
+=head2 C<capture_start>
+
+ my $capture_start = $mt->capture_start;
+ $mt = $mt->capture_start('{');
+
=head2 C<code>
my $code = $mt->code;
@@ -523,6 +702,16 @@ L<Mojo::Template> implements the following attributes.
my $code = $mt->prepend;
$mt = $mt->prepend('my $self = shift;');
+=head2 C<tag_start>
+
+ my $tag_start = $mt->tag_start;
+ $mt = $mt->tag_start('<%');
+
+=head2 C<tag_end>
+
+ my $tag_end = $mt->tag_end;
+ $mt = $mt->tag_end('%>');
+
=head2 C<template>
my $template = $mt->template;
@@ -533,15 +722,10 @@ L<Mojo::Template> implements the following attributes.
my $tree = $mt->tree;
$mt = $mt->tree($tree);
-=head2 C<tag_start>
-
- my $tag_start = $mt->tag_start;
- $mt = $mt->tag_start('<%');
-
-=head2 C<tag_end>
+=head2 C<trim_mark>
- my $tag_end = $mt->tag_end;
- $mt = $mt->tag_end('%>');
+ my $trim_mark = $mt->trim_mark;
+ $mt = $mt->trim_mark('-');
=head1 METHODS
@@ -38,6 +38,8 @@ sub client_spin { croak 'Method "client_spin" not implemented by subclass' }
sub is_paused { shift->is_state('paused') }
+sub is_pipeline { return shift->isa('Mojo::Transaction::Pipeline') ? 1 : 0 }
+
sub pause {
my $self = shift;
@@ -180,6 +182,10 @@ implements the following new ones.
my $paused = $tx->is_paused;
+=head2 C<is_pipeline>
+
+ my $is_pipeline = $tx->is_pipeline;
+
=head2 C<pause>
$tx = $tx->pause;
@@ -28,7 +28,7 @@ __PACKAGE__->attr(home => sub { Mojo::Home->new });
__PACKAGE__->attr(log => sub { Mojo::Log->new });
# Oh, so they have internet on computers now!
-our $VERSION = '0.999910';
+our $VERSION = '0.999913';
sub new {
my $self = shift->SUPER::new(@_);
@@ -59,6 +59,7 @@ sub render {
# We got called
$c->stash->{rendered} = 1;
+ $c->stash->{content} ||= {};
# Partial?
my $partial = delete $c->stash->{partial};
@@ -82,9 +83,9 @@ sub render {
# Render
$self->handler->{text}->($self, $c, \$output);
- # Layout?
- $c->stash->{inner_template} = $output
- if $c->stash->{layout} && !$partial;
+ # Extends?
+ $c->stash->{content}->{content} = b("$output")
+ if ($c->stash->{extends} || $c->stash->{layout}) && !$partial;
}
# JSON
@@ -94,9 +95,9 @@ sub render {
$self->handler->{json}->($self, $c, \$output);
$format = 'json';
- # Layout?
- $c->stash->{inner_template} = $output
- if $c->stash->{layout} && !$partial;
+ # Extends?
+ $c->stash->{content}->{content} = b("$output")
+ if ($c->stash->{extends} || $c->stash->{layout}) && !$partial;
}
# Template or templateless handler
@@ -105,13 +106,13 @@ sub render {
# Render
return unless $self->_render_template($c, \$output, $options);
- # Layout?
- $c->stash->{inner_template} = $output
- if $c->stash->{layout} && !$partial;
+ # Extends?
+ $c->stash->{content}->{content} = b("$output")
+ if ($c->stash->{extends} || $c->stash->{layout}) && !$partial;
}
- # Layout
- if (!$partial && (my $layout = delete $c->stash->{layout})) {
+ # Extends
+ while (!$partial && (my $extends = $self->_extends($c))) {
# Handler
$handler = $c->stash->{handler} || $self->default_handler;
@@ -121,8 +122,8 @@ sub render {
$format = $c->stash->{format} || $self->default_format;
$options->{format} = $format;
- # Fix
- $options->{template} = $self->layout_prefix . "/$layout";
+ # Template
+ $options->{template} = $extends;
# Render
$self->_render_template($c, \$output, $options);
@@ -166,6 +167,18 @@ sub template_path {
$self->template_name(shift));
}
+sub _extends {
+ my ($self, $c) = @_;
+
+ # Layout
+ $c->stash->{extends}
+ ||= ($self->layout_prefix . '/' . delete $c->stash->{layout})
+ if $c->stash->{layout};
+
+ # Extends
+ return delete $c->stash->{extends};
+}
+
# Well, at least here you'll be treated with dignity.
# Now strip naked and get on the probulator.
sub _render_template {
@@ -152,7 +152,11 @@ sub match {
$match->path($path);
# Reset stack
- $self->parent ? $match->stack($snapshot) : $match->stack([]);
+ if ($self->parent) { $match->stack($snapshot) }
+ else {
+ $match->captures({});
+ $match->stack([]);
+ }
}
$match->endpoint($self) if $self->is_endpoint && $match->is_path_empty;
@@ -2,7 +2,7 @@
=head1 NAME
-Mojolicious::Book - Modern Web Development With Perl And Mojolicious
+Mojolicious::Book - The Definitive Guide To Mojolicious
=head1 STATUS
@@ -140,23 +140,15 @@ sub welcome {
use strict;
use warnings;
-use Mojo::Client;
-use Mojo::Transaction::Single;
-use Test::More tests => 4;
+use Test::More tests => 5;
+use Test::Mojo;
use_ok('<%= $class %>');
-# Prepare client and transaction
-my $client = Mojo::Client->new;
-my $tx = Mojo::Transaction::Single->new_get('/');
-
-# Process request
-$client->process_app('<%= $class %>', $tx);
-
-# Test response
-is($tx->res->code, 200);
-is($tx->res->headers->content_type, 'text/html');
-like($tx->res->content->asset->slurp, qr/Mojolicious Web Framework/i);
+# Test
+my $t = Test::Mojo->new(app => '<%= $class %>');
+$t->get_ok('/')->status_is(200)->content_type_is(Server => 'text/html')
+ ->content_like(qr/Mojolicious Web Framework/i);
@@ not_found
<!doctype html><html>
<head><title>Not Found</title></head>
@@ -7,6 +7,7 @@ use warnings;
use base 'MojoX::Dispatcher::Routes::Controller';
+use Mojo::ByteStream;
use Mojo::URL;
# Space: It seems to go on and on forever...
@@ -81,7 +82,20 @@ sub render {
return $self->app->renderer->render($self);
}
-sub render_inner { delete shift->stash->{inner_template} }
+sub render_inner {
+ my ($self, $name, $content) = @_;
+
+ # Initialize
+ $self->stash->{content} ||= {};
+ $name ||= 'content';
+
+ # Set
+ $self->stash->{content}->{$name} ||= Mojo::ByteStream->new("$content")
+ if $content;
+
+ # Get
+ return $self->stash->{content}->{$name};
+}
sub render_json {
my $self = shift;
@@ -92,7 +106,7 @@ sub render_json {
sub render_partial {
my $self = shift;
local $self->stash->{partial} = 1;
- return $self->render(@_);
+ return Mojo::ByteStream->new($self->render(@_));
}
sub render_text {
@@ -186,6 +200,8 @@ ones.
=head2 C<render_inner>
my $output = $c->render_inner;
+ my $output = $c->render_inner('content');
+ my $output = $c->render_inner(content => 'Hello world!');
=head2 C<render_json>
@@ -231,7 +231,41 @@ Templates can have layouts.
@@ layouts/green.html.ep
<!doctype html><html>
<head><title>Green!</title></head>
- <body><%== content %></body>
+ <body><%= content %></body>
+ </html>
+
+Templates can also extend each other.
+
+ # GET /
+ get '/' => 'first';
+
+ # GET /second
+ get '/second' => 'second';
+
+ __DATA__
+
+ @@ first.html.ep
+ % extends 'second';
+ %{ content header =>
+ <title>Howdy!</title>
+ %}
+ First!
+
+ @@ second.html.ep
+ % layout 'third';
+ %{ content header =>
+ <title>Welcome!</title>
+ %}
+ Second!
+
+ @@ layouts/third.html.ep
+ <!doctype html><html>
+ <head>
+ <%{= content header => %>
+ <title>Lame default title...</title>
+ <%}%>
+ </head>
+ <body><%= content %></body>
</html>
Route placeholders allow capturing parts of a request path until a C</> or
@@ -367,7 +401,7 @@ multiple features at once.
@@ welcome.html.ep
<%= $groovy %> is groovy!
- <%== include 'menu' %>
+ <%= include 'menu' %>
@@ menu.html.ep
<a href="<%= url_for 'index' %>">Try again</a>
@@ -375,7 +409,7 @@ multiple features at once.
@@ layouts/funky.html.ep
<!doctype html><html>
<head><title>Funky!</title></head>
- <body><%== content %>
+ <body><%= content %>
</body>
</html>
@@ -460,6 +494,22 @@ exists.
% mkdir public
% mv something.js public/something.js
+Testing your application is as easy as creating a C<t> directory and filling
+it with normal Perl unit tests like C<t/funky.t>.
+
+ use Test::More tests => 3;
+ use Test::Mojo;
+
+ use FindBin;
+ require "$FindBin::Bin/../myapp.pl";
+
+ my $t = Test::Mojo->new;
+ $t->get_ok('/')->status_is(200)->content_like(qr/Funky!/);
+
+Run all unit tests with the C<test> command.
+
+ % ./myapp.pl test
+
To disable debug messages later in a production setup you can change the
L<Mojolicious> mode, default will be C<development>.
@@ -66,8 +66,16 @@ sub new {
# No template
else {
$c->app->log->error(
- qq/Template "$t" missing or not readable./)
- and return;
+ qq/Template "$t" missing or not readable./);
+ my $options = {
+ template => 'not_found',
+ format => 'html',
+ status => 404,
+ not_found => 1
+ };
+ $c->app->static->serve_404($c)
+ if $c->stash->{not_found} || !$c->render($options);
+ return;
}
# Cache
@@ -169,6 +177,9 @@ sub new {
}
);
+ # Add "extends" helper
+ $self->add_helper(extends => sub { shift->stash(extends => @_) });
+
# Add "include" helper
$self->add_helper(include => sub { shift->render_partial(@_) });
@@ -12,7 +12,8 @@ use FindBin;
use IO::Socket::INET;
use Mojo::Command;
use Mojo::Home;
-use Test::Builder;
+
+require Test::More;
use constant DEBUG => $ENV{MOJO_SERVER_DEBUG} || 0;
@@ -21,7 +22,6 @@ __PACKAGE__->attr(executable => 'mojo');
__PACKAGE__->attr(home => sub { Mojo::Home->new });
__PACKAGE__->attr(timeout => 5);
-__PACKAGE__->attr(_builder => sub { Test::Builder->new });
__PACKAGE__->attr('_server');
# Hello, my name is Barney Gumble, and I'm an alcoholic.
@@ -30,50 +30,53 @@ __PACKAGE__->attr('_server');
sub find_executable_ok {
my ($self, $desc) = @_;
my $path = $self->_find_executable;
- $self->_builder->ok($path ? 1 : 0, $desc);
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::ok($path ? 1 : 0, $desc);
return $path;
}
sub generate_port_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
my $port = $self->_generate_port;
if ($port) {
- $tb->ok(1, $desc);
+ Test::More::ok(1, $desc);
return $port;
}
- $tb->ok(0, $desc);
+ Test::More::ok(0, $desc);
return;
}
sub server_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Not running
unless ($self->port) {
- $tb->diag('No port specified for testing');
- return $tb->ok(0, $desc);
+ return Test::More::ok(0, $desc);
}
# Test
my $ok = $self->_check_server(1) ? 1 : 0;
- $tb->ok($ok, $desc);
+ Test::More::ok($ok, $desc);
}
sub start_daemon_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Port
my $port = $self->port || $self->_generate_port;
- return $tb->ok(0, $desc) unless $port;
+ return Test::More::ok(0, $desc) unless $port;
# Path
my $path = $self->_find_executable;
- return $tb->ok(0, $desc) unless $path;
+ return Test::More::ok(0, $desc) unless $path;
# Prepare command
$self->command(qq/$^X "$path" daemon --port $port/);
@@ -83,15 +86,16 @@ sub start_daemon_ok {
sub start_daemon_prefork_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Port
my $port = $self->port || $self->_generate_port;
- return $tb->ok(0, $desc) unless $port;
+ return Test::More::ok(0, $desc) unless $port;
# Path
my $path = $self->_find_executable;
- return $tb->ok(0, $desc) unless $path;
+ return Test::More::ok(0, $desc) unless $path;
# Prepare command
$self->command(qq/$^X "$path" daemon_prefork --port $port/);
@@ -101,11 +105,12 @@ sub start_daemon_prefork_ok {
sub start_server_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Start server
my $pid = $self->_start_server;
- return $tb->ok(0, $desc) unless $pid;
+ return Test::More::ok(0, $desc) unless $pid;
# Wait for server
my $timeout = $self->timeout;
@@ -116,8 +121,7 @@ sub start_server_ok {
$timeout -= time - $time_before;
if ($timeout <= 0) {
$self->_stop_server;
- $tb->diag('Server timed out');
- return $tb->ok(0, $desc);
+ return Test::More::ok(0, $desc);
}
# Wait
@@ -125,33 +129,34 @@ sub start_server_ok {
}
# Done
- $tb->ok(1, $desc);
+ Test::More::ok(1, $desc);
return $self->port;
}
sub start_server_untested_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Start server
my $pid = $self->_start_server($desc);
- return $tb->ok(0, $desc) unless $pid;
+ return Test::More::ok(0, $desc) unless $pid;
# Done
- $tb->ok(1, $desc);
+ Test::More::ok(1, $desc);
return $self->port;
}
sub stop_server_ok {
my ($self, $desc) = @_;
- my $tb = $self->_builder;
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
# Running?
unless ($self->pid && kill 0, $self->pid) {
- $tb->diag('Server not running');
- return $tb->ok(0, $desc);
+ return Test::More::ok(0, $desc);
}
# Debug
@@ -169,16 +174,15 @@ sub stop_server_ok {
sleep 1;
}
else {
- $tb->ok(1, $desc);
+ Test::More::ok(1, $desc);
return;
}
}
- $tb->diag("Can't stop server");
- $tb->ok(0, $desc);
+ Test::More::ok(0, $desc);
}
sub _check_server {
- my ($self, $diag) = @_;
+ my $self = shift;
# Create socket
my $server = IO::Socket::INET->new(
@@ -192,10 +196,8 @@ sub _check_server {
close $server;
return 1;
}
- else {
- $self->_builder->diag("Server check failed: $!") if $diag;
- return;
- }
+
+ return;
}
sub _find_executable {
@@ -246,7 +248,6 @@ sub _generate_port {
sub _start_server {
my $self = shift;
- my $tb = $self->_builder;
my $command = $self->command;
warn "\nSERVER COMMAND: $command\n" if DEBUG;
@@ -256,10 +257,7 @@ sub _start_server {
$self->pid($pid);
# Process started?
- unless ($pid) {
- $tb->diag("Can't start server: $!");
- return;
- }
+ return unless $pid;
$self->_server->blocking(0);
@@ -285,7 +283,7 @@ Test::Mojo::Server - Server Tests
=head1 SYNOPSIS
- use Mojo::Test::Server;
+ use Test::Mojo::Server;
my $server = Test::Mojo::Server->new;
$server->start_daemon_ok;
@@ -293,11 +291,12 @@ Test::Mojo::Server - Server Tests
=head1 DESCRIPTION
-L<Mojo::Test::Server> is a test harness for server tests.
+L<Test::Mojo::Server> is a collection of testing helpers specifically for
+developers of L<Mojo> server bindings.
=head1 ATTRIBUTES
-L<Mojo::Test::Server> implements the following attribute.
+L<Test::Mojo::Server> implements the following attributes.
=head2 C<command>
@@ -330,12 +329,12 @@ L<Mojo::Test::Server> implements the following attribute.
=head1 METHODS
-L<Mojo::Test::Server> inherits all methods from L<Mojo::Base> and implements
+L<Test::Mojo::Server> inherits all methods from L<Mojo::Base> and implements
the following new ones.
=head2 C<new>
- my $server = Mojo::Test::Server->new;
+ my $server = Test::Mojo::Server->new;
=head2 C<find_executable_ok>
@@ -0,0 +1,400 @@
+# Copyright (C) 2008-2009, Sebastian Riedel.
+
+package Test::Mojo;
+
+use strict;
+use warnings;
+
+use base 'Mojo::Base';
+
+use Mojo::ByteStream 'b';
+use Mojo::Client;
+use Mojo::JSON;
+
+require Test::More;
+
+__PACKAGE__->attr(app => sub { Mojolicious::Lite->new });
+__PACKAGE__->attr(redirects => sub { [] });
+__PACKAGE__->attr('tx');
+__PACKAGE__->attr(max_redirects => 0);
+
+__PACKAGE__->attr(_client => sub { Mojo::Client->new });
+
+# Ooh, a graduate student huh?
+# How come you guys can go to the moon but can't make my shoes smell good?
+sub content_is {
+ my ($self, $value, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::is($self->_get_content($tx), $value, $desc);
+
+ return $self;
+}
+
+sub content_like {
+ my ($self, $regex, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::like($self->_get_content($tx), $regex, $desc);
+
+ return $self;
+}
+
+# Marge, I can't wear a pink shirt to work.
+# Everybody wears white shirts.
+# I'm not popular enough to be different.
+sub content_type_is {
+ my ($self, $type, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::is($tx->res->headers->content_type, $type, $desc);
+
+ return $self;
+}
+
+sub content_type_like {
+ my ($self, $regex, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::like($tx->res->headers->content_type, $regex, $desc);
+
+ return $self;
+}
+
+# A job's a job. I mean, take me.
+# If my plant pollutes the water and poisons the town,
+# by your logic, that would make me a criminal.
+sub delete_ok { shift->_request_ok('delete', @_) }
+sub get_ok { shift->_request_ok('get', @_) }
+sub head_ok { shift->_request_ok('head', @_) }
+
+# No matter how good you are at something,
+# there's always about a million people better than you.
+sub header_is {
+ my ($self, $name, $value, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::is($tx->res->headers->header($name), $value, $desc);
+
+ return $self;
+}
+
+sub header_like {
+ my ($self, $name, $regex, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::like($tx->res->headers->header($name), $regex, $desc);
+
+ return $self;
+}
+
+sub json_content_is {
+ my ($self, $struct, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::is_deeply(Mojo::JSON->new->decode($tx->res->body),
+ $struct, $desc);
+
+ return $self;
+}
+
+# God bless those pagans.
+sub post_ok { shift->_request_ok('post', @_) }
+
+# Hey, I asked for ketchup! I'm eatin' salad here!
+sub post_form_ok {
+ my ($self, $url, $form, $headers, $desc) = @_;
+
+ # Description
+ $desc = $headers unless ref $headers;
+
+ # Client
+ my $client = $self->_client;
+ $client->app($self->app);
+ $client->max_redirects($self->max_redirects);
+
+ # Parameters
+ my $params = Mojo::Parameters->new;
+ for my $name (sort keys %$form) {
+
+ # Array
+ if (ref $form->{$name} eq 'ARRAY') {
+ $params->append($_, $form->{$_}) for @{$form->{$name}};
+ }
+
+ # Single value
+ else { $params->append($name, $form->{$name}) }
+ }
+
+ # Transaction
+ my $tx = Mojo::Transaction::Single->new;
+ $tx->req->method('POST');
+ $tx->req->url->parse($url);
+ $tx->req->headers->content_type('application/x-www-form-urlencoded');
+ $tx->req->body($params->to_string);
+
+ # Headers
+ $headers ||= {};
+ for my $name (keys %$headers) {
+ $tx->req->headers->header($name, $headers->{$name});
+ }
+
+ # Request
+ $client->queue($tx, sub { $self->tx($_[1]) and $self->redirects($_[2]) })
+ ->process;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::ok($self->tx->is_done, $desc);
+
+ return $self;
+}
+
+# WHO IS FONZY!? !Don't they teach you anything at school
+sub put_ok { shift->_request_ok('put', @_) }
+
+sub reset_session {
+ my $self = shift;
+
+ # Client
+ $self->_client(Mojo::Client->new);
+ $self->_client->app($self->app);
+ $self->_client->max_redirects($self->max_redirects);
+
+ # Transaction
+ $self->tx(undef);
+
+ return $self;
+}
+
+# Internet! Is that thing still around?
+
+sub status_is {
+ my ($self, $status, $desc) = @_;
+
+ # Transaction
+ my $tx = $self->tx;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+ Test::More::is($tx->res->code, $status, $desc);
+
+ return $self;
+}
+
+sub _get_content {
+ my ($self, $tx) = @_;
+
+ # Charset
+ ($tx->res->headers->content_type || '') =~ /charset=\"?(\S+)\"?/;
+ my $charset = $1;
+
+ # Content
+ return $charset
+ ? b($tx->res->body)->decode($charset)->to_string
+ : $tx->res->body;
+}
+
+# Are you sure this is the Sci-Fi Convention? It's full of nerds!
+sub _request_ok {
+ my ($self, $method, $url, $headers, $desc) = @_;
+
+ # Description
+ $desc = $headers unless ref $headers;
+ $headers ||= {};
+
+ # Client
+ my $client = $self->_client;
+ $client->app($self->app);
+ $client->max_redirects($self->max_redirects);
+
+ # Request
+ $client->$method($url, $headers,
+ sub { $self->tx($_[1]) and $self->redirects($_[2]) })->process;
+
+ # Test
+ local $Test::Builder::Level = $Test::Builder::Level + 2;
+ Test::More::ok($self->tx->is_done, $desc);
+
+ return $self;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Test::Mojo - Testing Mojo!
+
+=head1 SYNOPSIS
+
+ use Test::Mojo;
+ my $t = Test::Mojo->new(app => 'MyApp');
+
+ $t->get_ok('/welcome')
+ ->status_is(200)
+ ->content_like(qr/Hello!/, 'welcome message!');
+
+ $t->post_form_ok('/search', {title => 'Perl', author => 'taro'})
+ ->status_is(200)
+ ->content_like(qr/Perl.+taro/);
+
+ $t->delete_ok('/something')
+ ->status_is(200)
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is('Hello world!');
+
+=head1 DESCRIPTION
+
+L<Test::Mojo> is a collection of testing helpers for everyone developing
+L<Mojo> and L<Mojolicious> applications.
+
+=head1 ATTRIBUTES
+
+L<Test::Mojo> implements the following attributes.
+
+=head2 C<app>
+
+ my $app = $t->app;
+ $t = $t->app(MyApp->new);
+
+=head2 C<redirects>
+
+ my $redirects = $t->redirects;
+ $t = $t->redirects([]);
+
+=head2 C<tx>
+
+ my $tx = $t->tx;
+ $t = $t->tx(Mojo::Transaction::Simple->new);
+
+=head2 C<max_redirects>
+
+ my $max_redirects = $t->max_redirects;
+ $t = $t->max_redirects(3);
+
+=head1 METHODS
+
+L<Test::Mojo> inherits all methods from L<Mojo::Base> and implements the
+following new ones.
+
+=head2 C<content_is>
+
+ $t = $t->content_is('working!');
+ $t = $t->content_is('working!', 'right content!');
+
+=head2 C<content_like>
+
+ $t = $t->content_like(qr/working!/);
+ $t = $t->content_like(qr/working!/, 'right content!');
+
+=head2 C<content_type_is>
+
+ $t = $t->content_type_is('text/html');
+ $t = $t->content_type_is('text/html', 'right content type!');
+
+=head2 C<content_type_like>
+
+ $t = $t->content_type_like(qr/text/);
+ $t = $t->content_type_like(qr/text/, 'right content type!');
+
+=head2 C<delete_ok>
+
+ $t = $t->delete_ok('/foo');
+ $t = $t->delete_ok('/foo', {Expect => '100-continue'});
+ $t = $t->delete_ok('/foo', 'request worked!');
+ $t = $t->delete_ok('/foo', {Expect => '100-continue'}, 'request worked!');
+
+=head2 C<get_ok>
+
+ $t = $t->get_ok('/foo');
+ $t = $t->get_ok('/foo', {Expect => '100-continue'});
+ $t = $t->get_ok('/foo', 'request worked!');
+ $t = $t->get_ok('/foo', {Expect => '100-continue'}, 'request worked!');
+
+=head2 C<head_ok>
+
+ $t = $t->head_ok('/foo');
+ $t = $t->head_ok('/foo', {Expect => '100-continue'});
+ $t = $t->head_ok('/foo', 'request worked!');
+ $t = $t->head_ok('/foo', {Expect => '100-continue'}, 'request worked!');
+
+=head2 C<header_is>
+
+ $t = $t->header_is(Expect => '100-continue');
+ $t = $t->header_is(Expect => '100-continue', 'right header!');
+
+=head2 C<header_like>
+
+ $t = $t->header_like(Expect => qr/100-continue/);
+ $t = $t->header_like(Expect => qr/100-continue/, 'right header!');
+
+=head2 C<json_content_is>
+
+ $t = $t->json_content_is([1, 2, 3]);
+ $t = $t->json_content_is([1, 2, 3], 'right content!');
+
+=head2 C<post_ok>
+
+ $t = $t->post_ok('/foo');
+ $t = $t->post_ok('/foo', {Expect => '100-continue'});
+ $t = $t->post_ok('/foo', 'request worked!');
+ $t = $t->post_ok('/foo', {Expect => '100-continue'}, 'request worked!');
+
+=head2 C<post_form_ok>
+
+ $t = $t->post_form_ok('/foo' => {test => 123});
+ $t = $t->post_form_ok('/foo', {test => 123}, {Expect => '100-continue'});
+ $t = $t->post_form_ok('/foo', {test => 123}, 'request worked!');
+ $t = $t->post_form_ok(
+ '/foo',
+ {test => 123},
+ {Expect => '100-continue'},
+ 'request worked!'
+ );
+
+=head2 C<put_ok>
+
+ $t = $t->put_ok('/foo');
+ $t = $t->put_ok('/foo', {Expect => '100-continue'});
+ $t = $t->put_ok('/foo', 'request worked!');
+ $t = $t->put_ok('/foo', {Expect => '100-continue'}, 'request worked!');
+
+=head2 C<reset_session>
+
+ $t = $t->reset_session;
+
+=head2 C<status_is>
+
+ $t = $t->status_is(200);
+ $t = $t->status_is(200, 'right status!');
+
+=cut
@@ -7,9 +7,10 @@ use warnings;
use Test::More;
-plan skip_all => 'set TEST_CLIENT to enable this test'
+plan skip_all =>
+ 'set TEST_CLIENT to enable this test (internet connection required!)'
unless $ENV{TEST_CLIENT};
-plan tests => 57;
+plan tests => 63;
# So then I said to the cop, "No, you're driving under the influence...
# of being a jerk".
@@ -81,6 +82,21 @@ $client->get(
);
$client->process;
+# Simple requests with redirect
+$client->max_redirects(3);
+$client->get(
+ 'http://labs.kraih.com' => sub {
+ my ($self, $tx, $h) = @_;
+ is($tx->req->method, 'GET');
+ is($tx->req->url, 'http://labs.kraih.com/blog/');
+ is($tx->res->code, 200);
+ is($h->[0]->req->method, 'GET');
+ is($h->[0]->req->url, 'http://labs.kraih.com');
+ is($h->[0]->res->code, 301);
+ }
+)->process;
+$client->max_redirects(0);
+
# Custom chunked request without callback
$tx = Mojo::Transaction::Single->new;
$tx->req->method('GET');
@@ -0,0 +1,114 @@
+#!/usr/bin/env perl
+
+# Copyright (C) 2008-2009, Sebastian Riedel.
+
+use strict;
+use warnings;
+
+use Test::More tests => 24;
+
+# Hello, my name is Mr. Burns. I believe you have a letter for me.
+# Okay Mr. Burns, what’s your first name.
+# I don’t know.
+use_ok('Mojo::CookieJar');
+use_ok('Mojo::Cookie::Response');
+use_ok('Mojo::URL');
+
+my $jar = Mojo::CookieJar->new;
+
+# Session cookie
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => 'kraih.com',
+ path => '/foo',
+ name => 'foo',
+ value => 'bar'
+ )
+);
+my @cookies = $jar->find(Mojo::URL->new('http://kraih.com/foo'));
+is($cookies[0]->name, 'foo');
+is($cookies[0]->value, 'bar');
+is($cookies[1], undef);
+
+# Huge cookie
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => 'kraih.com',
+ path => '/foo',
+ name => 'huge',
+ value => 'foo' x 4096
+ )
+);
+@cookies = $jar->find(Mojo::URL->new('http://kraih.com/foo'));
+is($cookies[0]->name, 'foo');
+is($cookies[0]->value, 'bar');
+is($cookies[1], undef);
+
+# Expired cookie
+my $expired = Mojo::Cookie::Response->new(
+ domain => 'labs.kraih.com',
+ path => '/',
+ name => 'baz',
+ value => '23'
+);
+$expired->expires(time - 1);
+$jar->add($expired);
+@cookies = $jar->find(Mojo::URL->new('http://labs.kraih.com/foo'));
+is($cookies[0]->name, 'foo');
+is($cookies[0]->value, 'bar');
+is($cookies[1], undef);
+
+# Multiple cookies
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => 'labs.kraih.com',
+ path => '/',
+ name => 'baz',
+ value => '23',
+ max_age => 60
+ )
+);
+@cookies = $jar->find(Mojo::URL->new('http://labs.kraih.com/foo'));
+is($cookies[0]->name, 'baz');
+is($cookies[0]->value, '23');
+is($cookies[1]->name, 'foo');
+is($cookies[1]->value, 'bar');
+is($cookies[2], undef);
+
+# Multiple cookies with leading dot
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => '.kraih.com',
+ path => '/',
+ name => 'this',
+ value => 'that'
+ )
+);
+@cookies = $jar->find(Mojo::URL->new('http://labs.kraih.com/fo'));
+is($cookies[0]->name, 'baz');
+is($cookies[0]->value, '23');
+is($cookies[1]->name, 'this');
+is($cookies[1]->value, 'that');
+is($cookies[2], undef);
+
+# Replace cookie
+$jar = Mojo::CookieJar->new;
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => 'kraih.com',
+ path => '/foo',
+ name => 'foo',
+ value => 'bar1'
+ )
+);
+$jar->add(
+ Mojo::Cookie::Response->new(
+ domain => 'kraih.com',
+ path => '/foo',
+ name => 'foo',
+ value => 'bar2'
+ )
+);
+@cookies = $jar->find(Mojo::URL->new('http://kraih.com/foo'));
+is($cookies[0]->value, 'bar2');
+is($cookies[1], undef);
@@ -5,7 +5,7 @@
use strict;
use warnings;
-use Test::More tests => 72;
+use Test::More tests => 92;
use Mojo::ByteStream 'b';
@@ -21,26 +21,39 @@ $array = $json->decode('[ [ ]]');
is_deeply($array, [[]]);
# Decode number
+$array = $json->decode('[0]');
+is_deeply($array, [0], 'decode [0]');
$array = $json->decode('[1]');
is_deeply($array, [1]);
$array = $json->decode('[ -122.026020 ]');
is_deeply($array, ['-122.026020']);
+$array = $json->decode('[0.0]');
+isa_ok($array, 'ARRAY');
+cmp_ok($array->[0], '==', 0);
+$array = $json->decode('[0e0]');
+isa_ok($array, 'ARRAY');
+cmp_ok($array->[0], '==', 0);
$array = $json->decode('[1,-2]');
is_deeply($array, [1, -2]);
$array = $json->decode('[10e12 , [2 ]]');
is_deeply($array, ['10e12', [2]]);
$array = $json->decode('[37.7668 , [ 20 ]] ');
is_deeply($array, [37.7668, [20]]);
+$array = $json->decode('[1e3]');
+isa_ok($array, 'ARRAY');
+cmp_ok($array->[0], '==', 1e3);
# Decode name
$array = $json->decode('[true]');
-is_deeply($array, ['\1']);
+is_deeply($array, [$json->true]);
$array = $json->decode('[null]');
-is_deeply($array, ['0 but true']);
+is_deeply($array, [undef]);
$array = $json->decode('[true, false]');
-is_deeply($array, ['\1', undef]);
+is_deeply($array, [$json->true, $json->false]);
# Decode string
+$array = $json->decode('[" "]');
+is_deeply($array, [' ']);
$array = $json->decode('["hello world!"]');
is_deeply($array, ['hello world!']);
$array = $json->decode('["hello\nworld!"]');
@@ -49,6 +62,12 @@ $array = $json->decode('["hello\t\"world!"]');
is_deeply($array, ["hello\t\"world!"]);
$array = $json->decode('["hello\u0152world\u0152!"]');
is_deeply($array, ["hello\x{0152}world\x{0152}!"]);
+$array = $json->decode('["0."]');
+is_deeply($array, ['0.']);
+$array = $json->decode('[" 0"]');
+is_deeply($array, [' 0']);
+$array = $json->decode('["1"]');
+is_deeply($array, ['1']);
# Decode object
my $hash = $json->decode('{}');
@@ -106,6 +125,8 @@ $string = $json->encode(["hello\t\"world!"]);
is($string, '["hello\t\"world!"]');
$string = $json->encode(["hello\x{0003}\x{0152}world\x{0152}!"]);
is(b($string)->decode('UTF-8'), "[\"hello\\u0003\x{0152}world\x{0152}!\"]");
+$string = $json->encode(["123abc"]);
+is($string, '["123abc"]');
# Encode object
$string = $json->encode({});
@@ -120,11 +141,11 @@ $string = $json->encode({foo => ['bar']});
is($string, '{"foo":["bar"]}');
# Encode name
-$string = $json->encode(['\1']);
+$string = $json->encode([$json->true]);
is($string, '[true]');
-$string = $json->encode(['0 but true']);
+$string = $json->encode([undef]);
is($string, '[null]');
-$string = $json->encode(['\1', undef]);
+$string = $json->encode([$json->true, $json->false]);
is($string, '[true,false]');
# Encode number
@@ -147,7 +168,7 @@ is_deeply($array, ["\x{10346}"]);
# Decode UTF-16LE
$array = $json->decode(b("\x{feff}[true]")->encode('UTF-16LE'));
-is_deeply($array, ['\1']);
+is_deeply($array, [$json->true]);
# Decode UTF-16LE with faihu surrogate pair
$array = $json->decode(b("\x{feff}[\"\\ud800\\udf46\"]")->encode('UTF-16LE'));
@@ -159,11 +180,37 @@ is_deeply($array, ["\x{10346}"]);
# Decode UTF-32LE
$array = $json->decode(b("\x{feff}[true]")->encode('UTF-32LE'));
-is_deeply($array, ['\1']);
+is_deeply($array, [$json->true]);
# Decode UTF-32BE
$array = $json->decode(b("\x{feff}[true]")->encode('UTF-32BE'));
-is_deeply($array, ['\1']);
+is_deeply($array, [$json->true]);
+
+# Decode UTF-16LE without BOM
+$array = $json->decode(b("[\"\\ud800\\udf46\"]")->encode('UTF-16LE'));
+is_deeply($array, ["\x{10346}"]);
+
+# Decode UTF-16BE without BOM
+$array = $json->decode(b("[\"\\ud800\\udf46\"]")->encode('UTF-16BE'));
+is_deeply($array, ["\x{10346}"]);
+
+# Decode UTF-32LE without BOM
+$array = $json->decode(b("[\"\\ud800\\udf46\"]")->encode('UTF-32LE'));
+is_deeply($array, ["\x{10346}"]);
+
+# Decode UTF-32BE without BOM
+$array = $json->decode(b("[\"\\ud800\\udf46\"]")->encode('UTF-32BE'));
+is_deeply($array, ["\x{10346}"]);
+
+# Complicated roudtrips
+$string = '[null,false,true,"",0,1]';
+$array = $json->decode($string);
+isa_ok($array, 'ARRAY');
+is($json->encode($array), $string);
+$array = [undef, 0, 1, '', $json->true, $json->false];
+$string = $json->encode($array);
+ok($string);
+is_deeply($json->decode($string), $array);
# Errors
is($json->decode('[[]'), undef);
@@ -5,11 +5,7 @@
use strict;
use warnings;
-use Test::More;
-
-plan skip_all => 'set TEST_PIPELINE to enable this test'
- unless $ENV{TEST_PIPELINE};
-plan tests => 54;
+use Test::More tests => 54;
# Are we there yet?
# No
@@ -25,7 +25,7 @@ package main;
use strict;
use warnings;
-use Test::More tests => 70;
+use Test::More tests => 84;
use File::Spec;
use File::Temp;
@@ -35,9 +35,103 @@ use FindBin;
# like God must feel when he's holding a gun.
use_ok('Mojo::Template');
-# Strict
+# Trim line
my $mt = Mojo::Template->new;
-my $output = $mt->render(<<'EOF');
+my $output = $mt->render(" <%= 'test' =%> \n");
+is($output, 'test');
+
+# Trim line (with expression)
+$mt = Mojo::Template->new;
+$output = $mt->render("<%= '123' %><%= 'test' =%>\n");
+is($output, '123test');
+
+# Trim lines
+$mt = Mojo::Template->new;
+$output = $mt->render(" foo \n <%= 'test' =%>\n foo\n");
+is($output, " footestfoo\n");
+
+# Trim lines (at start of line)
+$mt = Mojo::Template->new;
+$output = $mt->render(" \n<%= 'test' =%>\n ");
+is($output, 'test');
+
+# Trim lines (multiple lines)
+$mt = Mojo::Template->new;
+$output = $mt->render(" bar\n foo\n <%= 'test' =%>\n foo\n bar\n");
+is($output, " bar\n footestfoo\n bar\n");
+
+# Trim lines (multiple empty lines)
+$mt = Mojo::Template->new;
+$output = $mt->render(" \n<%= 'test' =%>\n ");
+is($output, 'test');
+
+# Trim expression tags
+$mt = Mojo::Template->new;
+$output = $mt->render(' <%{= =%><html><%} =%> ');
+is($output, '<html>');
+
+# Expression block
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+%{=
+<html>
+%}
+EOF
+is($output, "<html>\n");
+
+# Escaped expression block
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+%{==
+<html>
+%}
+EOF
+is($output, "<html>\n");
+
+# Captured escaped expression block
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+%{== my $result =
+<html>
+%}
+%= $result
+EOF
+is($output, "<html>\n<html>\n");
+
+# Capture lines
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+%{ my $result = escape
+<html>
+%}
+%= $result
+EOF
+is($output, "<html>\n");
+
+# Capture tags
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+<%{ my $result = escape %><html><%}%><%= $result %>
+EOF
+is($output, "<html>\n");
+
+# Capture tags with appended code
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+<%{ my $result = escape( %><html><%} ); %><%= $result %>
+EOF
+is($output, "<html>\n");
+
+# Nested capture tags
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
+<%{ my $result = %><%{= escape %><html><%}%><%}%><%= $result %>
+EOF
+is($output, "<html>\n");
+
+# Strict
+$mt = Mojo::Template->new;
+$output = $mt->render(<<'EOF');
% $foo = 1;
EOF
is(ref $output, 'Mojo::Template::Exception');
@@ -190,7 +284,6 @@ $mt->parse(<<'EOF');
%# This is a comment!
% my $i = 2;
%= $i * 2
-%
</html>
EOF
$mt->build;
@@ -201,7 +294,7 @@ ok(!defined($mt->compiled));
$mt->compile;
is(ref($mt->compiled), 'CODE');
$output = $mt->interpret(2);
-is($output, "<html foo=\"bar\">\n3 test 4 lala \n4\%\n</html>\n");
+is($output, "<html foo=\"bar\">\n3 test 4 lala \n4\</html>\n");
# Arguments
$mt = Mojo::Template->new;
@@ -5,7 +5,7 @@
use strict;
use warnings;
-use Test::More tests => 106;
+use Test::More tests => 130;
use FindBin;
use lib "$FindBin::Bin/lib";
@@ -13,153 +13,86 @@ use lib "$FindBin::Bin/lib";
use File::stat;
use File::Spec;
use Mojo::Date;
-use Mojo::Client;
use Mojo::Transaction::Single;
+use Test::Mojo;
# Congratulations Fry, you've snagged the perfect girlfriend.
# Amy's rich, she's probably got other characteristics...
use_ok('MojoliciousTest');
-my $client = Mojo::Client->new(app => 'MojoliciousTest');
+my $t = Test::Mojo->new(app => 'MojoliciousTest');
# SyntaxError::foo (syntax error in controller)
-$client->get(
- '/syntax_error/foo' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 500);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Missing right curly/);
- }
-)->process;
+$t->get_ok('/syntax_error/foo')->status_is(500)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Missing right curly/);
# Foo::syntaxerror (syntax error in template)
-$client->get(
- '/foo/syntaxerror' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 500);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/^Missing right curly/);
- }
-)->process;
+$t->get_ok('/foo/syntaxerror')->status_is(500)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/^Missing right curly/);
# Foo::badtemplate (template missing)
-$client->get(
- '/foo/badtemplate' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '');
- }
-)->process;
+$t->get_ok('/foo/badtemplate')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/File Not Found/);
# Foo::test
-$client->get(
- '/foo/test' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->header('X-Bender'), 'Kiss my shiny metal ass!');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/\/bar\/test/);
- }
-)->process;
+$t->get_ok('/foo/test', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is('X-Bender' => 'Kiss my shiny metal ass!')
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/\/bar\/test/);
# Foo::index
-$client->get(
- '/foo' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->content_type, 'text/html');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body,
- qr/<body>\n23Hello Mojo from the template \/foo! He/);
- }
-)->process;
+$t->get_ok('/foo', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/<body>\n23Hello Mojo from the template \/foo! He/);
# Foo::Bar::index
-$client->get(
- '/foo-bar' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->content_type, 'text/html');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body,
- qr/Hello Mojo from the other template \/foo-bar!/);
- }
-)->process;
+$t->get_ok('/foo-bar', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Hello Mojo from the other template \/foo-bar!/);
# Foo::something
-$client->get(
- '/test4' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '/test4/42');
- }
-)->process;
+$t->get_ok('/test4', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/test4/42');
# Foo::templateless
-$client->get(
- '/foo/templateless' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Hello Mojo from a templateless renderer!/);
- }
-)->process;
+$t->get_ok('/foo/templateless', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Hello Mojo from a templateless renderer!/);
# Foo::withlayout
-$client->get(
- '/foo/withlayout' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Same old in green Seems to work!/);
- }
-)->process;
+$t->get_ok('/foo/withlayout', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Same old in green Seems to work!/);
# MojoliciousTest2::Foo::test
-$client->get(
- '/test2' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->header('X-Bender'), 'Kiss my shiny metal ass!');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/\/test2/);
- }
-)->process;
+$t->get_ok('/test2', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is('X-Bender' => 'Kiss my shiny metal ass!')
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/\/test2/);
# MojoliciousTestController::index
-$client->get(
- '/test3' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->header('X-Bender'), 'Kiss my shiny metal ass!');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/No class works!/);
- }
-)->process;
+$t->get_ok('/test3', {'X-Test' => 'Hi there!'})->status_is(200)
+ ->header_is('X-Bender' => 'Kiss my shiny metal ass!')
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/No class works!/);
# 404
-$client->get(
- '/' => ('X-Test' => 'Hi there!') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/File Not Found/);
- }
-)->process;
+$t->get_ok('/', {'X-Test' => 'Hi there!'})->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/File Not Found/);
# Check Last-Modified header for static files
my $path = File::Spec->catdir($FindBin::Bin, 'public_dev', 'hello.txt');
@@ -167,41 +100,23 @@ my $stat = stat($path);
my $mtime = Mojo::Date->new(stat($path)->mtime)->to_string;
# Static file /hello.txt
-$client->get(
- '/hello.txt' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->content_type, 'text/plain');
- is($tx->res->headers->header('Last-Modified'),
- $mtime, 'Last-Modified header is set correctly');
- is($tx->res->headers->content_length,
- $stat->size, 'Content-Length is set correctly');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->content->asset->slurp,
- qr/Hello Mojo from a development static file!/);
- }
-)->process;
+$t->get_ok('/hello.txt')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is('Last-Modified' => $mtime)
+ ->header_is('Content-Length' => $stat->size)->content_type_is('text/plain')
+ ->content_like(qr/Hello Mojo from a development static file!/);
# Try to access a file which is not under the web root via path
# traversal
-$client->get(
- '../../mojolicious/secret.txt' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- unlike($tx->res->content->asset->slurp, qr/Secret file/);
- }
-)->process;
+$t->get_ok('../../mojolicious/secret.txt')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/File Not Found/);
# Check If-Modified-Since
-$client->get(
- '/hello.txt' => ('If-Modified-Since' => $mtime) => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 304, 'Setting If-Modified-Since triggers 304');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- }
-)->process;
+$t->get_ok('/hello.txt', {'If-Modified-Since' => $mtime})->status_is(304)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('');
# Make sure we can override attributes with constructor arguments
my $app = MojoliciousTest->new({mode => 'test'});
@@ -228,95 +143,48 @@ $app->handler($tx);
is($tx->res->code, 200);
like($tx->res->body, qr/Hello Mojo from the template \/foo! Hello World!/);
-$client = Mojo::Client->new(app => 'SingleFileTestApp');
+$t = Test::Mojo->new(app => 'SingleFileTestApp');
# SingleFileTestApp::Foo::index
-$client->get(
- '/foo' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Same old in green Seems to work!/);
- }
-)->process;
+$t->get_ok('/foo')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Same old in green Seems to work!/);
# SingleFileTestApp::Foo::data_template
-$client->get(
- '/foo/data_template' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "23 works!\n");
- }
-)->process;
+$t->get_ok('/foo/data_template')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is("23 works!\n");
# SingleFileTestApp::Foo::data_template
-$client->get(
- '/foo/data_template2' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "This one works too!\n");
- }
-)->process;
+$t->get_ok('/foo/data_template2')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("This one works too!\n");
# SingleFileTestApp::Foo::bar
-$client->get(
- '/foo/bar' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->header('X-Bender'), 'Kiss my shiny metal ass!');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '/foo/bar');
- }
-)->process;
+$t->get_ok('/foo/bar')->status_is(200)
+ ->header_is('X-Bender' => 'Kiss my shiny metal ass!')
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/foo/bar');
# SingleFileTestApp::Baz::does_not_exist
-$client->get(
- '/baz/does_not_exist' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/File Not Found/);
- }
-)->process;
-
-$client = Mojo::Client->new(app => 'MojoliciousTest');
+$t->get_ok('/baz/does_not_exist')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/File Not Found/);
+
+$t = Test::Mojo->new(app => 'MojoliciousTest');
# MojoliciousTestController::Foo::stage2
-$client->get(
- '/staged' => ('X-Pass' => 1) => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Welcome aboard!');
- }
-)->process;
+$t->get_ok('/staged', {'X-Pass' => '1'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Welcome aboard!');
# MojoliciousTestController::Foo::stage1
-$client->get(
- '/staged' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Go away!');
- }
-)->process;
+$t->get_ok('/staged')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Go away!');
# MojoliciousTest::Foo::config
-$client->get(
- '/stash_config' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '123');
- }
-)->process;
+$t->get_ok('/stash_config')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('123');
@@ -7,7 +7,7 @@ use warnings;
use utf8;
-use Test::More tests => 164;
+use Test::More tests => 245;
# Wait you're the only friend I have...
# You really want a robot for a friend?
@@ -16,9 +16,11 @@ use Test::More tests => 164;
# so if anyone asks you're my debugger.
use Mojo::ByteStream 'b';
use Mojo::Client;
+use Mojo::Cookie::Response;
use Mojo::JSON;
use Mojo::Transaction::Single;
use Mojolicious::Lite;
+use Test::Mojo;
# Silence
app->log->level('error');
@@ -32,6 +34,27 @@ get '/' => 'root';
# GET /root
get '/root.html' => 'root_path';
+# GET /template.txt
+get '/template.txt' => 'template';
+
+# GET /template_inheritance
+get '/template_inheritance' => sub {
+ shift->render(template => 'template_inheritance', handler => 'ep');
+};
+
+# GET /layout_without_inheritance
+get '/layout_without_inheritance' => sub {
+ shift->render(
+ template => 'layouts/template_inheritance',
+ handler => 'ep'
+ );
+};
+
+# GET /double_inheritance
+get '/double_inheritance' => sub {
+ shift->render(template => 'double_inheritance', handler => 'ep');
+};
+
# GET /outerlayout
get '/outerlayout' => sub {
my $self = shift;
@@ -42,6 +65,27 @@ get '/outerlayout' => sub {
);
};
+# GET /session_cookie
+get '/session_cookie' => sub {
+ my $self = shift;
+ $self->render_text('Cookie set!');
+ $self->res->cookies(
+ Mojo::Cookie::Response->new(
+ path => '/session_cookie',
+ name => 'session',
+ value => '23'
+ )
+ );
+};
+
+# GET /session_cookie/2
+get '/session_cookie/2' => sub {
+ my $self = shift;
+ my $session = $self->req->cookie('session');
+ my $value = $session ? $session->value : 'missing';
+ $self->render_text("Session is $value!");
+};
+
# GET /foo
get '/foo' => sub {
my $self = shift;
@@ -187,240 +231,147 @@ get '/param_auth/too' =>
my $app = Mojolicious::Lite->new;
my $client = Mojo::Client->new(app => $app);
$app->client($client);
+my $t = Test::Mojo->new;
# GET /
-$client->get(
- '/' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "/root.html");
- }
-)->process;
+$t->get_ok('/')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/root.html');
# GET /root
-$client->get(
- '/root.html' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "/.html");
- }
-)->process;
+$t->get_ok('/root.html')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/.html');
# GET /.html
-$client->get(
- '/.html' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "/root.html");
- }
-)->process;
+$t->get_ok('/.html')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/root.html');
+
+# GET /template_inheritance
+$t->get_ok('/template_inheritance')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is(
+ "<title>Welcome</title>\nSidebar!\nHello World!\nDefault footer!\n");
+
+# GET /layout_without_inheritance
+$t->get_ok('/layout_without_inheritance')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("Default header!\nDefault sidebar!\nDefault footer!\n");
+
+# GET /double_inheritance
+$t->get_ok('/double_inheritance')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("<title>Welcome</title>\nSidebar too!\nDefault footer!\n");
# GET /outerlayout
-$client->get(
- '/outerlayout' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "layouted Hello\n[\n 1,\n 2\n]\nthere!\n\n\n");
- }
-)->process;
+$t->get_ok('/outerlayout')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("layouted Hello\n[\n 1,\n 2\n]\nthere<br/>!\n\n\n");
+
+# GET /session_cookie
+$t->get_ok('http://kraih.com/session_cookie')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Cookie set!');
+
+# GET /session_cookie/2
+$t->get_ok('http://kraih.com/session_cookie/2')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Session is 23!');
+
+# GET /session_cookie/2 (retry)
+$t->get_ok('http://kraih.com/session_cookie/2')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Session is 23!');
+
+# GET /session_cookie/2 (session reset)
+$t->reset_session;
+ok(!$t->tx);
+$t->get_ok('http://kraih.com/session_cookie/2')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is('Session is missing!');
# GET /foo
-$client->get(
- '/foo' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Yea baby!');
- }
-)->process;
+$t->get_ok('/foo')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Yea baby!');
# POST /template
-$client->post(
- '/template' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Just works!');
- }
-)->process;
+$t->post_ok('/template')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Just works!');
# GET /something
-$client->get(
- '/something' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Just works!');
- }
-)->process;
+$t->get_ok('/something')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Just works!');
# POST /something
-$client->post(
- '/something' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Just works!');
- }
-)->process;
+$t->post_ok('/something')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Just works!');
# DELETE /something
-$client->delete(
- '/something' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Just works!');
- }
-)->process;
+$t->delete_ok('/something')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Just works!');
# GET /something/else
-$client->get(
- '/something/else' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Yay!');
- }
-)->process;
+$t->get_ok('/something/else')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Yay!');
# POST /something/else
-$client->post(
- '/something/else' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Yay!');
- }
-)->process;
+$t->post_ok('/something/else')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Yay!');
# DELETE /something/else
-$client->delete(
- '/something/else' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Oops!/);
- }
-)->process;
+$t->delete_ok('/something/else')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Oops!/);
# GET /regex/23
-$client->get(
- '/regex/23' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '23');
- }
-)->process;
+$t->get_ok('/regex/23')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('23');
# GET /regex/foo
-$client->get(
- '/regex/foo' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Oops!/);
- }
-)->process;
+$t->get_ok('/regex/foo')->status_is(404)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Oops!/);
# POST /bar
-$client->post(
- '/bar' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'default');
- }
-)->process;
+$t->post_ok('/bar')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('default');
# POST /bar/baz
-$client->post(
- '/bar/baz' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'baz');
- }
-)->process;
+$t->post_ok('/bar/baz')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('baz');
# GET /layout
-$client->get(
- '/layout' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "Yea baby! with layout\n");
- }
-)->process;
+$t->get_ok('/layout')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("Yea baby! with layout\n");
# GET /firefox
-$client->get(
- '/firefox/bar' => ('User-Agent' => 'Firefox') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '/firefox/foo');
- }
-)->process;
+$t->get_ok('/firefox/bar', {'User-Agent' => 'Firefox'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('/firefox/foo');
# GET /firefox
-$client->get(
- '/firefox/bar' => ('User-Agent' => 'Explorer') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Oops!/);
- }
-)->process;
+$t->get_ok('/firefox/bar', {'User-Agent' => 'Explorer'})->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Oops!/);
# POST /utf8
-my $tx = Mojo::Transaction::Single->new;
-$tx->req->method('POST');
-$tx->req->url->parse('/utf8');
-$tx->req->headers->content_type('application/x-www-form-urlencoded');
-$tx->req->body('name=%D0%92%D1%8F%D1%87%D0%B5%D1%81%D0%BB%D0%B0%D0%B2');
-$client->queue(
- $tx => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->content_type, 'text/html');
- is($tx->res->headers->content_length, 40);
- is($tx->res->body, b(<<EOF)->encode('UTF-8')->to_string);
-Вячеслав Тихановский
-EOF
- }
-)->process;
+$t->post_form_ok('/utf8',
+ {name => b('Вячеслав')->encode('UTF-8')->to_string})
+ ->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is('Content-Length' => 40)->content_type_is('text/html')
+ ->content_is(b("Вячеслав Тихановский\n")->encode('UTF-8')
+ ->to_string);
# POST /malformed_utf8
my $level = $app->log->level;
$app->log->level('fatal');
-$tx = Mojo::Transaction::Single->new;
+my $tx = Mojo::Transaction::Single->new;
$tx->req->method('POST');
$tx->req->url->parse('/malformed_utf8');
$tx->req->headers->content_type('application/x-www-form-urlencoded');
@@ -437,211 +388,148 @@ $client->queue(
$app->log->level($level);
# GET /json
-$client->get(
- '/json' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->content_type, 'application/json');
- my $hash = Mojo::JSON->new->decode($tx->res->body);
- is($hash->{foo}->[0], 1);
- is($hash->{foo}->[1], -2);
- is($hash->{foo}->[2], 3);
- is($hash->{foo}->[3], 'bar');
- }
-)->process;
+$t->get_ok('/json')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_type_is('application/json')
+ ->json_content_is({foo => [1, -2, 3, 'bar']});
# GET /autostash
-$client->get(
- '/autostash?bar=23' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "layouted bar23\n");
- }
-)->process;
+$t->get_ok('/autostash?bar=23')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is("layouted bar23\n");
# GET /helper
-$client->get(
- '/helper' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body,
- '<br/><.../template(Mozilla/5.0 (compatible; Mojo; Perl))');
- }
-)->process;
+$t->get_ok('/helper')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is('<br/><.../template(Mozilla/5.0 (compatible; Mojo; Perl))');
# GET /helper
-$client->get(
- '/helper' => ('User-Agent' => 'Explorer') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, '<br/><.../template(Explorer)');
- }
-)->process;
+$t->get_ok('/helper', {'User-Agent' => 'Explorer'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is('<br/><.../template(Explorer)');
# GET /eperror
$level = $app->log->level;
$app->log->level('fatal');
-$client->get(
- '/eperror' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 500);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Internal Server Error/);
- }
-)->process;
+$t->get_ok('/eperror')->status_is(500)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Internal Server Error/);
$app->log->level($level);
# GET /subrequest
-$client->get(
- '/subrequest' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'Just works!');
- }
-)->process;
+$t->get_ok('/subrequest')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is('Just works!');
# GET /redirect_url
-$client->get(
- '/redirect_url' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 302);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->location, 'http://127.0.0.1/foo');
- is($tx->res->body, 'Redirecting!');
- }
-)->process;
+$t->get_ok('/redirect_url')->status_is(302)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is(Location => 'http://127.0.0.1/foo')->content_is('Redirecting!');
# GET /redirect_path
-$client->get(
- '/redirect_path' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 302);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->location, '/foo/bar');
- is($tx->res->body, 'Redirecting!');
- }
-)->process;
+$t->get_ok('/redirect_path')->status_is(302)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is(Location => '/foo/bar')->content_is('Redirecting!');
# GET /redirect_named
-$client->get(
- '/redirect_named' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 302);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->location, '/template.txt');
- is($tx->res->body, 'Redirecting!');
- }
-)->process;
+$t->get_ok('/redirect_named')->status_is(302)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is(Location => '/template.txt')->content_is('Redirecting!');
+
+# GET /redirect_named (with redirecting enabled in client)
+$t->max_redirects(3);
+$t->get_ok('/redirect_named')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->header_is(Location => undef)
+ ->content_is("Redirect works!\n");
+$t->max_redirects(0);
+Test::Mojo->new(tx => $t->redirects->[0])->status_is(302)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->header_is(Location => '/template.txt')->content_is('Redirecting!');
# GET /koi8-r
-$client->get(
- '/koi8-r' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->content_type, 'text/html; charset=koi8-r');
- is(b($tx->res->body)->decode('koi8-r'),
- "Этот человек наполняет меня надеждой."
- . " Ну, и некоторыми другими глубокими и приводящими в"
- . " замешательство эмоциями.\n");
- }
-)->process;
+$t->get_ok('/koi8-r')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_type_is('text/html; charset=koi8-r')
+ ->content_is(
+ "Этот человек наполняет меня надеждой."
+ . " Ну, и некоторыми другими глубокими и приводящими в"
+ . " замешательство эмоциями.\n");
# GET /with_ladder
-$client->get(
- '/with_ladder' => ('X-Bender' => 'Rodriguez') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->header('X-Ladder'), '23');
- is($tx->res->body, 'Ladders are cool!');
- }
-)->process;
+$t->get_ok('/with_ladder', {'X-Bender' => 'Rodriguez'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->header_is('X-Ladder' => 23)
+ ->content_is('Ladders are cool!');
# GET /with_ladder_too
-$client->get(
- '/with_ladder_too' => ('X-Bender' => 'Rodriguez') => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->headers->header('X-Ladder'), '23');
- is($tx->res->body, 'Ladders are cool too!');
- }
-)->process;
+$t->get_ok('/with_ladder_too', {'X-Bender' => 'Rodriguez'})->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->header_is('X-Ladder' => 23)
+ ->content_is('Ladders are cool too!');
# GET /with_ladder_too
-$client->get(
- '/with_ladder_too' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Oops!/);
- }
-)->process;
+$t->get_ok('/with_ladder_too')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Oops!/);
# GET /param_auth
-$client->get(
- '/param_auth' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "Not Bender!\n");
- }
-)->process;
+$t->get_ok('/param_auth')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is("Not Bender!\n");
# GET /param_auth?name=Bender
-$client->get(
- '/param_auth?name=Bender' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "Bender!\n");
- }
-)->process;
+$t->get_ok('/param_auth?name=Bender')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is("Bender!\n");
# GET /param_auth/too
-$client->get(
- '/param_auth/too' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, "Not Bender!\n");
- }
-)->process;
+$t->get_ok('/param_auth/too')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_is("Not Bender!\n");
# GET /param_auth/too?name=Bender
-$client->get(
- '/param_auth/too?name=Bender' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- is($tx->res->body, 'You could be Bender too!');
- }
-)->process;
+$t->get_ok('/param_auth/too?name=Bender')->status_is(200)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_is('You could be Bender too!');
__DATA__
+@@ template.txt.epl
+Redirect works!
+
+@@ template_inheritance.html.ep
+% layout 'template_inheritance';
+%{ content header =>
+<title>Welcome</title>
+%}
+%{ content sidebar =>
+Sidebar!
+%}
+Hello World!
+
+@@ layouts/template_inheritance.html.ep
+%{= content header =>
+Default header!
+%}
+%{= content sidebar =>
+Default sidebar!
+%}
+%= content
+%{= content footer =>
+Default footer!
+%}
+
+@@ double_inheritance.html.ep
+% extends 'template_inheritance';
+%{ content sidebar =>
+Sidebar too!
+%}
+
@@ param_auth.html.epl
Bender!
@@ -656,10 +544,10 @@ Not Bender!
@@ outerlayout.html.ep
Hello
-<%== include 'outermenu' %>
+<%= include 'outermenu' %>
@@ outermenu.html.ep
-<%= dumper [1, 2] %>there!
+<%= dumper [1, 2] %>there<br/>!
@@ not_found.html.epl
Oops!
@@ -5,76 +5,46 @@
use strict;
use warnings;
-use Test::More tests => 20;
+use Test::More tests => 26;
use FindBin;
use lib "$FindBin::Bin/lib";
-use Mojo::Client;
+use Test::Mojo;
# This concludes the part of the tour where you stay alive.
use_ok('MojoliciousTest');
-my $client = Mojo::Client->new(app => 'MojoliciousTest');
+my $t = Test::Mojo->new(app => 'MojoliciousTest');
my $backup = $ENV{MOJO_MODE} || '';
$ENV{MOJO_MODE} = 'production';
# Foo::bar in production mode (non existing action)
-$client->get(
- '/foo/bar' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Not Found/);
- }
-)->process;
+$t->get_ok('/foo/bar')->status_is(404)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Not Found/);
# SyntaxError::foo in production mode (syntax error in controller)
-$client->get(
- '/syntax_error/foo' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 500);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Internal Server Error/);
- }
-)->process;
+$t->get_ok('/syntax_error/foo')->status_is(500)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Internal Server Error/);
# Foo::syntaxerror in production mode (syntax error in template)
-$client->get(
- '/foo/syntaxerror' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 500);
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like($tx->res->body, qr/Internal Server Error/);
- }
-)->process;
+$t->get_ok('/foo/syntaxerror')->status_is(500)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Internal Server Error/);
# Static file /hello.txt in production mode
-$client->get(
- '/hello.txt' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 200);
- is($tx->res->headers->content_type, 'text/plain');
- is($tx->res->headers->server, 'Mojo (Perl)');
- is($tx->res->headers->header('X-Powered-By'), 'Mojo (Perl)');
- like(
- $tx->res->content->asset->slurp,
- qr/Hello Mojo from a static file!/
- );
- }
-)->process;
+$t->get_ok('/hello.txt')->status_is(200)->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')
+ ->content_like(qr/Hello Mojo from a static file!/);
# Try to access a file which is not under the web root via path
# traversal in production mode
-$client->get(
- '../../mojolicious/secret.txt' => sub {
- my ($self, $tx) = @_;
- is($tx->res->code, 404);
- unlike($tx->res->content->asset->slurp, qr/Secret file/);
- }
-)->process;
+$t->get_ok('../../mojolicious/secret.txt')->status_is(404)
+ ->header_is(Server => 'Mojo (Perl)')
+ ->header_is('X-Powered-By' => 'Mojo (Perl)')->content_like(qr/Not Found/);
+
$ENV{MOJO_MODE} = $backup;
@@ -5,7 +5,7 @@
use strict;
use warnings;
-use Test::More tests => 124;
+use Test::More tests => 130;
use Mojo::Transaction::Single;
@@ -15,6 +15,12 @@ use_ok('MojoX::Routes');
# Routes
my $r = MojoX::Routes->new;
+# /clean
+$r->route('/clean')->to(clean => 1);
+
+# /clean/too
+$r->route('/clean/too')->to(something => 1);
+
# /*/test
my $test = $r->route('/:controller/test')->to(action => 'test');
@@ -114,11 +120,27 @@ $r->route('/method/post')->via('post')
$r->route('/method/post_get')->via(qw/POST get/)
->to(controller => 'method', action => 'post_get');
-# Real world example using most features at once
+# Make sure stash stays clean
my $tx = Mojo::Transaction::Single->new;
$tx->req->method('GET');
-$tx->req->url->parse('/articles.html');
+$tx->req->url->parse('/clean');
my $match = $r->match($tx);
+is($match->stack->[0]->{clean}, 1);
+is($match->stack->[0]->{something}, undef);
+is($match->url_for, '/clean');
+$tx = Mojo::Transaction::Single->new;
+$tx->req->method('GET');
+$tx->req->url->parse('/clean/too');
+$match = $r->match($tx);
+is($match->stack->[0]->{clean}, undef);
+is($match->stack->[0]->{something}, 1);
+is($match->url_for, '/clean/too');
+
+# Real world example using most features at once
+$tx = Mojo::Transaction::Single->new;
+$tx->req->method('GET');
+$tx->req->url->parse('/articles.html');
+$match = $r->match($tx);
is($match->stack->[0]->{controller}, 'articles');
is($match->stack->[0]->{action}, 'index');
is($match->stack->[0]->{format}, 'html');