diff --git a/Changes b/Changes
index f1343cd..afc1509 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+v3.89 2013-03-14 00:00:00
+ - Rebased on Mojolicious v3.89
v3.84 2013-02-04 00:00:00
- Rebased on Mojolicious v3.84
v3.70 2012-12-24 00:00:00
diff --git a/MANIFEST.SKIP b/MANIFEST.SKIP
index aebfd65..0ca2d44 100644
--- a/MANIFEST.SKIP
+++ b/MANIFEST.SKIP
@@ -1,5 +1,7 @@
^\.(?!perltidyrc)
.*\.old$
+\.tar\.gz$
^Makefile$
+^MYMETA\.
^blib
^pm_to_blib
diff --git a/examples/connect-proxy.pl b/examples/connect-proxy.pl
index 3aac297..cd3ed8f 100644
--- a/examples/connect-proxy.pl
+++ b/examples/connect-proxy.pl
@@ -4,7 +4,7 @@
use Mojo::IOLoop;
-# Minimal connect proxy server to test TLS tunneling
+# Minimal CONNECT proxy server to test TLS tunneling
my %buffer;
Mojo::IOLoop->server(
{port => 3000} => sub {
@@ -79,7 +79,7 @@
) or die "Couldn't create listen socket!\n";
print <<'EOF';
-Starting connect proxy on port 3000.
+Starting CONNECT proxy on port 3000.
For testing use something like "HTTPS_PROXY=http://127.0.0.1:3000".
EOF
diff --git a/examples/microhttpd.pl b/examples/microhttpd.pl
index d176e93..04841a6 100644
--- a/examples/microhttpd.pl
+++ b/examples/microhttpd.pl
@@ -25,7 +25,7 @@
# Write a minimal HTTP response
# (the "Hello World!" message has been optimized away!)
- $stream->write("HTTP/1.1 200 OK\x0d\x0a"
+ $stream->write("HTTP/1.1 200 OK\x0d\x0aContent-Length: 0\x0d\x0a"
. "Connection: keep-alive\x0d\x0a\x0d\x0a");
}
}
@@ -36,7 +36,7 @@
print <<'EOF';
Starting server on port 8080.
-Try something like "ab -c 30 -n 100000 -k http://127.0.0.1:8080/" for testing.
+Try something like "wrk -c 100 -d 10s http://127.0.0.1:8080/" for testing.
On a MacBook Air this results in about 18k req/s.
EOF
diff --git a/examples/websocket.pl b/examples/websocket.pl
index b847ddc..e252b17 100644
--- a/examples/websocket.pl
+++ b/examples/websocket.pl
@@ -1,16 +1,14 @@
use FindBin;
use lib "$FindBin::Bin/../lib";
use Mojolicious::Lite;
-use Mojo::JSON 'j';
-websocket '/' => sub {
+websocket '/test' => sub {
my $self = shift;
$self->on(
- text => sub {
- my ($self, $data) = @_;
- my $hash = j($data);
+ json => sub {
+ my ($self, $hash) = @_;
$hash->{test} = "♥ $hash->{test}";
- $self->send({text => j($hash)});
+ $self->send({json => $hash});
}
);
};
@@ -25,29 +23,24 @@
- WebSocket
- % my $url = url_for->to_abs->scheme('ws');
+ WebSocket Test
%= javascript begin
var ws;
if ("WebSocket" in window) {
- ws = new WebSocket('<%= $url %>');
+ ws = new WebSocket('<%= url_for('test')->to_abs %>');
}
if(typeof(ws) !== 'undefined') {
- function wsmessage(event) {
- alert(JSON.parse(event.data).test);
- }
- function wsopen(event) {
- ws.send(JSON.stringify({test: "WebSocket support works! ♥"}));
- }
- ws.onmessage = wsmessage;
- ws.onopen = wsopen;
+ ws.onmessage = function (event) {
+ document.body.innerHTML += JSON.parse(event.data).test;
+ };
+ ws.onopen = function (event) {
+ ws.send(JSON.stringify({test: 'WebSocket support works! ♥'}));
+ };
}
else {
- alert("Sorry, your browser does not support WebSockets.");
+ document.body.innerHTML += 'Browser does not support WebSockets.';
}
% end
-
- Testing WebSockets, please make sure you have JavaScript enabled.
-
+ Testing WebSockets:
diff --git a/lib/Mojo.pm b/lib/Mojo.pm
index 45ae93e..c797340 100644
--- a/lib/Mojo.pm
+++ b/lib/Mojo.pm
@@ -58,6 +58,8 @@ sub _dict {
1;
+=encoding utf8
+
=head1 NAME
Mojo - Duct tape for the HTML5 web!
@@ -130,7 +132,7 @@ plugins, since non-blocking requests that are already in progress will
interfere with new blocking ones.
# Perform blocking request
- my $body = $app->ua->get('mojolicio.us')->res->body;
+ my $body = $app->ua->get('example.com')->res->body;
=head1 METHODS
@@ -153,17 +155,15 @@ object.
=head2 config
- my $config = $app->config;
- my $foo = $app->config('foo');
- $app = $app->config({foo => 'bar'});
- $app = $app->config(foo => 'bar');
+ my $hash = $app->config;
+ my $foo = $app->config('foo');
+ $app = $app->config({foo => 'bar'});
+ $app = $app->config(foo => 'bar');
Application configuration.
- # Manipulate configuration
- $app->config->{foo} = 'bar';
- my $foo = $app->config->{foo};
- delete $app->config->{foo};
+ # Remove value
+ my $foo = delete $app->config->{foo};
=head2 handler
diff --git a/lib/Mojo/Asset.pm b/lib/Mojo/Asset.pm
index aff4ad0..5fd0468 100644
--- a/lib/Mojo/Asset.pm
+++ b/lib/Mojo/Asset.pm
@@ -20,6 +20,8 @@ sub slurp { croak 'Method "slurp" not implemented by subclass' }
1;
+=encoding utf8
+
=head1 NAME
Mojo::Asset - HTTP content storage base class
@@ -83,9 +85,10 @@ subclass.
=head2 get_chunk
my $bytes = $asset->get_chunk($offset);
+ my $bytes = $asset->get_chunk($offset, $max);
-Get chunk of data starting from a specific position. Meant to be overloaded
-in a subclass.
+Get chunk of data starting from a specific position, defaults to a maximum
+chunk size of C<131072> bytes. Meant to be overloaded in a subclass.
=head2 is_file
diff --git a/lib/Mojo/Asset/File.pm b/lib/Mojo/Asset/File.pm
index dada732..efc71a8 100644
--- a/lib/Mojo/Asset/File.pm
+++ b/lib/Mojo/Asset/File.pm
@@ -22,11 +22,11 @@ has handle => sub {
}
# Open new or temporary file
- my $base = catfile File::Spec::Functions::tmpdir, 'mojo.tmp';
+ my $base = catfile $self->tmpdir, 'mojo.tmp';
my $name = defined $path ? $path : $base;
until ($handle->open($name, O_CREAT | O_EXCL | O_RDWR)) {
croak qq{Can't open file "$name": $!} if defined $path || $! != $!{EEXIST};
- $name = "$base." . md5_sum(time . $$ . rand 9999999);
+ $name = "$base." . md5_sum(time . $$ . rand 9 x 7);
}
$self->path($name);
@@ -57,14 +57,14 @@ sub add_chunk {
}
sub contains {
- my ($self, $string) = @_;
+ my ($self, $str) = @_;
my $handle = $self->handle;
$handle->sysseek($self->start_range, SEEK_SET);
# Calculate window size
my $end = defined $self->end_range ? $self->end_range : $self->size;
- my $len = length $string;
+ my $len = length $str;
my $size = $len > 131072 ? $len : 131072;
$size = $end - $self->start_range if $size > $end - $self->start_range;
@@ -79,7 +79,7 @@ sub contains {
$window .= $buffer;
# Search window
- my $pos = index $window, $string;
+ my $pos = index $window, $str;
return $offset + $pos if $pos >= 0;
$offset += $read;
return -1 if $read == 0 || $offset == $end;
@@ -92,19 +92,20 @@ sub contains {
}
sub get_chunk {
- my ($self, $start) = @_;
+ my ($self, $offset, $max) = @_;
+ $max = defined $max ? $max : 131072;
- $start += $self->start_range;
+ $offset += $self->start_range;
my $handle = $self->handle;
- $handle->sysseek($start, SEEK_SET);
+ $handle->sysseek($offset, SEEK_SET);
my $buffer;
if (defined(my $end = $self->end_range)) {
- my $chunk = $end + 1 - $start;
+ my $chunk = $end + 1 - $offset;
return '' if $chunk <= 0;
- $handle->sysread($buffer, $chunk > 131072 ? 131072 : $chunk);
+ $handle->sysread($buffer, $chunk > $max ? $max : $chunk);
}
- else { $handle->sysread($buffer, 131072) }
+ else { $handle->sysread($buffer, $max) }
return $buffer;
}
@@ -139,6 +140,8 @@ sub slurp {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Asset::File - File storage for HTTP content
@@ -183,7 +186,7 @@ Delete file automatically once it's not used anymore.
my $handle = $file->handle;
$file = $file->handle(IO::File->new);
-File handle, created on demand.
+Filehandle, created on demand.
=head2 path
@@ -199,7 +202,7 @@ necessary.
$file = $file->tmpdir('/tmp');
Temporary directory used to generate C, defaults to the value of the
-C environment variable or auto detection.
+MOJO_TMPDIR environment variable or auto detection.
=head1 METHODS
@@ -220,9 +223,11 @@ Check if asset contains a specific string.
=head2 get_chunk
- my $bytes = $file->get_chunk($start);
+ my $bytes = $file->get_chunk($offset);
+ my $bytes = $file->get_chunk($offset, $max);
-Get chunk of data starting from a specific position.
+Get chunk of data starting from a specific position, defaults to a maximum
+chunk size of C<131072> bytes.
=head2 is_file
diff --git a/lib/Mojo/Asset/Memory.pm b/lib/Mojo/Asset/Memory.pm
index 24b20f4..d517075 100644
--- a/lib/Mojo/Asset/Memory.pm
+++ b/lib/Mojo/Asset/Memory.pm
@@ -21,26 +21,26 @@ sub add_chunk {
}
sub contains {
- my ($self, $string) = @_;
+ my ($self, $str) = @_;
my $start = $self->start_range;
- my $pos = index $self->{content}, $string, $start;
+ my $pos = index $self->{content}, $str, $start;
$pos -= $start if $start && $pos >= 0;
my $end = $self->end_range;
- return $end && ($pos + length $string) >= $end ? -1 : $pos;
+ return $end && ($pos + length $str) >= $end ? -1 : $pos;
}
sub get_chunk {
- my ($self, $start) = @_;
+ my ($self, $offset, $max) = @_;
+ $max = defined $max ? $max : 131072;
- $start += $self->start_range;
- my $size = 131072;
+ $offset += $self->start_range;
if (my $end = $self->end_range) {
- $size = $end + 1 - $start if ($start + $size) > $end;
+ $max = $end + 1 - $offset if ($offset + $max) > $end;
}
- return substr shift->{content}, $start, $size;
+ return substr shift->{content}, $offset, $max;
}
sub move_to {
@@ -55,6 +55,8 @@ sub slurp { shift->{content} }
1;
+=encoding utf8
+
=head1 NAME
Mojo::Asset::Memory - In-memory storage for HTTP content
@@ -110,7 +112,7 @@ automatically upgrade to a L object.
Maximum size in bytes of data to keep in memory before automatically upgrading
to a L object, defaults to the value of the
-C environment variable or C<262144>.
+MOJO_MAX_MEMORY_SIZE environment variable or C<262144>.
=head1 METHODS
@@ -139,8 +141,10 @@ Check if asset contains a specific string.
=head2 get_chunk
my $bytes = $mem->get_chunk($offset);
+ my $bytes = $mem->get_chunk($offset, $max);
-Get chunk of data starting from a specific position.
+Get chunk of data starting from a specific position, defaults to a maximum
+chunk size of C<131072> bytes.
=head2 move_to
diff --git a/lib/Mojo/Base.pm b/lib/Mojo/Base.pm
index f4c34d4..250e030 100644
--- a/lib/Mojo/Base.pm
+++ b/lib/Mojo/Base.pm
@@ -23,10 +23,9 @@ sub import {
elsif ($flag eq '-strict') { $flag = undef }
# Module
- else {
- my $file = $flag;
- $file =~ s/::|'/\//g;
- require "$file.pm" unless $flag->can('new');
+ elsif ((my $file = $flag) && !$flag->can('new')) {
+ $file =~ s!::|'!/!g;
+ require "$file.pm";
}
# ISA
@@ -35,7 +34,7 @@ sub import {
push @{"${caller}::ISA"}, $flag;
*{"${caller}::has"} = sub { attr($caller, @_) };
}
-
+
my $caller = caller;
*{"${caller}::say"} = sub { say(@_) };
@@ -43,7 +42,6 @@ sub import {
strict->import;
warnings->import;
utf8->import;
- feature->import(':5.10');
}
sub new {
@@ -104,6 +102,8 @@ sub tap {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Base - Minimal base class for Mojo projects
@@ -213,7 +213,7 @@ pass it either a hash or a hash reference with attribute values.
Create attribute accessor for hash-based objects, an array reference can be
used to create more than one at a time. Pass an optional second argument to
set a default value, it should be a constant or a callback. The callback will
-be excuted at accessor read time if there's no set value. Accessors can be
+be executed at accessor read time if there's no set value. Accessors can be
chained, that means they return their invocant when they are called with an
argument.
@@ -222,15 +222,12 @@ argument.
$object = $object->tap(sub {...});
K combinator, tap into a method chain to perform operations on an object
-within the chain.
-
-=head2 C
-
-Backported from perl-5.10.1
+within the chain. The object will be the first argument passed to the callback
+and is also available as C<$_>.
=head1 DEBUGGING
-You can set the C environment variable to get some advanced
+You can set the MOJO_BASE_DEBUG environment variable to get some advanced
diagnostics information printed to C.
MOJO_BASE_DEBUG=1
diff --git a/lib/Mojo/ByteStream.pm b/lib/Mojo/ByteStream.pm
index 4966621..140a776 100644
--- a/lib/Mojo/ByteStream.pm
+++ b/lib/Mojo/ByteStream.pm
@@ -1,5 +1,5 @@
package Mojo::ByteStream;
-use Mojo::Base -base;
+use Mojo::Base -strict;
use overload '""' => sub { shift->to_string }, fallback => 1;
use Exporter 'import';
@@ -10,12 +10,11 @@ our @EXPORT_OK = ('b');
# Turn most functions from Mojo::Util into methods
my @UTILS = (
- qw(b64_decode b64_encode camelize decamelize hmac_md5_sum hmac_sha1_sum),
- qw(html_unescape md5_bytes md5_sum punycode_decode punycode_encode quote),
- qw(sha1_bytes sha1_sum slurp spurt squish trim unquote url_escape),
- qw(url_unescape xml_escape xor_encode)
+ qw(b64_decode b64_encode camelize decamelize hmac_sha1_sum html_unescape),
+ qw(md5_bytes md5_sum punycode_decode punycode_encode quote sha1_bytes),
+ qw(sha1_sum slurp spurt squish trim unquote url_escape url_unescape),
+ qw(xml_escape xor_encode)
);
-push @UTILS, 'html_escape'; # DEPRECATED in Rainbow!
for my $name (@UTILS) {
my $sub = Mojo::Util->can($name);
Mojo::Util::monkey_patch __PACKAGE__, $name, sub {
@@ -64,10 +63,14 @@ sub split {
return Mojo::Collection->new(map { $self->new($_) } split $pattern, $$self);
}
+sub tap { shift->Mojo::Base::tap(@_) }
+
sub to_string { ${$_[0]} }
1;
+=encoding utf8
+
=head1 NAME
Mojo::ByteStream - ByteStream
@@ -105,8 +108,7 @@ Construct a new scalar-based L object.
=head1 METHODS
-L inherits all methods from L and implements the
-following new ones.
+L implements the following methods.
=head2 new
@@ -165,12 +167,6 @@ Encode bytestream with L, defaults to C.
$stream->trim->quote->encode->say;
-=head2 hmac_md5_sum
-
- $stream = $stream->hmac_md5_sum('passw0rd');
-
-Generate HMAC-MD5 checksum for bytestream with L.
-
=head2 hmac_sha1_sum
$stream = $stream->hmac_sha1_sum('passw0rd');
@@ -226,7 +222,7 @@ Print bytestream to handle and append a newline, defaults to C.
=head2 secure_compare
- my $success = $stream->secure_compare($string);
+ my $success = $stream->secure_compare($str);
Compare bytestream with L.
@@ -270,9 +266,10 @@ Write all data from bytestream at once to file with L.
my $collection = $stream->split(',');
-Turn bytestream into L.
+Turn bytestream into L object containing L
+objects.
- b('a,b,c')->split(',')->pluck('quote')->join(',')->say;
+ b('a,b,c')->split(',')->quote->join(',')->say;
=head2 squish
@@ -282,10 +279,16 @@ Trim whitespace characters from both ends of bytestream and then change all
consecutive groups of whitespace into one space each with
L.
+=head2 tap
+
+ $stream = $stream->tap(sub {...});
+
+Alias for L.
+
=head2 to_string
- my $string = $stream->to_string;
- my $string = "$stream";
+ my $str = $stream->to_string;
+ my $str = "$stream";
Stringify bytestream.
@@ -334,6 +337,12 @@ bytestream with L.
XOR encode bytestream with L.
+=head1 BYTESTREAM
+
+Direct scalar reference access to the bytestream is also possible.
+
+ $$stream .= 'foo';
+
=head1 SEE ALSO
L, L, L.
diff --git a/lib/Mojo/Cache.pm b/lib/Mojo/Cache.pm
index d136296..681d4d7 100644
--- a/lib/Mojo/Cache.pm
+++ b/lib/Mojo/Cache.pm
@@ -19,6 +19,8 @@ sub set {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Cache - Naive in-memory cache
diff --git a/lib/Mojo/Collection.pm b/lib/Mojo/Collection.pm
index 4e006a1..75f117e 100644
--- a/lib/Mojo/Collection.pm
+++ b/lib/Mojo/Collection.pm
@@ -1,16 +1,29 @@
package Mojo::Collection;
-use Mojo::Base -base;
-use overload
- 'bool' => sub {1},
- '""' => sub { shift->join("\n") },
- fallback => 1;
+use Mojo::Base -strict;
+use overload bool => sub {1}, '""' => sub { shift->join("\n") }, fallback => 1;
+use Carp 'croak';
use Exporter 'import';
use List::Util;
use Mojo::ByteStream;
+use Scalar::Util 'blessed';
our @EXPORT_OK = ('c');
+sub AUTOLOAD {
+ my $self = shift;
+
+ my ($package, $method) = our $AUTOLOAD =~ /^([\w:]+)::(\w+)$/;
+ croak "Undefined subroutine &${package}::$method called"
+ unless blessed $self && $self->isa(__PACKAGE__);
+
+ croak qq{Can't locate object method "$method" via package "$package"}
+ unless @$self;
+ return $self->pluck($method, @_);
+}
+
+sub DESTROY { }
+
sub new {
my $class = shift;
return bless [@_], ref $class || $class;
@@ -18,6 +31,10 @@ sub new {
sub c { __PACKAGE__->new(@_) }
+sub compact {
+ shift->grep(sub {length});
+}
+
sub each {
my ($self, $cb) = @_;
return @$self unless $cb;
@@ -28,16 +45,15 @@ sub each {
sub first {
my ($self, $cb) = @_;
- return $cb ? do { (ref $cb) eq 'CODE' ? List::Util::first { $cb->($_) } @$self : List::Util::first { $_ =~ $cb } @$self } : $self->[0];
+ return $self->[0] unless $cb;
+ return List::Util::first { $cb->($_) } @$self if ref $cb eq 'CODE';
+ return List::Util::first { $_ =~ $cb } @$self;
}
sub grep {
my ($self, $cb) = @_;
- if ((ref $cb) eq 'CODE') {
- return $self->new(grep { $cb->($_) } @$self);
- } else {
- return $self->new(grep { $_ =~ $cb } @$self);
- }
+ return $self->new(grep { $cb->($_) } @$self) if ref $cb eq 'CODE';
+ return $self->new(grep { $_ =~ $cb } @$self);
}
sub join {
@@ -77,6 +93,8 @@ sub sort {
return $self->new($cb ? sort { $a->$cb($b) } @$self : sort @$self);
}
+sub tap { shift->Mojo::Base::tap(@_) }
+
sub uniq {
my $self = shift;
my %seen;
@@ -85,6 +103,8 @@ sub uniq {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Collection - Collection
@@ -120,8 +140,7 @@ Construct a new array-based L object.
=head1 METHODS
-L inherits all methods from L and implements the
-following new ones.
+L implements the following methods.
=head2 new
@@ -129,12 +148,20 @@ following new ones.
Construct a new array-based L object.
+=head2 compact
+
+ my $new = $collection->compact;
+
+Create a new collection with all elements that are defined and not an empty
+string.
+
=head2 each
my @elements = $collection->each;
$collection = $collection->each(sub {...});
-Evaluate callback for each element in collection.
+Evaluate callback for each element in collection. The element will be the
+first argument passed to the callback and is also available as C<$_>.
$collection->each(sub {
my ($e, $count) = @_;
@@ -149,7 +176,8 @@ Evaluate callback for each element in collection.
Evaluate regular expression or callback for each element in collection and
return the first one that matched the regular expression, or for which the
-callback returned true.
+callback returned true. The element will be the first argument passed to the
+callback and is also available as C<$_>.
my $five = $collection->first(sub { $_ == 5 });
@@ -160,7 +188,8 @@ callback returned true.
Evaluate regular expression or callback for each element in collection and
create a new collection with all elements that matched the regular expression,
-or for which the callback returned true.
+or for which the callback returned true. The element will be the first
+argument passed to the callback and is also available as C<$_>.
my $interesting = $collection->grep(qr/mojo/i);
@@ -177,7 +206,8 @@ Turn collection into L.
my $new = $collection->map(sub {...});
Evaluate callback for each element in collection and create a new collection
-from the results.
+from the results. The element will be the first argument passed to the
+callback and is also available as C<$_>.
my $doubled = $collection->map(sub { $_ * 2 });
@@ -226,12 +256,34 @@ from the results.
my $insensitive = $collection->sort(sub { uc(shift) cmp uc(shift) });
+=head2 tap
+
+ $collection = $collection->tap(sub {...});
+
+Alias for L.
+
=head2 uniq
my $new = $collection->uniq;
Create a new collection without duplicate elements.
+=head1 ELEMENT METHODS
+
+In addition to the methods above, you can also call methods provided by all
+elements in the collection directly and create a new collection from the
+results, similar to C.
+
+ push @$collection, Mojo::ByteStream->new("/home/sri/$_.txt") for 1 .. 9;
+ say $collection->slurp->b64_encode('');
+
+=head1 ELEMENTS
+
+Direct array reference access to elements is also possible.
+
+ say $collection->[23];
+ say for @$collection;
+
=head1 SEE ALSO
L, L, L.
diff --git a/lib/Mojo/Content.pm b/lib/Mojo/Content.pm
index 08a7f83..18f636b 100644
--- a/lib/Mojo/Content.pm
+++ b/lib/Mojo/Content.pm
@@ -18,7 +18,7 @@ sub body_size { croak 'Method "body_size" not implemented by subclass' }
sub boundary {
return undef unless my $type = shift->headers->content_type;
- $type =~ m!multipart.*boundary=(?:"([^"]+)"|([\w'(),.:?\-+/]+))!i
+ $type =~ m!multipart.*boundary\s*=\s*(?:"([^"]+)"|([\w'(),.:?\-+/]+))!i
and return defined $1 ? $1 : $2;
return undef;
}
@@ -27,8 +27,8 @@ sub build_body { shift->_build('get_body_chunk') }
sub build_headers { shift->_build('get_header_chunk') }
sub charset {
- my $type = shift->headers->content_type || '';
- return $type =~ /charset="?([^"\s;]+)"?/i ? $1 : undef;
+ my $type = do {my $tmp = shift->headers->content_type; defined $tmp ? $tmp : ''};
+ return $type =~ /charset\s*=\s*"?([^"\s;]+)"?/i ? $1 : undef;
}
sub clone {
@@ -64,15 +64,13 @@ sub get_header_chunk {
return substr $self->{header_buffer}, $offset, 131072;
}
-sub has_leftovers { !!length shift->leftovers }
-
sub header_size { length shift->build_headers }
sub is_chunked { !!shift->headers->transfer_encoding }
-sub is_compressed { (shift->headers->content_encoding || '') =~ /^gzip$/i }
+sub is_compressed { (do {my $tmp = shift->headers->content_encoding; defined $tmp ? $tmp : ''}) =~ /^gzip$/i }
-sub is_dynamic { $_[0]->{dynamic} && !defined $_[0]->headers->content_length }
+sub is_dynamic { $_[0]{dynamic} && !defined $_[0]->headers->content_length }
sub is_finished { my $tmp = shift->{state}; (defined $tmp ? $tmp : '') eq 'finished' }
@@ -117,8 +115,8 @@ sub parse {
# Relaxed parsing
my $headers = $self->headers;
if ($self->auto_relax) {
- my $connection = $headers->connection || '';
- my $len = defined $headers->content_length ? $headers->content_length : '';
+ my $connection = defined $headers->connection ? $headers->connection : '';
+ my $len = defined $headers->content_length ? $headers->content_length : '';
$self->relaxed(1)
if !length $len && ($connection =~ /close/i || $headers->content_type);
}
@@ -155,7 +153,7 @@ sub parse_body {
sub progress {
my $self = shift;
return 0 unless my $state = $self->{state};
- return 0 unless grep { $_ eq $state } qw(body finished);
+ return 0 unless $state eq 'body' || $state eq 'finished';
return $self->{raw_size} - ($self->{header_size} || 0);
}
@@ -222,7 +220,7 @@ sub _parse_chunked {
# Start new chunk (ignore the chunk extension)
unless ($self->{chunk_len}) {
last
- unless $self->{pre_buffer} =~ s/^(?:\x0d?\x0a)?([[:xdigit:]]+).*\x0a//;
+ unless $self->{pre_buffer} =~ s/^(?:\x0d?\x0a)?([0-9a-fA-F]+).*\x0a//;
next if $self->{chunk_len} = hex $1;
# Last chunk
@@ -293,13 +291,13 @@ sub _uncompress {
# Uncompress
$self->{post_buffer} .= $chunk;
my $gz = $self->{gz} = defined $self->{gz} ? $self->{gz} :
- Compress::Raw::Zlib::Inflate->new(WindowBits => WANT_GZIP());
+ Compress::Raw::Zlib::Inflate->new(WindowBits => WANT_GZIP);
my $status = $gz->inflate(\$self->{post_buffer}, my $out);
$self->emit(read => $out) if defined $out;
# Replace Content-Encoding with Content-Length
$self->headers->content_length($gz->total_out)->remove('Content-Encoding')
- if $status == Z_STREAM_END();
+ if $status == Z_STREAM_END;
# Check buffer size
$self->{limit} = $self->{state} = 'finished'
@@ -308,6 +306,8 @@ sub _uncompress {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Content - HTTP content base class
@@ -398,7 +398,7 @@ Content headers, defaults to a L object.
$content = $content->max_buffer_size(1024);
Maximum size in bytes of buffer for content parser, defaults to the value of
-the C environment variable or C<262144>.
+the MOJO_MAX_BUFFER_SIZE environment variable or C<262144>.
=head2 max_leftover_size
@@ -406,7 +406,7 @@ the C environment variable or C<262144>.
$content = $content->max_leftover_size(1024);
Maximum size in bytes of buffer for pipelined HTTP requests, defaults to the
-value of the C environment variable or C<262144>.
+value of the MOJO_MAX_LEFTOVER_SIZE environment variable or C<262144>.
=head2 relaxed
@@ -449,13 +449,13 @@ Extract multipart boundary from C header.
=head2 build_body
- my $string = $content->build_body;
+ my $str = $content->build_body;
Render whole body.
=head2 build_headers
- my $string = $content->build_headers;
+ my $str = $content->build_headers;
Render all headers.
@@ -481,20 +481,14 @@ Generate dynamic content.
my $bytes = $content->get_body_chunk(0);
-Get a chunk of content starting from a specfic position. Meant to be
+Get a chunk of content starting from a specific position. Meant to be
overloaded in a subclass.
=head2 get_header_chunk
my $bytes = $content->get_header_chunk(13);
-Get a chunk of the headers starting from a specfic position.
-
-=head2 has_leftovers
-
- my $success = $content->has_leftovers;
-
-Check if there are leftovers.
+Get a chunk of the headers starting from a specific position.
=head2 header_size
diff --git a/lib/Mojo/Content/MultiPart.pm b/lib/Mojo/Content/MultiPart.pm
index 6667d5f..b13b43c 100644
--- a/lib/Mojo/Content/MultiPart.pm
+++ b/lib/Mojo/Content/MultiPart.pm
@@ -45,14 +45,14 @@ sub build_boundary {
my $boundary;
my $size = 1;
while (1) {
- $boundary = b64_encode join('', map chr(rand(256)), 1 .. $size++ * 3);
+ $boundary = b64_encode join('', map chr(rand 256), 1 .. $size++ * 3);
$boundary =~ s/\W/X/g;
last unless $self->body_contains($boundary);
}
# Add boundary to Content-Type header
my $headers = $self->headers;
- ($headers->content_type || '') =~ m!^(.*multipart/[^;]+)(.*)$!;
+ (defined $headers->content_type ? $headers->content_type : '') =~ m!^(.*multipart/[^;]+)(.*)$!;
my $before = $1 || 'multipart/mixed';
my $after = $2 || '';
$headers->content_type("$before; boundary=$boundary$after");
@@ -199,6 +199,8 @@ sub _read {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Content::MultiPart - HTTP multipart content
@@ -289,7 +291,7 @@ Clone content if possible, otherwise return C.
my $bytes = $multi->get_body_chunk(0);
-Get a chunk of content starting from a specfic position.
+Get a chunk of content starting from a specific position.
=head2 is_multipart
diff --git a/lib/Mojo/Content/Single.pm b/lib/Mojo/Content/Single.pm
index 995f202..b67ba76 100644
--- a/lib/Mojo/Content/Single.pm
+++ b/lib/Mojo/Content/Single.pm
@@ -53,6 +53,8 @@ sub parse {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Content::Single - HTTP content
@@ -145,7 +147,7 @@ Clone content if possible, otherwise return C.
my $bytes = $single->get_body_chunk(0);
-Get a chunk of content starting from a specfic position.
+Get a chunk of content starting from a specific position.
=head2 parse
@@ -154,7 +156,7 @@ Get a chunk of content starting from a specfic position.
= $single->parse("Content-Type: multipart/form-data\x0d\x0a\x0d\x0a");
Parse content chunk and upgrade to L object if
-possible.
+necessary.
=head1 SEE ALSO
diff --git a/lib/Mojo/Cookie.pm b/lib/Mojo/Cookie.pm
index ff8bd8b..e5ea183 100644
--- a/lib/Mojo/Cookie.pm
+++ b/lib/Mojo/Cookie.pm
@@ -1,51 +1,18 @@
package Mojo::Cookie;
use Mojo::Base -base;
-use overload
- 'bool' => sub {1},
- '""' => sub { shift->to_string },
- fallback => 1;
+use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
use Carp 'croak';
-use Mojo::Util 'unquote';
has [qw(name value)];
sub parse { croak 'Method "parse" not implemented by subclass' }
sub to_string { croak 'Method "to_string" not implemented by subclass' }
-sub _tokenize {
- my ($self, $string) = @_;
-
- # Nibbling parser
- my (@tree, @token);
- while ($string) {
-
- # Name
- last unless $string =~ s/^\s*([^=;,]+)\s*=?\s*//;
- my $name = $1;
-
- # "expires" is a special case, thank you Netscape...
- $string =~ s/^([^;,]+,?[^;,]+)/"$1"/ if $name =~ /^expires$/i;
-
- # Value
- my $value;
- $value = unquote $1 if $string =~ s/^("(?:\\\\|\\"|[^"])+"|[^;,]+)\s*//;
- push @token, [$name, $value];
-
- # Separator
- $string =~ s/^\s*;\s*//;
- if ($string =~ s/^\s*,\s*//) {
- push @tree, [@token];
- @token = ();
- }
- }
-
- # Take care of final token
- return @token ? (@tree, \@token) : @tree;
-}
-
1;
+=encoding utf8
+
=head1 NAME
Mojo::Cookie - HTTP cookie base class
@@ -60,7 +27,8 @@ Mojo::Cookie - HTTP cookie base class
=head1 DESCRIPTION
-L is an abstract base class for HTTP cookies.
+L is an abstract base class for HTTP cookies as described in RFC
+6265.
=head1 ATTRIBUTES
@@ -87,14 +55,14 @@ following new ones.
=head2 parse
- my $cookies = $cookie->parse($string);
+ my $cookies = $cookie->parse($str);
Parse cookies. Meant to be overloaded in a subclass.
=head2 to_string
- my $string = $cookie->to_string;
- my $string = "$cookie";
+ my $str = $cookie->to_string;
+ my $str = "$cookie";
Render cookie. Meant to be overloaded in a subclass.
diff --git a/lib/Mojo/Cookie/Request.pm b/lib/Mojo/Cookie/Request.pm
index 0764d1e..8fbac8b 100644
--- a/lib/Mojo/Cookie/Request.pm
+++ b/lib/Mojo/Cookie/Request.pm
@@ -1,17 +1,17 @@
package Mojo::Cookie::Request;
use Mojo::Base 'Mojo::Cookie';
-use Mojo::Util 'quote';
+use Mojo::Util qw(quote split_header);
sub parse {
- my ($self, $string) = @_;
+ my ($self, $str) = @_;
my @cookies;
- for my $token (map {@$_} $self->_tokenize($string)) {
- my ($name, $value) = @$token;
+ my @pairs = map {@$_} @{split_header(defined $str ? $str : '')};
+ while (@pairs) {
+ my ($name, $value) = (shift @pairs, shift @pairs);
next if $name =~ /^\$/;
- push @cookies,
- Mojo::Cookie::Request->new(name => $name, value => defined $value ? $value : '');
+ push @cookies, $self->new(name => $name, value => defined $value ? $value : '');
}
return \@cookies;
@@ -21,12 +21,14 @@ sub to_string {
my $self = shift;
return '' unless my $name = $self->name;
my $value = defined $self->value ? $self->value : '';
- $value = $value =~ /[,;"]/ ? quote($value) : $value;
+ $value = $value =~ /[,;" ]/ ? quote($value) : $value;
return "$name=$value";
}
1;
+=encoding utf8
+
=head1 NAME
Mojo::Cookie::Request - HTTP request cookie
@@ -42,7 +44,8 @@ Mojo::Cookie::Request - HTTP request cookie
=head1 DESCRIPTION
-L is a container for HTTP request cookies.
+L is a container for HTTP request cookies as described
+in RFC 6265.
=head1 ATTRIBUTES
@@ -55,13 +58,13 @@ implements the following new ones.
=head2 parse
- my $cookies = $cookie->parse('f=b; g=a');
+ my $cookies = Mojo::Cookie::Request->parse('f=b; g=a');
Parse cookies.
=head2 to_string
- my $string = $cookie->to_string;
+ my $str = $cookie->to_string;
Render cookie.
diff --git a/lib/Mojo/Cookie/Response.pm b/lib/Mojo/Cookie/Response.pm
index f24354a..f80f951 100644
--- a/lib/Mojo/Cookie/Response.pm
+++ b/lib/Mojo/Cookie/Response.pm
@@ -2,7 +2,7 @@ package Mojo::Cookie::Response;
use Mojo::Base 'Mojo::Cookie';
use Mojo::Date;
-use Mojo::Util 'quote';
+use Mojo::Util qw(quote split_header);
has [qw(domain httponly max_age path secure)];
@@ -10,10 +10,8 @@ sub expires {
my $self = shift;
# Upgrade
- return $self->{expires}
- = defined $self->{expires} && !ref $self->{expires}
- ? Mojo::Date->new($self->{expires})
- : $self->{expires}
+ my $e = $self->{expires};
+ return $self->{expires} = defined $e && !ref $e ? Mojo::Date->new($e) : $e
unless @_;
$self->{expires} = shift;
@@ -21,26 +19,33 @@ sub expires {
}
sub parse {
- my ($self, $string) = @_;
+ my ($self, $str) = @_;
my @cookies;
- for my $token ($self->_tokenize($string)) {
- for my $i (0 .. $#$token) {
- my ($name, $value) = @{$token->[$i]};
+ my $tree = split_header(defined $str ? $str : '');
+ while (my $pairs = shift @$tree) {
+ my $i = 0;
+ while (@$pairs) {
+ my ($name, $value) = (shift @$pairs, shift @$pairs);
+
+ # "expires" is a special case, thank you Netscape...
+ if ($name =~ /^expires$/i) {
+ my $tmp = shift @$tree;
+ push @$pairs, @{ defined $tmp ? $tmp : [] };
+ my $len = (defined $pairs->[0] ? $pairs->[0] : '') =~ /-/ ? 6 : 10;
+ $value .= join ' ', ',', grep {defined} splice @$pairs, 0, $len;
+ }
# This will only run once
- push(@cookies,
- Mojo::Cookie::Response->new(name => $name, value => defined $value ? $value : ''))
- and next
- unless $i;
+ push @cookies, $self->new(name => $name, value => defined $value ? $value : '') and next
+ unless $i++;
# Attributes (Netscape and RFC 6265)
- next
- unless my @match
- = $name =~ /^(expires|domain|path|secure|Max-Age|HttpOnly)$/msi;
- my $attr = lc $match[0];
- $attr =~ tr/-/_/;
- $cookies[-1]->$attr($attr =~ /(?:secure|HttpOnly)/i ? 1 : $value);
+ next unless $name =~ /^(expires|domain|path|secure|max-age|httponly)$/i;
+ my $attr = lc $1;
+ $attr = 'max_age' if $attr eq 'max-age';
+ $cookies[-1]
+ ->$attr($attr eq 'secure' || $attr eq 'httponly' ? 1 : $value);
}
}
@@ -53,7 +58,7 @@ sub to_string {
# Name and value (Netscape)
return '' unless my $name = $self->name;
my $value = defined $self->value ? $self->value : '';
- $value = $value =~ /[,;"]/ ? quote($value) : $value;
+ $value = $value =~ /[,;" ]/ ? quote($value) : $value;
my $cookie = "$name=$value";
# "expires" (Netscape)
@@ -79,6 +84,8 @@ sub to_string {
1;
+=encoding utf8
+
=head1 NAME
Mojo::Cookie::Response - HTTP response cookie
@@ -94,12 +101,13 @@ Mojo::Cookie::Response - HTTP response cookie
=head1 DESCRIPTION
-L is a container for HTTP response cookies.
+L is a container for HTTP response cookies as
+described in RFC 6265.
=head1 ATTRIBUTES
L inherits all attributes from L and
-implements the followign new ones.
+implements the following new ones.
=head2 domain
@@ -153,13 +161,13 @@ Expiration for cookie.
=head2 parse
- my $cookies = $cookie->parse('f=b; path=/');
+ my $cookies = Mojo::Cookie::Response->parse('f=b; path=/');
Parse cookies.
=head2 to_string
- my $string = $cookie->to_string;
+ my $str = $cookie->to_string;
Render cookie.
diff --git a/lib/Mojo/DOM.pm b/lib/Mojo/DOM.pm
index 333acf4..405142f 100644
--- a/lib/Mojo/DOM.pm
+++ b/lib/Mojo/DOM.pm
@@ -1,8 +1,8 @@
package Mojo::DOM;
-use Mojo::Base -base;
+use Mojo::Base -strict;
use overload
- '%{}' => sub { shift->attrs },
- 'bool' => sub {1},
+ '%{}' => sub { shift->attr },
+ bool => sub {1},
'""' => sub { shift->to_xml },
fallback => 1;
@@ -12,18 +12,17 @@ use Carp 'croak';
use Mojo::Collection;
use Mojo::DOM::CSS;
use Mojo::DOM::HTML;
-use Mojo::Util 'squish';
+use Mojo::Util qw(deprecated squish);
use Scalar::Util qw(blessed weaken);
sub AUTOLOAD {
my $self = shift;
- # Method
my ($package, $method) = our $AUTOLOAD =~ /^([\w:]+)::(\w+)$/;
croak "Undefined subroutine &${package}::$method called"
unless blessed $self && $self->isa(__PACKAGE__);
- # Search children
+ # Search children of current element
my $children = $self->children($method);
return @$children > 1 ? $children : $children->[0] if @$children;
croak qq{Can't locate object method "$method" via package "$package"};
@@ -37,24 +36,22 @@ sub new {
return @_ ? $self->parse(@_) : $self;
}
-sub all_text {
- my ($self, $trim) = @_;
- my $tree = $self->tree;
- return _text(_elements($tree), 1, _trim($tree, $trim));
-}
+sub all_text { shift->_content(1, @_) }
+
+sub ancestors { $_[0]->_collection(_ancestors($_[0]->tree)) }
sub append { shift->_add(1, @_) }
sub append_content {
my ($self, $new) = @_;
my $tree = $self->tree;
- push @$tree, @{_parent($self->_parse("$new"), $tree)};
+ push @$tree, _link($self->_parse("$new"), $tree);
return $self;
}
sub at { shift->find(@_)->[0] }
-sub attrs {
+sub attr {
my $self = shift;
# Hash
@@ -71,21 +68,22 @@ sub attrs {
return $self;
}
-sub charset { shift->_html(charset => @_) }
+# DEPRECATED in Top Hat!
+sub attrs {
+ deprecated 'Mojo::DOM::attrs is DEPRECATED in favor of Mojo::DOM::attr';
+ shift->attr(@_);
+}
sub children {
my ($self, $type) = @_;
my @children;
- my $charset = $self->charset;
- my $xml = $self->xml;
- my $tree = $self->tree;
- for my $e (@$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree]) {
+ my $xml = $self->xml;
+ for my $n (@{_nodes($self->tree)}) {
# Make sure child is the right type
- next unless $e->[0] eq 'tag';
- next if defined $type && $e->[1] ne $type;
- push @children, $self->new->charset($charset)->tree($e)->xml($xml);
+ next if $n->[0] ne 'tag' || (defined $type && $n->[1] ne $type);
+ push @children, $self->new->tree($n)->xml($xml);
}
return Mojo::Collection->new(@children);
@@ -93,34 +91,24 @@ sub children {
sub content_xml {
my $self = shift;
-
- # Render children
- my $tree = $self->tree;
- my $charset = $self->charset;
- my $xml = $self->xml;
- return join '', map {
- Mojo::DOM::HTML->new(charset => $charset, tree => $_, xml => $xml)->render
- } @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree];
+ my $xml = $self->xml;
+ return join '', map { _render($_, $xml) } @{_nodes($self->tree)};
}
sub find {
- my ($self, $selector) = @_;
-
- my $charset = $self->charset;
- my $xml = $self->xml;
- return Mojo::Collection->new(
- map { $self->new->charset($charset)->tree($_)->xml($xml) }
- @{Mojo::DOM::CSS->new(tree => $self->tree)->select($selector)});
+ my $self = shift;
+ my $results = Mojo::DOM::CSS->new(tree => $self->tree)->select(@_);
+ return $self->_collection(@$results);
}
sub namespace {
my $self = shift;
- # Extract namespace prefix and search parents
return '' if (my $current = $self->tree)->[0] eq 'root';
+
+ # Extract namespace prefix and search parents
my $ns = $current->[1] =~ /^(.*?):/ ? "xmlns:$1" : undef;
- while ($current) {
- last if $current->[0] eq 'root';
+ while ($current->[0] ne 'root') {
# Namespace for prefix
my $attrs = $current->[2];
@@ -129,7 +117,6 @@ sub namespace {
# Namespace attribute
elsif (defined $attrs->{xmlns}) { return $attrs->{xmlns} }
- # Parent
$current = $current->[3];
}
@@ -141,23 +128,17 @@ sub next { shift->_sibling(1) }
sub parent {
my $self = shift;
return undef if (my $tree = $self->tree)->[0] eq 'root';
- return $self->new->charset($self->charset)->tree($tree->[3])
- ->xml($self->xml);
+ return $self->new->tree($tree->[3])->xml($self->xml);
}
-sub parse {
- my $self = shift;
- $self->[0]->parse(@_);
- return $self;
-}
+sub parse { shift->_html(parse => shift) }
sub prepend { shift->_add(0, @_) }
sub prepend_content {
my ($self, $new) = @_;
my $tree = $self->tree;
- splice @$tree, $tree->[0] eq 'root' ? 1 : 4, 0,
- @{_parent($self->_parse("$new"), $tree)};
+ splice @$tree, _offset($tree), 0, _link($self->_parse("$new"), $tree);
return $self;
}
@@ -167,79 +148,64 @@ sub remove { shift->replace('') }
sub replace {
my ($self, $new) = @_;
-
- # Parse
my $tree = $self->tree;
- if ($tree->[0] eq 'root') { return $self->xml(undef)->parse($new) }
- else { $new = $self->_parse("$new") }
-
- # Find and replace
- my $parent = $tree->[3];
- my $i = $parent->[0] eq 'root' ? 1 : 4;
- for my $e (@$parent[$i .. $#$parent]) {
- last if $e == $tree;
- $i++;
- }
- splice @$parent, $i, 1, @{_parent($new, $parent)};
-
- return $self;
+ return $self->xml(undef)->parse($new) if $tree->[0] eq 'root';
+ return $self->_replace($tree, $self->_parse("$new"));
}
sub replace_content {
my ($self, $new) = @_;
my $tree = $self->tree;
- splice @$tree, $tree->[0] eq 'root' ? 1 : 4, $#$tree,
- @{_parent($self->_parse("$new"), $tree)};
+ splice @$tree, _offset($tree), $#$tree, _link($self->_parse("$new"), $tree);
return $self;
}
sub root {
my $self = shift;
-
- my $root = $self->tree;
- while ($root->[0] eq 'tag') {
- last unless my $parent = $root->[3];
- $root = $parent;
- }
-
- return $self->new->charset($self->charset)->tree($root)->xml($self->xml);
+ return $self unless my $tree = _ancestors($self->tree, 1);
+ return $self->new->tree($tree)->xml($self->xml);
}
-sub text {
- my ($self, $trim) = @_;
+sub strip {
+ my $self = shift;
my $tree = $self->tree;
- return _text(_elements($tree), 0, _trim($tree, $trim));
+ return $self if $tree->[0] eq 'root';
+ return $self->_replace($tree, ['root', @{_nodes($tree)}]);
}
+sub tap { shift->Mojo::Base::tap(@_) }
+
+sub text { shift->_content(0, @_) }
+
sub text_after {
my ($self, $trim) = @_;
- # Find following text elements
return '' if (my $tree = $self->tree)->[0] eq 'root';
- my (@elements, $started);
- for my $e (@{_elements($tree->[3])}) {
- ++$started and next if $e eq $tree;
+
+ my (@nodes, $started);
+ for my $n (@{_nodes($tree->[3])}) {
+ ++$started and next if $n eq $tree;
next unless $started;
- last if $e->[0] eq 'tag';
- push @elements, $e;
+ last if $n->[0] eq 'tag';
+ push @nodes, $n;
}
- return _text(\@elements, 0, _trim($tree->[3], $trim));
+ return _text(\@nodes, 0, _trim($tree->[3], $trim));
}
sub text_before {
my ($self, $trim) = @_;
- # Find preceding text elements
return '' if (my $tree = $self->tree)->[0] eq 'root';
- my @elements;
- for my $e (@{_elements($tree->[3])}) {
- last if $e eq $tree;
- push @elements, $e;
- @elements = () if $e->[0] eq 'tag';
+
+ my @nodes;
+ for my $n (@{_nodes($tree->[3])}) {
+ last if $n eq $tree;
+ push @nodes, $n;
+ @nodes = () if $n->[0] eq 'tag';
}
- return _text(\@elements, 0, _trim($tree->[3], $trim));
+ return _text(\@nodes, 0, _trim($tree->[3], $trim));
}
sub to_xml { shift->[0]->render }
@@ -248,14 +214,9 @@ sub tree { shift->_html(tree => @_) }
sub type {
my ($self, $type) = @_;
-
- # Get
return '' if (my $tree = $self->tree)->[0] eq 'root';
return $tree->[1] unless $type;
-
- # Set
$tree->[1] = $type;
-
return $self;
}
@@ -264,26 +225,32 @@ sub xml { shift->_html(xml => @_) }
sub _add {
my ($self, $offset, $new) = @_;
- # Not a tag
return $self if (my $tree = $self->tree)->[0] eq 'root';
- # Find parent
my $parent = $tree->[3];
- my $i = $parent->[0] eq 'root' ? 1 : 4;
- for my $e (@$parent[$i .. $#$parent]) {
- last if $e == $tree;
- $i++;
- }
-
- # Add children
- splice @$parent, $i + $offset, 0, @{_parent($self->_parse("$new"), $parent)};
+ splice @$parent, _parent($parent, $tree) + $offset, 0,
+ _link($self->_parse("$new"), $parent);
return $self;
}
-sub _elements {
- return [] unless my $e = shift;
- return [@$e[($e->[0] eq 'root' ? 1 : 4) .. $#$e]];
+sub _ancestors {
+ my ($tree, $root) = @_;
+ my @ancestors;
+ push @ancestors, $tree while ($tree->[0] eq 'tag') && ($tree = $tree->[3]);
+ return $root ? $ancestors[-1] : @ancestors[0 .. $#ancestors - 1];
+}
+
+sub _collection {
+ my $self = shift;
+ my $xml = $self->xml;
+ return Mojo::Collection->new(@_)
+ ->map(sub { $self->new->tree($_)->xml($xml) });
+}
+
+sub _content {
+ my $tree = shift->tree;
+ return _text(_nodes($tree), shift, _trim($tree, @_));
}
sub _html {
@@ -293,26 +260,50 @@ sub _html {
return $self;
}
-sub _parent {
+sub _link {
my ($children, $parent) = @_;
# Link parent to children
my @new;
- for my $e (@$children[1 .. $#$children]) {
- if ($e->[0] eq 'tag') {
- $e->[3] = $parent;
- weaken $e->[3];
- }
- push @new, $e;
+ for my $n (@$children[1 .. $#$children]) {
+ push @new, $n;
+ next unless $n->[0] eq 'tag';
+ $n->[3] = $parent;
+ weaken $n->[3];
}
- return \@new;
+ return @new;
}
-sub _parse {
- my $self = shift;
- Mojo::DOM::HTML->new(charset => $self->charset, xml => $self->xml)
- ->parse(shift)->tree;
+sub _nodes {
+ return [] unless my $n = shift;
+ return [@$n[_offset($n) .. $#$n]];
+}
+
+sub _offset { $_[0][0] eq 'root' ? 1 : 4 }
+
+sub _parent {
+ my ($parent, $child) = @_;
+
+ # Find parent offset for child
+ my $i = _offset($parent);
+ for my $n (@$parent[$i .. $#$parent]) {
+ last if $n == $child;
+ $i++;
+ }
+
+ return $i;
+}
+
+sub _parse { Mojo::DOM::HTML->new(xml => shift->xml)->parse(shift)->tree }
+
+sub _render { Mojo::DOM::HTML->new(tree => shift, xml => shift)->render }
+
+sub _replace {
+ my ($self, $tree, $new) = @_;
+ my $parent = $tree->[3];
+ splice @$parent, _parent($parent, $tree), 1, _link($new, $parent);
+ return $self->parent;
}
sub _sibling {
@@ -334,23 +325,23 @@ sub _sibling {
}
sub _text {
- my ($elements, $recurse, $trim) = @_;
+ my ($nodes, $recurse, $trim) = @_;
my $text = '';
- for my $e (@$elements) {
- my $type = $e->[0];
+ for my $n (@$nodes) {
+ my $type = $n->[0];
# Nested tag
my $content = '';
if ($type eq 'tag' && $recurse) {
- $content = _text(_elements($e), 1, _trim($e, $trim));
+ $content = _text(_nodes($n), 1, _trim($n, $trim));
}
# Text
- elsif ($type eq 'text') { $content = $trim ? squish($e->[1]) : $e->[1] }
+ elsif ($type eq 'text') { $content = $trim ? squish($n->[1]) : $n->[1] }
# CDATA or raw text
- elsif ($type eq 'cdata' || $type eq 'raw') { $content = $e->[1] }
+ elsif ($type eq 'cdata' || $type eq 'raw') { $content = $n->[1] }
# Add leading whitespace if punctuation allows it
$content = " $content" if $text =~ /\S\z/ && $content =~ /^[^.!?,;:\s]+/;
@@ -379,6 +370,8 @@ sub _trim {
1;
+=encoding utf8
+
=head1 NAME
Mojo::DOM - Minimalistic HTML/XML DOM parser with CSS selectors
@@ -392,7 +385,8 @@ Mojo::DOM - Minimalistic HTML/XML DOM parser with CSS selectors
# Find
say $dom->at('#b')->text;
- say $dom->find('p')->pluck('text');
+ say $dom->find('p')->text;
+ say $dom->find('[id]')->attr('id');
# Walk
say $dom->div->p->[0]->text;
@@ -408,9 +402,10 @@ Mojo::DOM - Minimalistic HTML/XML DOM parser with CSS selectors
# Modify
$dom->div->p->[1]->append('
C
');
+ $dom->find(':not(p)')->strip;
# Render
- say $dom;
+ say "$dom";
=head1 DESCRIPTION
@@ -421,7 +416,7 @@ use it for validation.
=head1 CASE SENSITIVITY
L defaults to HTML semantics, that means all tags and attributes
-are lowercased and selectors need to be lower case as well.
+are lowercased and selectors need to be lowercase as well.
my $dom = Mojo::DOM->new('
Hi!
');
say $dom->at('p')->text;
@@ -444,15 +439,15 @@ XML detection can also be disabled with the C method.
=head1 METHODS
-L inherits all methods from L and implements the
-following new ones.
+L implements the following methods.
=head2 new
my $dom = Mojo::DOM->new;
my $dom = Mojo::DOM->new('test');
-Construct a new array-based L object.
+Construct a new array-based L object and C HTML/XML document
+if necessary.
=head2 all_text
@@ -468,11 +463,21 @@ enabled by default.
# "foo\nbarbaz\n"
$dom->parse("
foo\n
bar
baz\n
")->div->all_text(0);
+=head2 ancestors
+
+ my $collection = $dom->ancestors;
+
+Return a L object containing the ancestors of this element
+as L objects, similar to C.
+
+ # List types of ancestor elements
+ say $dom->ancestors->type;
+
=head2 append
$dom = $dom->append('
Hi!
');
-Append to element.
+Append HTML/XML to element.
# "
');
-Append to element content.
+Append HTML/XML to element content.
# "
AB
"
$dom->parse('
A
')->at('h1')->append_content('B')->root;
@@ -490,35 +495,32 @@ Append to element content.
my $result = $dom->at('html title');
-Find a single element with CSS selectors. All selectors from L
-are supported.
+Find first element matching the CSS selector and return it as a L
+object or return C if none could be found. All selectors from
+L are supported.
# Find first element with "svg" namespace definition
my $namespace = $dom->at('[xmlns\:svg]')->{'xmlns:svg'};
-=head2 attrs
+=head2 attr
- my $attrs = $dom->attrs;
- my $foo = $dom->attrs('foo');
- $dom = $dom->attrs({foo => 'bar'});
- $dom = $dom->attrs(foo => 'bar');
+ my $attrs = $dom->attr;
+ my $foo = $dom->attr('foo');
+ $dom = $dom->attr({foo => 'bar'});
+ $dom = $dom->attr(foo => 'bar');
Element attributes.
-=head2 charset
-
- my $charset = $dom->charset;
- $dom = $dom->charset('UTF-8');
-
-Charset used for decoding and encoding HTML/XML.
+ # List id attributes
+ say $dom->find('*')->attr('id')->compact;
=head2 children
my $collection = $dom->children;
my $collection = $dom->children('div');
-Return a L object containing the children of this element,
-similar to C.
+Return a L object containing the children of this element as
+L objects, similar to C.
# Show type of random child element
say $dom->children->shuffle->first->type;
@@ -527,8 +529,7 @@ similar to C.
my $xml = $dom->content_xml;
-Render content of this element to XML. Note that the XML will be encoded if a
-C has been defined.
+Render content of this element to XML.
# "test"
$dom->parse('
test
')->div->content_xml;
@@ -537,14 +538,16 @@ C has been defined.
my $collection = $dom->find('html title');
-Find elements with CSS selectors and return a L object. All
-selectors from L are supported.
+Find all elements matching the CSS selector and return a L
+object containing these elements as L objects. All selectors from
+L are supported.
# Find a specific element and extract information
my $id = $dom->find('div')->[23]{id};
# Extract information from multiple elements
- my @headers = $dom->find('h1, h2, h3')->pluck('text')->each;
+ my @headers = $dom->find('h1, h2, h3')->text->each;
+ my @links = $dom->find('a[href]')->attr('href')->each;
=head2 namespace
@@ -562,7 +565,8 @@ Find element namespace.
my $sibling = $dom->next;
-Next sibling of element.
+Return L object for next sibling of element or C if there
+are no more siblings.
# "
B
"
$dom->parse('
A
B
')->at('h1')->next;
@@ -571,7 +575,8 @@ Next sibling of element.
my $parent = $dom->parent;
-Parent of element.
+Return L object for parent of element or C if this element
+has no parent.
=head2 parse
@@ -579,14 +584,14 @@ Parent of element.
Parse HTML/XML document with L.
- # Parse UTF-8 encoded XML
- my $dom = Mojo::DOM->new->charset('UTF-8')->xml(1)->parse($xml);
+ # Parse XML
+ my $dom = Mojo::DOM->new->xml(1)->parse($xml);
=head2 prepend
$dom = $dom->prepend('
Hi!
');
-Prepend to element.
+Prepend HTML/XML to element.
# "
');
-Prepend to element content.
+Prepend HTML/XML to element content.
# "
AB
"
$dom->parse('
B
')->at('h2')->prepend_content('A')->root;
@@ -604,37 +609,39 @@ Prepend to element content.
my $sibling = $dom->previous;
-Previous sibling of element.
+Return L object for previous sibling of element or C if
+there are no more siblings.
# "
A
"
$dom->parse('
A
B
')->at('h2')->previous;
=head2 remove
- my $old = $dom->remove;
+ my $parent = $dom->remove;
-Remove element.
+Remove element and return L object for parent of element.
# ""
- $dom->parse('
A
')->at('h1')->remove->root;
+ $dom->parse('
A
')->at('h1')->remove;
=head2 replace
- my $old = $dom->replace('
test
');
+ my $parent = $dom->replace('
test
');
-Replace element.
+Replace element with HTML/XML and return L object for parent of
+element.
# "
');
-Replace element content.
+Replace element content with HTML/XML.
# "
B
"
$dom->parse('
A
')->at('h1')->replace_content('B')->root;
@@ -646,7 +653,23 @@ Replace element content.
my $root = $dom->root;
-Find root node.
+Return L object for root node.
+
+=head2 strip
+
+ my $parent = $dom->strip;
+
+Remove element while preserving its content and return L object for
+parent of element.
+
+ # "
A
"
+ $dom->parse('
A
')->at('h1')->strip;
+
+=head2 tap
+
+ $dom = $dom->tap(sub {...});
+
+Alias for L.
=head2 text
@@ -695,8 +718,7 @@ is enabled by default.
my $xml = $dom->to_xml;
my $xml = "$dom";
-Render this element and its content to XML. Note that the XML will be encoded
-if a C has been defined.
+Render this element and its content to XML.
# "test"
$dom->parse('
test
')->div->b->to_xml;
@@ -704,9 +726,10 @@ if a C has been defined.
=head2 tree
my $tree = $dom->tree;
- $dom = $dom->tree(['root', [qw(text lalala)]]);
+ $dom = $dom->tree(['root', ['text', 'foo']]);
-Document Object Model.
+Document Object Model. Note that this structure should only be used very
+carefully since it is very dynamic.
=head2 type
@@ -716,7 +739,7 @@ Document Object Model.
Element type.
# List types of child elements
- say $dom->children->pluck('type');
+ say $dom->children->type;
=head2 xml
@@ -734,7 +757,7 @@ L object, depending on number of children.
say $dom->p->text;
say $dom->div->[23]->text;
- say $dom->div->pluck('text');
+ say $dom->div->text;
=head1 ELEMENT ATTRIBUTES
diff --git a/lib/Mojo/DOM/CSS.pm b/lib/Mojo/DOM/CSS.pm
index dae5b29..ae5479d 100644
--- a/lib/Mojo/DOM/CSS.pm
+++ b/lib/Mojo/DOM/CSS.pm
@@ -3,14 +3,14 @@ use Mojo::Base -base;
has 'tree';
-my $ESCAPE_RE = qr/\\[^[:xdigit:]]|\\[[:xdigit:]]{1,6}/;
+my $ESCAPE_RE = qr/\\[^0-9a-fA-F]|\\[0-9a-fA-F]{1,6}/;
my $ATTR_RE = qr/
\[
((?:$ESCAPE_RE|[\w\-])+) # Key
(?:
(\W)? # Operator
=
- (?:"((?:\\"|[^"])+)"|(\S+)) # Value
+ (?:"((?:\\"|[^"])*)"|(\S+)) # Value
)?
\]
/x;
@@ -52,7 +52,7 @@ sub select {
# Try all selectors with element
for my $part (@$pattern) {
- push(@results, $current) and last
+ push @results, $current and last
if $self->_combinator([reverse @$part], $current, $tree);
}
}
@@ -125,7 +125,6 @@ sub _compile {
my ($separator, $element, $pc, $attrs, $combinator)
= ($1, defined $2 ? $2 : '', $3, $6, $11);
- # Trash
next unless $separator || $element || $pc || $attrs || $combinator;
# New selector
@@ -251,10 +250,9 @@ sub _pc {
# Siblings
my $parent = $current->[3];
- my $start = $parent->[0] eq 'root' ? 1 : 4;
my @siblings;
my $type = $class =~ /of-type$/ ? $current->[1] : undef;
- for my $i ($start .. $#$parent) {
+ for my $i (($parent->[0] eq 'root' ? 1 : 4) .. $#$parent) {
my $sibling = $parent->[$i];
next unless $sibling->[0] eq 'tag';
next if defined $type && $type ne $sibling->[1];
@@ -279,8 +277,7 @@ sub _pc {
# Siblings
my $parent = $current->[3];
- my $start = $parent->[0] eq 'root' ? 1 : 4;
- for my $i ($start .. $#$parent) {
+ for my $i (($parent->[0] eq 'root' ? 1 : 4) .. $#$parent) {
my $sibling = $parent->[$i];
next if $sibling->[0] ne 'tag' || $sibling eq $current;
return undef unless defined $type && $sibling->[1] ne $type;
@@ -345,8 +342,7 @@ sub _sibling {
my $parent = $current->[3];
my $found;
- my $start = $parent->[0] eq 'root' ? 1 : 4;
- for my $e (@$parent[$start .. $#$parent]) {
+ for my $e (@$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent]) {
return $found if $e eq $current;
next unless $e->[0] eq 'tag';
@@ -367,7 +363,7 @@ sub _unescape {
$value =~ s/\\\n//g;
# Unescape Unicode characters
- $value =~ s/\\([[:xdigit:]]{1,6})\s?/pack('U', hex $1)/ge;
+ $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack('U', hex $1)/ge;
# Remove backslash
$value =~ s/\\//g;
@@ -377,6 +373,8 @@ sub _unescape {
1;
+=encoding utf8
+
=head1 NAME
Mojo::DOM::CSS - CSS selector engine
@@ -600,9 +598,10 @@ L implements the following attributes.
=head2 tree
my $tree = $css->tree;
- $css = $css->tree(['root', [qw(text lalala)]]);
+ $css = $css->tree(['root', ['text', 'foo']]);
-Document Object Model.
+Document Object Model. Note that this structure should only be used very
+carefully since it is very dynamic.
=head1 METHODS
diff --git a/lib/Mojo/DOM/HTML.pm b/lib/Mojo/DOM/HTML.pm
index a28a1e5..b7fee4c 100644
--- a/lib/Mojo/DOM/HTML.pm
+++ b/lib/Mojo/DOM/HTML.pm
@@ -1,15 +1,14 @@
package Mojo::DOM::HTML;
use Mojo::Base -base;
-use Mojo::Util qw(decode encode html_unescape xml_escape);
+use Mojo::Util qw(html_unescape xml_escape);
use Scalar::Util 'weaken';
-has [qw(charset xml)];
+has 'xml';
has tree => sub { ['root'] };
my $ATTR_RE = qr/
- \s*
- ([^=\s>]+) # Key
+ ([^<>=\s]+) # Key
(?:
\s*=\s*
(?:
@@ -41,9 +40,12 @@ my $TOKEN_RE = qr/
|
<(
\s*
- [^>\s]+ # Tag
+ [^<>\s]+ # Tag
+ \s*
(?:$ATTR_RE)* # Attributes
)>
+ |
+ (<) # Runaway "<"
)??
/xis;
@@ -76,32 +78,34 @@ my %INLINE = map { $_ => 1 } (
sub parse {
my ($self, $html) = @_;
- my $charset = $self->charset;
- defined ($html = decode($charset, $html)) || return $self->charset(undef) if $charset;
-
- my $tree = ['root'];
- my $current = $tree;
+ my $current = my $tree = ['root'];
while ($html =~ m/\G$TOKEN_RE/gcs) {
- my ($text, $pi, $comment, $cdata, $doctype, $tag)
- = ($1, $2, $3, $4, $5, $6);
+ my ($text, $pi, $comment, $cdata, $doctype, $tag, $runaway)
+ = ($1, $2, $3, $4, $5, $6, $11);
- # Text
+ # Text (and runaway "<")
+ $text .= '<' if defined $runaway;
if (length $text) {
- $text = html_unescape $text if (index $text, '&') >= 0;
- $self->_text($text, \$current);
+ $text = html_unescape $text;
+ my $sibling = $current->[-1];
+ if (ref $sibling && $sibling->[0] eq 'text') { $sibling->[1] .= $text }
+ else { push @$current, ['text', $text] }
}
# DOCTYPE
- if ($doctype) { $self->_doctype($doctype, \$current) }
+ if ($doctype) { push @$current, ['doctype', $doctype] }
# Comment
- elsif ($comment) { $self->_comment($comment, \$current) }
+ elsif ($comment) { push @$current, ['comment', $comment] }
# CDATA
- elsif ($cdata) { $self->_cdata($cdata, \$current) }
+ elsif ($cdata) { push @$current, ['cdata', $cdata] }
- # Processing instruction
- elsif ($pi) { $self->_pi($pi, \$current) }
+ # Processing instruction (try to detect XML)
+ elsif ($pi) {
+ $self->xml(1) if !defined $self->xml && $pi =~ /xml/i;
+ push @$current, ['pi', $pi];
+ }
# End
next unless $tag;
@@ -121,12 +125,10 @@ sub parse {
# Empty tag
next if $key eq '/';
- # Add unescaped value
- $value = html_unescape $value if $value && (index $value, '&') >= 0;
- $attrs{$key} = $value;
+ $attrs{$key} = defined $value ? html_unescape($value) : $value;
}
- # Start
+ # Tag
$self->_start($start, \%attrs, \$current);
# Empty element
@@ -134,9 +136,9 @@ sub parse {
if (!$self->xml && $VOID{$start}) || $attr =~ m!/\s*$!;
# Relaxed "script" or "style"
- if (grep { $_ eq $start } qw(script style)) {
+ if ($start eq 'script' || $start eq 'style') {
if ($html =~ m!\G(.*?)<\s*/\s*$start\s*>!gcsi) {
- $self->_raw($1, \$current);
+ push @$current, ['raw', $1];
$self->_end($start, \$current);
}
}
@@ -146,17 +148,7 @@ sub parse {
return $self->tree($tree);
}
-sub render {
- my $self = shift;
- my $content = $self->_render($self->tree);
- my $charset = $self->charset;
- return $charset ? encode($charset, $content) : $content;
-}
-
-sub _cdata {
- my ($self, $cdata, $current) = @_;
- push @$$current, ['cdata', $cdata];
-}
+sub render { $_[0]->_render($_[0]->tree) }
sub _close {
my ($self, $current, $tags, $stop) = @_;
@@ -165,8 +157,7 @@ sub _close {
# Check if parents need to be closed
my $parent = $$current;
- while ($parent) {
- last if $parent->[0] eq 'root' || $parent->[1] eq $stop;
+ while ($parent->[0] ne 'root' && $parent->[1] ne $stop) {
# Close
$tags->{$parent->[1]} and $self->_end($parent->[1], $current);
@@ -176,27 +167,13 @@ sub _close {
}
}
-sub _comment {
- my ($self, $comment, $current) = @_;
- push @$$current, ['comment', $comment];
-}
-
-sub _doctype {
- my ($self, $doctype, $current) = @_;
- push @$$current, ['doctype', $doctype];
-}
-
sub _end {
my ($self, $end, $current) = @_;
- # Not a tag
- return if $$current->[0] eq 'root';
-
# Search stack for start tag
my $found = 0;
my $next = $$current;
- while ($next) {
- last if $next->[0] eq 'root';
+ while ($next->[0] ne 'root') {
# Right tag
++$found and last if $next->[1] eq $end;
@@ -204,7 +181,6 @@ sub _end {
# Inline elements can only cross other inline elements
return if !$self->xml && $INLINE{$end} && !$INLINE{$next->[1]};
- # Parent
$next = $next->[3];
}
@@ -213,17 +189,14 @@ sub _end {
# Walk backwards
$next = $$current;
- while ($$current = $next) {
- last if $$current->[0] eq 'root';
+ while (($$current = $next) && $$current->[0] ne 'root') {
$next = $$current->[3];
# Match
if ($end eq $$current->[1]) { return $$current = $$current->[3] }
# Optional elements
- elsif ($OPTIONAL{$$current->[1]}) {
- $self->_end($$current->[1], $current);
- }
+ elsif ($OPTIONAL{$$current->[1]}) { $self->_end($$current->[1], $current) }
# Table
elsif ($end eq 'table') { $self->_close($current) }
@@ -233,18 +206,6 @@ sub _end {
}
}
-# Try to detect XML from processing instructions
-sub _pi {
- my ($self, $pi, $current) = @_;
- $self->xml(1) if !defined $self->xml && $pi =~ /xml/i;
- push @$$current, ['pi', $pi];
-}
-
-sub _raw {
- my ($self, $raw, $current) = @_;
- push @$$current, ['raw', $raw];
-}
-
sub _render {
my ($self, $tree) = @_;
@@ -256,16 +217,16 @@ sub _render {
return $tree->[1] if $e eq 'raw';
# DOCTYPE
- return "[1] . ">" if $e eq 'doctype';
+ return '[1] . '>' if $e eq 'doctype';
# Comment
- return "" if $e eq 'comment';
+ return '' if $e eq 'comment';
# CDATA
- return "[1] . "]]>" if $e eq 'cdata';
+ return '[1] . ']]>' if $e eq 'cdata';
# Processing instruction
- return "[1] . "?>" if $e eq 'pi';
+ return '[1] . '?>' if $e eq 'pi';
# Start tag
my $start = $e eq 'root' ? 1 : 2;
@@ -338,21 +299,18 @@ sub _start {
elsif ($start eq 'tr') { $self->_close($current, {tr => 1}) }
# "