diff --git a/modules/Mojo/Base.pm b/modules/Mojo/Base.pm index 0b71ab2..8442b58 100644 --- a/modules/Mojo/Base.pm +++ b/modules/Mojo/Base.pm @@ -1,390 +1,419 @@ package Mojo::Base; use strict; use warnings; use utf8; use feature ':5.10'; use mro; # No imports because we get subclassed, a lot! use Carp (); use Scalar::Util (); # Defer to runtime so Mojo::Util can use "-strict" require Mojo::Util; # Only Perl 5.14+ requires it on demand use IO::Handle (); # Role support requires Role::Tiny 2.000001+ use constant ROLES => !!(eval { require Role::Tiny; Role::Tiny->VERSION('2.000001'); 1 }); +# async/await support requires Future::AsyncAwait 0.35+ +use constant ASYNC => $ENV{MOJO_NO_ASYNC} ? 0 : !!(eval { + require Future::AsyncAwait; + Future::AsyncAwait->VERSION('0.35'); + 1; +}); + # Protect subclasses using AUTOLOAD sub DESTROY { } sub attr { my ($self, $attrs, $value, %kv) = @_; return unless (my $class = ref $self || $self) && $attrs; Carp::croak 'Default has to be a code reference or constant value' if ref $value && ref $value ne 'CODE'; Carp::croak 'Unsupported attribute option' if grep { $_ ne 'weak' } keys %kv; # Weaken if ($kv{weak}) { state %weak_names; unless ($weak_names{$class}) { my $names = $weak_names{$class} = []; my $sub = sub { my $self = shift->next::method(@_); ref $self->{$_} and Scalar::Util::weaken $self->{$_} for @$names; return $self; }; Mojo::Util::monkey_patch(my $base = $class . '::_Base', 'new', $sub); no strict 'refs'; unshift @{"${class}::ISA"}, $base; } push @{$weak_names{$class}}, ref $attrs eq 'ARRAY' ? @$attrs : $attrs; } for my $attr (@{ref $attrs eq 'ARRAY' ? $attrs : [$attrs]}) { Carp::croak qq{Attribute "$attr" invalid} unless $attr =~ /^[a-zA-Z_]\w*$/; # Very performance-sensitive code with lots of micro-optimizations my $sub; if ($kv{weak}) { if (ref $value) { $sub = sub { return exists $_[0]{$attr} ? $_[0]{$attr} : ( ref($_[0]{$attr} = $value->($_[0])) && Scalar::Util::weaken($_[0]{$attr}), $_[0]{$attr} ) if @_ == 1; ref($_[0]{$attr} = $_[1]) and Scalar::Util::weaken($_[0]{$attr}); $_[0]; }; } else { $sub = sub { return $_[0]{$attr} if @_ == 1; ref($_[0]{$attr} = $_[1]) and Scalar::Util::weaken($_[0]{$attr}); $_[0]; }; } } elsif (ref $value) { $sub = sub { return exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value->($_[0])) if @_ == 1; $_[0]{$attr} = $_[1]; $_[0]; }; } elsif (defined $value) { $sub = sub { return exists $_[0]{$attr} ? $_[0]{$attr} : ($_[0]{$attr} = $value) if @_ == 1; $_[0]{$attr} = $_[1]; $_[0]; }; } else { $sub = sub { return $_[0]{$attr} if @_ == 1; $_[0]{$attr} = $_[1]; $_[0] }; } Mojo::Util::monkey_patch($class, $attr, $sub); } } sub import { my ($class, $caller) = (shift, caller); return unless my @flags = @_; - # Base - if ($flags[0] eq '-base') { $flags[0] = $class } - - # Role - if ($flags[0] eq '-role') { - Carp::croak 'Role::Tiny 2.000001+ is required for roles' unless ROLES; - Mojo::Util::monkey_patch($caller, 'has', sub { attr($caller, @_) }); - eval "package $caller; use Role::Tiny; 1" or die $@; - } - - # Module and not -strict - elsif ($flags[0] !~ /^-/) { - no strict 'refs'; - require(Mojo::Util::class_to_path($flags[0])) unless $flags[0]->can('new'); - push @{"${caller}::ISA"}, $flags[0]; - Mojo::Util::monkey_patch($caller, 'has', sub { attr($caller, @_) }); - } - # Mojo modules are strict! $_->import for qw(strict warnings utf8); feature->import(':5.10'); - # Signatures (Perl 5.20+) - if (($flags[1] || '') eq '-signatures') { - Carp::croak 'Subroutine signatures require Perl 5.20+' if $] < 5.020; - require experimental; - experimental->import('signatures'); + while (my $flag = shift @flags) { + + # Base + if ($flag eq '-base') { push @flags, $class } + + # Role + elsif ($flag eq '-role') { + Carp::croak 'Role::Tiny 2.000001+ is required for roles' unless ROLES; + Mojo::Util::monkey_patch($caller, 'has', sub { attr($caller, @_) }); + eval "package $caller; use Role::Tiny; 1" or die $@; + } + + # async/await + elsif ($flag eq '-async') { + Carp::croak 'Future::AsyncAwait 0.35+ is required for async/await' + unless ASYNC; + Future::AsyncAwait->import_into($caller, future_class => 'Mojo::Promise'); + } + + # Signatures (Perl 5.20+) + elsif ($flag eq '-signatures') { + Carp::croak 'Subroutine signatures require Perl 5.20+' if $] < 5.020; + require experimental; + experimental->import('signatures'); + } + + # Module + elsif ($flag !~ /^-/) { + no strict 'refs'; + require(Mojo::Util::class_to_path($flag)) unless $flag->can('new'); + push @{"${caller}::ISA"}, $flag; + Mojo::Util::monkey_patch($caller, 'has', sub { attr($caller, @_) }); + } + + elsif ($flag ne '-strict') { Carp::croak "Unsupported flag: $flag" } } } sub new { my $class = shift; bless @_ ? @_ > 1 ? {@_} : {%{$_[0]}} : {}, ref $class || $class; } sub tap { my ($self, $cb) = (shift, shift); $_->$cb(@_) for $self; return $self; } sub with_roles { Carp::croak 'Role::Tiny 2.000001+ is required for roles' unless ROLES; my ($self, @roles) = @_; + return $self unless @roles; return Role::Tiny->create_class_with_roles($self, map { /^\+(.+)$/ ? "${self}::Role::$1" : $_ } @roles) unless my $class = Scalar::Util::blessed $self; return Role::Tiny->apply_roles_to_object($self, map { /^\+(.+)$/ ? "${class}::Role::$1" : $_ } @roles); } 1; =encoding utf8 =head1 NAME Mojo::Base - Minimal base class for Mojo projects =head1 SYNOPSIS package Cat; use Mojo::Base -base; has name => 'Nyan'; has ['age', 'weight'] => 4; package Tiger; use Mojo::Base 'Cat'; has friend => sub { Cat->new }; has stripes => 42; package main; use Mojo::Base -strict; my $mew = Cat->new(name => 'Longcat'); say $mew->age; say $mew->age(3)->weight(5)->age; my $rawr = Tiger->new(stripes => 38, weight => 250); say $rawr->tap(sub { $_->friend->name('Tacgnol') })->weight; =head1 DESCRIPTION L is a simple base class for L projects with fluent interfaces. # Automatically enables "strict", "warnings", "utf8" and Perl 5.10 features use Mojo::Base -strict; use Mojo::Base -base; use Mojo::Base 'SomeBaseClass'; use Mojo::Base -role; All four forms save a lot of typing. Note that role support depends on L (2.000001+). # use Mojo::Base -strict; use strict; use warnings; use utf8; use feature ':5.10'; use mro; use IO::Handle (); # use Mojo::Base -base; use strict; use warnings; use utf8; use feature ':5.10'; use mro; use IO::Handle (); push @ISA, 'Mojo::Base'; sub has { Mojo::Base::attr(__PACKAGE__, @_) } # use Mojo::Base 'SomeBaseClass'; use strict; use warnings; use utf8; use feature ':5.10'; use mro; use IO::Handle (); require SomeBaseClass; push @ISA, 'SomeBaseClass'; sub has { Mojo::Base::attr(__PACKAGE__, @_) } # use Mojo::Base -role; use strict; use warnings; use utf8; use feature ':5.10'; use mro; use IO::Handle (); use Role::Tiny; sub has { Mojo::Base::attr(__PACKAGE__, @_) } -On Perl 5.20+ you can also append a C<-signatures> flag to all four forms and +On Perl 5.20+ you can also use the C<-signatures> flag with all four forms and enable support for L. # Also enable signatures use Mojo::Base -strict, -signatures; use Mojo::Base -base, -signatures; use Mojo::Base 'SomeBaseClass', -signatures; use Mojo::Base -role, -signatures; +If you have L 0.35+ installed you can also use the C<-async> +flag to activate the C and C keywords to deal much more +efficiently with promises. Note that this feature is B and might +change without warning! + + # Also enable async/await + use Mojo::Base -strict, -async; + use Mojo::Base -base, -signatures, -async; + This will also disable experimental warnings on versions of Perl where this feature was still experimental. =head1 FLUENT INTERFACES Fluent interfaces are a way to design object-oriented APIs around method chaining to create domain-specific languages, with the goal of making the -readablity of the source code close to written prose. +readability of the source code close to written prose. package Duck; use Mojo::Base -base; has 'name'; sub quack { my $self = shift; my $name = $self->name; say "$name: Quack!" } L will help you with this by having all attribute accessors created with L (or L) return their invocant (C<$self>) whenever they are used to assign a new attribute value. Duck->new->name('Donald')->quack; In this case the C attribute accessor is called on the object created by Cnew>. It assigns a new attribute value and then returns the C object, so the C method can be called on it afterwards. These method chains can continue until one of the methods called does not return the C object. =head1 FUNCTIONS L implements the following functions, which can be imported with the C<-base> flag or by setting a base class. =head2 has has 'name'; has ['name1', 'name2', 'name3']; has name => 'foo'; has name => sub {...}; has ['name1', 'name2', 'name3'] => 'foo'; has ['name1', 'name2', 'name3'] => sub {...}; has name => sub {...}, weak => 1; has name => undef, weak => 1; has ['name1', 'name2', 'name3'] => sub {...}, weak => 1; Create attributes for hash-based objects, just like the L method. =head1 METHODS L implements the following methods. =head2 attr $object->attr('name'); SubClass->attr('name'); SubClass->attr(['name1', 'name2', 'name3']); SubClass->attr(name => 'foo'); SubClass->attr(name => sub {...}); SubClass->attr(['name1', 'name2', 'name3'] => 'foo'); SubClass->attr(['name1', 'name2', 'name3'] => sub {...}); SubClass->attr(name => sub {...}, weak => 1); SubClass->attr(name => undef, weak => 1); SubClass->attr(['name1', 'name2', 'name3'] => sub {...}, weak => 1); Create attribute accessors 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 executed at accessor read time if there's no set value, and gets passed the current instance of the object as first argument. Accessors can be chained, that means they return their invocant when they are called with an argument. These options are currently available: =over 2 =item weak weak => $bool Weaken attribute reference to avoid L and memory leaks. =back =head2 new my $object = SubClass->new; my $object = SubClass->new(name => 'value'); my $object = SubClass->new({name => 'value'}); This base class provides a basic constructor for hash-based objects. You can pass it either a hash or a hash reference with attribute values. =head2 tap $object = $object->tap(sub {...}); $object = $object->tap('some_method'); $object = $object->tap('some_method', @args); Tap into a method chain to perform operations on an object within the chain (also known as a K combinator or Kestrel). The object will be the first argument passed to the callback, and is also available as C<$_>. The callback's return value will be ignored; instead, the object (the callback's first argument) will be the return value. In this way, arbitrary code can be used within (i.e., spliced or tapped into) a chained set of object method calls. # Longer version $object = $object->tap(sub { $_->some_method(@args) }); # Inject side effects into a method chain $object->foo('A')->tap(sub { say $_->foo })->foo('B'); =head2 with_roles my $new_class = SubClass->with_roles('SubClass::Role::One'); my $new_class = SubClass->with_roles('+One', '+Two'); $object = $object->with_roles('+One', '+Two'); Create a new class with one or more L roles. If called on a class returns the new class, or if called on an object reblesses the object into the new class. For roles following the naming scheme C you can use the shorthand C<+RoleName>. Note that role support depends on L (2.000001+). # Create a new class with the role "SubClass::Role::Foo" and instantiate it my $new_class = SubClass->with_roles('+Foo'); my $object = $new_class->new; =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Collection.pm b/modules/Mojo/Collection.pm index 593119e..1f46622 100644 --- a/modules/Mojo/Collection.pm +++ b/modules/Mojo/Collection.pm @@ -1,385 +1,414 @@ package Mojo::Collection; use Mojo::Base -strict; +use re 'is_regexp'; use Carp 'croak'; use Exporter 'import'; use List::Util; use Mojo::ByteStream; use Scalar::Util 'blessed'; our @EXPORT_OK = ('c'); sub TO_JSON { [@{shift()}] } sub c { __PACKAGE__->new(@_) } sub compact { my $self = shift; return $self->new(grep { defined && (ref || length) } @$self); } sub each { my ($self, $cb) = @_; return @$self unless $cb; my $i = 1; $_->$cb($i++) for @$self; return $self; } sub first { my ($self, $cb) = (shift, shift); return $self->[0] unless $cb; - return List::Util::first { $_ =~ $cb } @$self if ref $cb eq 'Regexp'; + return List::Util::first { $_ =~ $cb } @$self if is_regexp $cb; return List::Util::first { $_->$cb(@_) } @$self; } sub flatten { $_[0]->new(_flatten(@{$_[0]})) } sub grep { my ($self, $cb) = (shift, shift); - return $self->new(grep { $_ =~ $cb } @$self) if ref $cb eq 'Regexp'; + return $self->new(grep { $_ =~ $cb } @$self) if is_regexp $cb; return $self->new(grep { $_->$cb(@_) } @$self); } +sub head { + my ($self, $size) = @_; + return $self->new(@$self) if $size > @$self; + return $self->new(@$self[0 .. ($size - 1)]) if $size >= 0; + return $self->new(@$self[0 .. ($#$self + $size)]); +} + sub join { Mojo::ByteStream->new(join $_[1] // '', map {"$_"} @{$_[0]}); } sub last { shift->[-1] } sub map { my ($self, $cb) = (shift, shift); return $self->new(map { $_->$cb(@_) } @$self); } sub new { my $class = shift; return bless [@_], ref $class || $class; } sub reduce { my $self = shift; @_ = (@_, @$self); goto &List::Util::reduce; } sub reverse { $_[0]->new(reverse @{$_[0]}) } sub shuffle { $_[0]->new(List::Util::shuffle @{$_[0]}) } sub size { scalar @{$_[0]} } -sub slice { - my $self = shift; - return $self->new(@$self[@_]); -} - sub sort { my ($self, $cb) = @_; return $self->new(sort @$self) unless $cb; my $caller = caller; no strict 'refs'; my @sorted = sort { local (*{"${caller}::a"}, *{"${caller}::b"}) = (\$a, \$b); $a->$cb($b); } @$self; return $self->new(@sorted); } +sub tail { + my ($self, $size) = @_; + return $self->new(@$self) if $size > @$self; + return $self->new(@$self[($#$self - ($size - 1)) .. $#$self]) if $size >= 0; + return $self->new(@$self[(0 - $size) .. $#$self]); +} + sub tap { shift->Mojo::Base::tap(@_) } sub to_array { [@{shift()}] } sub uniq { my ($self, $cb) = (shift, shift); my %seen; return $self->new(grep { !$seen{$_->$cb(@_) // ''}++ } @$self) if $cb; return $self->new(grep { !$seen{$_ // ''}++ } @$self); } sub with_roles { shift->Mojo::Base::with_roles(@_) } sub _flatten { map { _ref($_) ? _flatten(@$_) : $_ } @_; } sub _ref { ref $_[0] eq 'ARRAY' || blessed $_[0] && $_[0]->isa(__PACKAGE__) } 1; =encoding utf8 =head1 NAME Mojo::Collection - Collection =head1 SYNOPSIS use Mojo::Collection; # Manipulate collection my $collection = Mojo::Collection->new(qw(just works)); unshift @$collection, 'it'; say $collection->join("\n"); # Chain methods $collection->map(sub { ucfirst })->shuffle->each(sub { my ($word, $num) = @_; say "$num: $word"; }); # Use the alternative constructor use Mojo::Collection 'c'; c(qw(a b c))->join('/')->url_escape->say; =head1 DESCRIPTION L is an array-based container for collections. # Access array directly to manipulate collection my $collection = Mojo::Collection->new(1 .. 25); $collection->[23] += 100; say for @$collection; =head1 FUNCTIONS L implements the following functions, which can be imported individually. =head2 c my $collection = c(1, 2, 3); Construct a new array-based L object. =head1 METHODS L implements the following methods. =head2 TO_JSON my $array = $collection->TO_JSON; Alias for L. =head2 compact my $new = $collection->compact; Create a new collection with all elements that are defined and not an empty string. # "0, 1, 2, 3" c(0, 1, undef, 2, '', 3)->compact->join(', '); =head2 each my @elements = $collection->each; $collection = $collection->each(sub {...}); Evaluate callback for each element in collection, or return all elements as a list if none has been provided. The element will be the first argument passed to the callback, and is also available as C<$_>. # Make a numbered list $collection->each(sub { my ($e, $num) = @_; say "$num: $e"; }); =head2 first my $first = $collection->first; my $first = $collection->first(qr/foo/); my $first = $collection->first(sub {...}); my $first = $collection->first('some_method'); my $first = $collection->first('some_method', @args); Evaluate regular expression/callback for, or call method on, each element in collection and return the first one that matched the regular expression, or for which the callback/method returned true. The element will be the first argument passed to the callback, and is also available as C<$_>. # Longer version my $first = $collection->first(sub { $_->some_method(@args) }); # Find first value that contains the word "mojo" my $interesting = $collection->first(qr/mojo/i); # Find first value that is greater than 5 my $greater = $collection->first(sub { $_ > 5 }); =head2 flatten my $new = $collection->flatten; Flatten nested collections/arrays recursively and create a new collection with all elements. # "1, 2, 3, 4, 5, 6, 7" c(1, [2, [3, 4], 5, [6]], 7)->flatten->join(', '); =head2 grep my $new = $collection->grep(qr/foo/); my $new = $collection->grep(sub {...}); my $new = $collection->grep('some_method'); my $new = $collection->grep('some_method', @args); Evaluate regular expression/callback for, or call method on, each element in collection and create a new collection with all elements that matched the regular expression, or for which the callback/method returned true. The element will be the first argument passed to the callback, and is also available as C<$_>. # Longer version my $new = $collection->grep(sub { $_->some_method(@args) }); # Find all values that contain the word "mojo" my $interesting = $collection->grep(qr/mojo/i); # Find all values that are greater than 5 my $greater = $collection->grep(sub { $_ > 5 }); +=head2 head + + my $new = $collection->head(4); + my $new = $collection->head(-2); + +Create a new collection with up to the specified number of elements from the +beginning of the collection. A negative number will count from the end. + + # "A B C" + c('A', 'B', 'C', 'D', 'E')->head(3)->join(' '); + + # "A B" + c('A', 'B', 'C', 'D', 'E')->head(-3)->join(' '); + =head2 join my $stream = $collection->join; my $stream = $collection->join("\n"); Turn collection into L. # Join all values with commas $collection->join(', ')->say; =head2 last my $last = $collection->last; Return the last element in collection. =head2 map my $new = $collection->map(sub {...}); my $new = $collection->map('some_method'); my $new = $collection->map('some_method', @args); Evaluate callback for, or call method on, each element in collection and create a new collection from the results. The element will be the first argument passed to the callback, and is also available as C<$_>. # Longer version my $new = $collection->map(sub { $_->some_method(@args) }); # Append the word "mojo" to all values my $mojoified = $collection->map(sub { $_ . 'mojo' }); =head2 new my $collection = Mojo::Collection->new(1, 2, 3); Construct a new array-based L object. =head2 reduce my $result = $collection->reduce(sub {...}); my $result = $collection->reduce(sub {...}, $initial); Reduce elements in collection with a callback and return its final result, setting C<$a> and C<$b> each time the callback is executed. The first time C<$a> will be set to an optional initial value or the first element in the collection. And from then on C<$a> will be set to the return value of the callback, while C<$b> will always be set to the next element in the collection. # Calculate the sum of all values my $sum = $collection->reduce(sub { $a + $b }); # Count how often each value occurs in collection my $hash = $collection->reduce(sub { $a->{$b}++; $a }, {}); =head2 reverse my $new = $collection->reverse; Create a new collection with all elements in reverse order. -=head2 slice - - my $new = $collection->slice(4 .. 7); - -Create a new collection with all selected elements. - - # "B C E" - c('A', 'B', 'C', 'D', 'E')->slice(1, 2, 4)->join(' '); - =head2 shuffle my $new = $collection->shuffle; Create a new collection with all elements in random order. =head2 size my $size = $collection->size; Number of elements in collection. =head2 sort my $new = $collection->sort; my $new = $collection->sort(sub {...}); Sort elements based on return value of a callback and create a new collection from the results, setting C<$a> and C<$b> to the elements being compared, each time the callback is executed. # Sort values case-insensitive my $case_insensitive = $collection->sort(sub { uc($a) cmp uc($b) }); +=head2 tail + + my $new = $collection->tail(4); + my $new = $collection->tail(-2); + +Create a new collection with up to the specified number of elements from the +end of the collection. A negative number will count from the beginning. + + # "C D E" + c('A', 'B', 'C', 'D', 'E')->tail(3)->join(' '); + + # "D E" + c('A', 'B', 'C', 'D', 'E')->tail(-3)->join(' '); + =head2 tap $collection = $collection->tap(sub {...}); Alias for L. =head2 to_array my $array = $collection->to_array; Turn collection into array reference. =head2 uniq my $new = $collection->uniq; my $new = $collection->uniq(sub {...}); my $new = $collection->uniq('some_method'); my $new = $collection->uniq('some_method', @args); Create a new collection without duplicate elements, using the string representation of either the elements or the return value of the callback/method to decide uniqueness. Note that C and empty string are treated the same. # Longer version my $new = $collection->uniq(sub { $_->some_method(@args) }); # "foo bar baz" c('foo', 'bar', 'bar', 'baz')->uniq->join(' '); # "[[1, 2], [2, 1]]" c([1, 2], [2, 1], [3, 2])->uniq(sub{ $_->[1] })->to_array; =head2 with_roles my $new_class = Mojo::Collection->with_roles('Mojo::Collection::Role::One'); my $new_class = Mojo::Collection->with_roles('+One', '+Two'); $collection = $collection->with_roles('+One', '+Two'); Alias for L. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Content.pm b/modules/Mojo/Content.pm index d0890dc..5cf7854 100644 --- a/modules/Mojo/Content.pm +++ b/modules/Mojo/Content.pm @@ -1,591 +1,595 @@ package Mojo::Content; use Mojo::Base 'Mojo::EventEmitter'; use Carp 'croak'; use Compress::Raw::Zlib qw(WANT_GZIP Z_STREAM_END); use Mojo::Headers; use Scalar::Util 'looks_like_number'; has [qw(auto_decompress auto_relax relaxed skip_body)]; has headers => sub { Mojo::Headers->new }; has max_buffer_size => sub { $ENV{MOJO_MAX_BUFFER_SIZE} || 262144 }; has max_leftover_size => sub { $ENV{MOJO_MAX_LEFTOVER_SIZE} || 262144 }; my $BOUNDARY_RE = qr!multipart.*boundary\s*=\s*(?:"([^"]+)"|([\w'(),.:?\-+/]+))!i; sub body_contains { croak 'Method "body_contains" not implemented by subclass'; } sub body_size { croak 'Method "body_size" not implemented by subclass' } sub boundary { (shift->headers->content_type // '') =~ $BOUNDARY_RE ? $1 // $2 : undef; } sub charset { my $type = shift->headers->content_type // ''; return $type =~ /charset\s*=\s*"?([^"\s;]+)"?/i ? $1 : undef; } sub clone { my $self = shift; return undef if $self->is_dynamic; return $self->new(headers => $self->headers->clone); } sub generate_body_chunk { my ($self, $offset) = @_; $self->emit(drain => $offset) unless length($self->{body_buffer} //= ''); - my $len = $self->headers->content_length; - return '' if looks_like_number $len && $len == $offset; - my $chunk = delete $self->{body_buffer}; - return $self->{eof} ? '' : undef unless length $chunk; + return delete $self->{body_buffer} if length $self->{body_buffer}; + return '' if $self->{eof}; - return $chunk; + my $len = $self->headers->content_length; + return looks_like_number $len && $len == $offset ? '' : undef; } sub get_body_chunk { croak 'Method "get_body_chunk" not implemented by subclass'; } sub get_header_chunk { substr shift->_headers->{header_buffer}, shift, 131072 } sub header_size { length shift->_headers->{header_buffer} } sub headers_contain { index(shift->_headers->{header_buffer}, shift) >= 0 } sub is_chunked { !!shift->headers->transfer_encoding } sub is_compressed { lc(shift->headers->content_encoding // '') eq 'gzip' } sub is_dynamic { !!$_[0]{dynamic} } sub is_finished { (shift->{state} // '') eq 'finished' } sub is_limit_exceeded { !!shift->{limit} } sub is_multipart {undef} sub is_parsing_body { (shift->{state} // '') eq 'body' } sub leftovers { shift->{buffer} } sub parse { my $self = shift; # Headers $self->_parse_until_body(@_); return $self if $self->{state} eq 'headers'; # Chunked content $self->{real_size} //= 0; if ($self->is_chunked && $self->{state} ne 'headers') { $self->_parse_chunked; $self->{state} = 'finished' if ($self->{chunk_state} // '') eq 'finished'; } # Not chunked, pass through to second buffer else { $self->{real_size} += length $self->{pre_buffer}; my $limit = $self->is_finished && length($self->{buffer}) > $self->max_leftover_size; $self->{buffer} .= $self->{pre_buffer} unless $limit; $self->{pre_buffer} = ''; } # No content if ($self->skip_body) { $self->{state} = 'finished'; return $self; } # Relaxed parsing my $headers = $self->headers; my $len = $headers->content_length // ''; if ($self->auto_relax && !length $len) { my $connection = lc($headers->connection // ''); $self->relaxed(1) if $connection eq 'close' || !$connection; } # Chunked or relaxed content if ($self->is_chunked || $self->relaxed) { $self->_decompress($self->{buffer} //= ''); $self->{size} += length $self->{buffer}; $self->{buffer} = ''; return $self; } # Normal content $len = 0 unless looks_like_number $len; if ((my $need = $len - ($self->{size} ||= 0)) > 0) { my $len = length $self->{buffer}; my $chunk = substr $self->{buffer}, 0, $need > $len ? $len : $need, ''; $self->_decompress($chunk); $self->{size} += length $chunk; } $self->{state} = 'finished' if $len <= $self->progress; return $self; } sub parse_body { my $self = shift; $self->{state} = 'body'; return $self->parse(@_); } sub progress { my $self = shift; return 0 unless my $state = $self->{state}; return 0 unless $state eq 'body' || $state eq 'finished'; return $self->{raw_size} - ($self->{header_size} || 0); } sub write { my ($self, $chunk, $cb) = @_; $self->{dynamic} = 1; $self->{body_buffer} .= $chunk if defined $chunk; $self->once(drain => $cb) if $cb; $self->{eof} = 1 if defined $chunk && !length $chunk; return $self; } sub write_chunk { my ($self, $chunk, $cb) = @_; - $self->headers->transfer_encoding('chunked') unless $self->is_chunked; - $self->write(defined $chunk ? $self->_build_chunk($chunk) : $chunk, $cb); + + $self->headers->transfer_encoding('chunked') unless $self->{chunked}; + @{$self}{qw(chunked dynamic)} = (1, 1); + + $self->{body_buffer} .= $self->_build_chunk($chunk) if defined $chunk; + $self->once(drain => $cb) if $cb; $self->{eof} = 1 if defined $chunk && !length $chunk; + return $self; } sub _build_chunk { my ($self, $chunk) = @_; # End return "\x0d\x0a0\x0d\x0a\x0d\x0a" unless length $chunk; # First chunk has no leading CRLF my $crlf = $self->{chunks}++ ? "\x0d\x0a" : ''; return $crlf . sprintf('%x', length $chunk) . "\x0d\x0a$chunk"; } sub _decompress { my ($self, $chunk) = @_; # No compression return $self->emit(read => $chunk) unless $self->auto_decompress && $self->is_compressed; # Decompress $self->{post_buffer} .= $chunk; my $gz = $self->{gz} //= 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; # Check buffer size @$self{qw(state limit)} = ('finished', 1) if length($self->{post_buffer} // '') > $self->max_buffer_size; } sub _headers { my $self = shift; return $self if defined $self->{header_buffer}; my $headers = $self->headers->to_string; $self->{header_buffer} = $headers ? "$headers\x0d\x0a\x0d\x0a" : "\x0d\x0a"; return $self; } sub _parse_chunked { my $self = shift; # Trailing headers return $self->_parse_chunked_trailing_headers if ($self->{chunk_state} // '') eq 'trailing_headers'; while (my $len = length $self->{pre_buffer}) { # Start new chunk (ignore the chunk extension) unless ($self->{chunk_len}) { last unless $self->{pre_buffer} =~ s/^(?:\x0d?\x0a)?([0-9a-fA-F]+).*\x0a//; next if $self->{chunk_len} = hex $1; # Last chunk $self->{chunk_state} = 'trailing_headers'; last; } # Remove as much as possible from payload $len = $self->{chunk_len} if $self->{chunk_len} < $len; $self->{buffer} .= substr $self->{pre_buffer}, 0, $len, ''; $self->{real_size} += $len; $self->{chunk_len} -= $len; } # Trailing headers $self->_parse_chunked_trailing_headers if ($self->{chunk_state} // '') eq 'trailing_headers'; # Check buffer size @$self{qw(state limit)} = ('finished', 1) if length($self->{pre_buffer} // '') > $self->max_buffer_size; } sub _parse_chunked_trailing_headers { my $self = shift; my $headers = $self->headers->parse(delete $self->{pre_buffer}); return unless $headers->is_finished; $self->{chunk_state} = 'finished'; # Take care of leftover and replace Transfer-Encoding with Content-Length $self->{buffer} .= $headers->leftovers; $headers->remove('Transfer-Encoding'); $headers->content_length($self->{real_size}) unless $headers->content_length; } sub _parse_headers { my $self = shift; my $headers = $self->headers->parse(delete $self->{pre_buffer}); return unless $headers->is_finished; $self->{state} = 'body'; # Take care of leftovers my $leftovers = $self->{pre_buffer} = $headers->leftovers; $self->{header_size} = $self->{raw_size} - length $leftovers; } sub _parse_until_body { my ($self, $chunk) = @_; $self->{raw_size} += length($chunk //= ''); $self->{pre_buffer} .= $chunk; $self->_parse_headers if ($self->{state} ||= 'headers') eq 'headers'; - $self->emit('body') if $self->{state} ne 'headers' && !$self->{body}++; + $self->emit('body') if $self->{state} ne 'headers' && !$self->{body}++; } 1; =encoding utf8 =head1 NAME Mojo::Content - HTTP content base class =head1 SYNOPSIS package Mojo::Content::MyContent; use Mojo::Base 'Mojo::Content'; sub body_contains {...} sub body_size {...} sub get_body_chunk {...} =head1 DESCRIPTION L is an abstract base class for HTTP content containers, based on L and L, like L and L. =head1 EVENTS L inherits all events from L and can emit the following new ones. =head2 body $content->on(body => sub { my $content = shift; ... }); Emitted once all headers have been parsed and the body starts. $content->on(body => sub { my $content = shift; $content->auto_upgrade(0) if $content->headers->header('X-No-MultiPart'); }); =head2 drain $content->on(drain => sub { my ($content, $offset) = @_; ... }); Emitted once all data has been written. $content->on(drain => sub { my $content = shift; $content->write_chunk(time); }); =head2 read $content->on(read => sub { my ($content, $bytes) = @_; ... }); Emitted when a new chunk of content arrives. $content->on(read => sub { my ($content, $bytes) = @_; say "Streaming: $bytes"; }); =head1 ATTRIBUTES L implements the following attributes. =head2 auto_decompress my $bool = $content->auto_decompress; $content = $content->auto_decompress($bool); Decompress content automatically if L is true. =head2 auto_relax my $bool = $content->auto_relax; $content = $content->auto_relax($bool); Try to detect when relaxed parsing is necessary. =head2 headers my $headers = $content->headers; $content = $content->headers(Mojo::Headers->new); Content headers, defaults to a L object. =head2 max_buffer_size my $size = $content->max_buffer_size; $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> (256KiB). =head2 max_leftover_size my $size = $content->max_leftover_size; $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> (256KiB). =head2 relaxed my $bool = $content->relaxed; $content = $content->relaxed($bool); Activate relaxed parsing for responses that are terminated with a connection close. =head2 skip_body my $bool = $content->skip_body; $content = $content->skip_body($bool); Skip body parsing and finish after headers. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 body_contains my $bool = $content->body_contains('foo bar baz'); Check if content contains a specific string. Meant to be overloaded in a subclass. =head2 body_size my $size = $content->body_size; Content size in bytes. Meant to be overloaded in a subclass. =head2 boundary my $boundary = $content->boundary; Extract multipart boundary from C header. =head2 charset my $charset = $content->charset; Extract charset from C header. =head2 clone my $clone = $content->clone; Return a new L object cloned from this content if possible, otherwise return C. =head2 generate_body_chunk my $bytes = $content->generate_body_chunk(0); Generate dynamic content. =head2 get_body_chunk my $bytes = $content->get_body_chunk(0); 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 specific position. Note that this method finalizes the content. =head2 header_size my $size = $content->header_size; Size of headers in bytes. Note that this method finalizes the content. =head2 headers_contain my $bool = $content->headers_contain('foo bar baz'); Check if headers contain a specific string. Note that this method finalizes the content. =head2 is_chunked my $bool = $content->is_chunked; Check if C header indicates chunked transfer encoding. =head2 is_compressed my $bool = $content->is_compressed; Check C header for C value. =head2 is_dynamic my $bool = $content->is_dynamic; Check if content will be dynamically generated, which prevents L from working. =head2 is_finished my $bool = $content->is_finished; Check if parser is finished. =head2 is_limit_exceeded my $bool = $content->is_limit_exceeded; Check if buffer has exceeded L. =head2 is_multipart my $bool = $content->is_multipart; False, this is not a L object. =head2 is_parsing_body my $bool = $content->is_parsing_body; Check if body parsing started yet. =head2 leftovers my $bytes = $content->leftovers; Get leftover data from content parser. =head2 parse $content = $content->parse("Content-Length: 12\x0d\x0a\x0d\x0aHello World!"); Parse content chunk. =head2 parse_body $content = $content->parse_body('Hi!'); Parse body chunk and skip headers. =head2 progress my $size = $content->progress; Size of content already received from message in bytes. =head2 write $content = $content->write; $content = $content->write(''); $content = $content->write($bytes); $content = $content->write($bytes => sub {...}); Write dynamic content non-blocking, the optional drain callback will be executed once all data has been written. Calling this method without a chunk of data will finalize the L and allow for dynamic content to be written later. You can write an empty chunk of data at any time to end the stream. # Make sure previous chunk of data has been written before continuing $content->write('He' => sub { my $content = shift; $content->write('llo!' => sub { my $content = shift; $content->write(''); }); }); =head2 write_chunk $content = $content->write_chunk; $content = $content->write_chunk(''); $content = $content->write_chunk($bytes); $content = $content->write_chunk($bytes => sub {...}); Write dynamic content non-blocking with chunked transfer encoding, the optional drain callback will be executed once all data has been written. Calling this method without a chunk of data will finalize the L and allow for dynamic content to be written later. You can write an empty chunk of data at any time to end the stream. # Make sure previous chunk of data has been written before continuing $content->write_chunk('He' => sub { my $content = shift; $content->write_chunk('llo!' => sub { my $content = shift; $content->write_chunk(''); }); }); =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Content/MultiPart.pm b/modules/Mojo/Content/MultiPart.pm index c520d96..419bfc2 100644 --- a/modules/Mojo/Content/MultiPart.pm +++ b/modules/Mojo/Content/MultiPart.pm @@ -1,314 +1,314 @@ package Mojo::Content::MultiPart; use Mojo::Base 'Mojo::Content'; use Mojo::Util 'b64_encode'; has parts => sub { [] }; sub body_contains { my ($self, $chunk) = @_; ($_->headers_contain($chunk) or $_->body_contains($chunk)) and return 1 for @{$self->parts}; return undef; } sub body_size { my $self = shift; # Check for existing Content-Length header if (my $len = $self->headers->content_length) { return $len } # Calculate length of whole body my $len = my $boundary_len = length($self->build_boundary) + 6; $len += $_->header_size + $_->body_size + $boundary_len for @{$self->parts}; return $len; } sub build_boundary { my $self = shift; # Check for existing boundary my $boundary; return $boundary if defined($boundary = $self->boundary); # Generate and check boundary my $size = 1; do { $boundary = b64_encode join('', map chr(rand 256), 1 .. $size++ * 3); $boundary =~ s/\W/X/g; } while $self->body_contains($boundary); # Add boundary to Content-Type header my $headers = $self->headers; my ($before, $after) = ('multipart/mixed', ''); ($before, $after) = ($1, $2) if ($headers->content_type // '') =~ m!^(.*multipart/[^;]+)(.*)$!; $headers->content_type("$before; boundary=$boundary$after"); return $boundary; } sub clone { my $self = shift; return undef unless my $clone = $self->SUPER::clone(); return $clone->parts($self->parts); } sub get_body_chunk { my ($self, $offset) = @_; # Body generator return $self->generate_body_chunk($offset) if $self->is_dynamic; # First boundary my $boundary = $self->{boundary} //= $self->build_boundary; my $boundary_len = length($boundary) + 6; my $len = $boundary_len - 2; return substr "--$boundary\x0d\x0a", $offset if $len > $offset; # Skip parts that have already been processed my $start = 0; ($len, $start) = ($self->{last_len}, $self->{last_part} + 1) if $self->{offset} && $offset > $self->{offset}; # Prepare content part by part my $parts = $self->parts; for (my $i = $start; $i < @$parts; $i++) { my $part = $parts->[$i]; # Headers my $header_len = $part->header_size; return $part->get_header_chunk($offset - $len) if ($len + $header_len) > $offset; $len += $header_len; # Content my $content_len = $part->body_size; return $part->get_body_chunk($offset - $len) if ($len + $content_len) > $offset; $len += $content_len; # Boundary if ($#$parts == $i) { $boundary .= '--'; $boundary_len += 2; } return substr "\x0d\x0a--$boundary\x0d\x0a", $offset - $len if ($len + $boundary_len) > $offset; $len += $boundary_len; @{$self}{qw(last_len last_part offset)} = ($len, $i, $offset); } } sub is_multipart {1} sub new { my $self = shift->SUPER::new(@_); $self->on(read => \&_read); return $self; } sub _parse_multipart_body { my ($self, $boundary) = @_; # Whole part in buffer my $pos = index $self->{multipart}, "\x0d\x0a--$boundary"; if ($pos < 0) { my $len = length($self->{multipart}) - (length($boundary) + 8); return undef unless $len > 0; # Store chunk my $chunk = substr $self->{multipart}, 0, $len, ''; $self->parts->[-1] = $self->parts->[-1]->parse($chunk); return undef; } # Store chunk my $chunk = substr $self->{multipart}, 0, $pos, ''; $self->parts->[-1] = $self->parts->[-1]->parse($chunk); return !!($self->{multi_state} = 'multipart_boundary'); } sub _parse_multipart_boundary { my ($self, $boundary) = @_; # Boundary begins if ((index $self->{multipart}, "\x0d\x0a--$boundary\x0d\x0a") == 0) { substr $self->{multipart}, 0, length($boundary) + 6, ''; # New part my $part = Mojo::Content::Single->new(relaxed => 1); $self->emit(part => $part); push @{$self->parts}, $part; return !!($self->{multi_state} = 'multipart_body'); } # Boundary ends my $end = "\x0d\x0a--$boundary--"; if ((index $self->{multipart}, $end) == 0) { substr $self->{multipart}, 0, length $end, ''; $self->{multi_state} = 'finished'; } return undef; } sub _parse_multipart_preamble { my ($self, $boundary) = @_; # No boundary yet return undef if (my $pos = index $self->{multipart}, "--$boundary") < 0; # Replace preamble with carriage return and line feed substr $self->{multipart}, 0, $pos, "\x0d\x0a"; # Parse boundary return !!($self->{multi_state} = 'multipart_boundary'); } sub _read { my ($self, $chunk) = @_; $self->{multipart} .= $chunk; my $boundary = $self->boundary; until (($self->{multi_state} //= 'multipart_preamble') eq 'finished') { # Preamble if ($self->{multi_state} eq 'multipart_preamble') { last unless $self->_parse_multipart_preamble($boundary); } # Boundary elsif ($self->{multi_state} eq 'multipart_boundary') { last unless $self->_parse_multipart_boundary($boundary); } # Body elsif ($self->{multi_state} eq 'multipart_body') { last unless $self->_parse_multipart_body($boundary); } } # Check buffer size @$self{qw(state limit)} = ('finished', 1) if length($self->{multipart} // '') > $self->max_buffer_size; } 1; =encoding utf8 =head1 NAME Mojo::Content::MultiPart - HTTP multipart content =head1 SYNOPSIS use Mojo::Content::MultiPart; my $multi = Mojo::Content::MultiPart->new; $multi->parse('Content-Type: multipart/mixed; boundary=---foobar'); my $single = $multi->parts->[4]; =head1 DESCRIPTION L is a container for HTTP multipart content, based on L, L and L. =head1 EVENTS L inherits all events from L and can emit the following new ones. =head2 part $multi->on(part => sub { my ($multi, $single) = @_; ... }); Emitted when a new L part starts. $multi->on(part => sub { my ($multi, $single) = @_; return unless $single->headers->content_disposition =~ /name="([^"]+)"/; say "Field: $1"; }); =head1 ATTRIBUTES L inherits all attributes from L and implements the following new ones. =head2 parts my $parts = $multi->parts; $multi = $multi->parts([Mojo::Content::Single->new]); Content parts embedded in this multipart content, usually L objects. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 body_contains my $bool = $multi->body_contains('foobarbaz'); Check if content parts contain a specific string. =head2 body_size my $size = $multi->body_size; Content size in bytes. =head2 build_boundary my $boundary = $multi->build_boundary; Generate a suitable boundary for content and add it to C header. =head2 clone my $clone = $multi->clone; Return a new L object cloned from this content if possible, otherwise return C. =head2 get_body_chunk my $bytes = $multi->get_body_chunk(0); Get a chunk of content starting from a specific position. Note that it might not be possible to get the same chunk twice if content was generated dynamically. =head2 is_multipart my $bool = $multi->is_multipart; True, this is a L object. =head2 new my $multi = Mojo::Content::MultiPart->new; my $multi = Mojo::Content::MultiPart->new(parts => [Mojo::Content::Single->new]); my $multi = Mojo::Content::MultiPart->new({parts => [Mojo::Content::Single->new]}); -Construct a new L object and subscribe to L -event with default content parser. +Construct a new L object and subscribe to event +L with default content parser. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Content/Single.pm b/modules/Mojo/Content/Single.pm index 9c16dbd..5fca244 100644 --- a/modules/Mojo/Content/Single.pm +++ b/modules/Mojo/Content/Single.pm @@ -1,171 +1,171 @@ package Mojo::Content::Single; use Mojo::Base 'Mojo::Content'; use Mojo::Asset::Memory; use Mojo::Content::MultiPart; has asset => sub { Mojo::Asset::Memory->new(auto_upgrade => 1) }; has auto_upgrade => 1; sub body_contains { shift->asset->contains(shift) >= 0 } sub body_size { my $self = shift; return ($self->headers->content_length || 0) if $self->is_dynamic; return $self->{body_size} //= $self->asset->size; } sub clone { my $self = shift; return undef unless my $clone = $self->SUPER::clone(); return $clone->asset($self->asset); } sub get_body_chunk { my ($self, $offset) = @_; return $self->generate_body_chunk($offset) if $self->is_dynamic; return $self->asset->get_chunk($offset); } sub new { my $self = shift->SUPER::new(@_); $self->{read} = $self->on(read => sub { $_[0]->asset($_[0]->asset->add_chunk($_[1])) }); return $self; } sub parse { my $self = shift; # Parse headers $self->_parse_until_body(@_); # Parse body return $self->SUPER::parse unless $self->auto_upgrade && defined $self->boundary; # Content needs to be upgraded to multipart $self->unsubscribe(read => $self->{read}); my $multi = Mojo::Content::MultiPart->new(%$self); $self->emit(upgrade => $multi); return $multi->parse; } 1; =encoding utf8 =head1 NAME Mojo::Content::Single - HTTP content =head1 SYNOPSIS use Mojo::Content::Single; my $single = Mojo::Content::Single->new; $single->parse("Content-Length: 12\x0d\x0a\x0d\x0aHello World!"); say $single->headers->content_length; =head1 DESCRIPTION L is a container for HTTP content, based on L and L. =head1 EVENTS L inherits all events from L and can emit the following new ones. =head2 upgrade $single->on(upgrade => sub { my ($single, $multi) = @_; ... }); Emitted when content gets upgraded to a L object. $single->on(upgrade => sub { my ($single, $multi) = @_; return unless $multi->headers->content_type =~ /multipart\/([^;]+)/i; say "Multipart: $1"; }); =head1 ATTRIBUTES L inherits all attributes from L and implements the following new ones. =head2 asset my $asset = $single->asset; $single = $single->asset(Mojo::Asset::Memory->new); The actual content, defaults to a L object with L enabled. =head2 auto_upgrade my $bool = $single->auto_upgrade; $single = $single->auto_upgrade($bool); Try to detect multipart content and automatically upgrade to a L object, defaults to a true value. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 body_contains my $bool = $single->body_contains('1234567'); Check if content contains a specific string. =head2 body_size my $size = $single->body_size; Content size in bytes. =head2 clone my $clone = $single->clone; Return a new L object cloned from this content if possible, otherwise return C. =head2 get_body_chunk my $bytes = $single->get_body_chunk(0); Get a chunk of content starting from a specific position. Note that it might not be possible to get the same chunk twice if content was generated dynamically. =head2 new my $single = Mojo::Content::Single->new; my $single = Mojo::Content::Single->new(asset => Mojo::Asset::File->new); my $single = Mojo::Content::Single->new({asset => Mojo::Asset::File->new}); -Construct a new L object and subscribe to L -event with default content parser. +Construct a new L object and subscribe to event +L with default content parser. =head2 parse $single = $single->parse("Content-Length: 12\x0d\x0a\x0d\x0aHello World!"); my $multi = $single->parse("Content-Type: multipart/form-data\x0d\x0a\x0d\x0a"); Parse content chunk and upgrade to L object if necessary. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Cookie/Response.pm b/modules/Mojo/Cookie/Response.pm index b2bc390..93d1cb7 100644 --- a/modules/Mojo/Cookie/Response.pm +++ b/modules/Mojo/Cookie/Response.pm @@ -1,176 +1,176 @@ package Mojo::Cookie::Response; use Mojo::Base 'Mojo::Cookie'; use Mojo::Date; use Mojo::Util qw(quote split_cookie_header); has [qw(domain expires host_only httponly max_age path samesite secure)]; my %ATTRS = map { $_ => 1 } qw(domain expires httponly max-age path samesite secure); sub parse { my ($self, $str) = @_; my @cookies; my $tree = split_cookie_header $str // ''; while (my $pairs = shift @$tree) { my ($name, $value) = splice @$pairs, 0, 2; push @cookies, $self->new(name => $name, value => $value // ''); while (my ($name, $value) = splice @$pairs, 0, 2) { next unless $ATTRS{my $attr = lc $name}; $value =~ s/^\.// if $attr eq 'domain' && defined $value; $value = Mojo::Date->new($value // '')->epoch if $attr eq 'expires'; $value = 1 if $attr eq 'secure' || $attr eq 'httponly'; $cookies[-1]{$attr eq 'max-age' ? 'max_age' : $attr} = $value; } } return \@cookies; } sub to_string { my $self = shift; # Name and value return '' unless length(my $name = $self->name // ''); - my $value = $self->value // ''; + my $value = $self->value // ''; my $cookie = join '=', $name, $value =~ /[,;" ]/ ? quote $value : $value; # "expires" my $expires = $self->expires; $cookie .= '; expires=' . Mojo::Date->new($expires) if defined $expires; # "domain" if (my $domain = $self->domain) { $cookie .= "; domain=$domain" } # "path" if (my $path = $self->path) { $cookie .= "; path=$path" } # "secure" $cookie .= "; secure" if $self->secure; # "HttpOnly" $cookie .= "; HttpOnly" if $self->httponly; # "Same-Site" if (my $samesite = $self->samesite) { $cookie .= "; SameSite=$samesite" } # "Max-Age" if (defined(my $max = $self->max_age)) { $cookie .= "; Max-Age=$max" } return $cookie; } 1; =encoding utf8 =head1 NAME Mojo::Cookie::Response - HTTP response cookie =head1 SYNOPSIS use Mojo::Cookie::Response; my $cookie = Mojo::Cookie::Response->new; $cookie->name('foo'); $cookie->value('bar'); say "$cookie"; =head1 DESCRIPTION L is a container for HTTP response cookies, based on L. =head1 ATTRIBUTES L inherits all attributes from L and implements the following new ones. =head2 domain my $domain = $cookie->domain; $cookie = $cookie->domain('localhost'); Cookie domain. =head2 expires my $expires = $cookie->expires; $cookie = $cookie->expires(time + 60); Expiration for cookie. =head2 host_only my $bool = $cookie->host_only; $cookie = $cookie->host_only($bool); Host-only flag, indicating that the canonicalized request-host is identical to the cookie's L. =head2 httponly my $bool = $cookie->httponly; $cookie = $cookie->httponly($bool); HttpOnly flag, which can prevent client-side scripts from accessing this cookie. =head2 max_age my $max_age = $cookie->max_age; $cookie = $cookie->max_age(60); Max age for cookie. =head2 path my $path = $cookie->path; $cookie = $cookie->path('/test'); Cookie path. =head2 samesite my $samesite = $cookie->samesite; $cookie = $cookie->samesite('Lax'); -SameSite value. Note that this attribute is EXPERIMENTAL because even though +SameSite value. Note that this attribute is B because even though most commonly used browsers support the feature, there is no specification yet besides L. =head2 secure my $bool = $cookie->secure; $cookie = $cookie->secure($bool); Secure flag, which instructs browsers to only send this cookie over HTTPS connections. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 parse my $cookies = Mojo::Cookie::Response->parse('f=b; path=/'); Parse cookies. =head2 to_string my $str = $cookie->to_string; Render cookie. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/DOM/CSS.pm b/modules/Mojo/DOM/CSS.pm index 1bc3d56..d40dfdc 100644 --- a/modules/Mojo/DOM/CSS.pm +++ b/modules/Mojo/DOM/CSS.pm @@ -1,673 +1,674 @@ package Mojo::DOM::CSS; use Mojo::Base -base; use Mojo::Util 'trim'; has 'tree'; my $ESCAPE_RE = qr/\\[^0-9a-fA-F]|\\[0-9a-fA-F]{1,6}/; my $ATTR_RE = qr/ \[ ((?:$ESCAPE_RE|[\w\-])+) # Key (?: (\W)?= # Operator (?:"((?:\\"|[^"])*)"|'((?:\\'|[^'])*)'|([^\]]+?)) # Value (?:\s+(i))? # Case-sensitivity )? \] /x; sub matches { my $tree = shift->tree; return $tree->[0] ne 'tag' ? undef : _match(_compile(@_), $tree, $tree); } sub select { _select(0, shift->tree, _compile(@_)) } sub select_one { _select(1, shift->tree, _compile(@_)) } sub _ancestor { my ($selectors, $current, $tree, $one, $pos) = @_; while ($current = $current->[3]) { return undef if $current->[0] eq 'root' || $current eq $tree; - return 1 if _combinator($selectors, $current, $tree, $pos); - last if $one; + return 1 if _combinator($selectors, $current, $tree, $pos); + last if $one; } return undef; } sub _attr { my ($name_re, $value_re, $current) = @_; my $attrs = $current->[2]; for my $name (keys %$attrs) { my $value = $attrs->{$name}; next if $name !~ $name_re || (!defined $value && defined $value_re); return 1 if !(defined $value && defined $value_re) || $value =~ $value_re; } return undef; } sub _combinator { my ($selectors, $current, $tree, $pos) = @_; # Selector return undef unless my $c = $selectors->[$pos]; if (ref $c) { return undef unless _selector($c, $current); return 1 unless $c = $selectors->[++$pos]; } # ">" (parent only) return _ancestor($selectors, $current, $tree, 1, ++$pos) if $c eq '>'; # "~" (preceding siblings) return _sibling($selectors, $current, $tree, 0, ++$pos) if $c eq '~'; # "+" (immediately preceding siblings) return _sibling($selectors, $current, $tree, 1, ++$pos) if $c eq '+'; # " " (ancestor) return _ancestor($selectors, $current, $tree, 0, ++$pos); } sub _compile { my ($css, %ns) = (trim('' . shift), @_); my $group = [[]]; while (my $selectors = $group->[-1]) { push @$selectors, [] unless @$selectors && ref $selectors->[-1]; my $last = $selectors->[-1]; # Separator if ($css =~ /\G\s*,\s*/gc) { push @$group, [] } # Combinator elsif ($css =~ /\G\s*([ >+~])\s*/gc) { push @$selectors, $1 } # Class or ID elsif ($css =~ /\G([.#])((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) { my ($name, $op) = $1 eq '.' ? ('class', '~') : ('id', ''); push @$last, ['attr', _name($name), _value($op, $2)]; } # Attributes elsif ($css =~ /\G$ATTR_RE/gco) { push @$last, ['attr', _name($1), _value($2 // '', $3 // $4 // $5, $6)]; } # Pseudo-class elsif ($css =~ /\G:([\w\-]+)(?:\(((?:\([^)]+\)|[^)])+)\))?/gcs) { my ($name, $args) = (lc $1, $2); # ":matches" and ":not" (contains more selectors) $args = _compile($args, %ns) if $name eq 'matches' || $name eq 'not'; # ":nth-*" (with An+B notation) $args = _equation($args) if $name =~ /^nth-/; # ":first-*" (rewrite to ":nth-*") ($name, $args) = ("nth-$1", [0, 1]) if $name =~ /^first-(.+)$/; # ":last-*" (rewrite to ":nth-*") ($name, $args) = ("nth-$name", [-1, 1]) if $name =~ /^last-/; push @$last, ['pc', $name, $args]; } # Tag elsif ($css =~ /\G((?:$ESCAPE_RE\s|\\.|[^,.#:[ >~+])+)/gco) { my $alias = (my $name = $1) =~ s/^([^|]*)\|// && $1 ne '*' ? $1 : undef; my $ns = length $alias ? $ns{$alias} // return [['invalid']] : $alias; push @$last, ['tag', $name eq '*' ? undef : _name($name), _unescape($ns)]; } else {last} } return $group; } sub _empty { $_[0][0] eq 'comment' || $_[0][0] eq 'pi' } sub _equation { return [0, 0] unless my $equation = shift; # "even" return [2, 2] if $equation =~ /^\s*even\s*$/i; # "odd" return [2, 1] if $equation =~ /^\s*odd\s*$/i; # "4", "+4" or "-4" return [0, $1] if $equation =~ /^\s*((?:\+|-)?\d+)\s*$/; # "n", "4n", "+4n", "-4n", "n+1", "4n-1", "+4n-1" (and other variations) return [0, 0] unless $equation =~ /^\s*((?:\+|-)?(?:\d+)?)?n\s*((?:\+|-)\s*\d+)?\s*$/i; return [$1 eq '-' ? -1 : !length $1 ? 1 : $1, join('', split(' ', $2 // 0))]; } sub _match { my ($group, $current, $tree) = @_; _combinator([reverse @$_], $current, $tree, 0) and return 1 for @$group; return undef; } sub _name {qr/(?:^|:)\Q@{[_unescape(shift)]}\E$/} sub _namespace { my ($ns, $current) = @_; my $attr = $current->[1] =~ /^([^:]+):/ ? "xmlns:$1" : 'xmlns'; while ($current) { last if $current->[0] eq 'root'; return $current->[2]{$attr} eq $ns if exists $current->[2]{$attr}; $current = $current->[3]; } # Failing to match yields true if searching for no namespace, false otherwise return !length $ns; } sub _pc { my ($class, $args, $current) = @_; # ":checked" return exists $current->[2]{checked} || exists $current->[2]{selected} if $class eq 'checked'; # ":not" return !_match($args, $current, $current) if $class eq 'not'; # ":matches" return !!_match($args, $current, $current) if $class eq 'matches'; # ":empty" return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty'; # ":root" return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root'; # ":link" and ":visited" if ($class eq 'link' || $class eq 'visited') { return undef unless $current->[0] eq 'tag' && exists $current->[2]{href}; return !!grep { $current->[1] eq $_ } qw(a area link); } # ":only-child" or ":only-of-type" if ($class eq 'only-child' || $class eq 'only-of-type') { my $type = $class eq 'only-of-type' ? $current->[1] : undef; $_ ne $current and return undef for @{_siblings($current, $type)}; return 1; } # ":nth-child", ":nth-last-child", ":nth-of-type" or ":nth-last-of-type" if (ref $args) { my $type = $class eq 'nth-of-type' || $class eq 'nth-last-of-type' ? $current->[1] : undef; my @siblings = @{_siblings($current, $type)}; @siblings = reverse @siblings if $class eq 'nth-last-child' || $class eq 'nth-last-of-type'; for my $i (0 .. $#siblings) { next if (my $result = $args->[0] * $i + $args->[1]) < 1; return undef unless my $sibling = $siblings[$result - 1]; return 1 if $sibling eq $current; } } # Everything else return undef; } sub _select { my ($one, $tree, $group) = @_; my @results; my @queue = @$tree[($tree->[0] eq 'root' ? 1 : 4) .. $#$tree]; while (my $current = shift @queue) { next unless $current->[0] eq 'tag'; unshift @queue, @$current[4 .. $#$current]; next unless _match($group, $current, $tree); $one ? return $current : push @results, $current; } return $one ? undef : \@results; } sub _selector { my ($selector, $current) = @_; for my $s (@$selector) { my $type = $s->[0]; # Tag if ($type eq 'tag') { return undef if defined $s->[1] && $current->[1] !~ $s->[1]; return undef if defined $s->[2] && !_namespace($s->[2], $current); } # Attribute elsif ($type eq 'attr') { return undef unless _attr(@$s[1, 2], $current) } # Pseudo-class elsif ($type eq 'pc') { return undef unless _pc(@$s[1, 2], $current) } # Invalid selector else { return undef } } return 1; } sub _sibling { my ($selectors, $current, $tree, $immediate, $pos) = @_; my $found; for my $sibling (@{_siblings($current)}) { return $found if $sibling eq $current; # "+" (immediately preceding sibling) if ($immediate) { $found = _combinator($selectors, $sibling, $tree, $pos) } # "~" (preceding sibling) else { return 1 if _combinator($selectors, $sibling, $tree, $pos) } } return undef; } sub _siblings { my ($current, $type) = @_; my $parent = $current->[3]; my @siblings = grep { $_->[0] eq 'tag' } @$parent[($parent->[0] eq 'root' ? 1 : 4) .. $#$parent]; @siblings = grep { $type eq $_->[1] } @siblings if defined $type; return \@siblings; } sub _unescape { return undef unless defined(my $value = shift); # Remove escaped newlines $value =~ s/\\\n//g; # Unescape Unicode characters $value =~ s/\\([0-9a-fA-F]{1,6})\s?/pack 'U', hex $1/ge; # Remove backslash $value =~ s/\\//g; return $value; } sub _value { my ($op, $value, $insensitive) = @_; return undef unless defined $value; $value = ($insensitive ? '(?i)' : '') . quotemeta _unescape($value); # "~=" (word) return qr/(?:^|\s+)$value(?:\s+|$)/ if $op eq '~'; # "|=" (hyphen-separated) return qr/^$value(?:-|$)/ if $op eq '|'; # "*=" (contains) return qr/$value/ if $op eq '*'; # "^=" (begins with) return qr/^$value/ if $op eq '^'; # "$=" (ends with) return qr/$value$/ if $op eq '$'; # Everything else return qr/^$value$/; } 1; =encoding utf8 =head1 NAME Mojo::DOM::CSS - CSS selector engine =head1 SYNOPSIS use Mojo::DOM::CSS; # Select elements from DOM tree my $css = Mojo::DOM::CSS->new(tree => $tree); my $elements = $css->select('h1, h2, h3'); =head1 DESCRIPTION L is the CSS selector engine used by L, based on the L and L. =head1 SELECTORS All CSS selectors that make sense for a standalone parser are supported. =head2 * Any element. my $all = $css->select('*'); =head2 E An element of type C. my $title = $css->select('title'); =head2 E[foo] An C element with a C attribute. my $links = $css->select('a[href]'); =head2 E[foo="bar"] An C element whose C attribute value is exactly equal to C. my $case_sensitive = $css->select('input[type="hidden"]'); my $case_sensitive = $css->select('input[type=hidden]'); =head2 E[foo="bar" i] An C element whose C attribute value is exactly equal to any (ASCII-range) case-permutation of C. Note that this selector is -EXPERIMENTAL and might change without warning! +B and might change without warning! my $case_insensitive = $css->select('input[type="hidden" i]'); my $case_insensitive = $css->select('input[type=hidden i]'); my $case_insensitive = $css->select('input[class~="foo" i]'); This selector is part of L, which is still a work in progress. =head2 E[foo~="bar"] An C element whose C attribute value is a list of whitespace-separated values, one of which is exactly equal to C. my $foo = $css->select('input[class~="foo"]'); my $foo = $css->select('input[class~=foo]'); =head2 E[foo^="bar"] An C element whose C attribute value begins exactly with the string C. my $begins_with = $css->select('input[name^="f"]'); my $begins_with = $css->select('input[name^=f]'); =head2 E[foo$="bar"] An C element whose C attribute value ends exactly with the string C. my $ends_with = $css->select('input[name$="o"]'); my $ends_with = $css->select('input[name$=o]'); =head2 E[foo*="bar"] An C element whose C attribute value contains the substring C. my $contains = $css->select('input[name*="fo"]'); my $contains = $css->select('input[name*=fo]'); =head2 E[foo|="en"] An C element whose C attribute has a hyphen-separated list of values beginning (from the left) with C. my $english = $css->select('link[hreflang|=en]'); =head2 E:root An C element, root of the document. my $root = $css->select(':root'); =head2 E:nth-child(n) An C element, the C child of its parent. my $third = $css->select('div:nth-child(3)'); my $odd = $css->select('div:nth-child(odd)'); my $even = $css->select('div:nth-child(even)'); my $top3 = $css->select('div:nth-child(-n+3)'); =head2 E:nth-last-child(n) An C element, the C child of its parent, counting from the last one. my $third = $css->select('div:nth-last-child(3)'); my $odd = $css->select('div:nth-last-child(odd)'); my $even = $css->select('div:nth-last-child(even)'); my $bottom3 = $css->select('div:nth-last-child(-n+3)'); =head2 E:nth-of-type(n) An C element, the C sibling of its type. my $third = $css->select('div:nth-of-type(3)'); my $odd = $css->select('div:nth-of-type(odd)'); my $even = $css->select('div:nth-of-type(even)'); my $top3 = $css->select('div:nth-of-type(-n+3)'); =head2 E:nth-last-of-type(n) An C element, the C sibling of its type, counting from the last one. my $third = $css->select('div:nth-last-of-type(3)'); my $odd = $css->select('div:nth-last-of-type(odd)'); my $even = $css->select('div:nth-last-of-type(even)'); my $bottom3 = $css->select('div:nth-last-of-type(-n+3)'); =head2 E:first-child An C element, first child of its parent. my $first = $css->select('div p:first-child'); =head2 E:last-child An C element, last child of its parent. my $last = $css->select('div p:last-child'); =head2 E:first-of-type An C element, first sibling of its type. my $first = $css->select('div p:first-of-type'); =head2 E:last-of-type An C element, last sibling of its type. my $last = $css->select('div p:last-of-type'); =head2 E:only-child An C element, only child of its parent. my $lonely = $css->select('div p:only-child'); =head2 E:only-of-type An C element, only sibling of its type. my $lonely = $css->select('div p:only-of-type'); =head2 E:empty An C element that has no children (including text nodes). my $empty = $css->select(':empty'); =head2 E:link An C element being the source anchor of a hyperlink of which the target is not yet visited (C<:link>) or already visited (C<:visited>). Note that L is not stateful, therefore C<:link> and C<:visited> yield exactly the same results. my $links = $css->select(':link'); my $links = $css->select(':visited'); =head2 E:visited Alias for L. =head2 E:checked A user interface element C which is checked (for instance a radio-button or checkbox). my $input = $css->select(':checked'); =head2 E.warning An C element whose class is "warning". my $warning = $css->select('div.warning'); =head2 E#myid An C element with C equal to "myid". my $foo = $css->select('div#foo'); =head2 E:not(s1, s2) An C element that does not match either compound selector C or compound -selector C. Note that support for compound selectors is EXPERIMENTAL and +selector C. Note that support for compound selectors is B and might change without warning! my $others = $css->select('div p:not(:first-child, :last-child)'); Support for compound selectors was added as part of L, which is still a work in progress. =head2 E:matches(s1, s2) An C element that matches compound selector C and/or compound selector -C. Note that this selector is EXPERIMENTAL and might change without warning! +C. Note that this selector is B and might change without +warning! my $headers = $css->select(':matches(section, article, aside, nav) h1'); This selector is part of L, which is still a work in progress. =head2 A|E An C element that belongs to the namespace alias C from L. Key/value pairs passed to selector methods are used to declare namespace aliases. my $elem = $css->select('lq|elem', lq => 'http://example.com/q-markup'); Using an empty alias searches for an element that belongs to no namespace. my $div = $c->select('|div'); =head2 E F An C element descendant of an C element. my $headlines = $css->select('div h1'); =head2 E E F An C element child of an C element. my $headlines = $css->select('html > body > div > h1'); =head2 E + F An C element immediately preceded by an C element. my $second = $css->select('h1 + h2'); =head2 E ~ F An C element preceded by an C element. my $second = $css->select('h1 ~ h2'); =head2 E, F, G Elements of type C, C and C. my $headlines = $css->select('h1, h2, h3'); =head2 E[foo=bar][bar=baz] An C element whose attributes match all following attribute selectors. my $links = $css->select('a[foo^=b][foo$=ar]'); =head1 ATTRIBUTES L implements the following attributes. =head2 tree my $tree = $css->tree; $css = $css->tree(['root']); Document Object Model. Note that this structure should only be used very carefully since it is very dynamic. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 matches my $bool = $css->matches('head > title'); my $bool = $css->matches('svg|line', svg => 'http://www.w3.org/2000/svg'); Check if first node in L matches the CSS selector. Trailing key/value pairs can be used to declare xml namespace aliases. =head2 select my $results = $css->select('head > title'); my $results = $css->select('svg|line', svg => 'http://www.w3.org/2000/svg'); Run CSS selector against L. Trailing key/value pairs can be used to declare xml namespace aliases. =head2 select_one my $result = $css->select_one('head > title'); my $result = $css->select_one('svg|line', svg => 'http://www.w3.org/2000/svg'); Run CSS selector against L and stop as soon as the first node matched. Trailing key/value pairs can be used to declare xml namespace aliases. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/DynamicMethods.pm b/modules/Mojo/DynamicMethods.pm index 5416b77..0810640 100644 --- a/modules/Mojo/DynamicMethods.pm +++ b/modules/Mojo/DynamicMethods.pm @@ -1,116 +1,116 @@ package Mojo::DynamicMethods; use Mojo::Base -strict; use Hash::Util::FieldHash 'fieldhash'; use Mojo::Util 'monkey_patch'; sub import { my ($flag, $caller) = ($_[1] // '', caller); return unless $flag eq '-dispatch'; my $dyn_pkg = "${caller}::_Dynamic"; my $caller_can = $caller->can('SUPER::can'); monkey_patch $dyn_pkg, 'can', sub { my ($self, $method, @rest) = @_; # Delegate to our parent's "can" if there is one, without breaking if not my $can = $self->$caller_can($method, @rest); return undef unless $can; no warnings 'once'; my $h = do { no strict 'refs'; *{"${dyn_pkg}::${method}"}{CODE} }; return $h && $h eq $can ? undef : $can; }; { no strict 'refs'; unshift @{"${caller}::ISA"}, $dyn_pkg; } } sub register { my ($target, $object, $name, $code) = @_; state %dyn_methods; state $setup = do { fieldhash %dyn_methods; 1 }; my $dyn_pkg = "${target}::_Dynamic"; monkey_patch($dyn_pkg, $name, $target->BUILD_DYNAMIC($name, \%dyn_methods)) unless do { no strict 'refs'; *{"${dyn_pkg}::${name}"}{CODE} }; $dyn_methods{$object}{$name} = $code; } 1; =encoding utf8 =head1 NAME Mojo::DynamicMethods - Fast dynamic method dispatch =head1 SYNOPSIS package MyClass; use Mojo::Base -base; use Mojo::DynamicMethods -dispatch; sub BUILD_DYNAMIC { my ($class, $method, $dyn_methods) = @_; return sub {...}; } sub add_helper { my ($self, $name, $cb) = @_; Mojo::DynamicMethods::register 'MyClass', $self, $name, $cb; } package main; # Generate methods dynamically (and hide them from "$obj->can(...)") my $obj = MyClass->new; $obj->add_helper(foo => sub { warn 'Hello Helper!' }); $obj->foo; =head1 DESCRIPTION L provides dynamic method dispatch for per-object helper methods without requiring use of C. To opt your class into dynamic dispatch simply pass the C<-dispatch> flag. use Mojo::DynamicMethods -dispatch; And then implement a C method in your class, making sure that the key you use to lookup methods in C<$dyn_methods> is the same thing you pass as C<$ref> to L. sub BUILD_DYNAMIC { my ($class, $method, $dyn_methods) = @_; return sub { my ($self, @args) = @_; my $dynamic = $dyn_methods->{$self}{$method}; return $self->$dynamic(@args) if $dynamic; my $package = ref $self; croak qq{Can't locate object method "$method" via package "$package"}; }; } -Note that this module is EXPERIMENTAL and might change without warning! +Note that this module is B and might change without warning! =head1 FUNCTIONS L implements the following functions. =head2 register Mojo::DynamicMethods::register $class, $ref, $name, $cb; Registers the method C<$name> as eligible for dynamic dispatch for C<$class>, and sets C<$cb> to be looked up for C<$name> by reference C<$ref> in a dynamic method constructed by C. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Exception.pm b/modules/Mojo/Exception.pm index 693bf39..eed1f42 100644 --- a/modules/Mojo/Exception.pm +++ b/modules/Mojo/Exception.pm @@ -1,241 +1,397 @@ package Mojo::Exception; use Mojo::Base -base; use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1; -use Mojo::Util 'decode'; +use Exporter 'import'; +use Mojo::Util qw(decode scope_guard); +use Scalar::Util 'blessed'; has [qw(frames line lines_after lines_before)] => sub { [] }; -has message => 'Exception!'; -has 'verbose'; +has message => 'Exception!'; +has verbose => sub { $ENV{MOJO_EXCEPTION_VERBOSE} }; + +our @EXPORT_OK = qw(check raise); + +sub check { + my ($err, @spec) = @_ % 2 ? @_ : ($@, @_); + + # Finally (search backwards since it is usually at the end) + my $guard; + for (my $i = $#spec - 1; $i >= 0; $i -= 2) { + ($guard = scope_guard($spec[$i + 1])) and last if $spec[$i] eq 'finally'; + } + + return undef unless $err; + + my ($default, $handler); + my ($is_obj, $str) = (!!blessed($err), "$err"); +CHECK: for (my $i = 0; $i < @spec; $i += 2) { + my ($checks, $cb) = @spec[$i, $i + 1]; + + ($default = $cb) and next if $checks eq 'default'; + + for my $c (ref $checks eq 'ARRAY' ? @$checks : $checks) { + my $is_re = !!ref $c; + ($handler = $cb) and last CHECK if $is_obj && !$is_re && $err->isa($c); + ($handler = $cb) and last CHECK if $is_re && $str =~ $c; + } + } + + # Rethrow if no handler could be found + die $err unless $handler ||= $default; + $handler->($_) for $err; + + return 1; +} sub inspect { my ($self, @sources) = @_; + return $self if @{$self->line}; + # Extract file and line from message my @files; - my $msg = $self->lines_before([])->line([])->lines_after([])->message; - while ($msg =~ /at\s+(.+?)\s+line\s+(\d+)/g) { unshift @files, [$1, $2] } + my $msg = $self->message; + unshift @files, [$1, $2] while $msg =~ /at\s+(.+?)\s+line\s+(\d+)/g; # Extract file and line from stack trace if (my $zero = $self->frames->[0]) { push @files, [$zero->[1], $zero->[2]] } # Search for context in files for my $file (@files) { next unless -r $file->[0] && open my $handle, '<', $file->[0]; $self->_context($file->[1], [[<$handle>]]); return $self; } # Search for context in sources $self->_context($files[-1][1], [map { [split "\n"] } @sources]) if @sources; return $self; } -sub new { @_ > 1 ? shift->SUPER::new(message => shift) : shift->SUPER::new } +sub new { + defined $_[1] ? shift->SUPER::new(message => shift) : shift->SUPER::new; +} + +sub raise { + my ($class, $err) = @_ > 1 ? (@_) : (__PACKAGE__, shift); + + if (!$class->can('new')) { + die $@ unless eval "package $class; use Mojo::Base 'Mojo::Exception'; 1"; + } + elsif (!$class->isa(__PACKAGE__)) { + die "$class is not a Mojo::Exception subclass"; + } + + CORE::die $class->new($err)->trace; +} sub to_string { my $self = shift; my $str = $self->message; + + my $frames = $self->frames; + if ($str !~ /\n$/) { + $str .= @$frames ? " at $frames->[0][1] line $frames->[0][2].\n" : "\n"; + } return $str unless $self->verbose; - $str .= "\n" unless $str =~ /\n$/; - $str .= $_->[0] . ': ' . $_->[1] . "\n" for @{$self->lines_before}; - $str .= $self->line->[0] . ': ' . $self->line->[1] . "\n" if $self->line->[0]; - $str .= $_->[0] . ': ' . $_->[1] . "\n" for @{$self->lines_after}; - $str .= "$_->[1]:$_->[2] ($_->[0])\n" for @{$self->frames}; + my $line = $self->line; + if (@$line) { + $str .= "Context:\n"; + $str .= " $_->[0]: $_->[1]\n" for @{$self->lines_before}; + $str .= " $line->[0]: $line->[1]\n"; + $str .= " $_->[0]: $_->[1]\n" for @{$self->lines_after}; + } + + if (my $max = @$frames) { + $str .= "Traceback (most recent call first):\n"; + $str .= qq{ File "$_->[1]", line $_->[2], in "$_->[0]"\n} for @$frames; + } return $str; } -sub throw { CORE::die shift->new(shift)->trace(2)->inspect } +sub throw { CORE::die shift->new(shift)->trace } sub trace { my ($self, $start) = (shift, shift // 1); my @frames; while (my @trace = caller($start++)) { push @frames, \@trace } return $self->frames(\@frames); } sub _append { my ($stack, $line) = @_; $line = decode('UTF-8', $line) // $line; chomp $line; push @$stack, $line; } sub _context { my ($self, $num, $sources) = @_; # Line return unless defined $sources->[0][$num - 1]; $self->line([$num]); _append($self->line, $_->[$num - 1]) for @$sources; # Before for my $i (2 .. 6) { last if ((my $previous = $num - $i) < 0); unshift @{$self->lines_before}, [$previous + 1]; _append($self->lines_before->[0], $_->[$previous]) for @$sources; } # After for my $i (0 .. 4) { next if ((my $next = $num + $i) < 0); next unless defined $sources->[0][$next]; push @{$self->lines_after}, [$next + 1]; _append($self->lines_after->[-1], $_->[$next]) for @$sources; } } 1; =encoding utf8 =head1 NAME -Mojo::Exception - Exceptions with context +Mojo::Exception - Exception base class =head1 SYNOPSIS - use Mojo::Exception; + # Create exception classes + package MyApp::X::Foo { + use Mojo::Base 'Mojo::Exception'; + } + package MyApp::X::Bar { + use Mojo::Base 'Mojo::Exception'; + } - # Throw exception and show stack trace - eval { Mojo::Exception->throw('Something went wrong!') }; - say "$_->[1]:$_->[2]" for @{$@->frames}; + # Throw exceptions and handle them gracefully + use Mojo::Exception 'check'; + eval { + MyApp::X::Foo->throw('Something went wrong!'); + }; + check( + 'MyApp::X::Foo' => sub { say "Foo: $_" }, + 'MyApp::X::Bar' => sub { say "Bar: $_" } + ); - # Customize exception + # Generate exception classes on demand + use Mojo::Exception qw(check raise); eval { - my $e = Mojo::Exception->new('Died at test.pl line 3.'); - die $e->trace(2)->inspect->verbose(1); + raise 'MyApp::X::Name', 'The name Minion is already taken'; }; - say $@; + check( + 'MyApp::X::Name' => sub { say "Name error: $_" }, + default => sub { say "Error: $_" } + ); =head1 DESCRIPTION L is a container for exceptions with context information. +=head1 FUNCTIONS + +L implements the following functions, which can be imported +individually. + +=head2 check + + my $bool = check 'MyApp::X::Foo' => sub {...}; + my $bool = check $err, 'MyApp::X::Foo' => sub {...}; + +Process exceptions by dispatching them to handlers with one or more matching +conditions. Exceptions that could not be handled will be rethrown automatically. +By default C<$@> will be used as exception source, so C needs to be +called right after C. Note that this function is B and might +change without warning! + + # Handle various types of exceptions + eval { + dangerous_code(); + }; + check( + 'MyApp::X::Foo' => sub { say "Foo: $_" }, + qr/^Could not open/ => sub { say "Open error: $_" }, + default => sub { say "Something went wrong: $_" }, + finally => sub { say 'Dangerous code is done' } + ); + +Matching conditions can be class names for ISA checks on exception objects, or +regular expressions to match string exceptions and stringified exception +objects. The matching exception will be the first argument passed to the +callback, and is also available as C<$_>. + + # Catch MyApp::X::Foo object or a specific string exception + eval { + dangerous_code(); + }; + check( + 'MyApp::X::Foo' => sub { say "Foo: $_" }, + qr/^Could not open/ => sub { say "Open error: $_" } + ); + +An array reference can be used to share the same handler with multiple +conditions, of which only one needs to match. And since exception handlers are +just callbacks, they can also throw their own exceptions. + + # Handle MyApp::X::Foo and MyApp::X::Bar the same + eval { + dangerous_code(); + }; + check( + ['MyApp::X::Foo', 'MyApp::X::Bar'] => sub { die "Foo/Bar: $_" } + ); + +There are currently two keywords you can use to set special handlers. The +C handler is used when no other handler matched. And the C +handler runs always, it does not affect normal handlers and even runs if the +exception was rethrown or if there was no exception to be handled at all. + + # Use "default" to catch everything + eval { + dangerous_code(); + }; + check( + default => sub { say "Error: $_" }, + finally => sub { say 'Dangerous code is done' } + ); + +=head2 raise + + raise 'Something went wrong!'; + raise 'MyApp::X::Foo', 'Something went wrong!'; + +Raise a L, if the class does not exist yet (classes are checked +for a C method), one is created as a L subclass on demand. +Note that this function is B and might change without warning! + =head1 ATTRIBUTES L implements the following attributes. =head2 frames my $frames = $e->frames; $e = $e->frames([$frame1, $frame2]); Stack trace if available. # Extract information from the last frame my ($package, $filename, $line, $subroutine, $hasargs, $wantarray, $evaltext, $is_require, $hints, $bitmask, $hinthash) = @{$e->frames->[-1]}; =head2 line my $line = $e->line; $e = $e->line([3, 'die;']); The line where the exception occurred if available. =head2 lines_after my $lines = $e->lines_after; $e = $e->lines_after([[4, 'say $foo;'], [5, 'say $bar;']]); Lines after the line where the exception occurred if available. =head2 lines_before my $lines = $e->lines_before; $e = $e->lines_before([[1, 'my $foo = 23;'], [2, 'my $bar = 24;']]); Lines before the line where the exception occurred if available. =head2 message my $msg = $e->message; $e = $e->message('Died at test.pl line 3.'); Exception message, defaults to C. =head2 verbose my $bool = $e->verbose; $e = $e->verbose($bool); -Enable context information for L. +Show more information with L, such as L, defaults to +the value of the C environment variable. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 inspect $e = $e->inspect; $e = $e->inspect($source1, $source2); Inspect L, L and optional additional sources to fill L, L and L with context information. =head2 new my $e = Mojo::Exception->new; my $e = Mojo::Exception->new('Died at test.pl line 3.'); Construct a new L object and assign L if necessary. =head2 to_string my $str = $e->to_string; -Render exception. - - # Render exception with context - say $e->verbose(1)->to_string; +Render exception. Note that the output format may change as more features are +added, only the error message at the beginning is guaranteed not to be modified +to allow regex matching. =head2 throw Mojo::Exception->throw('Something went wrong!'); Throw exception from the current execution context. # Longer version - die Mojo::Exception->new('Something went wrong!')->trace->inspect; + die Mojo::Exception->new('Something went wrong!')->trace; =head2 trace $e = $e->trace; $e = $e->trace($skip); Generate stack trace and store all L, defaults to skipping C<1> call frame. # Skip 3 call frames $e->trace(3); # Skip no call frames $e->trace(0); =head1 OPERATORS L overloads the following operators. =head2 bool my $bool = !!$e; Always true. =head2 stringify my $str = "$e"; Alias for L. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/File.pm b/modules/Mojo/File.pm index fc6bfdc..f196ed8 100644 --- a/modules/Mojo/File.pm +++ b/modules/Mojo/File.pm @@ -1,574 +1,584 @@ package Mojo::File; use Mojo::Base -strict; use overload '@{}' => sub { shift->to_array }, bool => sub {1}, '""' => sub { ${$_[0]} }, fallback => 1; use Carp 'croak'; use Cwd 'getcwd'; use Exporter 'import'; use File::Basename (); use File::Copy qw(copy move); use File::Find 'find'; use File::Path (); use File::Spec::Functions qw(abs2rel canonpath catfile file_name_is_absolute rel2abs splitdir); use File::stat (); use File::Temp (); use IO::File (); use Mojo::Collection; -our @EXPORT_OK = ('path', 'tempdir', 'tempfile'); +our @EXPORT_OK = ('curfile', 'path', 'tempdir', 'tempfile'); sub basename { File::Basename::basename ${shift()}, @_ } -sub child { $_[0]->new(@_) } +sub child { $_[0]->new(${shift()}, @_) } sub chmod { my ($self, $mode) = @_; chmod $mode, $$self or croak qq{Can't chmod file "$$self": $!}; return $self; } sub copy_to { my ($self, $to) = @_; copy($$self, $to) or croak qq{Can't copy file "$$self" to "$to": $!}; return $self->new(-d $to ? ($to, File::Basename::basename $self) : $to); } +sub curfile { __PACKAGE__->new(Cwd::realpath((caller)[1])) } + sub dirname { $_[0]->new(scalar File::Basename::dirname ${$_[0]}) } sub is_abs { file_name_is_absolute ${shift()} } sub list { my ($self, $options) = (shift, shift // {}); return Mojo::Collection->new unless -d $$self; opendir(my $dir, $$self) or croak qq{Can't open directory "$$self": $!}; my @files = grep { $_ ne '.' && $_ ne '..' } readdir $dir; @files = grep { !/^\./ } @files unless $options->{hidden}; - @files = map { catfile $$self, $_ } @files; + @files = map { catfile $$self, $_ } @files; @files = grep { !-d } @files unless $options->{dir}; return Mojo::Collection->new(map { $self->new($_) } sort @files); } sub list_tree { my ($self, $options) = (shift, shift // {}); # This may break in the future, but is worth it for performance local $File::Find::skip_pattern = qr/^\./ unless $options->{hidden}; # The File::Find documentation lies, this is needed for CIFS local $File::Find::dont_use_nlink = 1 if $options->{dont_use_nlink}; my %all; my $wanted = sub { if ($options->{max_depth}) { (my $rel = $File::Find::name) =~ s!^\Q$$self\E/?!!; $File::Find::prune = 1 if splitdir($rel) >= $options->{max_depth}; } $all{$File::Find::name}++ if $options->{dir} || !-d $File::Find::name; }; find {wanted => $wanted, no_chdir => 1}, $$self if -d $$self; delete $all{$$self}; return Mojo::Collection->new(map { $self->new(canonpath $_) } sort keys %all); } sub lstat { File::stat::lstat(${shift()}) } sub make_path { my $self = shift; File::Path::make_path $$self, @_; return $self; } sub move_to { my ($self, $to) = @_; move($$self, $to) or croak qq{Can't move file "$$self" to "$to": $!}; return $self->new(-d $to ? ($to, File::Basename::basename $self) : $to); } sub new { my $class = shift; + croak 'Invalid path' if grep { !defined } @_; my $value = @_ == 1 ? $_[0] : @_ > 1 ? catfile @_ : canonpath getcwd; return bless \$value, ref $class || $class; } sub open { my $self = shift; my $handle = IO::File->new; $handle->open($$self, @_) or croak qq{Can't open file "$$self": $!}; return $handle; } sub path { __PACKAGE__->new(@_) } sub realpath { $_[0]->new(Cwd::realpath ${$_[0]}) } sub remove { my ($self, $mode) = @_; unlink $$self or croak qq{Can't remove file "$$self": $!} if -e $$self; return $self; } sub remove_tree { my $self = shift; File::Path::remove_tree $$self, @_; return $self; } sub sibling { my $self = shift; return $self->new(scalar File::Basename::dirname($self), @_); } sub slurp { my $self = shift; CORE::open my $file, '<', $$self or croak qq{Can't open file "$$self": $!}; my $ret = my $content = ''; while ($ret = $file->sysread(my $buffer, 131072, 0)) { $content .= $buffer } croak qq{Can't read from file "$$self": $!} unless defined $ret; return $content; } sub spurt { my ($self, $content) = (shift, join '', @_); CORE::open my $file, '>', $$self or croak qq{Can't open file "$$self": $!}; ($file->syswrite($content) // -1) == length $content or croak qq{Can't write to file "$$self": $!}; return $self; } sub stat { File::stat::stat(${shift()}) } sub tap { shift->Mojo::Base::tap(@_) } sub tempdir { __PACKAGE__->new(File::Temp->newdir(@_)) } sub tempfile { __PACKAGE__->new(File::Temp->new(@_)) } sub to_abs { $_[0]->new(rel2abs ${$_[0]}) } sub to_array { [splitdir ${shift()}] } sub to_rel { $_[0]->new(abs2rel(${$_[0]}, $_[1])) } sub to_string {"${$_[0]}"} sub touch { my $self = shift; $self->open('>') unless -e $$self; utime undef, undef, $$self or croak qq{Can't touch file "$$self": $!}; return $self; } sub with_roles { shift->Mojo::Base::with_roles(@_) } 1; =encoding utf8 =head1 NAME Mojo::File - File system paths =head1 SYNOPSIS use Mojo::File; # Portably deal with file system paths my $path = Mojo::File->new('/home/sri/.vimrc'); say $path->slurp; say $path->dirname; say $path->basename; say $path->sibling('.bashrc'); # Use the alternative constructor use Mojo::File 'path'; my $path = path('/tmp/foo/bar')->make_path; $path->child('test.txt')->spurt('Hello Mojo!'); =head1 DESCRIPTION L is a scalar-based container for file system paths that provides a friendly API for dealing with different operating systems. # Access scalar directly to manipulate path my $path = Mojo::File->new('/home/sri/test'); $$path .= '.txt'; =head1 FUNCTIONS L implements the following functions, which can be imported individually. +=head2 curfile + + my $path = curfile; + +Construct a new scalar-based L object for the absolute path to the +current source file. + =head2 path my $path = path; my $path = path('/home/sri/.vimrc'); my $path = path('/home', 'sri', '.vimrc'); my $path = path(File::Temp->newdir); Construct a new scalar-based L object, defaults to using the current working directory. # "foo/bar/baz.txt" (on UNIX) path('foo', 'bar', 'baz.txt'); =head2 tempdir my $path = tempdir; my $path = tempdir('tempXXXXX'); Construct a new scalar-based L object for a temporary directory with L. # Longer version my $path = path(File::Temp->newdir('tempXXXXX')); =head2 tempfile my $path = tempfile; my $path = tempfile(DIR => '/tmp'); Construct a new scalar-based L object for a temporary file with L. # Longer version my $path = path(File::Temp->new(DIR => '/tmp')); =head1 METHODS L implements the following methods. =head2 basename my $name = $path->basename; my $name = $path->basename('.txt'); Return the last level of the path with L. # ".vimrc" (on UNIX) path('/home/sri/.vimrc')->basename; # "test" (on UNIX) path('/home/sri/test.txt')->basename('.txt'); =head2 child my $child = $path->child('.vimrc'); Return a new L object relative to the path. # "/home/sri/.vimrc" (on UNIX) path('/home')->child('sri', '.vimrc'); =head2 chmod $path = $path->chmod(0644); Change file permissions. =head2 copy_to my $destination = $path->copy_to('/home/sri'); my $destination = $path->copy_to('/home/sri/.vimrc.backup'); Copy file with L and return the destination as a L object. =head2 dirname my $name = $path->dirname; Return all but the last level of the path with L as a L object. # "/home/sri" (on UNIX) path('/home/sri/.vimrc')->dirname; =head2 is_abs my $bool = $path->is_abs; Check if the path is absolute. # True (on UNIX) path('/home/sri/.vimrc')->is_abs; # False (on UNIX) path('.vimrc')->is_abs; =head2 list my $collection = $path->list; my $collection = $path->list({hidden => 1}); List all files in the directory and return a L object containing the results as L objects. The list does not include C<.> and C<..>. # List files say for path('/home/sri/myapp')->list->each; These options are currently available: =over 2 =item dir dir => 1 Include directories. =item hidden hidden => 1 Include hidden files. =back =head2 list_tree my $collection = $path->list_tree; my $collection = $path->list_tree({hidden => 1}); List all files recursively in the directory and return a L object containing the results as L objects. The list does not include C<.> and C<..>. # List all templates say for path('/home/sri/myapp/templates')->list_tree->each; These options are currently available: =over 2 =item dir dir => 1 Include directories. =item dont_use_nlink dont_use_nlink => 1 Force L to always stat directories. =item hidden hidden => 1 Include hidden files and directories. =item max_depth max_depth => 3 Maximum number of levels to descend when searching for files. =back =head2 lstat my $stat = $path->lstat; Return a L object for the symlink. # Get symlink size say path('/usr/sbin/sendmail')->lstat->size; # Get symlink modification time say path('/usr/sbin/sendmail')->lstat->mtime; =head2 make_path $path = $path->make_path; $path = $path->make_path({mode => 0711}); Create the directories if they don't already exist, any additional arguments are passed through to L. =head2 move_to my $destination = $path->move_to('/home/sri'); my $destination = $path->move_to('/home/sri/.vimrc.backup'); Move file with L and return the destination as a L object. =head2 new my $path = Mojo::File->new; my $path = Mojo::File->new('/home/sri/.vimrc'); my $path = Mojo::File->new('/home', 'sri', '.vimrc'); my $path = Mojo::File->new(File::Temp->new); my $path = Mojo::File->new(File::Temp->newdir); Construct a new L object, defaults to using the current working directory. # "foo/bar/baz.txt" (on UNIX) Mojo::File->new('foo', 'bar', 'baz.txt'); =head2 open my $handle = $path->open('+<'); my $handle = $path->open('r+'); my $handle = $path->open(O_RDWR); my $handle = $path->open('<:encoding(UTF-8)'); Open file with L. # Combine "fcntl.h" constants use Fcntl qw(O_CREAT O_EXCL O_RDWR); my $handle = path('/home/sri/test.pl')->open(O_RDWR | O_CREAT | O_EXCL); =head2 realpath my $realpath = $path->realpath; Resolve the path with L and return the result as a L object. =head2 remove $path = $path->remove; Delete file. =head2 remove_tree $path = $path->remove_tree; $path = $path->remove_tree({keep_root => 1}); Delete this directory and any files and subdirectories it may contain, any additional arguments are passed through to L. =head2 sibling my $sibling = $path->sibling('.vimrc'); Return a new L object relative to the directory part of the path. # "/home/sri/.vimrc" (on UNIX) path('/home/sri/.bashrc')->sibling('.vimrc'); # "/home/sri/.ssh/known_hosts" (on UNIX) path('/home/sri/.bashrc')->sibling('.ssh', 'known_hosts'); =head2 slurp my $bytes = $path->slurp; Read all data at once from the file. =head2 spurt $path = $path->spurt($bytes); $path = $path->spurt(@chunks_of_bytes); Write all data at once to the file. =head2 stat my $stat = $path->stat; Return a L object for the path. # Get file size say path('/home/sri/.bashrc')->stat->size; # Get file modification time say path('/home/sri/.bashrc')->stat->mtime; =head2 tap $path = $path->tap(sub {...}); Alias for L. =head2 to_abs my $absolute = $path->to_abs; Return absolute path as a L object, the path does not need to exist on the file system. =head2 to_array my $parts = $path->to_array; Split the path on directory separators. # "home:sri:.vimrc" (on UNIX) join ':', @{path('/home/sri/.vimrc')->to_array}; =head2 to_rel my $relative = $path->to_rel('/some/base/path'); Return a relative path from the original path to the destination path as a L object. # "sri/.vimrc" (on UNIX) path('/home/sri/.vimrc')->to_rel('/home'); =head2 to_string my $str = $path->to_string; Stringify the path. =head2 touch $path = $path->touch; Create file if it does not exist or change the modification and access time to the current time. # Safely read file say path('.bashrc')->touch->slurp; =head2 with_roles my $new_class = Mojo::File->with_roles('Mojo::File::Role::One'); my $new_class = Mojo::File->with_roles('+One', '+Two'); $path = $path->with_roles('+One', '+Two'); Alias for L. =head1 OPERATORS L overloads the following operators. =head2 array my @parts = @$path; Alias for L. =head2 bool my $bool = !!$path; Always true. =head2 stringify my $str = "$path"; Alias for L. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/Headers.pm b/modules/Mojo/Headers.pm index 772e1b6..2822117 100644 --- a/modules/Mojo/Headers.pm +++ b/modules/Mojo/Headers.pm @@ -1,719 +1,747 @@ package Mojo::Headers; use Mojo::Base -base; use Carp 'croak'; use Mojo::Util 'monkey_patch'; has max_line_size => sub { $ENV{MOJO_MAX_LINE_SIZE} || 8192 }; has max_lines => sub { $ENV{MOJO_MAX_LINES} || 100 }; # Common headers my %NAMES = map { lc() => $_ } ( qw(Accept Accept-Charset Accept-Encoding Accept-Language Accept-Ranges), qw(Access-Control-Allow-Origin Allow Authorization Cache-Control Connection), qw(Content-Disposition Content-Encoding Content-Language Content-Length), qw(Content-Location Content-Range Content-Security-Policy Content-Type), qw(Cookie DNT Date ETag Expect Expires Host If-Modified-Since If-None-Match), qw(Last-Modified Link Location Origin Proxy-Authenticate), qw(Proxy-Authorization Range Sec-WebSocket-Accept Sec-WebSocket-Extensions), qw(Sec-WebSocket-Key Sec-WebSocket-Protocol Sec-WebSocket-Version Server), qw(Server-Timing Set-Cookie Status Strict-Transport-Security TE Trailer), qw(Transfer-Encoding Upgrade User-Agent Vary WWW-Authenticate) ); for my $header (keys %NAMES) { my $name = $header; $name =~ y/-/_/; monkey_patch __PACKAGE__, $name, sub { my $self = shift; $self->{headers}{$header} = [@_] and return $self if @_; return undef unless my $headers = $self->{headers}{$header}; return join ', ', @$headers; }; } +# Hop-by-hop headers +my @HOP_BY_HOP = map {lc} ( + qw(Connection Keep-Alive Proxy-Authenticate Proxy-Authorization TE Trailer), + qw(Transfer-Encoding Upgrade) +); + sub add { my ($self, $name) = (shift, shift); tr/\x0d\x0a// and croak "Invalid characters in $name header" for @_; # Make sure we have a normal case entry for name my $key = lc $name; $self->{names}{$key} //= $name unless $NAMES{$key}; push @{$self->{headers}{$key}}, @_; return $self; } sub append { my ($self, $name, $value) = @_; my $old = $self->header($name); return $self->header($name => defined $old ? "$old, $value" : $value); } -sub clone { $_[0]->new->from_hash($_[0]->to_hash(1)) } +sub clone { + my $self = shift; + + my $clone = $self->new; + %{$clone->{names}} = %{$self->{names} // {}}; + @{$clone->{headers}{$_}} = @{$self->{headers}{$_}} + for keys %{$self->{headers}}; + + return $clone; +} + +sub dehop { + my $self = shift; + delete @{$self->{headers}}{@HOP_BY_HOP}; + return $self; +} sub every_header { shift->{headers}{lc shift} || [] } sub from_hash { my ($self, $hash) = @_; # Empty hash deletes all headers delete $self->{headers} if keys %{$hash} == 0; # Merge for my $header (keys %$hash) { my $value = $hash->{$header}; $self->add($header => ref $value eq 'ARRAY' ? @$value : $value); } return $self; } sub header { my ($self, $name) = (shift, shift); # Replace return $self->remove($name)->add($name, @_) if @_; return undef unless my $headers = $self->{headers}{lc $name}; return join ', ', @$headers; } sub is_finished { (shift->{state} // '') eq 'finished' } sub is_limit_exceeded { !!shift->{limit} } sub leftovers { delete shift->{buffer} } sub names { my $self = shift; return [map { $NAMES{$_} || $self->{names}{$_} } keys %{$self->{headers}}]; } sub parse { my ($self, $chunk) = @_; $self->{state} = 'headers'; $self->{buffer} .= $chunk; my $headers = $self->{cache} ||= []; my $size = $self->max_line_size; my $lines = $self->max_lines; while ($self->{buffer} =~ s/^(.*?)\x0d?\x0a//) { my $line = $1; # Check line size limit if ($+[0] > $size || @$headers >= $lines) { @$self{qw(state limit)} = ('finished', 1); return $self; } # New header if ($line =~ /^(\S[^:]*)\s*:\s*(.*)$/) { push @$headers, [$1, $2] } # Multi-line elsif ($line =~ s/^\s+// && @$headers) { $headers->[-1][1] .= " $line" } # Empty line else { $self->add(@$_) for @$headers; @$self{qw(state cache)} = ('finished', []); return $self; } } # Check line size limit @$self{qw(state limit)} = ('finished', 1) if length $self->{buffer} > $size; return $self; } sub referrer { shift->header(Referer => @_) } sub remove { my ($self, $name) = @_; delete $self->{headers}{lc $name}; return $self; } sub to_hash { my ($self, $multi) = @_; return {map { $_ => $self->{headers}{lc $_} } @{$self->names}} if $multi; return {map { $_ => $self->header($_) } @{$self->names}}; } sub to_string { my $self = shift; # Make sure multi-line values are formatted correctly my @headers; for my $name (@{$self->names}) { push @headers, "$name: $_" for @{$self->{headers}{lc $name}}; } return join "\x0d\x0a", @headers; } 1; =encoding utf8 =head1 NAME Mojo::Headers - HTTP headers =head1 SYNOPSIS use Mojo::Headers; # Parse my $headers = Mojo::Headers->new; $headers->parse("Content-Length: 42\x0d\x0a"); $headers->parse("Content-Type: text/html\x0d\x0a\x0d\x0a"); say $headers->content_length; say $headers->content_type; # Build my $headers = Mojo::Headers->new; $headers->content_length(42); $headers->content_type('text/plain'); say $headers->to_string; =head1 DESCRIPTION L is a container for HTTP headers, based on L and L. =head1 ATTRIBUTES L implements the following attributes. =head2 max_line_size my $size = $headers->max_line_size; $headers = $headers->max_line_size(1024); Maximum header line size in bytes, defaults to the value of the C environment variable or C<8192> (8KiB). =head2 max_lines my $num = $headers->max_lines; $headers = $headers->max_lines(200); Maximum number of header lines, defaults to the value of the C environment variable or C<100>. =head1 METHODS L inherits all methods from L and implements the following new ones. =head2 accept my $accept = $headers->accept; $headers = $headers->accept('application/json'); Get or replace current header value, shortcut for the C header. =head2 accept_charset my $charset = $headers->accept_charset; $headers = $headers->accept_charset('UTF-8'); Get or replace current header value, shortcut for the C header. =head2 accept_encoding my $encoding = $headers->accept_encoding; $headers = $headers->accept_encoding('gzip'); Get or replace current header value, shortcut for the C header. =head2 accept_language my $language = $headers->accept_language; $headers = $headers->accept_language('de, en'); Get or replace current header value, shortcut for the C header. =head2 accept_ranges my $ranges = $headers->accept_ranges; $headers = $headers->accept_ranges('bytes'); Get or replace current header value, shortcut for the C header. =head2 access_control_allow_origin my $origin = $headers->access_control_allow_origin; $headers = $headers->access_control_allow_origin('*'); Get or replace current header value, shortcut for the C header from L. =head2 add $headers = $headers->add(Foo => 'one value'); $headers = $headers->add(Foo => 'first value', 'second value'); Add header with one or more lines. # "Vary: Accept # Vary: Accept-Encoding" $headers->add(Vary => 'Accept')->add(Vary => 'Accept-Encoding')->to_string; =head2 allow my $allow = $headers->allow; $headers = $headers->allow('GET, POST'); Get or replace current header value, shortcut for the C header. =head2 append $headers = $headers->append(Vary => 'Accept-Encoding'); Append value to header and flatten it if necessary. # "Vary: Accept" $headers->append(Vary => 'Accept')->to_string; # "Vary: Accept, Accept-Encoding" $headers->vary('Accept')->append(Vary => 'Accept-Encoding')->to_string; =head2 authorization my $authorization = $headers->authorization; $headers = $headers->authorization('Basic Zm9vOmJhcg=='); Get or replace current header value, shortcut for the C header. =head2 cache_control my $cache_control = $headers->cache_control; $headers = $headers->cache_control('max-age=1, no-cache'); Get or replace current header value, shortcut for the C header. =head2 clone my $clone = $headers->clone; Return a new L object cloned from these headers. =head2 connection my $connection = $headers->connection; $headers = $headers->connection('close'); Get or replace current header value, shortcut for the C header. =head2 content_disposition my $disposition = $headers->content_disposition; $headers = $headers->content_disposition('foo'); Get or replace current header value, shortcut for the C header. =head2 content_encoding my $encoding = $headers->content_encoding; $headers = $headers->content_encoding('gzip'); Get or replace current header value, shortcut for the C header. =head2 content_language my $language = $headers->content_language; $headers = $headers->content_language('en'); Get or replace current header value, shortcut for the C header. =head2 content_length my $len = $headers->content_length; $headers = $headers->content_length(4000); Get or replace current header value, shortcut for the C header. =head2 content_location my $location = $headers->content_location; $headers = $headers->content_location('http://127.0.0.1/foo'); Get or replace current header value, shortcut for the C header. =head2 content_range my $range = $headers->content_range; $headers = $headers->content_range('bytes 2-8/100'); Get or replace current header value, shortcut for the C header. =head2 content_security_policy my $policy = $headers->content_security_policy; $headers = $headers->content_security_policy('default-src https:'); Get or replace current header value, shortcut for the C header from L. =head2 content_type my $type = $headers->content_type; $headers = $headers->content_type('text/plain'); Get or replace current header value, shortcut for the C header. =head2 cookie my $cookie = $headers->cookie; $headers = $headers->cookie('f=b'); Get or replace current header value, shortcut for the C header from L. =head2 date my $date = $headers->date; $headers = $headers->date('Sun, 17 Aug 2008 16:27:35 GMT'); Get or replace current header value, shortcut for the C header. +=head2 dehop + + $heders = $headers->dehop; + +Remove hop-by-hop headers that should not be retransmitted. Note that this +method is B and might change without warning! + =head2 dnt my $dnt = $headers->dnt; $headers = $headers->dnt(1); Get or replace current header value, shortcut for the C (Do Not Track) header, which has no specification yet, but is very commonly used. =head2 etag my $etag = $headers->etag; $headers = $headers->etag('"abc321"'); Get or replace current header value, shortcut for the C header. =head2 every_header my $all = $headers->every_header('Location'); Similar to L, but returns all headers sharing the same name as an array reference. # Get first header value say $headers->every_header('Location')->[0]; =head2 expect my $expect = $headers->expect; $headers = $headers->expect('100-continue'); Get or replace current header value, shortcut for the C header. =head2 expires my $expires = $headers->expires; $headers = $headers->expires('Thu, 01 Dec 1994 16:00:00 GMT'); Get or replace current header value, shortcut for the C header. =head2 from_hash $headers = $headers->from_hash({'Cookie' => 'a=b'}); $headers = $headers->from_hash({'Cookie' => ['a=b', 'c=d']}); $headers = $headers->from_hash({}); Parse headers from a hash reference, an empty hash removes all headers. =head2 header my $value = $headers->header('Foo'); $headers = $headers->header(Foo => 'one value'); $headers = $headers->header(Foo => 'first value', 'second value'); Get or replace the current header values. =head2 host my $host = $headers->host; $headers = $headers->host('127.0.0.1'); Get or replace current header value, shortcut for the C header. =head2 if_modified_since my $date = $headers->if_modified_since; $headers = $headers->if_modified_since('Sun, 17 Aug 2008 16:27:35 GMT'); Get or replace current header value, shortcut for the C header. =head2 if_none_match my $etag = $headers->if_none_match; $headers = $headers->if_none_match('"abc321"'); Get or replace current header value, shortcut for the C header. =head2 is_finished my $bool = $headers->is_finished; Check if header parser is finished. =head2 is_limit_exceeded my $bool = $headers->is_limit_exceeded; Check if headers have exceeded L or L. =head2 last_modified my $date = $headers->last_modified; $headers = $headers->last_modified('Sun, 17 Aug 2008 16:27:35 GMT'); Get or replace current header value, shortcut for the C header. =head2 leftovers my $bytes = $headers->leftovers; Get and remove leftover data from header parser. =head2 link my $link = $headers->link; $headers = $headers->link('; rel="next"'); Get or replace current header value, shortcut for the C header from L. =head2 location my $location = $headers->location; $headers = $headers->location('http://127.0.0.1/foo'); Get or replace current header value, shortcut for the C header. =head2 names my $names = $headers->names; Return an array reference with all currently defined headers. # Names of all headers say for @{$headers->names}; =head2 origin my $origin = $headers->origin; $headers = $headers->origin('http://example.com'); Get or replace current header value, shortcut for the C header from L. =head2 parse $headers = $headers->parse("Content-Type: text/plain\x0d\x0a\x0d\x0a"); Parse formatted headers. =head2 proxy_authenticate my $authenticate = $headers->proxy_authenticate; $headers = $headers->proxy_authenticate('Basic "realm"'); Get or replace current header value, shortcut for the C header. =head2 proxy_authorization my $authorization = $headers->proxy_authorization; $headers = $headers->proxy_authorization('Basic Zm9vOmJhcg=='); Get or replace current header value, shortcut for the C header. =head2 range my $range = $headers->range; $headers = $headers->range('bytes=2-8'); Get or replace current header value, shortcut for the C header. =head2 referrer my $referrer = $headers->referrer; $headers = $headers->referrer('http://example.com'); Get or replace current header value, shortcut for the C header, there was a typo in L which resulted in C becoming an official header. =head2 remove $headers = $headers->remove('Foo'); Remove a header. =head2 sec_websocket_accept my $accept = $headers->sec_websocket_accept; $headers = $headers->sec_websocket_accept('s3pPLMBiTxaQ9kYGzzhZRbK+xOo='); Get or replace current header value, shortcut for the C header from L. =head2 sec_websocket_extensions my $extensions = $headers->sec_websocket_extensions; $headers = $headers->sec_websocket_extensions('foo'); Get or replace current header value, shortcut for the C header from L. =head2 sec_websocket_key my $key = $headers->sec_websocket_key; $headers = $headers->sec_websocket_key('dGhlIHNhbXBsZSBub25jZQ=='); Get or replace current header value, shortcut for the C header from L. =head2 sec_websocket_protocol my $proto = $headers->sec_websocket_protocol; $headers = $headers->sec_websocket_protocol('sample'); Get or replace current header value, shortcut for the C header from L. =head2 sec_websocket_version my $version = $headers->sec_websocket_version; $headers = $headers->sec_websocket_version(13); Get or replace current header value, shortcut for the C header from L. =head2 server my $server = $headers->server; $headers = $headers->server('Mojo'); Get or replace current header value, shortcut for the C header. =head2 server_timing my $timing = $headers->server_timing; $headers = $headers->server_timing('app;desc=Mojolicious;dur=0.0001'); Get or replace current header value, shortcut for the C header from L. =head2 set_cookie my $cookie = $headers->set_cookie; $headers = $headers->set_cookie('f=b; path=/'); Get or replace current header value, shortcut for the C header from L. =head2 status my $status = $headers->status; $headers = $headers->status('200 OK'); Get or replace current header value, shortcut for the C header from L. =head2 strict_transport_security my $policy = $headers->strict_transport_security; $headers = $headers->strict_transport_security('max-age=31536000'); Get or replace current header value, shortcut for the C header from L. =head2 te my $te = $headers->te; $headers = $headers->te('chunked'); Get or replace current header value, shortcut for the C header. =head2 to_hash my $single = $headers->to_hash; my $multi = $headers->to_hash(1); Turn headers into hash reference, array references to represent multiple headers with the same name are disabled by default. say $headers->to_hash->{DNT}; =head2 to_string my $str = $headers->to_string; Turn headers into a string, suitable for HTTP messages. =head2 trailer my $trailer = $headers->trailer; $headers = $headers->trailer('X-Foo'); Get or replace current header value, shortcut for the C header. =head2 transfer_encoding my $encoding = $headers->transfer_encoding; $headers = $headers->transfer_encoding('chunked'); Get or replace current header value, shortcut for the C header. =head2 upgrade my $upgrade = $headers->upgrade; $headers = $headers->upgrade('websocket'); Get or replace current header value, shortcut for the C header. =head2 user_agent my $agent = $headers->user_agent; $headers = $headers->user_agent('Mojo/1.0'); Get or replace current header value, shortcut for the C header. =head2 vary my $vary = $headers->vary; $headers = $headers->vary('*'); Get or replace current header value, shortcut for the C header. =head2 www_authenticate my $authenticate = $headers->www_authenticate; $headers = $headers->www_authenticate('Basic realm="realm"'); Get or replace current header value, shortcut for the C header. =head1 SEE ALSO L, L, L. =cut diff --git a/modules/Mojo/IOLoop.pm b/modules/Mojo/IOLoop.pm index f7b30b4..b258629 100644 --- a/modules/Mojo/IOLoop.pm +++ b/modules/Mojo/IOLoop.pm @@ -1,653 +1,653 @@ package Mojo::IOLoop; use Mojo::Base 'Mojo::EventEmitter'; # "Professor: Amy, technology isn't intrinsically good or evil. It's how it's # used. Like the death ray." use Carp 'croak'; use Mojo::IOLoop::Client; use Mojo::IOLoop::Delay; use Mojo::IOLoop::Server; use Mojo::IOLoop::Stream; use Mojo::IOLoop::Subprocess; use Mojo::Reactor::Poll; use Mojo::Util qw(md5_sum steady_time); use Scalar::Util qw(blessed weaken); use constant DEBUG => $ENV{MOJO_IOLOOP_DEBUG} || 0; has max_accepts => 0; has max_connections => 1000; has reactor => sub { my $class = Mojo::Reactor::Poll->detect; warn "-- Reactor initialized ($class)\n" if DEBUG; return $class->new->catch(sub { warn "@{[blessed $_[0]]}: $_[1]" }); }; # Ignore PIPE signal $SIG{PIPE} = 'IGNORE'; # Initialize singleton reactor early __PACKAGE__->singleton->reactor; sub acceptor { my ($self, $acceptor) = (_instance(shift), @_); # Find acceptor for id return $self->{acceptors}{$acceptor} unless ref $acceptor; # Connect acceptor with reactor $self->{acceptors}{my $id = $self->_id} = $acceptor->reactor($self->reactor); # Allow new acceptor to get picked up $self->_not_accepting->_maybe_accepting; return $id; } sub client { my ($self, $cb) = (_instance(shift), pop); my $id = $self->_id; my $client = $self->{out}{$id}{client} = Mojo::IOLoop::Client->new(reactor => $self->reactor); weaken $self; $client->on( connect => sub { delete $self->{out}{$id}{client}; my $stream = Mojo::IOLoop::Stream->new(pop); $self->_stream($stream => $id); $self->$cb(undef, $stream); } ); $client->on(error => sub { $self->_remove($id); $self->$cb(pop, undef) }); $client->connect(@_); return $id; } sub delay { my $delay = Mojo::IOLoop::Delay->new->ioloop(_instance(shift)); return @_ ? $delay->steps(@_) : $delay; } sub is_running { _instance(shift)->reactor->is_running } sub next_tick { my ($self, $cb) = (_instance(shift), @_); weaken $self; return $self->reactor->next_tick(sub { $self->$cb }); } sub one_tick { my $self = _instance(shift); croak 'Mojo::IOLoop already running' if $self->is_running; $self->reactor->one_tick; } sub recurring { shift->_timer(recurring => @_) } sub remove { my ($self, $id) = (_instance(shift), @_); my $c = $self->{in}{$id} || $self->{out}{$id}; if ($c && (my $stream = $c->{stream})) { return $stream->close_gracefully } $self->_remove($id); } sub reset { my $self = _instance(shift)->emit('reset'); delete @$self{qw(accepting acceptors events in out stop)}; $self->reactor->reset; $self->stop; } sub server { my ($self, $cb) = (_instance(shift), pop); my $server = Mojo::IOLoop::Server->new; weaken $self; $server->on( accept => sub { my $stream = Mojo::IOLoop::Stream->new(pop); $self->$cb($stream, $self->_stream($stream, $self->_id, 1)); # Enforce connection limit (randomize to improve load balancing) if (my $max = $self->max_accepts) { $self->{accepts} //= $max - int rand $max / 2; $self->stop_gracefully if ($self->{accepts} -= 1) <= 0; } # Stop accepting if connection limit has been reached $self->_not_accepting if $self->_limit; } ); $server->listen(@_); return $self->acceptor($server); } -sub singleton { state $loop = shift->SUPER::new } +sub singleton { state $loop = shift->new } sub start { my $self = _instance(shift); croak 'Mojo::IOLoop already running' if $self->is_running; $self->reactor->start; } sub stop { _instance(shift)->reactor->stop } sub stop_gracefully { my $self = _instance(shift)->_not_accepting; ++$self->{stop} and !$self->emit('finish')->_in and $self->stop; } sub stream { my ($self, $stream) = (_instance(shift), @_); return $self->_stream($stream => $self->_id) if ref $stream; my $c = $self->{in}{$stream} || $self->{out}{$stream} || {}; return $c->{stream}; } sub subprocess { my $subprocess = Mojo::IOLoop::Subprocess->new(ioloop => _instance(shift)); return @_ ? $subprocess->run(@_) : $subprocess; } sub timer { shift->_timer(timer => @_) } sub _id { my $self = shift; my $id; do { $id = md5_sum 'c' . steady_time . rand } while $self->{in}{$id} || $self->{out}{$id} || $self->{acceptors}{$id}; return $id; } sub _in { scalar keys %{shift->{in} || {}} } sub _instance { ref $_[0] ? $_[0] : $_[0]->singleton } sub _limit { $_[0]{stop} ? 1 : $_[0]->_in >= $_[0]->max_connections } sub _maybe_accepting { my $self = shift; return if $self->{accepting} || $self->_limit; $_->start for values %{$self->{acceptors} || {}}; $self->{accepting} = 1; } sub _not_accepting { my $self = shift; return $self unless delete $self->{accepting}; $_->stop for values %{$self->{acceptors} || {}}; return $self; } sub _out { scalar keys %{shift->{out} || {}} } sub _remove { my ($self, $id) = @_; # Timer return undef unless my $reactor = $self->reactor; return undef if $reactor->remove($id); # Acceptor return $self->_not_accepting->_maybe_accepting if delete $self->{acceptors}{$id}; # Connection return undef unless delete $self->{in}{$id} || delete $self->{out}{$id}; return $self->stop if $self->{stop} && !$self->_in; $self->_maybe_accepting; warn "-- $id <<< $$ (@{[$self->_in]}:@{[$self->_out]})\n" if DEBUG; } sub _stream { my ($self, $stream, $id, $server) = @_; # Connect stream with reactor $self->{$server ? 'in' : 'out'}{$id}{stream} = $stream->reactor($self->reactor); warn "-- $id >>> $$ (@{[$self->_in]}:@{[$self->_out]})\n" if DEBUG; weaken $self; $stream->on(close => sub { $self && $self->_remove($id) }); $stream->start; return $id; } sub _timer { my ($self, $method, $after, $cb) = (_instance(shift), @_); weaken $self; return $self->reactor->$method($after => sub { $self->$cb }); } 1; =encoding utf8 =head1 NAME Mojo::IOLoop - Minimalistic event loop =head1 SYNOPSIS use Mojo::IOLoop; # Listen on port 3000 Mojo::IOLoop->server({port => 3000} => sub { my ($loop, $stream) = @_; $stream->on(read => sub { my ($stream, $bytes) = @_; # Process input chunk say $bytes; # Write response $stream->write('HTTP/1.1 200 OK'); }); }); # Connect to port 3000 my $id = Mojo::IOLoop->client({port => 3000} => sub { my ($loop, $err, $stream) = @_; $stream->on(read => sub { my ($stream, $bytes) = @_; # Process input say "Input: $bytes"; }); # Write request $stream->write("GET / HTTP/1.1\x0d\x0a\x0d\x0a"); }); # Add a timer Mojo::IOLoop->timer(5 => sub { my $loop = shift; $loop->remove($id); }); # Start event loop if necessary Mojo::IOLoop->start unless Mojo::IOLoop->is_running; =head1 DESCRIPTION L is a very minimalistic event loop based on L, it has been reduced to the absolute minimal feature set required to build solid and scalable non-blocking clients and servers. Depending on operating system, the default per-process and system-wide file descriptor limits are often very low and need to be tuned for better scalability. The C environment variable should also be used to select the best possible L backend, which usually defaults to the not very scalable C