Initial Commit
This commit is contained in:
Riley Schneider
142
database/perl/vendor/lib/Mojo/Asset.pm
vendored
Normal file
142
database/perl/vendor/lib/Mojo/Asset.pm
vendored
Normal file
@@ -0,0 +1,142 @@
|
||||
package Mojo::Asset;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
has 'end_range';
|
||||
has start_range => 0;
|
||||
|
||||
sub add_chunk { croak 'Method "add_chunk" not implemented by subclass' }
|
||||
sub contains { croak 'Method "contains" not implemented by subclass' }
|
||||
sub get_chunk { croak 'Method "get_chunk" not implemented by subclass' }
|
||||
|
||||
sub is_file {undef}
|
||||
|
||||
sub is_range { !!($_[0]->end_range || $_[0]->start_range) }
|
||||
|
||||
sub move_to { croak 'Method "move_to" not implemented by subclass' }
|
||||
sub mtime { croak 'Method "mtime" not implemented by subclass' }
|
||||
sub size { croak 'Method "size" not implemented by subclass' }
|
||||
sub slurp { croak 'Method "slurp" not implemented by subclass' }
|
||||
sub to_file { croak 'Method "to_file" not implemented by subclass' }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Asset - HTTP content storage base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Asset::MyAsset;
|
||||
use Mojo::Base 'Mojo::Asset';
|
||||
|
||||
sub add_chunk {...}
|
||||
sub contains {...}
|
||||
sub get_chunk {...}
|
||||
sub move_to {...}
|
||||
sub mtime {...}
|
||||
sub size {...}
|
||||
sub slurp {...}
|
||||
sub to_file {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Asset> is an abstract base class for HTTP content storage backends, like L<Mojo::Asset::File> and
|
||||
L<Mojo::Asset::Memory>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Asset> inherits all events from L<Mojo::EventEmitter>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Asset> implements the following attributes.
|
||||
|
||||
=head2 end_range
|
||||
|
||||
my $end = $asset->end_range;
|
||||
$asset = $asset->end_range(8);
|
||||
|
||||
Pretend file ends earlier.
|
||||
|
||||
=head2 start_range
|
||||
|
||||
my $start = $asset->start_range;
|
||||
$asset = $asset->start_range(3);
|
||||
|
||||
Pretend file starts later.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Asset> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 add_chunk
|
||||
|
||||
$asset = $asset->add_chunk('foo bar baz');
|
||||
|
||||
Add chunk of data to asset. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 contains
|
||||
|
||||
my $position = $asset->contains('bar');
|
||||
|
||||
Check if asset contains a specific string. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 get_chunk
|
||||
|
||||
my $bytes = $asset->get_chunk($offset);
|
||||
my $bytes = $asset->get_chunk($offset, $max);
|
||||
|
||||
Get chunk of data starting from a specific position, defaults to a maximum chunk size of C<131072> bytes (128KiB).
|
||||
Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 is_file
|
||||
|
||||
my $bool = $asset->is_file;
|
||||
|
||||
False, this is not a L<Mojo::Asset::File> object.
|
||||
|
||||
=head2 is_range
|
||||
|
||||
my $bool = $asset->is_range;
|
||||
|
||||
Check if asset has a L</"start_range"> or L</"end_range">.
|
||||
|
||||
=head2 move_to
|
||||
|
||||
$asset = $asset->move_to('/home/sri/foo.txt');
|
||||
|
||||
Move asset data into a specific file. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 mtime
|
||||
|
||||
my $mtime = $asset->mtime;
|
||||
|
||||
Modification time of asset. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 size
|
||||
|
||||
my $size = $asset->size;
|
||||
|
||||
Size of asset data in bytes. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 slurp
|
||||
|
||||
my $bytes = $asset->slurp;
|
||||
|
||||
Read all asset data at once. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 to_file
|
||||
|
||||
my $file = $asset->to_file;
|
||||
|
||||
Convert asset to L<Mojo::Asset::File> object. Meant to be overloaded in a subclass.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
266
database/perl/vendor/lib/Mojo/Asset/File.pm
vendored
Normal file
266
database/perl/vendor/lib/Mojo/Asset/File.pm
vendored
Normal file
@@ -0,0 +1,266 @@
|
||||
package Mojo::Asset::File;
|
||||
use Mojo::Base 'Mojo::Asset';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Fcntl qw(SEEK_SET);
|
||||
use File::Spec::Functions ();
|
||||
use Mojo::File qw(tempfile);
|
||||
|
||||
has [qw(cleanup path)];
|
||||
has handle => sub {
|
||||
my $self = shift;
|
||||
|
||||
# Open existing file
|
||||
my $path = $self->path;
|
||||
return Mojo::File->new($path)->open('<') if defined $path && -e $path;
|
||||
|
||||
$self->cleanup(1) unless defined $self->cleanup;
|
||||
|
||||
# Create a specific file
|
||||
return Mojo::File->new($path)->open('+>>') if defined $path;
|
||||
|
||||
# Create a temporary file
|
||||
my $file = tempfile DIR => $self->tmpdir, TEMPLATE => 'mojo.tmp.XXXXXXXXXXXXXXXX', UNLINK => 0;
|
||||
$self->path($file->to_string);
|
||||
return $file->open('+>>');
|
||||
};
|
||||
has tmpdir => sub { $ENV{MOJO_TMPDIR} || File::Spec::Functions::tmpdir };
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
|
||||
return unless $self->cleanup && defined(my $path = $self->path);
|
||||
if (my $handle = $self->handle) { close $handle }
|
||||
|
||||
# Only the process that created the file is allowed to remove it
|
||||
Mojo::File->new($path)->remove if -w $path && ($self->{pid} // $$) == $$;
|
||||
}
|
||||
|
||||
sub add_chunk {
|
||||
my ($self, $chunk) = @_;
|
||||
($self->handle->syswrite($chunk) // -1) == length $chunk or croak "Can't write to asset: $!";
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub contains {
|
||||
my ($self, $str) = @_;
|
||||
|
||||
my $handle = $self->handle;
|
||||
$handle->sysseek($self->start_range, SEEK_SET);
|
||||
|
||||
# Calculate window size
|
||||
my $end = $self->end_range // $self->size;
|
||||
my $len = length $str;
|
||||
my $size = $len > 131072 ? $len : 131072;
|
||||
$size = $end - $self->start_range if $size > $end - $self->start_range;
|
||||
|
||||
# Sliding window search
|
||||
my $offset = 0;
|
||||
my $start = $handle->sysread(my $window, $len);
|
||||
while ($offset < $end) {
|
||||
|
||||
# Read as much as possible
|
||||
my $diff = $end - ($start + $offset);
|
||||
my $read = $handle->sysread(my $buffer, $diff < $size ? $diff : $size);
|
||||
$window .= $buffer;
|
||||
|
||||
# Search window
|
||||
my $pos = index $window, $str;
|
||||
return $offset + $pos if $pos >= 0;
|
||||
return -1 if $read == 0 || ($offset += $read) == $end;
|
||||
|
||||
# Resize window
|
||||
substr $window, 0, $read, '';
|
||||
}
|
||||
|
||||
return -1;
|
||||
}
|
||||
|
||||
sub get_chunk {
|
||||
my ($self, $offset, $max) = @_;
|
||||
$max //= 131072;
|
||||
|
||||
$offset += $self->start_range;
|
||||
my $handle = $self->handle;
|
||||
$handle->sysseek($offset, SEEK_SET);
|
||||
|
||||
my $buffer;
|
||||
if (defined(my $end = $self->end_range)) {
|
||||
return '' if (my $chunk = $end + 1 - $offset) <= 0;
|
||||
$handle->sysread($buffer, $chunk > $max ? $max : $chunk);
|
||||
}
|
||||
else { $handle->sysread($buffer, $max) }
|
||||
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
sub is_file {1}
|
||||
|
||||
sub move_to {
|
||||
my ($self, $to) = @_;
|
||||
|
||||
# Windows requires that the handle is closed
|
||||
close $self->handle;
|
||||
delete $self->{handle};
|
||||
|
||||
# Move file and prevent clean up
|
||||
Mojo::File->new($self->path)->move_to($to);
|
||||
return $self->path($to)->cleanup(0);
|
||||
}
|
||||
|
||||
sub mtime { (stat shift->handle)[9] }
|
||||
|
||||
sub new {
|
||||
my $file = shift->SUPER::new(@_);
|
||||
$file->{pid} = $$;
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub size { -s shift->handle }
|
||||
|
||||
sub slurp {
|
||||
my $handle = shift->handle;
|
||||
$handle->sysseek(0, SEEK_SET);
|
||||
my $ret = my $content = '';
|
||||
while ($ret = $handle->sysread(my $buffer, 131072, 0)) { $content .= $buffer }
|
||||
return defined $ret ? $content : croak "Can't read from asset: $!";
|
||||
}
|
||||
|
||||
sub to_file {shift}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Asset::File - File storage for HTTP content
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Asset::File;
|
||||
|
||||
# Temporary file
|
||||
my $file = Mojo::Asset::File->new;
|
||||
$file->add_chunk('foo bar baz');
|
||||
say 'File contains "bar"' if $file->contains('bar') >= 0;
|
||||
say $file->slurp;
|
||||
|
||||
# Existing file
|
||||
my $file = Mojo::Asset::File->new(path => '/home/sri/foo.txt');
|
||||
$file->move_to('/yada.txt');
|
||||
say $file->slurp;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Asset::File> is a file storage backend for HTTP content.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Asset::File> inherits all events from L<Mojo::Asset>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Asset::File> inherits all attributes from L<Mojo::Asset> and implements the following new ones.
|
||||
|
||||
=head2 cleanup
|
||||
|
||||
my $bool = $file->cleanup;
|
||||
$file = $file->cleanup($bool);
|
||||
|
||||
Delete L</"path"> automatically once the file is not used anymore.
|
||||
|
||||
=head2 handle
|
||||
|
||||
my $handle = $file->handle;
|
||||
$file = $file->handle(IO::File->new);
|
||||
|
||||
Filehandle, created on demand for L</"path">, which can be generated automatically and safely based on L</"tmpdir">.
|
||||
|
||||
=head2 path
|
||||
|
||||
my $path = $file->path;
|
||||
$file = $file->path('/home/sri/foo.txt');
|
||||
|
||||
File path used to create L</"handle">.
|
||||
|
||||
=head2 tmpdir
|
||||
|
||||
my $tmpdir = $file->tmpdir;
|
||||
$file = $file->tmpdir('/tmp');
|
||||
|
||||
Temporary directory used to generate L</"path">, defaults to the value of the C<MOJO_TMPDIR> environment variable or
|
||||
auto-detection.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Asset::File> inherits all methods from L<Mojo::Asset> and implements the following new ones.
|
||||
|
||||
=head2 add_chunk
|
||||
|
||||
$file = $file->add_chunk('foo bar baz');
|
||||
|
||||
Add chunk of data.
|
||||
|
||||
=head2 contains
|
||||
|
||||
my $position = $file->contains('bar');
|
||||
|
||||
Check if asset contains a specific string.
|
||||
|
||||
=head2 get_chunk
|
||||
|
||||
my $bytes = $file->get_chunk($offset);
|
||||
my $bytes = $file->get_chunk($offset, $max);
|
||||
|
||||
Get chunk of data starting from a specific position, defaults to a maximum chunk size of C<131072> bytes (128KiB).
|
||||
|
||||
=head2 is_file
|
||||
|
||||
my $bool = $file->is_file;
|
||||
|
||||
True, this is a L<Mojo::Asset::File> object.
|
||||
|
||||
=head2 move_to
|
||||
|
||||
$file = $file->move_to('/home/sri/bar.txt');
|
||||
|
||||
Move asset data into a specific file and disable L</"cleanup">.
|
||||
|
||||
=head2 mtime
|
||||
|
||||
my $mtime = $file->mtime;
|
||||
|
||||
Modification time of asset.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $file = Mojo::Asset::File->new;
|
||||
my $file = Mojo::Asset::File->new(path => '/home/sri/test.txt');
|
||||
my $file = Mojo::Asset::File->new({path => '/home/sri/test.txt'});
|
||||
|
||||
Construct a new L<Mojo::Asset::File> object.
|
||||
|
||||
=head2 size
|
||||
|
||||
my $size = $file->size;
|
||||
|
||||
Size of asset data in bytes.
|
||||
|
||||
=head2 slurp
|
||||
|
||||
my $bytes = $file->slurp;
|
||||
|
||||
Read all asset data at once.
|
||||
|
||||
=head2 to_file
|
||||
|
||||
$file = $file->to_file;
|
||||
|
||||
Does nothing but return the invocant, since we already have a L<Mojo::Asset::File> object.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
161
database/perl/vendor/lib/Mojo/Asset/Memory.pm
vendored
Normal file
161
database/perl/vendor/lib/Mojo/Asset/Memory.pm
vendored
Normal file
@@ -0,0 +1,161 @@
|
||||
package Mojo::Asset::Memory;
|
||||
use Mojo::Base 'Mojo::Asset';
|
||||
|
||||
use Mojo::Asset::File;
|
||||
use Mojo::File qw(path);
|
||||
|
||||
has 'auto_upgrade';
|
||||
has max_memory_size => sub { $ENV{MOJO_MAX_MEMORY_SIZE} || 262144 };
|
||||
has mtime => sub {$^T};
|
||||
|
||||
sub add_chunk {
|
||||
my ($self, $chunk) = @_;
|
||||
|
||||
# Upgrade if necessary
|
||||
$self->{content} .= $chunk;
|
||||
return $self if !$self->auto_upgrade || $self->size <= $self->max_memory_size;
|
||||
$self->emit(upgrade => my $file = Mojo::Asset::File->new);
|
||||
return $file->add_chunk($self->slurp);
|
||||
}
|
||||
|
||||
sub contains {
|
||||
my ($self, $str) = @_;
|
||||
|
||||
my $start = $self->start_range;
|
||||
my $pos = index $self->{content} // '', $str, $start;
|
||||
$pos -= $start if $start && $pos >= 0;
|
||||
my $end = $self->end_range;
|
||||
|
||||
return $end && ($pos + length $str) >= $end ? -1 : $pos;
|
||||
}
|
||||
|
||||
sub get_chunk {
|
||||
my ($self, $offset, $max) = @_;
|
||||
$max //= 131072;
|
||||
|
||||
$offset += $self->start_range;
|
||||
if (my $end = $self->end_range) { $max = $end + 1 - $offset if ($offset + $max) > $end }
|
||||
|
||||
return substr shift->{content} // '', $offset, $max;
|
||||
}
|
||||
|
||||
sub move_to { path($_[1])->spurt($_[0]{content} // '') and return $_[0] }
|
||||
|
||||
sub size { length(shift->{content} // '') }
|
||||
|
||||
sub slurp { shift->{content} // '' }
|
||||
|
||||
sub to_file { Mojo::Asset::File->new->add_chunk(shift->slurp) }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Asset::Memory - In-memory storage for HTTP content
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Asset::Memory;
|
||||
|
||||
my $mem = Mojo::Asset::Memory->new;
|
||||
$mem->add_chunk('foo bar baz');
|
||||
say $mem->slurp;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Asset::Memory> is an in-memory storage backend for HTTP content.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Asset::Memory> inherits all events from L<Mojo::Asset> and can emit the following new ones.
|
||||
|
||||
=head2 upgrade
|
||||
|
||||
$mem->on(upgrade => sub ($mem, $file) {...});
|
||||
|
||||
Emitted when asset gets upgraded to a L<Mojo::Asset::File> object.
|
||||
|
||||
$mem->on(upgrade => sub ($mem, $file) { $file->tmpdir('/tmp') });
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Asset::Memory> inherits all attributes from L<Mojo::Asset> and implements the following new ones.
|
||||
|
||||
=head2 auto_upgrade
|
||||
|
||||
my $bool = $mem->auto_upgrade;
|
||||
$mem = $mem->auto_upgrade($bool);
|
||||
|
||||
Try to detect if content size exceeds L</"max_memory_size"> limit and automatically upgrade to a L<Mojo::Asset::File>
|
||||
object.
|
||||
|
||||
=head2 max_memory_size
|
||||
|
||||
my $size = $mem->max_memory_size;
|
||||
$mem = $mem->max_memory_size(1024);
|
||||
|
||||
Maximum size in bytes of data to keep in memory before automatically upgrading to a L<Mojo::Asset::File> object,
|
||||
defaults to the value of the C<MOJO_MAX_MEMORY_SIZE> environment variable or C<262144> (256KiB).
|
||||
|
||||
=head2 mtime
|
||||
|
||||
my $mtime = $mem->mtime;
|
||||
$mem = $mem->mtime(1408567500);
|
||||
|
||||
Modification time of asset, defaults to the value of C<$^T>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Asset::Memory> inherits all methods from L<Mojo::Asset> and implements the following new ones.
|
||||
|
||||
=head2 add_chunk
|
||||
|
||||
$mem = $mem->add_chunk('foo bar baz');
|
||||
my $file = $mem->add_chunk('abc' x 262144);
|
||||
|
||||
Add chunk of data and upgrade to L<Mojo::Asset::File> object if necessary.
|
||||
|
||||
=head2 contains
|
||||
|
||||
my $position = $mem->contains('bar');
|
||||
|
||||
Check if asset contains a specific string.
|
||||
|
||||
=head2 get_chunk
|
||||
|
||||
my $bytes = $mem->get_chunk($offset);
|
||||
my $bytes = $mem->get_chunk($offset, $max);
|
||||
|
||||
Get chunk of data starting from a specific position, defaults to a maximum chunk size of C<131072> bytes (128KiB).
|
||||
|
||||
=head2 move_to
|
||||
|
||||
$mem = $mem->move_to('/home/sri/foo.txt');
|
||||
|
||||
Move asset data into a specific file.
|
||||
|
||||
=head2 size
|
||||
|
||||
my $size = $mem->size;
|
||||
|
||||
Size of asset data in bytes.
|
||||
|
||||
=head2 slurp
|
||||
|
||||
my $bytes = mem->slurp;
|
||||
|
||||
Read all asset data at once.
|
||||
|
||||
=head2 to_file
|
||||
|
||||
my $file = $mem->to_file;
|
||||
|
||||
Convert asset to L<Mojo::Asset::File> object.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
384
database/perl/vendor/lib/Mojo/Base.pm
vendored
Normal file
384
database/perl/vendor/lib/Mojo/Base.pm
vendored
Normal file
@@ -0,0 +1,384 @@
|
||||
package Mojo::Base;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature ':5.16';
|
||||
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;
|
||||
|
||||
# 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.36+
|
||||
use constant ASYNC => $ENV{MOJO_NO_ASYNC}
|
||||
? 0
|
||||
: !!(eval { require Future::AsyncAwait; Future::AsyncAwait->VERSION('0.36'); 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 = @_;
|
||||
|
||||
# Mojo modules are strict!
|
||||
$_->import for qw(strict warnings utf8);
|
||||
feature->import(':5.16');
|
||||
|
||||
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_await') {
|
||||
Carp::croak 'Future::AsyncAwait 0.36+ is required for async/await' unless ASYNC;
|
||||
require Mojo::Promise;
|
||||
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<Mojo::Base> is a simple base class for L<Mojo> projects with fluent interfaces.
|
||||
|
||||
# Automatically enables "strict", "warnings", "utf8" and Perl 5.16 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<Role::Tiny> (2.000001+).
|
||||
|
||||
# use Mojo::Base -strict;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature ':5.16';
|
||||
use mro;
|
||||
|
||||
# use Mojo::Base -base;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature ':5.16';
|
||||
use mro;
|
||||
push @ISA, 'Mojo::Base';
|
||||
sub has { Mojo::Base::attr(__PACKAGE__, @_) }
|
||||
|
||||
# use Mojo::Base 'SomeBaseClass';
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature ':5.16';
|
||||
use mro;
|
||||
require SomeBaseClass;
|
||||
push @ISA, 'SomeBaseClass';
|
||||
sub has { Mojo::Base::attr(__PACKAGE__, @_) }
|
||||
|
||||
# use Mojo::Base -role;
|
||||
use strict;
|
||||
use warnings;
|
||||
use utf8;
|
||||
use feature ':5.16';
|
||||
use mro;
|
||||
use Role::Tiny;
|
||||
sub has { Mojo::Base::attr(__PACKAGE__, @_) }
|
||||
|
||||
On Perl 5.20+ you can also use the C<-signatures> flag with all four forms and enable support for L<subroutine
|
||||
signatures|perlsub/"Signatures">.
|
||||
|
||||
# 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<Future::AsyncAwait> 0.36+ installed you can also use the C<-async_await> flag to activate the C<async>
|
||||
and C<await> keywords to deal much more efficiently with promises. Note that this feature is B<EXPERIMENTAL> and might
|
||||
change without warning!
|
||||
|
||||
# Also enable async/await
|
||||
use Mojo::Base -strict, -async_await;
|
||||
use Mojo::Base -base, -signatures, -async_await;
|
||||
|
||||
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 readability of the source code close to written prose.
|
||||
|
||||
package Duck;
|
||||
use Mojo::Base -base, -signatures;
|
||||
|
||||
has 'name';
|
||||
|
||||
sub quack ($self) {
|
||||
my $name = $self->name;
|
||||
say "$name: Quack!"
|
||||
}
|
||||
|
||||
L<Mojo::Base> will help you with this by having all attribute accessors created with L</"has"> (or L</"attr">) 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<name> attribute accessor is called on the object created by C<Duck-E<gt>new>. It assigns a new
|
||||
attribute value and then returns the C<Duck> object, so the C<quack> method can be called on it afterwards. These
|
||||
method chains can continue until one of the methods called does not return the C<Duck> object.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::Base> 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</"attr"> method.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Base> 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<circular references|perlref/"Circular-References"> 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<Role::Tiny> 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<MyClass::Role::RoleName> you
|
||||
can use the shorthand C<+RoleName>. Note that role support depends on L<Role::Tiny> (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<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
392
database/perl/vendor/lib/Mojo/ByteStream.pm
vendored
Normal file
392
database/perl/vendor/lib/Mojo/ByteStream.pm
vendored
Normal file
@@ -0,0 +1,392 @@
|
||||
package Mojo::ByteStream;
|
||||
use Mojo::Base -strict;
|
||||
use overload bool => sub {1}, '""' => sub { ${$_[0]} }, fallback => 1;
|
||||
|
||||
use Exporter qw(import);
|
||||
use Mojo::Collection;
|
||||
use Mojo::Util;
|
||||
|
||||
our @EXPORT_OK = ('b');
|
||||
|
||||
# Turn most functions from Mojo::Util into methods
|
||||
my @UTILS = (
|
||||
qw(b64_decode b64_encode camelize decamelize gunzip gzip hmac_sha1_sum html_unescape humanize_bytes md5_bytes),
|
||||
qw(md5_sum punycode_decode punycode_encode quote sha1_bytes sha1_sum slugify term_escape trim unindent unquote),
|
||||
qw(url_escape url_unescape xml_escape xor_encode)
|
||||
);
|
||||
for my $name (@UTILS) {
|
||||
my $sub = Mojo::Util->can($name);
|
||||
Mojo::Util::monkey_patch __PACKAGE__, $name, sub {
|
||||
my $self = shift;
|
||||
$$self = $sub->($$self, @_);
|
||||
return $self;
|
||||
};
|
||||
}
|
||||
|
||||
sub b { __PACKAGE__->new(@_) }
|
||||
|
||||
sub clone { $_[0]->new(${$_[0]}) }
|
||||
|
||||
sub decode { shift->_delegate(\&Mojo::Util::decode, @_) }
|
||||
sub encode { shift->_delegate(\&Mojo::Util::encode, @_) }
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
return bless \(my $dummy = join '', @_), ref $class || $class;
|
||||
}
|
||||
|
||||
sub say {
|
||||
my ($self, $handle) = @_;
|
||||
$handle ||= \*STDOUT;
|
||||
say $handle $$self;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub secure_compare { Mojo::Util::secure_compare ${shift()}, shift }
|
||||
|
||||
sub size { length ${$_[0]} }
|
||||
|
||||
sub split {
|
||||
my ($self, $pat, $lim) = (shift, shift, shift // 0);
|
||||
return Mojo::Collection->new(map { $self->new($_) } split $pat, $$self, $lim);
|
||||
}
|
||||
|
||||
sub tap { shift->Mojo::Base::tap(@_) }
|
||||
|
||||
sub to_string { ${$_[0]} }
|
||||
|
||||
sub with_roles { shift->Mojo::Base::with_roles(@_) }
|
||||
|
||||
sub _delegate {
|
||||
my ($self, $sub) = (shift, shift);
|
||||
$$self = $sub->(shift || 'UTF-8', $$self);
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::ByteStream - ByteStream
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::ByteStream;
|
||||
|
||||
# Manipulate bytestream
|
||||
my $stream = Mojo::ByteStream->new('foo_bar_baz');
|
||||
say $stream->camelize;
|
||||
|
||||
# Chain methods
|
||||
my $stream = Mojo::ByteStream->new('foo bar baz')->quote;
|
||||
$stream = $stream->unquote->encode('UTF-8')->b64_encode('');
|
||||
say "$stream";
|
||||
|
||||
# Use the alternative constructor
|
||||
use Mojo::ByteStream qw(b);
|
||||
my $stream = b('foobarbaz')->b64_encode('')->say;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::ByteStream> is a scalar-based container for bytestreams that provides a more friendly API for many of the
|
||||
functions in L<Mojo::Util>.
|
||||
|
||||
# Access scalar directly to manipulate bytestream
|
||||
my $stream = Mojo::ByteStream->new('foo');
|
||||
$$stream .= 'bar';
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::ByteStream> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 b
|
||||
|
||||
my $stream = b('test123');
|
||||
|
||||
Construct a new scalar-based L<Mojo::ByteStream> object.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::ByteStream> implements the following methods.
|
||||
|
||||
=head2 b64_decode
|
||||
|
||||
$stream = $stream->b64_decode;
|
||||
|
||||
Base64 decode bytestream with L<Mojo::Util/"b64_decode">.
|
||||
|
||||
=head2 b64_encode
|
||||
|
||||
$stream = $stream->b64_encode;
|
||||
$stream = $stream->b64_encode("\n");
|
||||
|
||||
Base64 encode bytestream with L<Mojo::Util/"b64_encode">.
|
||||
|
||||
# "Zm9vIGJhciBiYXo="
|
||||
b('foo bar baz')->b64_encode('');
|
||||
|
||||
=head2 camelize
|
||||
|
||||
$stream = $stream->camelize;
|
||||
|
||||
Camelize bytestream with L<Mojo::Util/"camelize">.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $stream2 = $stream->clone;
|
||||
|
||||
Return a new L<Mojo::ByteStream> object cloned from this bytestream.
|
||||
|
||||
=head2 decamelize
|
||||
|
||||
$stream = $stream->decamelize;
|
||||
|
||||
Decamelize bytestream with L<Mojo::Util/"decamelize">.
|
||||
|
||||
=head2 decode
|
||||
|
||||
$stream = $stream->decode;
|
||||
$stream = $stream->decode('iso-8859-1');
|
||||
|
||||
Decode bytestream with L<Mojo::Util/"decode">, defaults to using C<UTF-8>.
|
||||
|
||||
# "♥"
|
||||
b('%E2%99%A5')->url_unescape->decode;
|
||||
|
||||
=head2 encode
|
||||
|
||||
$stream = $stream->encode;
|
||||
$stream = $stream->encode('iso-8859-1');
|
||||
|
||||
Encode bytestream with L<Mojo::Util/"encode">, defaults to using C<UTF-8>.
|
||||
|
||||
# "%E2%99%A5"
|
||||
b('♥')->encode->url_escape;
|
||||
|
||||
=head2 gunzip
|
||||
|
||||
$stream = $stream->gunzip;
|
||||
|
||||
Uncompress bytestream with L<Mojo::Util/"gunzip">.
|
||||
|
||||
=head2 gzip
|
||||
|
||||
stream = $stream->gzip;
|
||||
|
||||
Compress bytestream with L<Mojo::Util/"gzip">.
|
||||
|
||||
=head2 hmac_sha1_sum
|
||||
|
||||
$stream = $stream->hmac_sha1_sum('passw0rd');
|
||||
|
||||
Generate HMAC-SHA1 checksum for bytestream with L<Mojo::Util/"hmac_sha1_sum">.
|
||||
|
||||
# "7fbdc89263974a89210ea71f171c77d3f8c21471"
|
||||
b('foo bar baz')->hmac_sha1_sum('secr3t');
|
||||
|
||||
=head2 html_unescape
|
||||
|
||||
$stream = $stream->html_unescape;
|
||||
|
||||
Unescape all HTML entities in bytestream with L<Mojo::Util/"html_unescape">.
|
||||
|
||||
# "%3Chtml%3E"
|
||||
b('<html>')->html_unescape->url_escape;
|
||||
|
||||
=head2 humanize_bytes
|
||||
|
||||
$stream = $stream->humanize_bytes;
|
||||
|
||||
Turn number of bytes into a simplified human readable format for bytestream with L<Mojo::Util/"humanize_bytes">.
|
||||
|
||||
=head2 md5_bytes
|
||||
|
||||
$stream = $stream->md5_bytes;
|
||||
|
||||
Generate binary MD5 checksum for bytestream with L<Mojo::Util/"md5_bytes">.
|
||||
|
||||
=head2 md5_sum
|
||||
|
||||
$stream = $stream->md5_sum;
|
||||
|
||||
Generate MD5 checksum for bytestream with L<Mojo::Util/"md5_sum">.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $stream = Mojo::ByteStream->new('test123');
|
||||
|
||||
Construct a new scalar-based L<Mojo::ByteStream> object.
|
||||
|
||||
=head2 punycode_decode
|
||||
|
||||
$stream = $stream->punycode_decode;
|
||||
|
||||
Punycode decode bytestream with L<Mojo::Util/"punycode_decode">.
|
||||
|
||||
=head2 punycode_encode
|
||||
|
||||
$stream = $stream->punycode_encode;
|
||||
|
||||
Punycode encode bytestream with L<Mojo::Util/"punycode_encode">.
|
||||
|
||||
=head2 quote
|
||||
|
||||
$stream = $stream->quote;
|
||||
|
||||
Quote bytestream with L<Mojo::Util/"quote">.
|
||||
|
||||
=head2 say
|
||||
|
||||
$stream = $stream->say;
|
||||
$stream = $stream->say(*STDERR);
|
||||
|
||||
Print bytestream to handle and append a newline, defaults to using C<STDOUT>.
|
||||
|
||||
=head2 secure_compare
|
||||
|
||||
my $bool = $stream->secure_compare($str);
|
||||
|
||||
Compare bytestream with L<Mojo::Util/"secure_compare">.
|
||||
|
||||
=head2 sha1_bytes
|
||||
|
||||
$stream = $stream->sha1_bytes;
|
||||
|
||||
Generate binary SHA1 checksum for bytestream with L<Mojo::Util/"sha1_bytes">.
|
||||
|
||||
=head2 sha1_sum
|
||||
|
||||
$stream = $stream->sha1_sum;
|
||||
|
||||
Generate SHA1 checksum for bytestream with L<Mojo::Util/"sha1_sum">.
|
||||
|
||||
=head2 size
|
||||
|
||||
my $size = $stream->size;
|
||||
|
||||
Size of bytestream.
|
||||
|
||||
=head2 slugify
|
||||
|
||||
$stream = $stream->slugify;
|
||||
$stream = $stream->slugify($bool);
|
||||
|
||||
Generate URL slug for bytestream with L<Mojo::Util/"slugify">.
|
||||
|
||||
=head2 split
|
||||
|
||||
my $collection = $stream->split(',');
|
||||
my $collection = $stream->split(',', -1);
|
||||
|
||||
Turn bytestream into L<Mojo::Collection> object containing L<Mojo::ByteStream> objects.
|
||||
|
||||
# "One,Two,Three"
|
||||
b("one,two,three")->split(',')->map('camelize')->join(',');
|
||||
|
||||
# "One,Two,Three,,,"
|
||||
b("one,two,three,,,")->split(',', -1)->map('camelize')->join(',');
|
||||
|
||||
=head2 tap
|
||||
|
||||
$stream = $stream->tap(sub {...});
|
||||
|
||||
Alias for L<Mojo::Base/"tap">.
|
||||
|
||||
=head2 term_escape
|
||||
|
||||
$stream = $stream->term_escape;
|
||||
|
||||
Escape POSIX control characters in bytestream with L<Mojo::Util/"term_escape">.
|
||||
|
||||
# Print binary checksum to terminal
|
||||
b('foo')->sha1_bytes->term_escape->say;
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $stream->to_string;
|
||||
|
||||
Stringify bytestream.
|
||||
|
||||
=head2 trim
|
||||
|
||||
$stream = $stream->trim;
|
||||
|
||||
Trim whitespace characters from both ends of bytestream with L<Mojo::Util/"trim">.
|
||||
|
||||
=head2 unindent
|
||||
|
||||
$stream = $stream->unindent;
|
||||
|
||||
Unindent bytestream with L<Mojo::Util/"unindent">.
|
||||
|
||||
=head2 unquote
|
||||
|
||||
$stream = $stream->unquote;
|
||||
|
||||
Unquote bytestream with L<Mojo::Util/"unquote">.
|
||||
|
||||
=head2 url_escape
|
||||
|
||||
$stream = $stream->url_escape;
|
||||
$stream = $stream->url_escape('^A-Za-z0-9\-._~');
|
||||
|
||||
Percent encode all unsafe characters in bytestream with L<Mojo::Util/"url_escape">.
|
||||
|
||||
# "%E2%98%83"
|
||||
b('☃')->encode->url_escape;
|
||||
|
||||
=head2 url_unescape
|
||||
|
||||
$stream = $stream->url_unescape;
|
||||
|
||||
Decode percent encoded characters in bytestream with L<Mojo::Util/"url_unescape">.
|
||||
|
||||
# "<html>"
|
||||
b('%3Chtml%3E')->url_unescape->xml_escape;
|
||||
|
||||
=head2 with_roles
|
||||
|
||||
my $new_class = Mojo::ByteStream->with_roles('Mojo::ByteStream::Role::One');
|
||||
my $new_class = Mojo::ByteStream->with_roles('+One', '+Two');
|
||||
$stream = $stream->with_roles('+One', '+Two');
|
||||
|
||||
Alias for L<Mojo::Base/"with_roles">.
|
||||
|
||||
=head2 xml_escape
|
||||
|
||||
$stream = $stream->xml_escape;
|
||||
|
||||
Escape only the characters C<&>, C<E<lt>>, C<E<gt>>, C<"> and C<'> in bytestream with L<Mojo::Util/"xml_escape">.
|
||||
|
||||
=head2 xor_encode
|
||||
|
||||
$stream = $stream->xor_encode($key);
|
||||
|
||||
XOR encode bytestream with L<Mojo::Util/"xor_encode">.
|
||||
|
||||
# "%04%0E%15B%03%1B%10"
|
||||
b('foo bar')->xor_encode('baz')->url_escape;
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::ByteStream> overloads the following operators.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$bytestream;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$bytestream";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
73
database/perl/vendor/lib/Mojo/Cache.pm
vendored
Normal file
73
database/perl/vendor/lib/Mojo/Cache.pm
vendored
Normal file
@@ -0,0 +1,73 @@
|
||||
package Mojo::Cache;
|
||||
use Mojo::Base -base;
|
||||
|
||||
has 'max_keys' => 100;
|
||||
|
||||
sub get { (shift->{cache} // {})->{shift()} }
|
||||
|
||||
sub set {
|
||||
my ($self, $key, $value) = @_;
|
||||
|
||||
return $self unless (my $max = $self->max_keys) > 0;
|
||||
|
||||
my $cache = $self->{cache} //= {};
|
||||
my $queue = $self->{queue} //= [];
|
||||
delete $cache->{shift @$queue} while @$queue >= $max;
|
||||
push @$queue, $key unless exists $cache->{$key};
|
||||
$cache->{$key} = $value;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Cache - Naive in-memory cache
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Cache;
|
||||
|
||||
my $cache = Mojo::Cache->new(max_keys => 50);
|
||||
$cache->set(foo => 'bar');
|
||||
my $foo = $cache->get('foo');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Cache> is a naive in-memory cache with size limits.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Cache> implements the following attributes.
|
||||
|
||||
=head2 max_keys
|
||||
|
||||
my $max = $cache->max_keys;
|
||||
$cache = $cache->max_keys(50);
|
||||
|
||||
Maximum number of cache keys, defaults to C<100>. Setting the value to C<0> will disable caching.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Cache> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 get
|
||||
|
||||
my $value = $cache->get('foo');
|
||||
|
||||
Get cached value.
|
||||
|
||||
=head2 set
|
||||
|
||||
$cache = $cache->set(foo => 'bar');
|
||||
|
||||
Set cached value.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
400
database/perl/vendor/lib/Mojo/Collection.pm
vendored
Normal file
400
database/perl/vendor/lib/Mojo/Collection.pm
vendored
Normal file
@@ -0,0 +1,400 @@
|
||||
package Mojo::Collection;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use re qw(is_regexp);
|
||||
use Carp qw(croak);
|
||||
use Exporter qw(import);
|
||||
use List::Util;
|
||||
use Mojo::ByteStream;
|
||||
use Scalar::Util qw(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 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 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 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 ($word, $num) {
|
||||
say "$num: $word";
|
||||
});
|
||||
|
||||
# Use the alternative constructor
|
||||
use Mojo::Collection qw(c);
|
||||
c(qw(a b c))->join('/')->url_escape->say;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Collection> 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<Mojo::Collection> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 c
|
||||
|
||||
my $collection = c(1, 2, 3);
|
||||
|
||||
Construct a new array-based L<Mojo::Collection> object.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Collection> implements the following methods.
|
||||
|
||||
=head2 TO_JSON
|
||||
|
||||
my $array = $collection->TO_JSON;
|
||||
|
||||
Alias for L</"to_array">.
|
||||
|
||||
=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 ($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<Mojo::ByteStream>.
|
||||
|
||||
# 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<Mojo::Collection> 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 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<Mojo::Base/"tap">.
|
||||
|
||||
=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<undef> 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<Mojo::Base/"with_roles">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
548
database/perl/vendor/lib/Mojo/Content.pm
vendored
Normal file
548
database/perl/vendor/lib/Mojo/Content.pm
vendored
Normal file
@@ -0,0 +1,548 @@
|
||||
package Mojo::Content;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Compress::Raw::Zlib qw(WANT_GZIP Z_STREAM_END);
|
||||
use Mojo::Headers;
|
||||
use Scalar::Util qw(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} //= '');
|
||||
return delete $self->{body_buffer} if length $self->{body_buffer};
|
||||
return '' if $self->{eof};
|
||||
|
||||
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->{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}++;
|
||||
}
|
||||
|
||||
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<Mojo::Content> is an abstract base class for HTTP content containers, based on L<RFC
|
||||
7230|https://tools.ietf.org/html/rfc7230> and L<RFC 7231|https://tools.ietf.org/html/rfc7231>, like
|
||||
L<Mojo::Content::MultiPart> and L<Mojo::Content::Single>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Content> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 body
|
||||
|
||||
$content->on(body => sub ($content) {...});
|
||||
|
||||
Emitted once all headers have been parsed and the body starts.
|
||||
|
||||
$content->on(body => sub ($content) {
|
||||
$content->auto_upgrade(0) if $content->headers->header('X-No-MultiPart');
|
||||
});
|
||||
|
||||
=head2 drain
|
||||
|
||||
$content->on(drain => sub ($content, $offset) {...});
|
||||
|
||||
Emitted once all data has been written.
|
||||
|
||||
$content->on(drain => sub ($content) {
|
||||
$content->write_chunk(time);
|
||||
});
|
||||
|
||||
=head2 read
|
||||
|
||||
$content->on(read => sub ($content, $bytes) {...});
|
||||
|
||||
Emitted when a new chunk of content arrives.
|
||||
|
||||
$content->on(read => sub ($content, $bytes) {
|
||||
say "Streaming: $bytes";
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Content> implements the following attributes.
|
||||
|
||||
=head2 auto_decompress
|
||||
|
||||
my $bool = $content->auto_decompress;
|
||||
$content = $content->auto_decompress($bool);
|
||||
|
||||
Decompress content automatically if L</"is_compressed"> 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<Mojo::Headers> 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<MOJO_MAX_BUFFER_SIZE> 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<MOJO_MAX_LEFTOVER_SIZE>
|
||||
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<Mojo::Content> inherits all methods from L<Mojo::EventEmitter> 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<Content-Type> header.
|
||||
|
||||
=head2 charset
|
||||
|
||||
my $charset = $content->charset;
|
||||
|
||||
Extract charset from C<Content-Type> header.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $clone = $content->clone;
|
||||
|
||||
Return a new L<Mojo::Content> object cloned from this content if possible, otherwise return C<undef>.
|
||||
|
||||
=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<Transfer-Encoding> header indicates chunked transfer encoding.
|
||||
|
||||
=head2 is_compressed
|
||||
|
||||
my $bool = $content->is_compressed;
|
||||
|
||||
Check C<Content-Encoding> header for C<gzip> value.
|
||||
|
||||
=head2 is_dynamic
|
||||
|
||||
my $bool = $content->is_dynamic;
|
||||
|
||||
Check if content will be dynamically generated, which prevents L</"clone"> 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</"max_buffer_size">.
|
||||
|
||||
=head2 is_multipart
|
||||
|
||||
my $bool = $content->is_multipart;
|
||||
|
||||
False, this is not a L<Mojo::Content::MultiPart> 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</"headers"> 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 ($content) {
|
||||
$content->write('llo!' => sub ($content) {
|
||||
$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</"headers"> 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 ($content) {
|
||||
$content->write_chunk('llo!' => sub ($content) {
|
||||
$content->write_chunk('');
|
||||
});
|
||||
});
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
290
database/perl/vendor/lib/Mojo/Content/MultiPart.pm
vendored
Normal file
290
database/perl/vendor/lib/Mojo/Content/MultiPart.pm
vendored
Normal file
@@ -0,0 +1,290 @@
|
||||
package Mojo::Content::MultiPart;
|
||||
use Mojo::Base 'Mojo::Content';
|
||||
|
||||
use Mojo::Util qw(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<Mojo::Content::MultiPart> is a container for HTTP multipart content, based on L<RFC
|
||||
7230|https://tools.ietf.org/html/rfc7230>, L<RFC 7231|https://tools.ietf.org/html/rfc7231> and L<RFC
|
||||
2388|https://tools.ietf.org/html/rfc2388>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Content::Multipart> inherits all events from L<Mojo::Content> and can emit the following new ones.
|
||||
|
||||
=head2 part
|
||||
|
||||
$multi->on(part => sub ($multi, $single) {...});
|
||||
|
||||
Emitted when a new L<Mojo::Content::Single> part starts.
|
||||
|
||||
$multi->on(part => sub ($multi, $single) {
|
||||
return unless $single->headers->content_disposition =~ /name="([^"]+)"/;
|
||||
say "Field: $1";
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Content::MultiPart> inherits all attributes from L<Mojo::Content> 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<Mojo::Content::Single> objects.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Content::MultiPart> inherits all methods from L<Mojo::Content> 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<Content-Type> header.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $clone = $multi->clone;
|
||||
|
||||
Return a new L<Mojo::Content::MultiPart> object cloned from this content if possible, otherwise return C<undef>.
|
||||
|
||||
=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<Mojo::Content::MultiPart> 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<Mojo::Content::MultiPart> object and subscribe to event L<Mojo::Content/"read"> with default content
|
||||
parser.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
156
database/perl/vendor/lib/Mojo/Content/Single.pm
vendored
Normal file
156
database/perl/vendor/lib/Mojo/Content/Single.pm
vendored
Normal file
@@ -0,0 +1,156 @@
|
||||
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<Mojo::Content::Single> is a container for HTTP content, based on L<RFC 7230|https://tools.ietf.org/html/rfc7230> and
|
||||
L<RFC 7231|https://tools.ietf.org/html/rfc7231>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Content::Single> inherits all events from L<Mojo::Content> and can emit the following new ones.
|
||||
|
||||
=head2 upgrade
|
||||
|
||||
$single->on(upgrade => sub ($single, $multi) {...});
|
||||
|
||||
Emitted when content gets upgraded to a L<Mojo::Content::MultiPart> object.
|
||||
|
||||
$single->on(upgrade => sub ($single, $multi) {
|
||||
return unless $multi->headers->content_type =~ /multipart\/([^;]+)/i;
|
||||
say "Multipart: $1";
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Content::Single> inherits all attributes from L<Mojo::Content> 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<Mojo::Asset::Memory> object with L<Mojo::Asset::Memory/"auto_upgrade"> 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<Mojo::Content::MultiPart> object, defaults to a true
|
||||
value.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Content::Single> inherits all methods from L<Mojo::Content> 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<Mojo::Content::Single> object cloned from this content if possible, otherwise return C<undef>.
|
||||
|
||||
=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<Mojo::Content::Single> object and subscribe to event L<Mojo::Content/"read"> 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<Mojo::Content::MultiPart> object if necessary.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
87
database/perl/vendor/lib/Mojo/Cookie.pm
vendored
Normal file
87
database/perl/vendor/lib/Mojo/Cookie.pm
vendored
Normal file
@@ -0,0 +1,87 @@
|
||||
package Mojo::Cookie;
|
||||
use Mojo::Base -base;
|
||||
use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
has [qw(name value)];
|
||||
|
||||
sub parse { croak 'Method "parse" not implemented by subclass' }
|
||||
sub to_string { croak 'Method "to_string" not implemented by subclass' }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Cookie - HTTP cookie base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Cookie::MyCookie;
|
||||
use Mojo::Base 'Mojo::Cookie';
|
||||
|
||||
sub parse {...}
|
||||
sub to_string {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Cookie> is an abstract base class for HTTP cookie containers, based on L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>, like L<Mojo::Cookie::Request> and L<Mojo::Cookie::Response>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Cookie> implements the following attributes.
|
||||
|
||||
=head2 name
|
||||
|
||||
my $name = $cookie->name;
|
||||
$cookie = $cookie->name('foo');
|
||||
|
||||
Cookie name.
|
||||
|
||||
=head2 value
|
||||
|
||||
my $value = $cookie->value;
|
||||
$cookie = $cookie->value('/test');
|
||||
|
||||
Cookie value.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Cookie> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 parse
|
||||
|
||||
my $cookies = $cookie->parse($str);
|
||||
|
||||
Parse cookies. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $cookie->to_string;
|
||||
|
||||
Render cookie. Meant to be overloaded in a subclass.
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Cookie> overloads the following operators.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$cookie;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$cookie";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
72
database/perl/vendor/lib/Mojo/Cookie/Request.pm
vendored
Normal file
72
database/perl/vendor/lib/Mojo/Cookie/Request.pm
vendored
Normal file
@@ -0,0 +1,72 @@
|
||||
package Mojo::Cookie::Request;
|
||||
use Mojo::Base 'Mojo::Cookie';
|
||||
|
||||
use Mojo::Util qw(quote split_header);
|
||||
|
||||
sub parse {
|
||||
my ($self, $str) = @_;
|
||||
|
||||
my @cookies;
|
||||
my @pairs = map {@$_} @{split_header $str // ''};
|
||||
while (my ($name, $value) = splice @pairs, 0, 2) {
|
||||
next if $name =~ /^\$/;
|
||||
push @cookies, $self->new(name => $name, value => $value // '');
|
||||
}
|
||||
|
||||
return \@cookies;
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
return '' unless length(my $name = $self->name // '');
|
||||
my $value = $self->value // '';
|
||||
return join '=', $name, $value =~ /[,;" ]/ ? quote $value : $value;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Cookie::Request - HTTP request cookie
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Cookie::Request;
|
||||
|
||||
my $cookie = Mojo::Cookie::Request->new;
|
||||
$cookie->name('foo');
|
||||
$cookie->value('bar');
|
||||
say "$cookie";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Cookie::Request> is a container for HTTP request cookies, based on L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Cookie::Request> inherits all attributes from L<Mojo::Cookie>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Cookie::Request> inherits all methods from L<Mojo::Cookie> and implements the following new ones.
|
||||
|
||||
=head2 parse
|
||||
|
||||
my $cookies = Mojo::Cookie::Request->parse('f=b; g=a');
|
||||
|
||||
Parse cookies.
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $cookie->to_string;
|
||||
|
||||
Render cookie.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
169
database/perl/vendor/lib/Mojo/Cookie/Response.pm
vendored
Normal file
169
database/perl/vendor/lib/Mojo/Cookie/Response.pm
vendored
Normal file
@@ -0,0 +1,169 @@
|
||||
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 $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<Mojo::Cookie::Response> is a container for HTTP response cookies, based on L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Cookie::Response> inherits all attributes from L<Mojo::Cookie> 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</"domain">.
|
||||
|
||||
=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 B<EXPERIMENTAL> because even though most commonly used browsers support the
|
||||
feature, there is no specification yet besides L<this
|
||||
draft|https://tools.ietf.org/html/draft-west-first-party-cookies-07>.
|
||||
|
||||
=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<Mojo::Cookie::Response> inherits all methods from L<Mojo::Cookie> 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<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
1105
database/perl/vendor/lib/Mojo/DOM.pm
vendored
Normal file
1105
database/perl/vendor/lib/Mojo/DOM.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
736
database/perl/vendor/lib/Mojo/DOM/CSS.pm
vendored
Normal file
736
database/perl/vendor/lib/Mojo/DOM/CSS.pm
vendored
Normal file
@@ -0,0 +1,736 @@
|
||||
package Mojo::DOM::CSS;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::Util qw(dumper trim);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_DOM_CSS_DEBUG} || 0;
|
||||
|
||||
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|I)|s|S))? # Case-sensitivity
|
||||
)?
|
||||
\]
|
||||
/x;
|
||||
|
||||
sub matches {
|
||||
my $tree = shift->tree;
|
||||
return $tree->[0] ne 'tag' ? undef : _match(_compile(@_), $tree, $tree, _root($tree));
|
||||
}
|
||||
|
||||
sub select { _select(0, shift->tree, _compile(@_)) }
|
||||
sub select_one { _select(1, shift->tree, _compile(@_)) }
|
||||
|
||||
sub _absolutize { [map { _is_scoped($_) ? $_ : [[['pc', 'scope']], ' ', @$_] } @{shift()}] }
|
||||
|
||||
sub _ancestor {
|
||||
my ($selectors, $current, $tree, $scope, $one, $pos) = @_;
|
||||
|
||||
while ($current ne $scope && $current->[0] ne 'root' && ($current = $current->[3])) {
|
||||
return 1 if _combinator($selectors, $current, $tree, $scope, $pos);
|
||||
return undef if $current eq $scope;
|
||||
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, $scope, $pos) = @_;
|
||||
|
||||
# Selector
|
||||
return undef unless my $c = $selectors->[$pos];
|
||||
if (ref $c) {
|
||||
return undef unless _selector($c, $current, $tree, $scope);
|
||||
return 1 unless $c = $selectors->[++$pos];
|
||||
}
|
||||
|
||||
# ">" (parent only)
|
||||
return _ancestor($selectors, $current, $tree, $scope, 1, ++$pos) if $c eq '>';
|
||||
|
||||
# "~" (preceding siblings)
|
||||
return _sibling($selectors, $current, $tree, $scope, 0, ++$pos) if $c eq '~';
|
||||
|
||||
# "+" (immediately preceding siblings)
|
||||
return _sibling($selectors, $current, $tree, $scope, 1, ++$pos) if $c eq '+';
|
||||
|
||||
# " " (ancestor)
|
||||
return _ancestor($selectors, $current, $tree, $scope, 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 @$last, ['pc', 'scope'] unless @$last;
|
||||
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);
|
||||
|
||||
# ":is" and ":not" (contains more selectors)
|
||||
$args = _compile($args, %ns) if $name eq 'has' || $name eq 'is' || $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 { pos $css < length $css ? croak "Unknown CSS selector: $css" : last }
|
||||
}
|
||||
|
||||
warn qq{-- CSS Selector ($css)\n@{[dumper $group]}} if DEBUG;
|
||||
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 _is_scoped {
|
||||
my $selector = shift;
|
||||
|
||||
for my $pc (grep { $_->[0] eq 'pc' } map { ref $_ ? @$_ : () } @$selector) {
|
||||
|
||||
# Selector with ":scope"
|
||||
return 1 if $pc->[1] eq 'scope';
|
||||
|
||||
# Argument of functional pseudo-class with ":scope"
|
||||
return 1 if ($pc->[1] eq 'has' || $pc->[1] eq 'is' || $pc->[1] eq 'not') && grep { _is_scoped($_) } @{$pc->[2]};
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _match {
|
||||
my ($group, $current, $tree, $scope) = @_;
|
||||
_combinator([reverse @$_], $current, $tree, $scope, 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, $tree, $scope) = @_;
|
||||
|
||||
# ":scope" (root can only be a :scope)
|
||||
return $current eq $scope if $class eq 'scope';
|
||||
return undef if $current->[0] eq 'root';
|
||||
|
||||
# ":checked"
|
||||
return exists $current->[2]{checked} || exists $current->[2]{selected} if $class eq 'checked';
|
||||
|
||||
# ":not"
|
||||
return !_match($args, $current, $current, $scope) if $class eq 'not';
|
||||
|
||||
# ":is"
|
||||
return !!_match($args, $current, $current, $scope) if $class eq 'is';
|
||||
|
||||
# ":has"
|
||||
return !!_select(1, $current, $args) if $class eq 'has';
|
||||
|
||||
# ":empty"
|
||||
return !grep { !_empty($_) } @$current[4 .. $#$current] if $class eq 'empty';
|
||||
|
||||
# ":root"
|
||||
return $current->[3] && $current->[3][0] eq 'root' if $class eq 'root';
|
||||
|
||||
# ":any-link", ":link" and ":visited"
|
||||
if ($class eq 'any-link' || $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 _root {
|
||||
my $tree = shift;
|
||||
$tree = $tree->[3] while $tree->[0] ne 'root';
|
||||
return $tree;
|
||||
}
|
||||
|
||||
sub _select {
|
||||
my ($one, $scope, $group) = @_;
|
||||
|
||||
# Scoped selectors require the whole tree to be searched
|
||||
my $tree = $scope;
|
||||
($group, $tree) = (_absolutize($group), _root($scope)) if grep { _is_scoped($_) } @$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, $scope);
|
||||
$one ? return $current : push @results, $current;
|
||||
}
|
||||
|
||||
return $one ? undef : \@results;
|
||||
}
|
||||
|
||||
sub _selector {
|
||||
my ($selector, $current, $tree, $scope) = @_;
|
||||
|
||||
# The root might be the scope
|
||||
my $is_tag = $current->[0] eq 'tag';
|
||||
for my $s (@$selector) {
|
||||
my $type = $s->[0];
|
||||
|
||||
# Tag
|
||||
if ($is_tag && $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 ($is_tag && $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, $tree, $scope) }
|
||||
|
||||
# No match
|
||||
else { return undef }
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _sibling {
|
||||
my ($selectors, $current, $tree, $scope, $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, $scope, $pos) }
|
||||
|
||||
# "~" (preceding sibling)
|
||||
else { return 1 if _combinator($selectors, $sibling, $tree, $scope, $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<Mojo::DOM::CSS> is the CSS selector engine used by L<Mojo::DOM>, based on the L<HTML Living
|
||||
Standard|https://html.spec.whatwg.org> and L<Selectors Level 3|https://www.w3.org/TR/css3-selectors/>.
|
||||
|
||||
=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<E>.
|
||||
|
||||
my $title = $css->select('title');
|
||||
|
||||
=head2 E[foo]
|
||||
|
||||
An C<E> element with a C<foo> attribute.
|
||||
|
||||
my $links = $css->select('a[href]');
|
||||
|
||||
=head2 E[foo="bar"]
|
||||
|
||||
An C<E> element whose C<foo> attribute value is exactly equal to C<bar>.
|
||||
|
||||
my $case_sensitive = $css->select('input[type="hidden"]');
|
||||
my $case_sensitive = $css->select('input[type=hidden]');
|
||||
|
||||
=head2 E[foo="bar" i]
|
||||
|
||||
An C<E> element whose C<foo> attribute value is exactly equal to any (ASCII-range) case-permutation of C<bar>. Note
|
||||
that this selector is B<EXPERIMENTAL> 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<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
|
||||
=head2 E[foo="bar" s]
|
||||
|
||||
An C<E> element whose C<foo> attribute value is exactly and case-sensitively equal to C<bar>. Note that this selector
|
||||
is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
my $case_sensitive = $css->select('input[type="hidden" s]');
|
||||
|
||||
This selector is part of L<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
|
||||
=head2 E[foo~="bar"]
|
||||
|
||||
An C<E> element whose C<foo> attribute value is a list of whitespace-separated values, one of which is exactly equal to
|
||||
C<bar>.
|
||||
|
||||
my $foo = $css->select('input[class~="foo"]');
|
||||
my $foo = $css->select('input[class~=foo]');
|
||||
|
||||
=head2 E[foo^="bar"]
|
||||
|
||||
An C<E> element whose C<foo> attribute value begins exactly with the string C<bar>.
|
||||
|
||||
my $begins_with = $css->select('input[name^="f"]');
|
||||
my $begins_with = $css->select('input[name^=f]');
|
||||
|
||||
=head2 E[foo$="bar"]
|
||||
|
||||
An C<E> element whose C<foo> attribute value ends exactly with the string C<bar>.
|
||||
|
||||
my $ends_with = $css->select('input[name$="o"]');
|
||||
my $ends_with = $css->select('input[name$=o]');
|
||||
|
||||
=head2 E[foo*="bar"]
|
||||
|
||||
An C<E> element whose C<foo> attribute value contains the substring C<bar>.
|
||||
|
||||
my $contains = $css->select('input[name*="fo"]');
|
||||
my $contains = $css->select('input[name*=fo]');
|
||||
|
||||
=head2 E[foo|="en"]
|
||||
|
||||
An C<E> element whose C<foo> attribute has a hyphen-separated list of values beginning (from the left) with C<en>.
|
||||
|
||||
my $english = $css->select('link[hreflang|=en]');
|
||||
|
||||
=head2 E:root
|
||||
|
||||
An C<E> element, root of the document.
|
||||
|
||||
my $root = $css->select(':root');
|
||||
|
||||
=head2 E:nth-child(n)
|
||||
|
||||
An C<E> element, the C<n-th> 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<E> element, the C<n-th> 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<E> element, the C<n-th> 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<E> element, the C<n-th> 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<E> element, first child of its parent.
|
||||
|
||||
my $first = $css->select('div p:first-child');
|
||||
|
||||
=head2 E:last-child
|
||||
|
||||
An C<E> element, last child of its parent.
|
||||
|
||||
my $last = $css->select('div p:last-child');
|
||||
|
||||
=head2 E:first-of-type
|
||||
|
||||
An C<E> element, first sibling of its type.
|
||||
|
||||
my $first = $css->select('div p:first-of-type');
|
||||
|
||||
=head2 E:last-of-type
|
||||
|
||||
An C<E> element, last sibling of its type.
|
||||
|
||||
my $last = $css->select('div p:last-of-type');
|
||||
|
||||
=head2 E:only-child
|
||||
|
||||
An C<E> element, only child of its parent.
|
||||
|
||||
my $lonely = $css->select('div p:only-child');
|
||||
|
||||
=head2 E:only-of-type
|
||||
|
||||
An C<E> element, only sibling of its type.
|
||||
|
||||
my $lonely = $css->select('div p:only-of-type');
|
||||
|
||||
=head2 E:empty
|
||||
|
||||
An C<E> element that has no children (including text nodes).
|
||||
|
||||
my $empty = $css->select(':empty');
|
||||
|
||||
=head2 E:any-link
|
||||
|
||||
Alias for L</"E:link">. Note that this selector is B<EXPERIMENTAL> and might change without warning! This selector is
|
||||
part of L<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
|
||||
=head2 E:link
|
||||
|
||||
An C<E> 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<Mojo::DOM::CSS> is not stateful, therefore C<:any-link>, C<:link> and C<:visited>
|
||||
yield exactly the same results.
|
||||
|
||||
my $links = $css->select(':any-link');
|
||||
my $links = $css->select(':link');
|
||||
my $links = $css->select(':visited');
|
||||
|
||||
=head2 E:visited
|
||||
|
||||
Alias for L</"E:link">.
|
||||
|
||||
=head2 E:scope
|
||||
|
||||
An C<E> element being a designated reference element. Note that this selector is B<EXPERIMENTAL> and might change
|
||||
without warning!
|
||||
|
||||
my $scoped = $css->select('a:not(:scope > a)');
|
||||
my $scoped = $css->select('div :scope p');
|
||||
my $scoped = $css->select('~ p');
|
||||
|
||||
This selector is part of L<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
|
||||
=head2 E:checked
|
||||
|
||||
A user interface element C<E> which is checked (for instance a radio-button or checkbox).
|
||||
|
||||
my $input = $css->select(':checked');
|
||||
|
||||
=head2 E.warning
|
||||
|
||||
An C<E> element whose class is "warning".
|
||||
|
||||
my $warning = $css->select('div.warning');
|
||||
|
||||
=head2 E#myid
|
||||
|
||||
An C<E> element with C<ID> equal to "myid".
|
||||
|
||||
my $foo = $css->select('div#foo');
|
||||
|
||||
=head2 E:not(s1, s2)
|
||||
|
||||
An C<E> element that does not match either compound selector C<s1> or compound selector C<s2>. Note that support for
|
||||
compound selectors is B<EXPERIMENTAL> 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<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is
|
||||
still a work in progress.
|
||||
|
||||
=head2 E:is(s1, s2)
|
||||
|
||||
An C<E> element that matches compound selector C<s1> and/or compound selector C<s2>. Note that this selector is
|
||||
B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
my $headers = $css->select(':is(section, article, aside, nav) h1');
|
||||
|
||||
This selector is part of L<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
|
||||
=head2 E:has(rs1, rs2)
|
||||
|
||||
An C<E> element, if either of the relative selectors C<rs1> or C<rs2>, when evaluated with C<E> as the :scope elements,
|
||||
match an element. Note that this selector is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
my $link = $css->select('a:has(> img)');
|
||||
|
||||
This selector is part of L<Selectors Level 4|https://dev.w3.org/csswg/selectors-4>, which is still a work in progress.
|
||||
Also be aware that this feature is currently marked C<at-risk>, so there is a high chance that it will get removed
|
||||
completely.
|
||||
|
||||
=head2 A|E
|
||||
|
||||
An C<E> element that belongs to the namespace alias C<A> from L<CSS Namespaces Module Level
|
||||
3|https://www.w3.org/TR/css-namespaces-3/>. 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<F> element descendant of an C<E> element.
|
||||
|
||||
my $headlines = $css->select('div h1');
|
||||
|
||||
=head2 E E<gt> F
|
||||
|
||||
An C<F> element child of an C<E> element.
|
||||
|
||||
my $headlines = $css->select('html > body > div > h1');
|
||||
|
||||
=head2 E + F
|
||||
|
||||
An C<F> element immediately preceded by an C<E> element.
|
||||
|
||||
my $second = $css->select('h1 + h2');
|
||||
|
||||
=head2 E ~ F
|
||||
|
||||
An C<F> element preceded by an C<E> element.
|
||||
|
||||
my $second = $css->select('h1 ~ h2');
|
||||
|
||||
=head2 E, F, G
|
||||
|
||||
Elements of type C<E>, C<F> and C<G>.
|
||||
|
||||
my $headlines = $css->select('h1, h2, h3');
|
||||
|
||||
=head2 E[foo=bar][bar=baz]
|
||||
|
||||
An C<E> element whose attributes match all following attribute selectors.
|
||||
|
||||
my $links = $css->select('a[foo^=b][foo$=ar]');
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::DOM::CSS> 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<Mojo::DOM::CSS> inherits all methods from L<Mojo::Base> 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</"tree"> 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</"tree">. 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</"tree"> and stop as soon as the first node matched. Trailing key/value pairs can be used to
|
||||
declare xml namespace aliases.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_DOM_CSS_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_DOM_CSS_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
370
database/perl/vendor/lib/Mojo/DOM/HTML.pm
vendored
Normal file
370
database/perl/vendor/lib/Mojo/DOM/HTML.pm
vendored
Normal file
@@ -0,0 +1,370 @@
|
||||
package Mojo::DOM::HTML;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Exporter qw(import);
|
||||
use Mojo::Util qw(html_attr_unescape html_unescape xml_escape);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
our @EXPORT_OK = ('tag_to_html');
|
||||
|
||||
has tree => sub { ['root'] };
|
||||
has 'xml';
|
||||
|
||||
my $ATTR_RE = qr/
|
||||
([^<>=\s\/]+|\/) # Key
|
||||
(?:
|
||||
\s*=\s*
|
||||
(?s:(["'])(.*?)\g{-2}|([^>\s]*)) # Value
|
||||
)?
|
||||
\s*
|
||||
/x;
|
||||
my $TOKEN_RE = qr/
|
||||
([^<]+)? # Text
|
||||
(?:
|
||||
<(?:
|
||||
!(?:
|
||||
DOCTYPE(
|
||||
\s+\w+ # Doctype
|
||||
(?:(?:\s+\w+)?(?:\s+(?:"[^"]*"|'[^']*'))+)? # External ID
|
||||
(?:\s+\[.+?\])? # Int Subset
|
||||
\s*)
|
||||
|
|
||||
--(.*?)--\s* # Comment
|
||||
|
|
||||
\[CDATA\[(.*?)\]\] # CDATA
|
||||
)
|
||||
|
|
||||
\?(.*?)\? # Processing Instruction
|
||||
|
|
||||
\s*([^<>\s]+\s*(?:(?:$ATTR_RE){0,32766})*+) # Tag
|
||||
)>
|
||||
|
|
||||
(<) # Runaway "<"
|
||||
)??
|
||||
/xis;
|
||||
|
||||
# HTML elements that only contain raw text
|
||||
my %RAW = map { $_ => 1 } qw(script style);
|
||||
|
||||
# HTML elements that only contain raw text and entities
|
||||
my %RCDATA = map { $_ => 1 } qw(title textarea);
|
||||
|
||||
# HTML elements with optional end tags
|
||||
my %END = (body => 'head', optgroup => 'optgroup', option => 'option');
|
||||
|
||||
# HTML elements that break paragraphs
|
||||
map { $END{$_} = 'p' } (
|
||||
qw(address article aside blockquote details dialog div dl fieldset figcaption figure footer form h1 h2 h3 h4 h5 h6),
|
||||
qw(header hgroup hr main menu nav ol p pre section table ul)
|
||||
);
|
||||
|
||||
# HTML table elements with optional end tags
|
||||
my %TABLE = map { $_ => 1 } qw(colgroup tbody td tfoot th thead tr);
|
||||
|
||||
# HTML elements with optional end tags and scoping rules
|
||||
my %CLOSE = (li => [{li => 1}, {ul => 1, ol => 1}], tr => [{tr => 1}, {table => 1}]);
|
||||
$CLOSE{$_} = [\%TABLE, {table => 1}] for qw(colgroup tbody tfoot thead);
|
||||
$CLOSE{$_} = [{dd => 1, dt => 1}, {dl => 1}] for qw(dd dt);
|
||||
$CLOSE{$_} = [{rp => 1, rt => 1}, {ruby => 1}] for qw(rp rt);
|
||||
$CLOSE{$_} = [{th => 1, td => 1}, {table => 1}] for qw(td th);
|
||||
|
||||
# HTML parent elements that signal no more content when closed, but that are also phrasing content
|
||||
my %NO_MORE_CONTENT = (ruby => [qw(rt rp)], select => [qw(option optgroup)]);
|
||||
|
||||
# HTML elements without end tags
|
||||
my %EMPTY = map { $_ => 1 } qw(area base br col embed hr img input keygen link menuitem meta param source track wbr);
|
||||
|
||||
# HTML elements categorized as phrasing content (and obsolete inline elements)
|
||||
my @PHRASING = (
|
||||
qw(a abbr area audio b bdi bdo br button canvas cite code data datalist del dfn em embed i iframe img input ins kbd),
|
||||
qw(keygen label link map mark math meta meter noscript object output picture progress q ruby s samp script select),
|
||||
qw(slot small span strong sub sup svg template textarea time u var video wbr)
|
||||
);
|
||||
my @OBSOLETE = qw(acronym applet basefont big font strike tt);
|
||||
my %PHRASING = map { $_ => 1 } @OBSOLETE, @PHRASING;
|
||||
|
||||
# HTML elements that don't get their self-closing flag acknowledged
|
||||
my %BLOCK = map { $_ => 1 } (
|
||||
qw(a address applet article aside b big blockquote body button caption center code col colgroup dd details dialog),
|
||||
qw(dir div dl dt em fieldset figcaption figure font footer form frameset h1 h2 h3 h4 h5 h6 head header hgroup html),
|
||||
qw(i iframe li listing main marquee menu nav nobr noembed noframes noscript object ol optgroup option p plaintext),
|
||||
qw(pre rp rt s script section select small strike strong style summary table tbody td template textarea tfoot th),
|
||||
qw(thead title tr tt u ul xmp)
|
||||
);
|
||||
|
||||
sub parse {
|
||||
my ($self, $html) = (shift, "$_[0]");
|
||||
|
||||
my $xml = $self->xml;
|
||||
my $current = my $tree = ['root'];
|
||||
while ($html =~ /\G$TOKEN_RE/gcso) {
|
||||
my ($text, $doctype, $comment, $cdata, $pi, $tag, $runaway) = ($1, $2, $3, $4, $5, $6, $11);
|
||||
|
||||
# Text (and runaway "<")
|
||||
$text .= '<' if defined $runaway;
|
||||
_node($current, 'text', html_unescape $text) if defined $text;
|
||||
|
||||
# Tag
|
||||
if (defined $tag) {
|
||||
|
||||
# End
|
||||
if ($tag =~ /^\/\s*(\S+)/) {
|
||||
my $end = $xml ? $1 : lc $1;
|
||||
|
||||
# No more content
|
||||
if (!$xml && (my $tags = $NO_MORE_CONTENT{$end})) { _end($_, $xml, \$current) for @$tags }
|
||||
|
||||
_end($xml ? $1 : lc $1, $xml, \$current);
|
||||
}
|
||||
|
||||
# Start
|
||||
elsif ($tag =~ m!^([^\s/]+)([\s\S]*)!) {
|
||||
my ($start, $attr) = ($xml ? $1 : lc $1, $2);
|
||||
|
||||
# Attributes
|
||||
my (%attrs, $closing);
|
||||
while ($attr =~ /$ATTR_RE/go) {
|
||||
my ($key, $value) = ($xml ? $1 : lc $1, $3 // $4);
|
||||
|
||||
# Empty tag
|
||||
++$closing and next if $key eq '/';
|
||||
|
||||
$attrs{$key} = defined $value ? html_attr_unescape $value : $value;
|
||||
}
|
||||
|
||||
# "image" is an alias for "img"
|
||||
$start = 'img' if !$xml && $start eq 'image';
|
||||
_start($start, \%attrs, $xml, \$current);
|
||||
|
||||
# Element without end tag (self-closing)
|
||||
_end($start, $xml, \$current) if !$xml && $EMPTY{$start} || ($xml || !$BLOCK{$start}) && $closing;
|
||||
|
||||
# Raw text elements
|
||||
next if $xml || !$RAW{$start} && !$RCDATA{$start};
|
||||
next unless $html =~ m!\G(.*?)<\s*/\s*\Q$start\E\s*>!gcsi;
|
||||
_node($current, 'raw', $RCDATA{$start} ? html_unescape $1 : $1);
|
||||
_end($start, 0, \$current);
|
||||
}
|
||||
}
|
||||
|
||||
# DOCTYPE
|
||||
elsif (defined $doctype) { _node($current, 'doctype', $doctype) }
|
||||
|
||||
# Comment
|
||||
elsif (defined $comment) { _node($current, 'comment', $comment) }
|
||||
|
||||
# CDATA
|
||||
elsif (defined $cdata) { _node($current, 'cdata', $cdata) }
|
||||
|
||||
# Processing instruction (try to detect XML)
|
||||
elsif (defined $pi) {
|
||||
$self->xml($xml = 1) if !exists $self->{xml} && $pi =~ /xml/i;
|
||||
_node($current, 'pi', $pi);
|
||||
}
|
||||
}
|
||||
|
||||
return $self->tree($tree);
|
||||
}
|
||||
|
||||
sub render { _render($_[0]->tree, $_[0]->xml) }
|
||||
|
||||
sub tag { shift->tree(['root', _tag(@_)]) }
|
||||
|
||||
sub tag_to_html { _render(_tag(@_), undef) }
|
||||
|
||||
sub _end {
|
||||
my ($end, $xml, $current) = @_;
|
||||
|
||||
# Search stack for start tag
|
||||
my $next = $$current;
|
||||
do {
|
||||
|
||||
# Ignore useless end tag
|
||||
return if $next->[0] eq 'root';
|
||||
|
||||
# Right tag
|
||||
return $$current = $next->[3] if $next->[1] eq $end;
|
||||
|
||||
# Phrasing content can only cross phrasing content
|
||||
return if !$xml && $PHRASING{$end} && !$PHRASING{$next->[1]};
|
||||
|
||||
} while $next = $next->[3];
|
||||
}
|
||||
|
||||
sub _node {
|
||||
my ($current, $type, $content) = @_;
|
||||
push @$current, my $new = [$type, $content, $current];
|
||||
weaken $new->[2];
|
||||
}
|
||||
|
||||
sub _render {
|
||||
my ($tree, $xml) = @_;
|
||||
|
||||
# Tag
|
||||
my $type = $tree->[0];
|
||||
if ($type eq 'tag') {
|
||||
|
||||
# Start tag
|
||||
my $tag = $tree->[1];
|
||||
my $result = "<$tag";
|
||||
|
||||
# Attributes
|
||||
for my $key (sort keys %{$tree->[2]}) {
|
||||
my $value = $tree->[2]{$key};
|
||||
$result .= $xml ? qq{ $key="$key"} : " $key" and next unless defined $value;
|
||||
$result .= qq{ $key="} . xml_escape($value) . '"';
|
||||
}
|
||||
|
||||
# No children
|
||||
return $xml ? "$result />" : $EMPTY{$tag} ? "$result>" : "$result></$tag>" unless $tree->[4];
|
||||
|
||||
# Children
|
||||
no warnings 'recursion';
|
||||
$result .= '>' . join '', map { _render($_, $xml) } @$tree[4 .. $#$tree];
|
||||
|
||||
# End tag
|
||||
return "$result</$tag>";
|
||||
}
|
||||
|
||||
# Text (escaped)
|
||||
return xml_escape $tree->[1] if $type eq 'text';
|
||||
|
||||
# Raw text
|
||||
return $tree->[1] if $type eq 'raw';
|
||||
|
||||
# Root
|
||||
return join '', map { _render($_, $xml) } @$tree[1 .. $#$tree] if $type eq 'root';
|
||||
|
||||
# DOCTYPE
|
||||
return '<!DOCTYPE' . $tree->[1] . '>' if $type eq 'doctype';
|
||||
|
||||
# Comment
|
||||
return '<!--' . $tree->[1] . '-->' if $type eq 'comment';
|
||||
|
||||
# CDATA
|
||||
return '<![CDATA[' . $tree->[1] . ']]>' if $type eq 'cdata';
|
||||
|
||||
# Processing instruction
|
||||
return '<?' . $tree->[1] . '?>' if $type eq 'pi';
|
||||
|
||||
# Everything else
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _start {
|
||||
my ($start, $attrs, $xml, $current) = @_;
|
||||
|
||||
# Autoclose optional HTML elements
|
||||
if (!$xml && $$current->[0] ne 'root') {
|
||||
if (my $end = $END{$start}) { _end($end, 0, $current) }
|
||||
|
||||
elsif (my $close = $CLOSE{$start}) {
|
||||
my ($allowed, $scope) = @$close;
|
||||
|
||||
# Close allowed parent elements in scope
|
||||
my $parent = $$current;
|
||||
while ($parent->[0] ne 'root' && !$scope->{$parent->[1]}) {
|
||||
_end($parent->[1], 0, $current) if $allowed->{$parent->[1]};
|
||||
$parent = $parent->[3];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# New tag
|
||||
push @$$current, my $new = ['tag', $start, $attrs, $$current];
|
||||
weaken $new->[3];
|
||||
$$current = $new;
|
||||
}
|
||||
|
||||
sub _tag {
|
||||
my $tree = ['tag', shift, undef, undef];
|
||||
|
||||
# Content
|
||||
push @$tree, ref $_[-1] eq 'CODE' ? ['raw', pop->()] : ['text', pop] if @_ % 2;
|
||||
|
||||
# Attributes
|
||||
my $attrs = $tree->[2] = {@_};
|
||||
return $tree unless exists $attrs->{data} && ref $attrs->{data} eq 'HASH';
|
||||
my $data = delete $attrs->{data};
|
||||
@$attrs{map { y/_/-/; lc "data-$_" } keys %$data} = values %$data;
|
||||
return $tree;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::DOM::HTML - HTML/XML engine
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::DOM::HTML;
|
||||
|
||||
# Turn HTML into DOM tree
|
||||
my $html = Mojo::DOM::HTML->new;
|
||||
$html->parse('<div><p id="a">Test</p><p id="b">123</p></div>');
|
||||
my $tree = $html->tree;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::DOM::HTML> is the HTML/XML engine used by L<Mojo::DOM>, based on the L<HTML Living
|
||||
Standard|https://html.spec.whatwg.org> and the L<Extensible Markup Language (XML) 1.0|https://www.w3.org/TR/xml/>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::DOM::HTML> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 tag_to_html
|
||||
|
||||
my $str = tag_to_html 'div', id => 'foo', 'safe content';
|
||||
|
||||
Generate HTML/XML tag and render it right away. This is a significantly faster alternative to L</"tag"> for template
|
||||
systems that have to generate a lot of tags.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::DOM::HTML> implements the following attributes.
|
||||
|
||||
=head2 tree
|
||||
|
||||
my $tree = $html->tree;
|
||||
$html = $html->tree(['root']);
|
||||
|
||||
Document Object Model. Note that this structure should only be used very carefully since it is very dynamic.
|
||||
|
||||
=head2 xml
|
||||
|
||||
my $bool = $html->xml;
|
||||
$html = $html->xml($bool);
|
||||
|
||||
Disable HTML semantics in parser and activate case-sensitivity, defaults to auto-detection based on XML declarations.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::DOM::HTML> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$html = $html->parse('<foo bar="baz">I ♥ Mojolicious!</foo>');
|
||||
|
||||
Parse HTML/XML fragment.
|
||||
|
||||
=head2 render
|
||||
|
||||
my $str = $html->render;
|
||||
|
||||
Render DOM to HTML/XML.
|
||||
|
||||
=head2 tag
|
||||
|
||||
$html = $html->tag('div', id => 'foo', 'safe content');
|
||||
|
||||
Generate HTML/XML tag.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
182
database/perl/vendor/lib/Mojo/Date.pm
vendored
Normal file
182
database/perl/vendor/lib/Mojo/Date.pm
vendored
Normal file
@@ -0,0 +1,182 @@
|
||||
package Mojo::Date;
|
||||
use Mojo::Base -base;
|
||||
use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Time::Local qw(timegm);
|
||||
|
||||
has epoch => sub {time};
|
||||
|
||||
my $RFC3339_RE = qr/
|
||||
^(\d+)-(\d+)-(\d+)\D+(\d+):(\d+):(\d+(?:\.\d+)?) # Date and time
|
||||
(?:Z|([+-])(\d+):(\d+))?$ # Offset
|
||||
/xi;
|
||||
|
||||
my @DAYS = qw(Sun Mon Tue Wed Thu Fri Sat);
|
||||
my @MONTHS = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
|
||||
my %MONTHS;
|
||||
@MONTHS{@MONTHS} = (0 .. 11);
|
||||
|
||||
sub new { @_ > 1 ? shift->SUPER::new->parse(@_) : shift->SUPER::new }
|
||||
|
||||
sub parse {
|
||||
my ($self, $date) = @_;
|
||||
|
||||
# epoch (784111777)
|
||||
return $self->epoch($date) if $date =~ /^\d+$|^\d+\.\d+$/;
|
||||
|
||||
# RFC 822/1123 (Sun, 06 Nov 1994 08:49:37 GMT)
|
||||
# RFC 850/1036 (Sunday, 06-Nov-94 08:49:37 GMT)
|
||||
my $offset = 0;
|
||||
my ($day, $month, $year, $h, $m, $s);
|
||||
if ($date =~ /^\w+\W+(\d+)\W+(\w+)\W+(\d+)\W+(\d+):(\d+):(\d+)\W*\w+$/) {
|
||||
($day, $month, $year, $h, $m, $s) = ($1, $MONTHS{$2}, $3, $4, $5, $6);
|
||||
}
|
||||
|
||||
# RFC 3339 (1994-11-06T08:49:37Z)
|
||||
elsif ($date =~ $RFC3339_RE) {
|
||||
($year, $month, $day, $h, $m, $s) = ($1, $2 - 1, $3, $4, $5, $6);
|
||||
$offset = (($8 * 3600) + ($9 * 60)) * ($7 eq '+' ? -1 : 1) if $7;
|
||||
}
|
||||
|
||||
# ANSI C asctime() (Sun Nov 6 08:49:37 1994)
|
||||
elsif ($date =~ /^\w+\s+(\w+)\s+(\d+)\s+(\d+):(\d+):(\d+)\s+(\d+)$/) {
|
||||
($month, $day, $h, $m, $s, $year) = ($MONTHS{$1}, $2, $3, $4, $5, $6);
|
||||
}
|
||||
|
||||
# Invalid
|
||||
else { return $self->epoch(undef) }
|
||||
|
||||
my $epoch = eval { timegm $s, $m, $h, $day, $month, $year };
|
||||
return $self->epoch((defined $epoch && ($epoch += $offset) >= 0) ? $epoch : undef);
|
||||
}
|
||||
|
||||
sub to_datetime {
|
||||
|
||||
# RFC 3339 (1994-11-06T08:49:37Z)
|
||||
my ($s, $m, $h, $day, $month, $year) = gmtime(my $epoch = shift->epoch);
|
||||
my $str = sprintf '%04d-%02d-%02dT%02d:%02d:%02d', $year + 1900, $month + 1, $day, $h, $m, $s;
|
||||
return $str . ($epoch =~ /(\.\d+)$/ ? $1 : '') . 'Z';
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
|
||||
# RFC 7231 (Sun, 06 Nov 1994 08:49:37 GMT)
|
||||
my ($s, $m, $h, $mday, $month, $year, $wday) = gmtime shift->epoch;
|
||||
return sprintf '%s, %02d %s %04d %02d:%02d:%02d GMT', $DAYS[$wday], $mday, $MONTHS[$month], $year + 1900, $h, $m, $s;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Date - HTTP date
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Date;
|
||||
|
||||
# Parse
|
||||
my $date = Mojo::Date->new('Sun, 06 Nov 1994 08:49:37 GMT');
|
||||
say $date->epoch;
|
||||
|
||||
# Build
|
||||
my $date = Mojo::Date->new(time + 60);
|
||||
say "$date";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Date> implements HTTP date and time functions, based on L<RFC 7230|https://tools.ietf.org/html/rfc7230>, L<RFC
|
||||
7231|https://tools.ietf.org/html/rfc7231> and L<RFC 3339|https://tools.ietf.org/html/rfc3339>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Date> implements the following attributes.
|
||||
|
||||
=head2 epoch
|
||||
|
||||
my $epoch = $date->epoch;
|
||||
$date = $date->epoch(784111777);
|
||||
|
||||
Epoch seconds, defaults to the current time.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Date> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $date = Mojo::Date->new;
|
||||
my $date = Mojo::Date->new('Sun Nov 6 08:49:37 1994');
|
||||
|
||||
Construct a new L<Mojo::Date> object and L</"parse"> date if necessary.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$date = $date->parse('Sun Nov 6 08:49:37 1994');
|
||||
|
||||
Parse date.
|
||||
|
||||
# Epoch
|
||||
say Mojo::Date->new('784111777')->epoch;
|
||||
say Mojo::Date->new('784111777.21')->epoch;
|
||||
|
||||
# RFC 822/1123
|
||||
say Mojo::Date->new('Sun, 06 Nov 1994 08:49:37 GMT')->epoch;
|
||||
|
||||
# RFC 850/1036
|
||||
say Mojo::Date->new('Sunday, 06-Nov-94 08:49:37 GMT')->epoch;
|
||||
|
||||
# Ansi C asctime()
|
||||
say Mojo::Date->new('Sun Nov 6 08:49:37 1994')->epoch;
|
||||
|
||||
# RFC 3339
|
||||
say Mojo::Date->new('1994-11-06T08:49:37Z')->epoch;
|
||||
say Mojo::Date->new('1994-11-06T08:49:37')->epoch;
|
||||
say Mojo::Date->new('1994-11-06T08:49:37.21Z')->epoch;
|
||||
say Mojo::Date->new('1994-11-06T08:49:37+01:00')->epoch;
|
||||
say Mojo::Date->new('1994-11-06T08:49:37-01:00')->epoch;
|
||||
|
||||
=head2 to_datetime
|
||||
|
||||
my $str = $date->to_datetime;
|
||||
|
||||
Render L<RFC 3339|https://tools.ietf.org/html/rfc3339> date and time.
|
||||
|
||||
# "1994-11-06T08:49:37Z"
|
||||
Mojo::Date->new(784111777)->to_datetime;
|
||||
|
||||
# "1994-11-06T08:49:37.21Z"
|
||||
Mojo::Date->new(784111777.21)->to_datetime;
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $date->to_string;
|
||||
|
||||
Render date suitable for HTTP messages.
|
||||
|
||||
# "Sun, 06 Nov 1994 08:49:37 GMT"
|
||||
Mojo::Date->new(784111777)->to_string;
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Date> overloads the following operators.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$date;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$date";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
110
database/perl/vendor/lib/Mojo/DynamicMethods.pm
vendored
Normal file
110
database/perl/vendor/lib/Mojo/DynamicMethods.pm
vendored
Normal file
@@ -0,0 +1,110 @@
|
||||
package Mojo::DynamicMethods;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use Hash::Util::FieldHash qw(fieldhash);
|
||||
use Mojo::Util qw(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, -signatures;
|
||||
|
||||
use Mojo::DynamicMethods -dispatch;
|
||||
|
||||
sub BUILD_DYNAMIC ($class, $method, $dyn_methods) {
|
||||
return sub {...};
|
||||
}
|
||||
|
||||
sub add_helper ($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<Mojo::DynamicMethods> provides dynamic method dispatch for per-object helper methods without requiring use of
|
||||
C<AUTOLOAD>.
|
||||
|
||||
To opt your class into dynamic dispatch simply pass the C<-dispatch> flag.
|
||||
|
||||
use Mojo::DynamicMethods -dispatch;
|
||||
|
||||
And then implement a C<BUILD_DYNAMIC> 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</"register">.
|
||||
|
||||
sub BUILD_DYNAMIC ($class, $method, $dyn_methods) {
|
||||
return sub ($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 B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::DynamicMethods> 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<BUILD_DYNAMIC>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
171
database/perl/vendor/lib/Mojo/EventEmitter.pm
vendored
Normal file
171
database/perl/vendor/lib/Mojo/EventEmitter.pm
vendored
Normal file
@@ -0,0 +1,171 @@
|
||||
package Mojo::EventEmitter;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Scalar::Util qw(blessed weaken);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_EVENTEMITTER_DEBUG} || 0;
|
||||
|
||||
sub catch { $_[0]->on(error => $_[1]) and return $_[0] }
|
||||
|
||||
sub emit {
|
||||
my ($self, $name) = (shift, shift);
|
||||
|
||||
if (my $s = $self->{events}{$name}) {
|
||||
warn "-- Emit $name in @{[blessed $self]} (@{[scalar @$s]})\n" if DEBUG;
|
||||
for my $cb (@$s) { $self->$cb(@_) }
|
||||
}
|
||||
else {
|
||||
warn "-- Emit $name in @{[blessed $self]} (0)\n" if DEBUG;
|
||||
die "@{[blessed $self]}: $_[0]" if $name eq 'error';
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub has_subscribers { !!shift->{events}{shift()} }
|
||||
|
||||
sub on { push @{$_[0]{events}{$_[1]}}, $_[2] and return $_[2] }
|
||||
|
||||
sub once {
|
||||
my ($self, $name, $cb) = @_;
|
||||
|
||||
weaken $self;
|
||||
my $wrapper = sub {
|
||||
$self->unsubscribe($name => __SUB__);
|
||||
$cb->(@_);
|
||||
};
|
||||
$self->on($name => $wrapper);
|
||||
|
||||
return $wrapper;
|
||||
}
|
||||
|
||||
sub subscribers { shift->{events}{shift()} //= [] }
|
||||
|
||||
sub unsubscribe {
|
||||
my ($self, $name, $cb) = @_;
|
||||
|
||||
# One
|
||||
if ($cb) {
|
||||
$self->{events}{$name} = [grep { $cb ne $_ } @{$self->{events}{$name}}];
|
||||
delete $self->{events}{$name} unless @{$self->{events}{$name}};
|
||||
}
|
||||
|
||||
# All
|
||||
else { delete $self->{events}{$name} }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::EventEmitter - Event emitter base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Cat;
|
||||
use Mojo::Base 'Mojo::EventEmitter', -signatures;
|
||||
|
||||
# Emit events
|
||||
sub poke ($self) { $self->emit(roar => 3) }
|
||||
|
||||
package main;
|
||||
|
||||
# Subscribe to events
|
||||
my $tiger = Cat->new;
|
||||
$tiger->on(roar => sub ($tiger, $times) { say 'RAWR!' for 1 .. $times });
|
||||
$tiger->poke;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::EventEmitter> is a simple base class for event emitting objects.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::EventEmitter> can emit the following events.
|
||||
|
||||
=head2 error
|
||||
|
||||
$e->on(error => sub ($e, $err) {...});
|
||||
|
||||
This is a special event for errors, it will not be emitted directly by this class, but is fatal if unhandled.
|
||||
Subclasses may choose to emit it, but are not required to do so.
|
||||
|
||||
$e->on(error => sub ($e, $err) { say "This looks bad: $err" });
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::EventEmitter> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 catch
|
||||
|
||||
$e = $e->catch(sub {...});
|
||||
|
||||
Subscribe to L</"error"> event.
|
||||
|
||||
# Longer version
|
||||
$e->on(error => sub {...});
|
||||
|
||||
=head2 emit
|
||||
|
||||
$e = $e->emit('foo');
|
||||
$e = $e->emit('foo', 123);
|
||||
|
||||
Emit event.
|
||||
|
||||
=head2 has_subscribers
|
||||
|
||||
my $bool = $e->has_subscribers('foo');
|
||||
|
||||
Check if event has subscribers.
|
||||
|
||||
=head2 on
|
||||
|
||||
my $cb = $e->on(foo => sub {...});
|
||||
|
||||
Subscribe to event.
|
||||
|
||||
$e->on(foo => sub ($e, @args) {...});
|
||||
|
||||
=head2 once
|
||||
|
||||
my $cb = $e->once(foo => sub {...});
|
||||
|
||||
Subscribe to event and unsubscribe again after it has been emitted once.
|
||||
|
||||
$e->once(foo => sub ($e, @args) {...});
|
||||
|
||||
=head2 subscribers
|
||||
|
||||
my $subscribers = $e->subscribers('foo');
|
||||
|
||||
All subscribers for event.
|
||||
|
||||
# Unsubscribe last subscriber
|
||||
$e->unsubscribe(foo => $e->subscribers('foo')->[-1]);
|
||||
|
||||
# Change order of subscribers
|
||||
@{$e->subscribers('foo')} = reverse @{$e->subscribers('foo')};
|
||||
|
||||
=head2 unsubscribe
|
||||
|
||||
$e = $e->unsubscribe('foo');
|
||||
$e = $e->unsubscribe(foo => $cb);
|
||||
|
||||
Unsubscribe from event.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_EVENTEMITTER_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_EVENTEMITTER_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
382
database/perl/vendor/lib/Mojo/Exception.pm
vendored
Normal file
382
database/perl/vendor/lib/Mojo/Exception.pm
vendored
Normal file
@@ -0,0 +1,382 @@
|
||||
package Mojo::Exception;
|
||||
use Mojo::Base -base;
|
||||
use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Exporter qw(import);
|
||||
use Mojo::Util qw(decode scope_guard);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
has [qw(frames line lines_after lines_before)] => sub { [] };
|
||||
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->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 { 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;
|
||||
|
||||
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 }
|
||||
|
||||
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 - Exception base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Create exception classes
|
||||
package MyApp::X::Foo {
|
||||
use Mojo::Base 'Mojo::Exception';
|
||||
}
|
||||
package MyApp::X::Bar {
|
||||
use Mojo::Base 'Mojo::Exception';
|
||||
}
|
||||
|
||||
# Throw exceptions and handle them gracefully
|
||||
use Mojo::Exception qw(check);
|
||||
eval {
|
||||
MyApp::X::Foo->throw('Something went wrong!');
|
||||
};
|
||||
check(
|
||||
'MyApp::X::Foo' => sub { say "Foo: $_" },
|
||||
'MyApp::X::Bar' => sub { say "Bar: $_" }
|
||||
);
|
||||
|
||||
# Generate exception classes on demand
|
||||
use Mojo::Exception qw(check raise);
|
||||
eval {
|
||||
raise 'MyApp::X::Name', 'The name Minion is already taken';
|
||||
};
|
||||
check(
|
||||
'MyApp::X::Name' => sub { say "Name error: $_" },
|
||||
default => sub { say "Error: $_" }
|
||||
);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Exception> is a container for exceptions with context information.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::Exception> 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<check> needs to be
|
||||
called right after C<eval>. Note that this function is B<EXPERIMENTAL> 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<default> handler is used when no other
|
||||
handler matched. And the C<finally> 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<Mojo::Exception>, if the class does not exist yet (classes are checked for a C<new> method), one is created
|
||||
as a L<Mojo::Exception> subclass on demand. Note that this function is B<EXPERIMENTAL> and might change without
|
||||
warning!
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Exception> 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<Exception!>.
|
||||
|
||||
=head2 verbose
|
||||
|
||||
my $bool = $e->verbose;
|
||||
$e = $e->verbose($bool);
|
||||
|
||||
Show more information with L</"to_string">, such as L</"frames">, defaults to the value of the
|
||||
C<MOJO_EXCEPTION_VERBOSE> environment variable.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Exception> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 inspect
|
||||
|
||||
$e = $e->inspect;
|
||||
$e = $e->inspect($source1, $source2);
|
||||
|
||||
Inspect L</"message">, L</"frames"> and optional additional sources to fill L</"lines_before">, L</"line"> and
|
||||
L</"lines_after"> 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<Mojo::Exception> object and assign L</"message"> if necessary.
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $e->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;
|
||||
|
||||
=head2 trace
|
||||
|
||||
$e = $e->trace;
|
||||
$e = $e->trace($skip);
|
||||
|
||||
Generate stack trace and store all L</"frames">, defaults to skipping C<1> call frame.
|
||||
|
||||
# Skip 3 call frames
|
||||
$e->trace(3);
|
||||
|
||||
# Skip no call frames
|
||||
$e->trace(0);
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Exception> overloads the following operators.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$e;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$e";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
575
database/perl/vendor/lib/Mojo/File.pm
vendored
Normal file
575
database/perl/vendor/lib/Mojo/File.pm
vendored
Normal file
@@ -0,0 +1,575 @@
|
||||
package Mojo::File;
|
||||
use Mojo::Base -strict;
|
||||
use overload '@{}' => sub { shift->to_array }, bool => sub {1}, '""' => sub { ${$_[0]} }, fallback => 1;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Cwd qw(getcwd);
|
||||
use Exporter qw(import);
|
||||
use File::Basename ();
|
||||
use File::Copy qw(copy move);
|
||||
use File::Find qw(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 = ('curfile', 'path', 'tempdir', 'tempfile');
|
||||
|
||||
sub basename { File::Basename::basename ${shift()}, @_ }
|
||||
|
||||
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 extname { shift->basename =~ /.+\.([^.]+)$/ ? $1 : '' }
|
||||
|
||||
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 = 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->extname;
|
||||
say $path->sibling('.bashrc');
|
||||
|
||||
# Use the alternative constructor
|
||||
use Mojo::File qw(path);
|
||||
my $path = path('/tmp/foo/bar')->make_path;
|
||||
$path->child('test.txt')->spurt('Hello Mojo!');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::File> 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<Mojo::File> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 curfile
|
||||
|
||||
my $path = curfile;
|
||||
|
||||
Construct a new scalar-based L<Mojo::File> 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<Mojo::File> 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<Mojo::File> object for a temporary directory with L<File::Temp>.
|
||||
|
||||
# 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<Mojo::File> object for a temporary file with L<File::Temp>.
|
||||
|
||||
# Longer version
|
||||
my $path = path(File::Temp->new(DIR => '/tmp'));
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::File> implements the following methods.
|
||||
|
||||
=head2 basename
|
||||
|
||||
my $name = $path->basename;
|
||||
my $name = $path->basename('.txt');
|
||||
|
||||
Return the last level of the path with L<File::Basename>.
|
||||
|
||||
# ".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<Mojo::File> 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<File::Copy> and return the destination as a L<Mojo::File> object.
|
||||
|
||||
=head2 dirname
|
||||
|
||||
my $name = $path->dirname;
|
||||
|
||||
Return all but the last level of the path with L<File::Basename> as a L<Mojo::File> object.
|
||||
|
||||
# "/home/sri" (on UNIX)
|
||||
path('/home/sri/.vimrc')->dirname;
|
||||
|
||||
=head2 extname
|
||||
|
||||
my $ext = $path->extname;
|
||||
|
||||
Return file extension of the path. Note that this method is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
# "js"
|
||||
path('/home/sri/test.js')->extname;
|
||||
|
||||
=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<Mojo::Collection> object containing the results as L<Mojo::File>
|
||||
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<Mojo::Collection> object containing the results as
|
||||
L<Mojo::File> 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<File::Find> 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<File::stat> 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<File::Path>.
|
||||
|
||||
=head2 move_to
|
||||
|
||||
my $destination = $path->move_to('/home/sri');
|
||||
my $destination = $path->move_to('/home/sri/.vimrc.backup');
|
||||
|
||||
Move file with L<File::Copy> and return the destination as a L<Mojo::File> 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<Mojo::File> 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<IO::File>.
|
||||
|
||||
# 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<Cwd> and return the result as a L<Mojo::File> 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<File::Path>.
|
||||
|
||||
=head2 sibling
|
||||
|
||||
my $sibling = $path->sibling('.vimrc');
|
||||
|
||||
Return a new L<Mojo::File> 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<File::stat> 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<Mojo::Base/"tap">.
|
||||
|
||||
=head2 to_abs
|
||||
|
||||
my $absolute = $path->to_abs;
|
||||
|
||||
Return absolute path as a L<Mojo::File> 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<Mojo::File> 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<Mojo::Base/"with_roles">.
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::File> overloads the following operators.
|
||||
|
||||
=head2 array
|
||||
|
||||
my @parts = @$path;
|
||||
|
||||
Alias for L</"to_array">.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$path;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$path";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
721
database/perl/vendor/lib/Mojo/Headers.pm
vendored
Normal file
721
database/perl/vendor/lib/Mojo/Headers.pm
vendored
Normal file
@@ -0,0 +1,721 @@
|
||||
package Mojo::Headers;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::Util qw(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 Access-Control-Allow-Origin Allow),
|
||||
qw(Authorization Cache-Control Connection Content-Disposition Content-Encoding Content-Language Content-Length),
|
||||
qw(Content-Location Content-Range Content-Security-Policy Content-Type Cookie DNT Date ETag Expect Expires Host),
|
||||
qw(If-Modified-Since If-None-Match Last-Modified Link Location Origin Proxy-Authenticate Proxy-Authorization),
|
||||
qw(Range Sec-WebSocket-Accept Sec-WebSocket-Extensions Sec-WebSocket-Key Sec-WebSocket-Protocol),
|
||||
qw(Sec-WebSocket-Version Server 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 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 {
|
||||
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<Mojo::Headers> is a container for HTTP headers, based on L<RFC 7230|https://tools.ietf.org/html/rfc7230> and L<RFC
|
||||
7231|https://tools.ietf.org/html/rfc7231>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Headers> 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<MOJO_MAX_LINE_SIZE> 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<MOJO_MAX_LINES> environment variable or C<100>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Headers> inherits all methods from L<Mojo::Base> 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<Accept> 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<Accept-Charset> header.
|
||||
|
||||
=head2 accept_encoding
|
||||
|
||||
my $encoding = $headers->accept_encoding;
|
||||
$headers = $headers->accept_encoding('gzip');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Accept-Encoding> 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<Accept-Language> header.
|
||||
|
||||
=head2 accept_ranges
|
||||
|
||||
my $ranges = $headers->accept_ranges;
|
||||
$headers = $headers->accept_ranges('bytes');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Accept-Ranges> 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<Access-Control-Allow-Origin> header from L<Cross-Origin
|
||||
Resource Sharing|https://www.w3.org/TR/cors/>.
|
||||
|
||||
=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<Allow> 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<Authorization> 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<Cache-Control> header.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $clone = $headers->clone;
|
||||
|
||||
Return a new L<Mojo::Headers> 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<Connection> header.
|
||||
|
||||
=head2 content_disposition
|
||||
|
||||
my $disposition = $headers->content_disposition;
|
||||
$headers = $headers->content_disposition('foo');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Content-Disposition> header.
|
||||
|
||||
=head2 content_encoding
|
||||
|
||||
my $encoding = $headers->content_encoding;
|
||||
$headers = $headers->content_encoding('gzip');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Content-Encoding> header.
|
||||
|
||||
=head2 content_language
|
||||
|
||||
my $language = $headers->content_language;
|
||||
$headers = $headers->content_language('en');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Content-Language> header.
|
||||
|
||||
=head2 content_length
|
||||
|
||||
my $len = $headers->content_length;
|
||||
$headers = $headers->content_length(4000);
|
||||
|
||||
Get or replace current header value, shortcut for the C<Content-Length> 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<Content-Location> 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<Content-Range> 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<Content-Security-Policy> header from L<Content Security Policy
|
||||
1.0|https://www.w3.org/TR/CSP/>.
|
||||
|
||||
=head2 content_type
|
||||
|
||||
my $type = $headers->content_type;
|
||||
$headers = $headers->content_type('text/plain');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Content-Type> header.
|
||||
|
||||
=head2 cookie
|
||||
|
||||
my $cookie = $headers->cookie;
|
||||
$headers = $headers->cookie('f=b');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Cookie> header from L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=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<Date> header.
|
||||
|
||||
=head2 dehop
|
||||
|
||||
$headers = $headers->dehop;
|
||||
|
||||
Remove hop-by-hop headers that should not be retransmitted.
|
||||
|
||||
=head2 dnt
|
||||
|
||||
my $dnt = $headers->dnt;
|
||||
$headers = $headers->dnt(1);
|
||||
|
||||
Get or replace current header value, shortcut for the C<DNT> (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<ETag> header.
|
||||
|
||||
=head2 every_header
|
||||
|
||||
my $all = $headers->every_header('Location');
|
||||
|
||||
Similar to L</"header">, 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<Expect> 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<Expires> 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<Host> 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<If-Modified-Since> 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<If-None-Match> 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</"max_line_size"> or L</"max_lines">.
|
||||
|
||||
=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<Last-Modified> header.
|
||||
|
||||
=head2 leftovers
|
||||
|
||||
my $bytes = $headers->leftovers;
|
||||
|
||||
Get and remove leftover data from header parser.
|
||||
|
||||
=head2 link
|
||||
|
||||
my $link = $headers->link;
|
||||
$headers = $headers->link('<http://127.0.0.1/foo/3>; rel="next"');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Link> header from L<RFC
|
||||
5988|https://tools.ietf.org/html/rfc5988>.
|
||||
|
||||
=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<Location> 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<Origin> header from L<RFC
|
||||
6454|https://tools.ietf.org/html/rfc6454>.
|
||||
|
||||
=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<Proxy-Authenticate> 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<Proxy-Authorization> header.
|
||||
|
||||
=head2 range
|
||||
|
||||
my $range = $headers->range;
|
||||
$headers = $headers->range('bytes=2-8');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Range> header.
|
||||
|
||||
=head2 referrer
|
||||
|
||||
my $referrer = $headers->referrer;
|
||||
$headers = $headers->referrer('http://example.com');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Referer> header, there was a typo in L<RFC
|
||||
2068|https://tools.ietf.org/html/rfc2068> which resulted in C<Referer> 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<Sec-WebSocket-Accept> header from L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455>.
|
||||
|
||||
=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<Sec-WebSocket-Extensions> header from L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455>.
|
||||
|
||||
=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<Sec-WebSocket-Key> header from L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455>.
|
||||
|
||||
=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<Sec-WebSocket-Protocol> header from L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455>.
|
||||
|
||||
=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<Sec-WebSocket-Version> header from L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455>.
|
||||
|
||||
=head2 server
|
||||
|
||||
my $server = $headers->server;
|
||||
$headers = $headers->server('Mojo');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Server> 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<Server-Timing> header from L<Server
|
||||
Timing|https://www.w3.org/TR/server-timing/>.
|
||||
|
||||
=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<Set-Cookie> header from L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=head2 status
|
||||
|
||||
my $status = $headers->status;
|
||||
$headers = $headers->status('200 OK');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Status> header from L<RFC
|
||||
3875|https://tools.ietf.org/html/rfc3875>.
|
||||
|
||||
=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<Strict-Transport-Security> header from L<RFC
|
||||
6797|https://tools.ietf.org/html/rfc6797>.
|
||||
|
||||
=head2 te
|
||||
|
||||
my $te = $headers->te;
|
||||
$headers = $headers->te('chunked');
|
||||
|
||||
Get or replace current header value, shortcut for the C<TE> 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<Trailer> header.
|
||||
|
||||
=head2 transfer_encoding
|
||||
|
||||
my $encoding = $headers->transfer_encoding;
|
||||
$headers = $headers->transfer_encoding('chunked');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Transfer-Encoding> header.
|
||||
|
||||
=head2 upgrade
|
||||
|
||||
my $upgrade = $headers->upgrade;
|
||||
$headers = $headers->upgrade('websocket');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Upgrade> 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<User-Agent> header.
|
||||
|
||||
=head2 vary
|
||||
|
||||
my $vary = $headers->vary;
|
||||
$headers = $headers->vary('*');
|
||||
|
||||
Get or replace current header value, shortcut for the C<Vary> 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<WWW-Authenticate> header.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
47
database/perl/vendor/lib/Mojo/HelloWorld.pm
vendored
Normal file
47
database/perl/vendor/lib/Mojo/HelloWorld.pm
vendored
Normal file
@@ -0,0 +1,47 @@
|
||||
package Mojo::HelloWorld;
|
||||
use Mojo::Base 'Mojolicious';
|
||||
|
||||
sub startup {
|
||||
my $self = shift;
|
||||
$self->log->level('error')->path(undef);
|
||||
$self->routes->any('/*whatever' => {whatever => '', text => 'Your Mojo is working!'});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::HelloWorld - Hello World!
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::HelloWorld;
|
||||
|
||||
my $hello = Mojo::HelloWorld->new;
|
||||
$hello->start;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::HelloWorld> is the default L<Mojolicious> application, used mostly for testing.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::HelloWorld> inherits all attributes from L<Mojolicious>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::HelloWorld> inherits all methods from L<Mojolicious> and implements the following new ones.
|
||||
|
||||
=head2 startup
|
||||
|
||||
$hello->startup;
|
||||
|
||||
Creates a catch-all route that renders a text message.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
73
database/perl/vendor/lib/Mojo/Home.pm
vendored
Normal file
73
database/perl/vendor/lib/Mojo/Home.pm
vendored
Normal file
@@ -0,0 +1,73 @@
|
||||
package Mojo::Home;
|
||||
use Mojo::Base 'Mojo::File';
|
||||
|
||||
use Mojo::Util qw(class_to_path);
|
||||
|
||||
sub detect {
|
||||
my ($self, $class) = @_;
|
||||
|
||||
# Environment variable
|
||||
my $home;
|
||||
if ($ENV{MOJO_HOME}) { $home = Mojo::File->new($ENV{MOJO_HOME})->to_array }
|
||||
|
||||
# Location of the application class (Windows mixes backslash and slash)
|
||||
elsif ($class && (my $path = $INC{my $file = class_to_path $class})) {
|
||||
$home = Mojo::File->new($path)->to_array;
|
||||
splice @$home, (my @dummy = split(/\//, $file)) * -1;
|
||||
@$home && $home->[-1] eq $_ && pop @$home for qw(lib blib);
|
||||
}
|
||||
|
||||
$$self = Mojo::File->new(@$home)->to_abs->to_string if $home;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub rel_file { shift->child(split(/\//, shift)) }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Home - Home sweet home
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Home;
|
||||
|
||||
# Find and manage the project root directory
|
||||
my $home = Mojo::Home->new;
|
||||
$home->detect;
|
||||
say $home->child('templates', 'layouts', 'default.html.ep');
|
||||
say "$home";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Home> is a container for home directories based on L<Mojo::File>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Home> inherits all methods from L<Mojo::File> and implements the following new ones.
|
||||
|
||||
=head2 detect
|
||||
|
||||
$home = $home->detect;
|
||||
$home = $home->detect('My::App');
|
||||
|
||||
Detect home directory from the value of the C<MOJO_HOME> environment variable or the location of the application class.
|
||||
|
||||
=head2 rel_file
|
||||
|
||||
my $path = $home->rel_file('foo/bar.html');
|
||||
|
||||
Return a new L<Mojo::Home> object relative to the home directory.
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Home> inherits all overloaded operators from L<Mojo::File>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
614
database/perl/vendor/lib/Mojo/IOLoop.pm
vendored
Normal file
614
database/perl/vendor/lib/Mojo/IOLoop.pm
vendored
Normal file
@@ -0,0 +1,614 @@
|
||||
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 qw(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, $options) = (_instance(shift), shift // {});
|
||||
|
||||
$self->emit('reset')->stop;
|
||||
if ($options->{freeze}) {
|
||||
state @frozen;
|
||||
push @frozen, {%$self};
|
||||
delete $self->{reactor};
|
||||
}
|
||||
else { $self->reactor->reset }
|
||||
|
||||
delete @$self{qw(accepting acceptors events in out 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->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 ($loop, $stream) {
|
||||
$stream->on(read => sub ($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 ($loop, $err, $stream) {
|
||||
$stream->on(read => sub ($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 ($loop) { $loop->remove($id) });
|
||||
|
||||
# Start event loop if necessary
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop> is a very minimalistic event loop based on L<Mojo::Reactor>, 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<LIBEV_FLAGS> environment variable should also be used to select the best
|
||||
possible L<EV> backend, which usually defaults to the not very scalable C<select>.
|
||||
|
||||
LIBEV_FLAGS=1 # select
|
||||
LIBEV_FLAGS=2 # poll
|
||||
LIBEV_FLAGS=4 # epoll (Linux)
|
||||
LIBEV_FLAGS=8 # kqueue (*BSD, OS X)
|
||||
LIBEV_FLAGS=64 # Linux AIO
|
||||
|
||||
The event loop will be resilient to time jumps if a monotonic clock is available through L<Time::HiRes>. A TLS
|
||||
certificate and key are also built right in, to make writing test servers as easy as possible. Also note that for
|
||||
convenience the C<PIPE> signal will be set to C<IGNORE> when L<Mojo::IOLoop> is loaded.
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(2.009+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"REAL-TIME WEB"> for more.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$loop->on(finish => sub ($loop) {...});
|
||||
|
||||
Emitted when the event loop wants to shut down gracefully and is just waiting for all existing connections to be
|
||||
closed.
|
||||
|
||||
=head2 reset
|
||||
|
||||
$loop->on(reset => sub ($loop) {...});
|
||||
|
||||
Emitted when the event loop is reset, this usually happens after the process is forked to clean up resources that
|
||||
cannot be shared.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop> implements the following attributes.
|
||||
|
||||
=head2 max_accepts
|
||||
|
||||
my $max = $loop->max_accepts;
|
||||
$loop = $loop->max_accepts(1000);
|
||||
|
||||
The maximum number of connections this event loop is allowed to accept, before shutting down gracefully without
|
||||
interrupting existing connections, defaults to C<0>. Setting the value to C<0> will allow this event loop to accept new
|
||||
connections indefinitely. Note that up to half of this value can be subtracted randomly to improve load balancing
|
||||
between multiple server processes, and to make sure that not all of them restart at the same time.
|
||||
|
||||
=head2 max_connections
|
||||
|
||||
my $max = $loop->max_connections;
|
||||
$loop = $loop->max_connections(100);
|
||||
|
||||
The maximum number of accepted connections this event loop is allowed to handle concurrently, before stopping to accept
|
||||
new incoming connections, defaults to C<1000>.
|
||||
|
||||
=head2 reactor
|
||||
|
||||
my $reactor = $loop->reactor;
|
||||
$loop = $loop->reactor(Mojo::Reactor->new);
|
||||
|
||||
Low-level event reactor, usually a L<Mojo::Reactor::Poll> or L<Mojo::Reactor::EV> object with a default subscriber to
|
||||
the event L<Mojo::Reactor/"error">.
|
||||
|
||||
# Watch if handle becomes readable or writable
|
||||
Mojo::IOLoop->singleton->reactor->io($handle => sub ($reactor, $writable) {
|
||||
say $writable ? 'Handle is writable' : 'Handle is readable';
|
||||
});
|
||||
|
||||
# Change to watching only if handle becomes writable
|
||||
Mojo::IOLoop->singleton->reactor->watch($handle, 0, 1);
|
||||
|
||||
# Remove handle again
|
||||
Mojo::IOLoop->singleton->reactor->remove($handle);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 acceptor
|
||||
|
||||
my $server = Mojo::IOLoop->acceptor($id);
|
||||
my $server = $loop->acceptor($id);
|
||||
my $id = $loop->acceptor(Mojo::IOLoop::Server->new);
|
||||
|
||||
Get L<Mojo::IOLoop::Server> object for id or turn object into an acceptor.
|
||||
|
||||
=head2 client
|
||||
|
||||
my $id = Mojo::IOLoop->client(address => '127.0.0.1', port => 3000, sub {...});
|
||||
my $id = $loop->client(address => '127.0.0.1', port => 3000, sub {...});
|
||||
my $id = $loop->client({address => '127.0.0.1', port => 3000} => sub {...});
|
||||
|
||||
Open a TCP/IP or UNIX domain socket connection with L<Mojo::IOLoop::Client> and create a stream object (usually
|
||||
L<Mojo::IOLoop::Stream>), takes the same arguments as L<Mojo::IOLoop::Client/"connect">.
|
||||
|
||||
=head2 delay
|
||||
|
||||
my $delay = Mojo::IOLoop->delay;
|
||||
my $delay = $loop->delay;
|
||||
my $delay = $loop->delay(sub {...});
|
||||
my $delay = $loop->delay(sub {...}, sub {...});
|
||||
|
||||
Build L<Mojo::IOLoop::Delay> object to use as a promise and/or for flow-control. Callbacks will be passed along to
|
||||
L<Mojo::IOLoop::Delay/"steps">.
|
||||
|
||||
# Wrap continuation-passing style APIs with promises
|
||||
my $ua = Mojo::UserAgent->new;
|
||||
sub get {
|
||||
my $promise = Mojo::IOLoop->delay;
|
||||
$ua->get(@_ => sub ($ua, $tx) {
|
||||
my $err = $tx->error;
|
||||
if (!$err || $err->{code}) { $promise->resolve($tx) }
|
||||
else { $promise->reject($err->{message}) }
|
||||
});
|
||||
return $promise;
|
||||
}
|
||||
my $mojo = get('https://mojolicious.org');
|
||||
my $cpan = get('https://metacpan.org');
|
||||
Mojo::Promise->race($mojo, $cpan)->then(sub ($tx) { say $tx->req->url })->wait;
|
||||
|
||||
# Synchronize multiple non-blocking operations
|
||||
my $delay = Mojo::IOLoop->delay(sub { say 'BOOM!' });
|
||||
for my $i (1 .. 10) {
|
||||
my $end = $delay->begin;
|
||||
Mojo::IOLoop->timer($i => sub {
|
||||
say 10 - $i;
|
||||
$end->();
|
||||
});
|
||||
}
|
||||
$delay->wait;
|
||||
|
||||
# Sequentialize multiple non-blocking operations
|
||||
Mojo::IOLoop->delay(
|
||||
|
||||
# First step (simple timer)
|
||||
sub ($delay) {
|
||||
Mojo::IOLoop->timer(2 => $delay->begin);
|
||||
say 'Second step in 2 seconds.';
|
||||
},
|
||||
|
||||
# Second step (concurrent timers)
|
||||
sub ($delay) {
|
||||
Mojo::IOLoop->timer(1 => $delay->begin);
|
||||
Mojo::IOLoop->timer(3 => $delay->begin);
|
||||
say 'Third step in 3 seconds.';
|
||||
},
|
||||
|
||||
# Third step (the end)
|
||||
sub { say 'And done after 5 seconds total.' }
|
||||
)->wait;
|
||||
|
||||
=head2 is_running
|
||||
|
||||
my $bool = Mojo::IOLoop->is_running;
|
||||
my $bool = $loop->is_running;
|
||||
|
||||
Check if event loop is running.
|
||||
|
||||
=head2 next_tick
|
||||
|
||||
my $undef = Mojo::IOLoop->next_tick(sub ($loop) {...});
|
||||
my $undef = $loop->next_tick(sub ($loop) {...});
|
||||
|
||||
Execute callback as soon as possible, but not before returning or other callbacks that have been registered with this
|
||||
method, always returns C<undef>.
|
||||
|
||||
# Perform operation on next reactor tick
|
||||
Mojo::IOLoop->next_tick(sub ($loop) {...});
|
||||
|
||||
=head2 one_tick
|
||||
|
||||
Mojo::IOLoop->one_tick;
|
||||
$loop->one_tick;
|
||||
|
||||
Run event loop until an event occurs.
|
||||
|
||||
# Don't block longer than 0.5 seconds
|
||||
my $id = Mojo::IOLoop->timer(0.5 => sub ($loop) {});
|
||||
Mojo::IOLoop->one_tick;
|
||||
Mojo::IOLoop->remove($id);
|
||||
|
||||
=head2 recurring
|
||||
|
||||
my $id = Mojo::IOLoop->recurring(3 => sub ($loop) {...});
|
||||
my $id = $loop->recurring(0 => sub ($loop) {...});
|
||||
my $id = $loop->recurring(0.25 => sub ($loop) {...});
|
||||
|
||||
Create a new recurring timer, invoking the callback repeatedly after a given amount of time in seconds.
|
||||
|
||||
# Perform operation every 5 seconds
|
||||
Mojo::IOLoop->recurring(5 => sub ($loop) {...});
|
||||
|
||||
=head2 remove
|
||||
|
||||
Mojo::IOLoop->remove($id);
|
||||
$loop->remove($id);
|
||||
|
||||
Remove anything with an id, connections will be dropped gracefully by allowing them to finish writing all data in their
|
||||
write buffers.
|
||||
|
||||
=head2 reset
|
||||
|
||||
Mojo::IOLoop->reset;
|
||||
$loop->reset;
|
||||
$loop->reset({freeze => 1});
|
||||
|
||||
Remove everything and stop the event loop.
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item freeze
|
||||
|
||||
freeze => 1
|
||||
|
||||
Freeze the current state of the event loop in time before resetting it. This will prevent active connections from
|
||||
getting closed immediately, which can help with many unintended side effects when processes are forked. Note that this
|
||||
option is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
=back
|
||||
|
||||
=head2 server
|
||||
|
||||
my $id = Mojo::IOLoop->server(port => 3000, sub {...});
|
||||
my $id = $loop->server(port => 3000, sub {...});
|
||||
my $id = $loop->server({port => 3000} => sub {...});
|
||||
|
||||
Accept TCP/IP and UNIX domain socket connections with L<Mojo::IOLoop::Server> and create stream objects (usually
|
||||
L<Mojo::IOLoop::Stream>, takes the same arguments as L<Mojo::IOLoop::Server/"listen">.
|
||||
|
||||
# Listen on random port
|
||||
my $id = Mojo::IOLoop->server({address => '127.0.0.1'} => sub ($loop, $stream, $id) {...});
|
||||
my $port = Mojo::IOLoop->acceptor($id)->port;
|
||||
|
||||
=head2 singleton
|
||||
|
||||
my $loop = Mojo::IOLoop->singleton;
|
||||
|
||||
The global L<Mojo::IOLoop> singleton, used to access a single shared event loop object from everywhere inside the
|
||||
process.
|
||||
|
||||
# Many methods also allow you to take shortcuts
|
||||
Mojo::IOLoop->timer(2 => sub { Mojo::IOLoop->stop });
|
||||
Mojo::IOLoop->start;
|
||||
|
||||
# Restart active timer
|
||||
my $id = Mojo::IOLoop->timer(3 => sub { say 'Timeout!' });
|
||||
Mojo::IOLoop->singleton->reactor->again($id);
|
||||
|
||||
# Turn file descriptor into handle and watch if it becomes readable
|
||||
my $handle = IO::Handle->new_from_fd($fd, 'r');
|
||||
Mojo::IOLoop->singleton->reactor->io($handle => sub ($reactor, $writable) {
|
||||
say $writable ? 'Handle is writable' : 'Handle is readable';
|
||||
})->watch($handle, 1, 0);
|
||||
|
||||
=head2 start
|
||||
|
||||
Mojo::IOLoop->start;
|
||||
$loop->start;
|
||||
|
||||
Start the event loop, this will block until L</"stop"> is called. Note that some reactors stop automatically if there
|
||||
are no events being watched anymore.
|
||||
|
||||
# Start event loop only if it is not running already
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 stop
|
||||
|
||||
Mojo::IOLoop->stop;
|
||||
$loop->stop;
|
||||
|
||||
Stop the event loop, this will not interrupt any existing connections and the event loop can be restarted by running
|
||||
L</"start"> again.
|
||||
|
||||
=head2 stop_gracefully
|
||||
|
||||
Mojo::IOLoop->stop_gracefully;
|
||||
$loop->stop_gracefully;
|
||||
|
||||
Stop accepting new connections and wait for already accepted connections to be closed, before stopping the event loop.
|
||||
|
||||
=head2 stream
|
||||
|
||||
my $stream = Mojo::IOLoop->stream($id);
|
||||
my $stream = $loop->stream($id);
|
||||
my $id = $loop->stream(Mojo::IOLoop::Stream->new);
|
||||
|
||||
Get L<Mojo::IOLoop::Stream> object for id or turn object into a connection.
|
||||
|
||||
# Increase inactivity timeout for connection to 300 seconds
|
||||
Mojo::IOLoop->stream($id)->timeout(300);
|
||||
|
||||
=head2 subprocess
|
||||
|
||||
my $subprocess = Mojo::IOLoop->subprocess;
|
||||
my $subprocess = $loop->subprocess;
|
||||
my $subprocess = $loop->subprocess(sub ($subprocess) {...}, sub ($subprocess, $err, @results) {...});
|
||||
|
||||
Build L<Mojo::IOLoop::Subprocess> object to perform computationally expensive operations in subprocesses, without
|
||||
blocking the event loop. Callbacks will be passed along to L<Mojo::IOLoop::Subprocess/"run">.
|
||||
|
||||
# Operation that would block the event loop for 5 seconds
|
||||
Mojo::IOLoop->subprocess->run_p(sub {
|
||||
sleep 5;
|
||||
return '♥', 'Mojolicious';
|
||||
})->then(sub (@results) {
|
||||
say "I $results[0] $results[1]!";
|
||||
})->catch(sub ($err) {
|
||||
say "Subprocess error: $err";
|
||||
});
|
||||
|
||||
=head2 timer
|
||||
|
||||
my $id = Mojo::IOLoop->timer(3 => sub ($loop) {...});
|
||||
my $id = $loop->timer(0 => sub ($loop) {...});
|
||||
my $id = $loop->timer(0.25 => sub ($loop) {...});
|
||||
|
||||
Create a new timer, invoking the callback after a given amount of time in seconds.
|
||||
|
||||
# Perform operation in 5 seconds
|
||||
Mojo::IOLoop->timer(5 => sub ($loop) {...});
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_IOLOOP_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_IOLOOP_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
355
database/perl/vendor/lib/Mojo/IOLoop/Client.pm
vendored
Normal file
355
database/perl/vendor/lib/Mojo/IOLoop/Client.pm
vendored
Normal file
@@ -0,0 +1,355 @@
|
||||
package Mojo::IOLoop::Client;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Errno qw(EINPROGRESS);
|
||||
use IO::Socket::IP;
|
||||
use IO::Socket::UNIX;
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::IOLoop::TLS;
|
||||
use Scalar::Util qw(weaken);
|
||||
use Socket qw(IPPROTO_TCP SOCK_STREAM TCP_NODELAY);
|
||||
|
||||
# Non-blocking name resolution requires Net::DNS::Native
|
||||
use constant NNR => $ENV{MOJO_NO_NNR} ? 0 : eval { require Net::DNS::Native; Net::DNS::Native->VERSION('0.15'); 1 };
|
||||
my $NDN;
|
||||
|
||||
# SOCKS support requires IO::Socket::Socks
|
||||
use constant SOCKS => $ENV{MOJO_NO_SOCKS}
|
||||
? 0
|
||||
: eval { require IO::Socket::Socks; IO::Socket::Socks->VERSION('0.64'); 1 };
|
||||
use constant READ => SOCKS ? IO::Socket::Socks::SOCKS_WANT_READ() : 0;
|
||||
use constant WRITE => SOCKS ? IO::Socket::Socks::SOCKS_WANT_WRITE() : 0;
|
||||
|
||||
has reactor => sub { Mojo::IOLoop->singleton->reactor }, weak => 1;
|
||||
|
||||
sub DESTROY { shift->_cleanup }
|
||||
|
||||
sub can_nnr {NNR}
|
||||
sub can_socks {SOCKS}
|
||||
|
||||
sub connect {
|
||||
my ($self, $args) = (shift, ref $_[0] ? $_[0] : {@_});
|
||||
|
||||
# Timeout
|
||||
weaken $self;
|
||||
my $reactor = $self->reactor;
|
||||
$self->{timer} = $reactor->timer($args->{timeout} || 10, sub { $self->emit(error => 'Connect timeout') });
|
||||
|
||||
# Blocking name resolution
|
||||
$_ && s/[[\]]//g for @$args{qw(address socks_address)};
|
||||
my $address = $args->{socks_address} || ($args->{address} ||= '127.0.0.1');
|
||||
return $reactor->next_tick(sub { $self && $self->_connect($args) }) if !NNR || $args->{handle} || $args->{path};
|
||||
|
||||
# Non-blocking name resolution
|
||||
$NDN //= Net::DNS::Native->new(pool => 5, extra_thread => 1);
|
||||
my $handle = $self->{dns}
|
||||
= $NDN->getaddrinfo($address, _port($args), {protocol => IPPROTO_TCP, socktype => SOCK_STREAM});
|
||||
$reactor->io(
|
||||
$handle => sub {
|
||||
my $reactor = shift;
|
||||
|
||||
$reactor->remove($self->{dns});
|
||||
my ($err, @res) = $NDN->get_result(delete $self->{dns});
|
||||
return $self->emit(error => "Can't resolve: $err") if $err;
|
||||
|
||||
$args->{addr_info} = \@res;
|
||||
$self->_connect($args);
|
||||
}
|
||||
)->watch($handle, 1, 0);
|
||||
}
|
||||
|
||||
sub _cleanup {
|
||||
my $self = shift;
|
||||
$NDN->timedout($self->{dns}) if $NDN && $self->{dns};
|
||||
return $self unless my $reactor = $self->reactor;
|
||||
$self->{$_} && $reactor->remove(delete $self->{$_}) for qw(dns timer handle);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _connect {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
my $path = $args->{path};
|
||||
my $handle = $self->{handle} = $args->{handle};
|
||||
|
||||
unless ($handle) {
|
||||
my $class = $path ? 'IO::Socket::UNIX' : 'IO::Socket::IP';
|
||||
my %options = (Blocking => 0);
|
||||
|
||||
# UNIX domain socket
|
||||
if ($path) { $options{Peer} = $path }
|
||||
|
||||
# IP socket
|
||||
else {
|
||||
if (my $info = $args->{addr_info}) { $options{PeerAddrInfo} = $info }
|
||||
else {
|
||||
$options{PeerAddr} = $args->{socks_address} || $args->{address};
|
||||
$options{PeerPort} = _port($args);
|
||||
}
|
||||
$options{LocalAddr} = $args->{local_address} if $args->{local_address};
|
||||
}
|
||||
|
||||
return $self->emit(error => "Can't connect: $@") unless $self->{handle} = $handle = $class->new(%options);
|
||||
}
|
||||
$handle->blocking(0);
|
||||
|
||||
$path ? $self->_try_socks($args) : $self->_wait('_ready', $handle, $args);
|
||||
}
|
||||
|
||||
sub _port { $_[0]{socks_port} || $_[0]{port} || ($_[0]{tls} ? 443 : 80) }
|
||||
|
||||
sub _ready {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
# Socket changes in between attempts and needs to be re-added for epoll/kqueue
|
||||
my $handle = $self->{handle};
|
||||
unless ($handle->connect) {
|
||||
return $self->emit(error => $!) unless $! == EINPROGRESS;
|
||||
$self->reactor->remove($handle);
|
||||
return $self->_wait('_ready', $handle, $args);
|
||||
}
|
||||
|
||||
return $self->emit(error => $! || 'Not connected') unless $handle->connected;
|
||||
|
||||
# Disable Nagle's algorithm
|
||||
setsockopt $handle, IPPROTO_TCP, TCP_NODELAY, 1;
|
||||
|
||||
$self->_try_socks($args);
|
||||
}
|
||||
|
||||
sub _socks {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
# Connected
|
||||
my $handle = $self->{handle};
|
||||
return $self->_try_tls($args) if $handle->ready;
|
||||
|
||||
# Switch between reading and writing
|
||||
my $err = $IO::Socket::Socks::SOCKS_ERROR;
|
||||
if ($err == READ) { $self->reactor->watch($handle, 1, 0) }
|
||||
elsif ($err == WRITE) { $self->reactor->watch($handle, 1, 1) }
|
||||
else { $self->emit(error => $err) }
|
||||
}
|
||||
|
||||
sub _try_socks {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
my $handle = $self->{handle};
|
||||
return $self->_try_tls($args) unless $args->{socks_address};
|
||||
return $self->emit(error => 'IO::Socket::Socks 0.64+ required for SOCKS support') unless SOCKS;
|
||||
|
||||
my %options = (ConnectAddr => $args->{address}, ConnectPort => $args->{port});
|
||||
@options{qw(AuthType Username Password)} = ('userpass', @$args{qw(socks_user socks_pass)}) if $args->{socks_user};
|
||||
my $reactor = $self->reactor;
|
||||
$reactor->remove($handle);
|
||||
return $self->emit(error => 'SOCKS upgrade failed') unless IO::Socket::Socks->start_SOCKS($handle, %options);
|
||||
|
||||
$self->_wait('_socks', $handle, $args);
|
||||
}
|
||||
|
||||
sub _try_tls {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
my $handle = $self->{handle};
|
||||
return $self->_cleanup->emit(connect => $handle) unless $args->{tls};
|
||||
my $reactor = $self->reactor;
|
||||
$reactor->remove($handle);
|
||||
|
||||
# Start TLS handshake
|
||||
weaken $self;
|
||||
my $tls = Mojo::IOLoop::TLS->new($handle)->reactor($self->reactor);
|
||||
$tls->on(upgrade => sub { $self->_cleanup->emit(connect => pop) });
|
||||
$tls->on(error => sub { $self->emit(error => pop) });
|
||||
$tls->negotiate(%$args);
|
||||
}
|
||||
|
||||
sub _wait {
|
||||
my ($self, $next, $handle, $args) = @_;
|
||||
weaken $self;
|
||||
$self->reactor->io($handle => sub { $self->$next($args) })->watch($handle, 0, 1);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::Client - Non-blocking TCP/IP and UNIX domain socket client
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::Client;
|
||||
|
||||
# Create socket connection
|
||||
my $client = Mojo::IOLoop::Client->new;
|
||||
$client->on(connect => sub ($client, $handle) {...});
|
||||
$client->on(error => sub ($client, $err) {...});
|
||||
$client->connect(address => 'example.com', port => 80);
|
||||
|
||||
# Start reactor if necessary
|
||||
$client->reactor->start unless $client->reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::Client> opens TCP/IP and UNIX domain socket connections for L<Mojo::IOLoop>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop::Client> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 connect
|
||||
|
||||
$client->on(connect => sub ($client, $handle) {...});
|
||||
|
||||
Emitted once the connection is established.
|
||||
|
||||
=head2 error
|
||||
|
||||
$client->on(error => sub ($client, $err) {...});
|
||||
|
||||
Emitted if an error occurs on the connection, fatal if unhandled.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::Client> implements the following attributes.
|
||||
|
||||
=head2 reactor
|
||||
|
||||
my $reactor = $client->reactor;
|
||||
$client = $client->reactor(Mojo::Reactor::Poll->new);
|
||||
|
||||
Low-level event reactor, defaults to the C<reactor> attribute value of the global L<Mojo::IOLoop> singleton. Note that
|
||||
this attribute is weakened.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::Client> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 can_nnr
|
||||
|
||||
my $bool = Mojo::IOLoop::Client->can_nnr;
|
||||
|
||||
True if L<Net::DNS::Native> 0.15+ is installed and non-blocking name resolution support enabled.
|
||||
|
||||
=head2 can_socks
|
||||
|
||||
my $bool = Mojo::IOLoop::Client->can_socks;
|
||||
|
||||
True if L<IO::Socket::SOCKS> 0.64+ is installed and SOCKS5 support enabled.
|
||||
|
||||
=head2 connect
|
||||
|
||||
$client->connect(address => '127.0.0.1', port => 3000);
|
||||
$client->connect({address => '127.0.0.1', port => 3000});
|
||||
|
||||
Open a socket connection to a remote host. Note that non-blocking name resolution depends on L<Net::DNS::Native>
|
||||
(0.15+), SOCKS5 support on L<IO::Socket::Socks> (0.64), and TLS support on L<IO::Socket::SSL> (2.009+).
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item address
|
||||
|
||||
address => 'mojolicious.org'
|
||||
|
||||
Address or host name of the peer to connect to, defaults to C<127.0.0.1>.
|
||||
|
||||
=item handle
|
||||
|
||||
handle => $handle
|
||||
|
||||
Use an already prepared L<IO::Socket::IP> object.
|
||||
|
||||
=item local_address
|
||||
|
||||
local_address => '127.0.0.1'
|
||||
|
||||
Local address to bind to.
|
||||
|
||||
=item path
|
||||
|
||||
path => '/tmp/myapp.sock'
|
||||
|
||||
Path of UNIX domain socket to connect to.
|
||||
|
||||
=item port
|
||||
|
||||
port => 80
|
||||
|
||||
Port to connect to, defaults to C<80> or C<443> with C<tls> option.
|
||||
|
||||
=item socks_address
|
||||
|
||||
socks_address => '127.0.0.1'
|
||||
|
||||
Address or host name of SOCKS5 proxy server to use for connection.
|
||||
|
||||
=item socks_pass
|
||||
|
||||
socks_pass => 'secr3t'
|
||||
|
||||
Password to use for SOCKS5 authentication.
|
||||
|
||||
=item socks_port
|
||||
|
||||
socks_port => 9050
|
||||
|
||||
Port of SOCKS5 proxy server to use for connection.
|
||||
|
||||
=item socks_user
|
||||
|
||||
socks_user => 'sri'
|
||||
|
||||
Username to use for SOCKS5 authentication.
|
||||
|
||||
=item timeout
|
||||
|
||||
timeout => 15
|
||||
|
||||
Maximum amount of time in seconds establishing connection may take before getting canceled, defaults to C<10>.
|
||||
|
||||
=item tls
|
||||
|
||||
tls => 1
|
||||
|
||||
Enable TLS.
|
||||
|
||||
=item tls_ca
|
||||
|
||||
tls_ca => '/etc/tls/ca.crt'
|
||||
|
||||
Path to TLS certificate authority file.
|
||||
|
||||
=item tls_cert
|
||||
|
||||
tls_cert => '/etc/tls/client.crt'
|
||||
|
||||
Path to the TLS certificate file.
|
||||
|
||||
=item tls_key
|
||||
|
||||
tls_key => '/etc/tls/client.key'
|
||||
|
||||
Path to the TLS key file.
|
||||
|
||||
=item tls_protocols
|
||||
|
||||
tls_protocols => ['foo', 'bar']
|
||||
|
||||
ALPN protocols to negotiate.
|
||||
|
||||
=item tls_verify
|
||||
|
||||
tls_verify => 0x00
|
||||
|
||||
TLS verification mode.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
204
database/perl/vendor/lib/Mojo/IOLoop/Delay.pm
vendored
Normal file
204
database/perl/vendor/lib/Mojo/IOLoop/Delay.pm
vendored
Normal file
@@ -0,0 +1,204 @@
|
||||
package Mojo::IOLoop::Delay;
|
||||
use Mojo::Base 'Mojo::Promise';
|
||||
|
||||
sub begin {
|
||||
my ($self, $offset, $len) = @_;
|
||||
$self->{pending}++;
|
||||
my $id = $self->{counter}++;
|
||||
return sub { $self->_step($id, $offset // 1, $len, @_) };
|
||||
}
|
||||
|
||||
sub pass { $_[0]->begin->(@_) }
|
||||
|
||||
sub steps {
|
||||
my ($self, @steps) = @_;
|
||||
$self->{steps} = \@steps;
|
||||
$self->ioloop->next_tick($self->begin);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _step {
|
||||
my ($self, $id, $offset, $len) = (shift, shift, shift, shift);
|
||||
|
||||
$self->{args}[$id] = [@_ ? defined $len ? splice @_, $offset, $len : splice @_, $offset : ()];
|
||||
return $self if $self->{fail} || --$self->{pending} || $self->{lock};
|
||||
local $self->{lock} = 1;
|
||||
my @args = map {@$_} @{delete $self->{args}};
|
||||
|
||||
$self->{counter} = 0;
|
||||
if (my $cb = shift @{$self->{steps}}) {
|
||||
unless (eval { $self->$cb(@args); 1 }) {
|
||||
my $err = $@;
|
||||
@{$self}{qw(fail steps)} = (1, []);
|
||||
return $self->reject($err);
|
||||
}
|
||||
}
|
||||
|
||||
($self->{steps} = []) and return $self->resolve(@args) unless $self->{counter};
|
||||
$self->ioloop->next_tick($self->begin) unless $self->{pending};
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::Delay - Promises/A+ and flow-control helpers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::Delay;
|
||||
|
||||
# Synchronize multiple non-blocking operations
|
||||
my $delay = Mojo::IOLoop::Delay->new;
|
||||
$delay->steps(sub { say 'BOOM!' });
|
||||
for my $i (1 .. 10) {
|
||||
my $end = $delay->begin;
|
||||
Mojo::IOLoop->timer($i => sub {
|
||||
say 10 - $i;
|
||||
$end->();
|
||||
});
|
||||
}
|
||||
$delay->wait;
|
||||
|
||||
# Sequentialize multiple non-blocking operations
|
||||
Mojo::IOLoop::Delay->new->steps(
|
||||
|
||||
# First step (simple timer)
|
||||
sub ($delay) {
|
||||
Mojo::IOLoop->timer(2 => $delay->begin);
|
||||
say 'Second step in 2 seconds.';
|
||||
},
|
||||
|
||||
# Second step (concurrent timers)
|
||||
sub ($delay, @args) {
|
||||
Mojo::IOLoop->timer(1 => $delay->begin);
|
||||
Mojo::IOLoop->timer(3 => $delay->begin);
|
||||
say 'Third step in 3 seconds.';
|
||||
},
|
||||
|
||||
# Third step (the end)
|
||||
sub ($delay, @args) {
|
||||
say 'And done after 5 seconds total.';
|
||||
}
|
||||
)->wait;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::Delay> adds flow-control helpers to L<Mojo::Promise>, which can help you avoid deep nested closures
|
||||
that often result from continuation-passing style.
|
||||
|
||||
use Mojo::IOLoop;
|
||||
|
||||
# These deep nested closures are often referred to as "Callback Hell"
|
||||
Mojo::IOLoop->timer(3 => sub ($loop) {
|
||||
|
||||
say '3 seconds';
|
||||
Mojo::IOLoop->timer(3 => sub ($loop) {
|
||||
|
||||
say '6 seconds';
|
||||
Mojo::IOLoop->timer(3 => sub ($loop) {
|
||||
|
||||
say '9 seconds';
|
||||
Mojo::IOLoop->stop;
|
||||
});
|
||||
});
|
||||
});
|
||||
|
||||
Mojo::IOLoop->start;
|
||||
|
||||
The idea behind L<Mojo::IOLoop::Delay> is to turn the nested closures above into a flat series of closures. In the
|
||||
example below, the call to L</"begin"> creates a code reference that we can pass to L<Mojo::IOLoop/"timer"> as a
|
||||
callback, and that leads to the next closure in the series when executed.
|
||||
|
||||
use Mojo::IOLoop;
|
||||
|
||||
# Instead of nested closures we now have a simple chain of steps
|
||||
my $delay = Mojo::IOLoop->delay(
|
||||
sub ($delay) { Mojo::IOLoop->timer(3 => $delay->begin) },
|
||||
sub ($delay) {
|
||||
say '3 seconds';
|
||||
Mojo::IOLoop->timer(3 => $delay->begin);
|
||||
},
|
||||
sub ($delay) {
|
||||
say '6 seconds';
|
||||
Mojo::IOLoop->timer(3 => $delay->begin);
|
||||
},
|
||||
sub ($delay) { say '9 seconds' }
|
||||
);
|
||||
$delay->wait;
|
||||
|
||||
Another positive side effect of this pattern is that we do not need to call L<Mojo::IOLoop/"start"> and
|
||||
L<Mojo::IOLoop/"stop"> manually, because we know exactly when our chain of L</"steps"> has reached the end. So
|
||||
L<Mojo::Promise/"wait"> can stop the event loop automatically if it had to be started at all in the first place.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::Delay> inherits all attributes from L<Mojo::Promise>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::Delay> inherits all methods from L<Mojo::Promise> and implements the following new ones.
|
||||
|
||||
=head2 begin
|
||||
|
||||
my $cb = $delay->begin;
|
||||
my $cb = $delay->begin($offset);
|
||||
my $cb = $delay->begin($offset, $len);
|
||||
|
||||
Indicate an active event by incrementing the event counter, the returned code reference can be used as a callback, and
|
||||
needs to be executed when the event has completed to decrement the event counter again. When all code references
|
||||
generated by this method have been executed and the event counter has reached zero, L</"steps"> will continue.
|
||||
|
||||
# Capture all arguments except for the first one (invocant)
|
||||
my $delay = Mojo::IOLoop->delay(sub ($delay, $err, $stream) { ... });
|
||||
Mojo::IOLoop->client({port => 3000} => $delay->begin);
|
||||
$delay->wait;
|
||||
|
||||
Arguments passed to the returned code reference are spliced with the given offset and length, defaulting to an offset
|
||||
of C<1> with no default length. The arguments are then combined in the same order L</"begin"> was called, and passed
|
||||
together to the next step.
|
||||
|
||||
# Capture all arguments
|
||||
my $delay = Mojo::IOLoop->delay(sub ($delay, $loop, $err, $stream) { ... });
|
||||
Mojo::IOLoop->client({port => 3000} => $delay->begin(0));
|
||||
$delay->wait;
|
||||
|
||||
# Capture only the second argument
|
||||
my $delay = Mojo::IOLoop->delay(sub ($delay, $err) { ... });
|
||||
Mojo::IOLoop->client({port => 3000} => $delay->begin(1, 1));
|
||||
$delay->wait;
|
||||
|
||||
# Capture and combine arguments
|
||||
my $delay = Mojo::IOLoop->delay(sub ($delay, $three_err, $three_stream, $four_err, $four_stream) { ... });
|
||||
Mojo::IOLoop->client({port => 3000} => $delay->begin);
|
||||
Mojo::IOLoop->client({port => 4000} => $delay->begin);
|
||||
$delay->wait;
|
||||
|
||||
=head2 pass
|
||||
|
||||
$delay = $delay->pass;
|
||||
$delay = $delay->pass(@args);
|
||||
|
||||
Shortcut for passing values between L</"steps">.
|
||||
|
||||
# Longer version
|
||||
$delay->begin(0)->(@args);
|
||||
|
||||
=head2 steps
|
||||
|
||||
$delay = $delay->steps(sub {...}, sub {...});
|
||||
|
||||
Sequentialize multiple events, every time the event counter reaches zero a callback will run, the first one
|
||||
automatically runs during the next reactor tick unless it is delayed by incrementing the event counter. This chain will
|
||||
continue until there are no remaining callbacks, a callback does not increment the event counter or an exception gets
|
||||
thrown in a callback. Finishing the chain will also result in the promise being fulfilled, or if an exception got
|
||||
thrown it will be rejected.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
313
database/perl/vendor/lib/Mojo/IOLoop/Server.pm
vendored
Normal file
313
database/perl/vendor/lib/Mojo/IOLoop/Server.pm
vendored
Normal file
@@ -0,0 +1,313 @@
|
||||
package Mojo::IOLoop::Server;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use IO::Socket::IP;
|
||||
use IO::Socket::UNIX;
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::IOLoop::TLS;
|
||||
use Scalar::Util qw(weaken);
|
||||
use Socket qw(IPPROTO_TCP TCP_NODELAY);
|
||||
|
||||
has reactor => sub { Mojo::IOLoop->singleton->reactor }, weak => 1;
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$ENV{MOJO_REUSE} =~ s/(?:^|\,)\Q$self->{reuse}\E// if $self->{reuse};
|
||||
$self->stop if $self->{handle} && $self->reactor;
|
||||
}
|
||||
|
||||
sub generate_port { IO::Socket::IP->new(Listen => 5, LocalAddr => '127.0.0.1')->sockport }
|
||||
|
||||
sub handle { shift->{handle} }
|
||||
|
||||
sub is_accepting { !!shift->{active} }
|
||||
|
||||
sub listen {
|
||||
my ($self, $args) = (shift, ref $_[0] ? $_[0] : {@_});
|
||||
|
||||
# Look for reusable file descriptor
|
||||
my $path = $args->{path};
|
||||
my $address = $args->{address} || '0.0.0.0';
|
||||
my $port = $args->{port};
|
||||
$ENV{MOJO_REUSE} ||= '';
|
||||
my $fd = ($path && $ENV{MOJO_REUSE} =~ /(?:^|\,)unix:\Q$path\E:(\d+)/)
|
||||
|| ($port && $ENV{MOJO_REUSE} =~ /(?:^|\,)\Q$address:$port\E:(\d+)/) ? $1 : undef;
|
||||
|
||||
# Allow file descriptor inheritance
|
||||
local $^F = 1023;
|
||||
|
||||
# Reuse file descriptor
|
||||
my $handle;
|
||||
my $class = $path ? 'IO::Socket::UNIX' : 'IO::Socket::IP';
|
||||
if (defined($fd //= $args->{fd})) {
|
||||
$handle = $class->new_from_fd($fd, 'r') or croak "Can't open file descriptor $fd: $!";
|
||||
}
|
||||
|
||||
else {
|
||||
my %options = (Listen => $args->{backlog} // SOMAXCONN, Type => SOCK_STREAM);
|
||||
|
||||
# UNIX domain socket
|
||||
my $reuse;
|
||||
if ($path) {
|
||||
path($path)->remove if -S $path;
|
||||
$options{Local} = $path;
|
||||
$handle = $class->new(%options) or croak "Can't create listen socket: $!";
|
||||
$reuse = $self->{reuse} = join ':', 'unix', $path, fileno $handle;
|
||||
}
|
||||
|
||||
# IP socket
|
||||
else {
|
||||
$options{LocalAddr} = $address;
|
||||
$options{LocalAddr} =~ y/[]//d;
|
||||
$options{LocalPort} = $port if $port;
|
||||
$options{ReuseAddr} = 1;
|
||||
$options{ReusePort} = $args->{reuse};
|
||||
$handle = $class->new(%options) or croak "Can't create listen socket: $@";
|
||||
$fd = fileno $handle;
|
||||
$reuse = $self->{reuse} = join ':', $address, $handle->sockport, $fd;
|
||||
}
|
||||
|
||||
$ENV{MOJO_REUSE} .= length $ENV{MOJO_REUSE} ? ",$reuse" : "$reuse";
|
||||
}
|
||||
$handle->blocking(0);
|
||||
@$self{qw(args handle)} = ($args, $handle);
|
||||
|
||||
croak 'IO::Socket::SSL 2.009+ required for TLS support' if !Mojo::IOLoop::TLS->can_tls && $args->{tls};
|
||||
}
|
||||
|
||||
sub port { shift->{handle}->sockport }
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
weaken $self;
|
||||
++$self->{active} and $self->reactor->io($self->{handle} => sub { $self->_accept })->watch($self->{handle}, 1, 0);
|
||||
}
|
||||
|
||||
sub stop { delete($_[0]{active}) and $_[0]->reactor->remove($_[0]{handle}) }
|
||||
|
||||
sub _accept {
|
||||
my $self = shift;
|
||||
|
||||
# Greedy accept
|
||||
my $args = $self->{args};
|
||||
my $accepted = 0;
|
||||
while ($self->{active} && !($args->{single_accept} && $accepted++)) {
|
||||
return unless my $handle = $self->{handle}->accept;
|
||||
$handle->blocking(0);
|
||||
|
||||
# Disable Nagle's algorithm
|
||||
setsockopt $handle, IPPROTO_TCP, TCP_NODELAY, 1;
|
||||
|
||||
$self->emit(accept => $handle) and next unless $args->{tls};
|
||||
|
||||
# Start TLS handshake
|
||||
my $tls = Mojo::IOLoop::TLS->new($handle)->reactor($self->reactor);
|
||||
$tls->on(upgrade => sub { $self->emit(accept => pop) });
|
||||
$tls->on(error => sub { });
|
||||
$tls->negotiate(%$args, server => 1);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::Server - Non-blocking TCP and UNIX domain socket server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::Server;
|
||||
|
||||
# Create listen socket
|
||||
my $server = Mojo::IOLoop::Server->new;
|
||||
$server->on(accept => sub ($server, $handle) {...});
|
||||
$server->listen(port => 3000);
|
||||
|
||||
# Start and stop accepting connections
|
||||
$server->start;
|
||||
$server->stop;
|
||||
|
||||
# Start reactor if necessary
|
||||
$server->reactor->start unless $server->reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::Server> accepts TCP/IP and UNIX domain socket connections for L<Mojo::IOLoop>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop::Server> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 accept
|
||||
|
||||
$server->on(accept => sub ($server, $handle) {...});
|
||||
|
||||
Emitted for each accepted connection.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::Server> implements the following attributes.
|
||||
|
||||
=head2 reactor
|
||||
|
||||
my $reactor = $server->reactor;
|
||||
$server = $server->reactor(Mojo::Reactor::Poll->new);
|
||||
|
||||
Low-level event reactor, defaults to the C<reactor> attribute value of the global L<Mojo::IOLoop> singleton. Note that
|
||||
this attribute is weakened.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::Server> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 generate_port
|
||||
|
||||
my $port = Mojo::IOLoop::Server->generate_port;
|
||||
|
||||
Find a free TCP port, primarily used for tests.
|
||||
|
||||
=head2 handle
|
||||
|
||||
my $handle = $server->handle;
|
||||
|
||||
Get handle for server, usually an L<IO::Socket::IP> object.
|
||||
|
||||
=head2 is_accepting
|
||||
|
||||
my $bool = $server->is_accepting;
|
||||
|
||||
Check if connections are currently being accepted.
|
||||
|
||||
=head2 listen
|
||||
|
||||
$server->listen(port => 3000);
|
||||
$server->listen({port => 3000});
|
||||
|
||||
Create a new listen socket. Note that TLS support depends on L<IO::Socket::SSL> (2.009+).
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item address
|
||||
|
||||
address => '127.0.0.1'
|
||||
|
||||
Local address to listen on, defaults to C<0.0.0.0>.
|
||||
|
||||
=item backlog
|
||||
|
||||
backlog => 128
|
||||
|
||||
Maximum backlog size, defaults to C<SOMAXCONN>.
|
||||
|
||||
=item fd
|
||||
|
||||
fd => 3
|
||||
|
||||
File descriptor with an already prepared listen socket.
|
||||
|
||||
=item path
|
||||
|
||||
path => '/tmp/myapp.sock'
|
||||
|
||||
Path for UNIX domain socket to listen on.
|
||||
|
||||
=item port
|
||||
|
||||
port => 80
|
||||
|
||||
Port to listen on, defaults to a random port.
|
||||
|
||||
=item reuse
|
||||
|
||||
reuse => 1
|
||||
|
||||
Allow multiple servers to use the same port with the C<SO_REUSEPORT> socket option.
|
||||
|
||||
=item single_accept
|
||||
|
||||
single_accept => 1
|
||||
|
||||
Only accept one connection at a time.
|
||||
|
||||
=item tls
|
||||
|
||||
tls => 1
|
||||
|
||||
Enable TLS.
|
||||
|
||||
=item tls_ca
|
||||
|
||||
tls_ca => '/etc/tls/ca.crt'
|
||||
|
||||
Path to TLS certificate authority file.
|
||||
|
||||
=item tls_cert
|
||||
|
||||
tls_cert => '/etc/tls/server.crt'
|
||||
tls_cert => {'mojolicious.org' => '/etc/tls/mojo.crt'}
|
||||
|
||||
Path to the TLS cert file, defaults to a built-in test certificate.
|
||||
|
||||
=item tls_ciphers
|
||||
|
||||
tls_ciphers => 'AES128-GCM-SHA256:RC4:HIGH:!MD5:!aNULL:!EDH'
|
||||
|
||||
TLS cipher specification string. For more information about the format see
|
||||
L<https://www.openssl.org/docs/manmaster/apps/ciphers.html#CIPHER-STRINGS>.
|
||||
|
||||
=item tls_key
|
||||
|
||||
tls_key => '/etc/tls/server.key'
|
||||
tls_key => {'mojolicious.org' => '/etc/tls/mojo.key'}
|
||||
|
||||
Path to the TLS key file, defaults to a built-in test key.
|
||||
|
||||
=item tls_protocols
|
||||
|
||||
tls_protocols => ['foo', 'bar']
|
||||
|
||||
ALPN protocols to negotiate.
|
||||
|
||||
=item tls_verify
|
||||
|
||||
tls_verify => 0x00
|
||||
|
||||
TLS verification mode.
|
||||
|
||||
=item tls_version
|
||||
|
||||
tls_version => 'TLSv1_2'
|
||||
|
||||
TLS protocol version.
|
||||
|
||||
=back
|
||||
|
||||
=head2 port
|
||||
|
||||
my $port = $server->port;
|
||||
|
||||
Get port this server is listening on.
|
||||
|
||||
=head2 start
|
||||
|
||||
$server->start;
|
||||
|
||||
Start or resume accepting connections.
|
||||
|
||||
=head2 stop
|
||||
|
||||
$server->stop;
|
||||
|
||||
Stop accepting connections.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
327
database/perl/vendor/lib/Mojo/IOLoop/Stream.pm
vendored
Normal file
327
database/perl/vendor/lib/Mojo/IOLoop/Stream.pm
vendored
Normal file
@@ -0,0 +1,327 @@
|
||||
package Mojo::IOLoop::Stream;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Errno qw(EAGAIN ECONNRESET EINTR EWOULDBLOCK);
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::Util;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
has high_water_mark => 1048576;
|
||||
has reactor => sub { Mojo::IOLoop->singleton->reactor }, weak => 1;
|
||||
|
||||
sub DESTROY { Mojo::Util::_global_destruction() or shift->close }
|
||||
|
||||
sub bytes_read { shift->{read} || 0 }
|
||||
|
||||
sub bytes_waiting { length(shift->{buffer} // '') }
|
||||
|
||||
sub bytes_written { shift->{written} || 0 }
|
||||
|
||||
sub can_write { $_[0]{handle} && $_[0]->bytes_waiting < $_[0]->high_water_mark }
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
return unless my $reactor = $self->reactor;
|
||||
return unless my $handle = delete $self->timeout(0)->{handle};
|
||||
$reactor->remove($handle);
|
||||
$self->emit('close');
|
||||
}
|
||||
|
||||
sub close_gracefully { $_[0]->is_writing ? $_[0]{graceful}++ : $_[0]->close }
|
||||
|
||||
sub handle { shift->{handle} }
|
||||
|
||||
sub is_readable {
|
||||
my $self = shift;
|
||||
$self->_again;
|
||||
return $self->{handle} && Mojo::Util::_readable(0, fileno $self->{handle});
|
||||
}
|
||||
|
||||
sub is_writing {
|
||||
my $self = shift;
|
||||
return undef unless $self->{handle};
|
||||
return !!length($self->{buffer}) || $self->has_subscribers('drain');
|
||||
}
|
||||
|
||||
sub new { shift->SUPER::new(handle => shift, timeout => 15) }
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
|
||||
# Resume
|
||||
return unless $self->{handle};
|
||||
my $reactor = $self->reactor;
|
||||
return $reactor->watch($self->{handle}, 1, $self->is_writing) if delete $self->{paused};
|
||||
|
||||
weaken $self;
|
||||
my $cb = sub { pop() ? $self->_write : $self->_read };
|
||||
$reactor->io($self->timeout($self->{timeout})->{handle} => $cb);
|
||||
}
|
||||
|
||||
sub steal_handle {
|
||||
my $self = shift;
|
||||
$self->reactor->remove($self->{handle});
|
||||
return delete $self->{handle};
|
||||
}
|
||||
|
||||
sub stop { $_[0]->reactor->watch($_[0]{handle}, 0, $_[0]->is_writing) if $_[0]{handle} && !$_[0]{paused}++ }
|
||||
|
||||
sub timeout {
|
||||
my ($self, $timeout) = @_;
|
||||
|
||||
return $self->{timeout} unless defined $timeout;
|
||||
$self->{timeout} = $timeout;
|
||||
|
||||
my $reactor = $self->reactor;
|
||||
if ($self->{timer}) {
|
||||
if (!$self->{timeout}) { $reactor->remove(delete $self->{timer}) }
|
||||
else { $reactor->again($self->{timer}, $self->{timeout}) }
|
||||
}
|
||||
elsif ($self->{timeout}) {
|
||||
weaken $self;
|
||||
$self->{timer}
|
||||
= $reactor->timer($timeout => sub { $self and delete($self->{timer}) and $self->emit('timeout')->close });
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub write {
|
||||
my ($self, $chunk, $cb) = @_;
|
||||
|
||||
# IO::Socket::SSL will corrupt data with the wrong internal representation
|
||||
utf8::downgrade $chunk;
|
||||
$self->{buffer} .= $chunk;
|
||||
if ($cb) { $self->once(drain => $cb) }
|
||||
elsif (!length $self->{buffer}) { return $self }
|
||||
$self->reactor->watch($self->{handle}, !$self->{paused}, 1) if $self->{handle};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _again { $_[0]->reactor->again($_[0]{timer}) if $_[0]{timer} }
|
||||
|
||||
sub _read {
|
||||
my $self = shift;
|
||||
|
||||
if (defined(my $read = $self->{handle}->sysread(my $buffer, 131072, 0))) {
|
||||
$self->{read} += $read;
|
||||
return $read == 0 ? $self->close : $self->emit(read => $buffer)->_again;
|
||||
}
|
||||
|
||||
# Retry
|
||||
return undef if $! == EAGAIN || $! == EINTR || $! == EWOULDBLOCK;
|
||||
|
||||
# Closed (maybe real error)
|
||||
$! == ECONNRESET ? $self->close : $self->emit(error => $!)->close;
|
||||
}
|
||||
|
||||
sub _write {
|
||||
my $self = shift;
|
||||
|
||||
# Handle errors only when reading (to avoid timing problems)
|
||||
my $handle = $self->{handle};
|
||||
if (length $self->{buffer}) {
|
||||
return undef unless defined(my $written = $handle->syswrite($self->{buffer}));
|
||||
$self->{written} += $written;
|
||||
$self->emit(write => substr($self->{buffer}, 0, $written, ''))->_again;
|
||||
}
|
||||
|
||||
# Clear the buffer to free the underlying SV* memory
|
||||
undef $self->{buffer}, $self->emit('drain') unless length $self->{buffer};
|
||||
return undef if $self->is_writing;
|
||||
return $self->close if $self->{graceful};
|
||||
$self->reactor->watch($handle, !$self->{paused}, 0) if $self->{handle};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::Stream - Non-blocking I/O stream
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::Stream;
|
||||
|
||||
# Create stream
|
||||
my $stream = Mojo::IOLoop::Stream->new($handle);
|
||||
$stream->on(read => sub ($stream, $bytes) {...});
|
||||
$stream->on(close => sub ($stream) {...});
|
||||
$stream->on(error => sub ($stream, $err) {...});
|
||||
|
||||
# Start and stop watching for new data
|
||||
$stream->start;
|
||||
$stream->stop;
|
||||
|
||||
# Start reactor if necessary
|
||||
$stream->reactor->start unless $stream->reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::Stream> is a container for I/O streams used by L<Mojo::IOLoop>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop::Stream> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 close
|
||||
|
||||
$stream->on(close => sub ($stream) {...});
|
||||
|
||||
Emitted if the stream gets closed.
|
||||
|
||||
=head2 drain
|
||||
|
||||
$stream->on(drain => sub ($stream) {...});
|
||||
|
||||
Emitted once all data has been written.
|
||||
|
||||
=head2 error
|
||||
|
||||
$stream->on(error => sub ($stream, $err) {...});
|
||||
|
||||
Emitted if an error occurs on the stream, fatal if unhandled.
|
||||
|
||||
=head2 read
|
||||
|
||||
$stream->on(read => sub ($stream, $bytes) {...});
|
||||
|
||||
Emitted if new data arrives on the stream.
|
||||
|
||||
=head2 timeout
|
||||
|
||||
$stream->on(timeout => sub ($stream) {...});
|
||||
|
||||
Emitted if the stream has been inactive for too long and will get closed automatically.
|
||||
|
||||
=head2 write
|
||||
|
||||
$stream->on(write => sub ($stream, $bytes) {...});
|
||||
|
||||
Emitted if new data has been written to the stream.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::Stream> implements the following attributes.
|
||||
|
||||
=head2 high_water_mark
|
||||
|
||||
my $size = $msg->high_water_mark;
|
||||
$msg = $msg->high_water_mark(1024);
|
||||
|
||||
Maximum size of L</"write"> buffer in bytes before L</"can_write"> returns false, defaults to C<1048576> (1MiB).
|
||||
|
||||
=head2 reactor
|
||||
|
||||
my $reactor = $stream->reactor;
|
||||
$stream = $stream->reactor(Mojo::Reactor::Poll->new);
|
||||
|
||||
Low-level event reactor, defaults to the C<reactor> attribute value of the global L<Mojo::IOLoop> singleton. Note that
|
||||
this attribute is weakened.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::Stream> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 bytes_read
|
||||
|
||||
my $num = $stream->bytes_read;
|
||||
|
||||
Number of bytes received.
|
||||
|
||||
=head2 bytes_waiting
|
||||
|
||||
my $num = $stream->bytes_waiting;
|
||||
|
||||
Number of bytes that have been enqueued with L</"write"> and are waiting to be written.
|
||||
|
||||
=head2 bytes_written
|
||||
|
||||
my $num = $stream->bytes_written;
|
||||
|
||||
Number of bytes written.
|
||||
|
||||
=head2 can_write
|
||||
|
||||
my $bool = $stream->can_write;
|
||||
|
||||
Returns true if calling L</"write"> is safe.
|
||||
|
||||
=head2 close
|
||||
|
||||
$stream->close;
|
||||
|
||||
Close stream immediately.
|
||||
|
||||
=head2 close_gracefully
|
||||
|
||||
$stream->close_gracefully;
|
||||
|
||||
Close stream gracefully.
|
||||
|
||||
=head2 handle
|
||||
|
||||
my $handle = $stream->handle;
|
||||
|
||||
Get handle for stream, usually an L<IO::Socket::IP> or L<IO::Socket::SSL> object.
|
||||
|
||||
=head2 is_readable
|
||||
|
||||
my $bool = $stream->is_readable;
|
||||
|
||||
Quick non-blocking check if stream is readable, useful for identifying tainted sockets.
|
||||
|
||||
=head2 is_writing
|
||||
|
||||
my $bool = $stream->is_writing;
|
||||
|
||||
Check if stream is writing.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $stream = Mojo::IOLoop::Stream->new($handle);
|
||||
|
||||
Construct a new L<Mojo::IOLoop::Stream> object.
|
||||
|
||||
=head2 start
|
||||
|
||||
$stream->start;
|
||||
|
||||
Start or resume watching for new data on the stream.
|
||||
|
||||
=head2 steal_handle
|
||||
|
||||
my $handle = $stream->steal_handle;
|
||||
|
||||
Steal L</"handle"> and prevent it from getting closed automatically.
|
||||
|
||||
=head2 stop
|
||||
|
||||
$stream->stop;
|
||||
|
||||
Stop watching for new data on the stream.
|
||||
|
||||
=head2 timeout
|
||||
|
||||
my $timeout = $stream->timeout;
|
||||
$stream = $stream->timeout(45);
|
||||
|
||||
Maximum amount of time in seconds stream can be inactive before getting closed automatically, defaults to C<15>.
|
||||
Setting the value to C<0> will allow this stream to be inactive indefinitely.
|
||||
|
||||
=head2 write
|
||||
|
||||
$stream = $stream->write($bytes);
|
||||
$stream = $stream->write($bytes => sub {...});
|
||||
|
||||
Enqueue data to be written to the stream as soon as possible, the optional drain callback will be executed once all
|
||||
data has been written.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
265
database/perl/vendor/lib/Mojo/IOLoop/Subprocess.pm
vendored
Normal file
265
database/perl/vendor/lib/Mojo/IOLoop/Subprocess.pm
vendored
Normal file
@@ -0,0 +1,265 @@
|
||||
package Mojo::IOLoop::Subprocess;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Config;
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::IOLoop::Stream;
|
||||
use Mojo::JSON;
|
||||
use Mojo::Promise;
|
||||
use POSIX ();
|
||||
|
||||
has deserialize => sub { \&Mojo::JSON::decode_json };
|
||||
has ioloop => sub { Mojo::IOLoop->singleton }, weak => 1;
|
||||
has serialize => sub { \&Mojo::JSON::encode_json };
|
||||
|
||||
sub exit_code { shift->{exit_code} }
|
||||
|
||||
sub pid { shift->{pid} }
|
||||
|
||||
sub run {
|
||||
my ($self, @args) = @_;
|
||||
$self->ioloop->next_tick(sub { $self->_start(@args) });
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub run_p {
|
||||
my ($self, $child) = @_;
|
||||
|
||||
my $p = Mojo::Promise->new;
|
||||
my $parent = sub {
|
||||
my ($self, $err) = (shift, shift);
|
||||
$err ? $p->reject($err) : $p->resolve(@_);
|
||||
};
|
||||
$self->ioloop->next_tick(sub { $self->_start($child, $parent) });
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
sub _start {
|
||||
my ($self, $child, $parent) = @_;
|
||||
|
||||
# No fork emulation support
|
||||
return $self->$parent('Subprocesses do not support fork emulation') if $Config{d_pseudofork};
|
||||
|
||||
# Pipe for subprocess communication
|
||||
return $self->$parent("Can't create pipe: $!") unless pipe(my $reader, $self->{writer});
|
||||
$self->{writer}->autoflush(1);
|
||||
|
||||
# Child
|
||||
return $self->$parent("Can't fork: $!") unless defined(my $pid = $self->{pid} = fork);
|
||||
unless ($pid) {
|
||||
eval {
|
||||
$self->ioloop->reset({freeze => 1});
|
||||
my $results = eval { [$self->$child] } // [];
|
||||
print {$self->{writer}} '0-', $self->serialize->([$@, @$results]);
|
||||
$self->emit('cleanup');
|
||||
} or warn $@;
|
||||
POSIX::_exit(0);
|
||||
}
|
||||
|
||||
# Parent
|
||||
my $me = $$;
|
||||
close $self->{writer};
|
||||
my $stream = Mojo::IOLoop::Stream->new($reader)->timeout(0);
|
||||
$self->emit('spawn')->ioloop->stream($stream);
|
||||
my $buffer = '';
|
||||
$stream->on(
|
||||
read => sub {
|
||||
$buffer .= pop;
|
||||
while (1) {
|
||||
my ($len) = $buffer =~ /^([0-9]+)\-/;
|
||||
last unless $len and length $buffer >= $len + $+[0];
|
||||
my $snippet = substr $buffer, 0, $len + $+[0], '';
|
||||
my $args = $self->deserialize->(substr $snippet, $+[0]);
|
||||
$self->emit(progress => @$args);
|
||||
}
|
||||
}
|
||||
);
|
||||
$stream->on(
|
||||
close => sub {
|
||||
return unless $$ == $me;
|
||||
waitpid $pid, 0;
|
||||
$self->{exit_code} = $? >> 8;
|
||||
substr $buffer, 0, 2, '';
|
||||
my $results = eval { $self->deserialize->($buffer) } // [];
|
||||
$self->$parent(shift(@$results) // $@, @$results);
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub progress {
|
||||
my ($self, @args) = @_;
|
||||
my $serialized = $self->serialize->(\@args);
|
||||
print {$self->{writer}} length($serialized), '-', $serialized;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::Subprocess - Subprocesses
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::Subprocess;
|
||||
|
||||
# Operation that would block the event loop for 5 seconds
|
||||
my $subprocess = Mojo::IOLoop::Subprocess->new;
|
||||
$subprocess->run(
|
||||
sub ($subprocess) {
|
||||
sleep 5;
|
||||
return '♥', 'Mojolicious';
|
||||
},
|
||||
sub ($subprocess, $err, @results) {
|
||||
say "Subprocess error: $err" and return if $err;
|
||||
say "I $results[0] $results[1]!";
|
||||
}
|
||||
);
|
||||
|
||||
# Operation that would block the event loop for 5 seconds (with promise)
|
||||
$subprocess->run_p(sub {
|
||||
sleep 5;
|
||||
return '♥', 'Mojolicious';
|
||||
})->then(sub (@results) {
|
||||
say "I $results[0] $results[1]!";
|
||||
})->catch(sub {
|
||||
my $err = shift;
|
||||
say "Subprocess error: $err";
|
||||
});
|
||||
|
||||
# Start event loop if necessary
|
||||
$subprocess->ioloop->start unless $subprocess->ioloop->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::Subprocess> allows L<Mojo::IOLoop> to perform computationally expensive operations in subprocesses,
|
||||
without blocking the event loop.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop::Subprocess> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 cleanup
|
||||
|
||||
$subprocess->on(cleanup => sub ($subprocess) {...});
|
||||
|
||||
Emitted in the subprocess right before the process will exit.
|
||||
|
||||
$subprocess->on(cleanup => sub ($subprocess) { say "Process $$ is about to exit" });
|
||||
|
||||
=head2 progress
|
||||
|
||||
$subprocess->on(progress => sub ($subprocess, @data) {...});
|
||||
|
||||
Emitted in the parent process when the subprocess calls the L<progress|/"progress1"> method.
|
||||
|
||||
=head2 spawn
|
||||
|
||||
$subprocess->on(spawn => sub ($subprocess) {...});
|
||||
|
||||
Emitted in the parent process when the subprocess has been spawned.
|
||||
|
||||
$subprocess->on(spawn => sub ($subprocess) {
|
||||
my $pid = $subprocess->pid;
|
||||
say "Performing work in process $pid";
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::Subprocess> implements the following attributes.
|
||||
|
||||
=head2 deserialize
|
||||
|
||||
my $cb = $subprocess->deserialize;
|
||||
$subprocess = $subprocess->deserialize(sub {...});
|
||||
|
||||
A callback used to deserialize subprocess return values, defaults to using L<Mojo::JSON>.
|
||||
|
||||
$subprocess->deserialize(sub ($bytes) { return [] });
|
||||
|
||||
=head2 ioloop
|
||||
|
||||
my $loop = $subprocess->ioloop;
|
||||
$subprocess = $subprocess->ioloop(Mojo::IOLoop->new);
|
||||
|
||||
Event loop object to control, defaults to the global L<Mojo::IOLoop> singleton. Note that this attribute is weakened.
|
||||
|
||||
=head2 serialize
|
||||
|
||||
my $cb = $subprocess->serialize;
|
||||
$subprocess = $subprocess->serialize(sub {...});
|
||||
|
||||
A callback used to serialize subprocess return values, defaults to using L<Mojo::JSON>.
|
||||
|
||||
$subprocess->serialize(sub ($array) { return '' });
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::Subprocess> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 exit_code
|
||||
|
||||
my $code = $subprocess->exit_code;
|
||||
|
||||
Returns the subprocess exit code, or C<undef> if the subprocess is still running.
|
||||
|
||||
=head2 pid
|
||||
|
||||
my $pid = $subprocess->pid;
|
||||
|
||||
Process id of the spawned subprocess if available.
|
||||
|
||||
=head2 progress
|
||||
|
||||
$subprocess->progress(@data);
|
||||
|
||||
Send data serialized with L<Mojo::JSON> to the parent process at any time during the subprocess's execution. Must be
|
||||
called by the subprocess and emits the L</"progress"> event in the parent process with the data.
|
||||
|
||||
# Send progress information to the parent process
|
||||
$subprocess->run(
|
||||
sub ($subprocess) {
|
||||
$subprocess->progress('0%');
|
||||
sleep 5;
|
||||
$subprocess->progress('50%');
|
||||
sleep 5;
|
||||
return 'Hello Mojo!';
|
||||
},
|
||||
sub ($subprocess, $err, @results) {
|
||||
say 'Progress is 100%';
|
||||
say $results[0];
|
||||
}
|
||||
);
|
||||
$subprocess->on(progress => sub ($subprocess, @data) { say "Progress is $data[0]" });
|
||||
|
||||
=head2 run
|
||||
|
||||
$subprocess = $subprocess->run(sub {...}, sub {...});
|
||||
|
||||
Execute the first callback in a child process and wait for it to return one or more values, without blocking
|
||||
L</"ioloop"> in the parent process. Then execute the second callback in the parent process with the results. The return
|
||||
values of the first callback and exceptions thrown by it, will be serialized with L<Mojo::JSON>, so they can be shared
|
||||
between processes.
|
||||
|
||||
=head2 run_p
|
||||
|
||||
my $promise = $subprocess->run_p(sub {...});
|
||||
|
||||
Same as L</"run">, but returns a L<Mojo::Promise> object instead of accepting a second callback.
|
||||
|
||||
$subprocess->run_p(sub {
|
||||
sleep 5;
|
||||
return '♥', 'Mojolicious';
|
||||
})->then(sub (@results) {
|
||||
say "I $results[0] $results[1]!";
|
||||
})->catch(sub ($err) {
|
||||
say "Subprocess error: $err";
|
||||
})->wait;
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
221
database/perl/vendor/lib/Mojo/IOLoop/TLS.pm
vendored
Normal file
221
database/perl/vendor/lib/Mojo/IOLoop/TLS.pm
vendored
Normal file
@@ -0,0 +1,221 @@
|
||||
package Mojo::IOLoop::TLS;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Mojo::File qw(curfile);
|
||||
use Mojo::IOLoop;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
# TLS support requires IO::Socket::SSL
|
||||
use constant TLS => $ENV{MOJO_NO_TLS} ? 0 : eval { require IO::Socket::SSL; IO::Socket::SSL->VERSION('2.009'); 1 };
|
||||
use constant READ => TLS ? IO::Socket::SSL::SSL_WANT_READ() : 0;
|
||||
use constant WRITE => TLS ? IO::Socket::SSL::SSL_WANT_WRITE() : 0;
|
||||
|
||||
has reactor => sub { Mojo::IOLoop->singleton->reactor }, weak => 1;
|
||||
|
||||
# To regenerate the certificate run this command (28.06.2019)
|
||||
# openssl req -x509 -newkey rsa:4096 -nodes -sha256 -out server.crt \
|
||||
# -keyout server.key -days 7300 -subj '/CN=localhost'
|
||||
my $CERT = curfile->sibling('resources', 'server.crt')->to_string;
|
||||
my $KEY = curfile->sibling('resources', 'server.key')->to_string;
|
||||
|
||||
sub DESTROY { shift->_cleanup }
|
||||
|
||||
sub can_tls {TLS}
|
||||
|
||||
sub negotiate {
|
||||
my ($self, $args) = (shift, ref $_[0] ? $_[0] : {@_});
|
||||
|
||||
return $self->emit(error => 'IO::Socket::SSL 2.009+ required for TLS support') unless TLS;
|
||||
|
||||
my $handle = $self->{handle};
|
||||
return $self->emit(error => $IO::Socket::SSL::SSL_ERROR)
|
||||
unless IO::Socket::SSL->start_SSL($handle, %{$self->_expand($args)});
|
||||
$self->reactor->io($handle => sub { $self->_tls($handle, $args->{server}) });
|
||||
}
|
||||
|
||||
sub new { shift->SUPER::new(handle => shift) }
|
||||
|
||||
sub _cleanup {
|
||||
my $self = shift;
|
||||
return undef unless my $reactor = $self->reactor;
|
||||
$reactor->remove($self->{handle}) if $self->{handle};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _expand {
|
||||
my ($self, $args) = @_;
|
||||
|
||||
weaken $self;
|
||||
my $tls = {SSL_error_trap => sub { $self->_cleanup->emit(error => $_[1]) }, SSL_startHandshake => 0};
|
||||
$tls->{SSL_alpn_protocols} = $args->{tls_protocols} if $args->{tls_protocols};
|
||||
$tls->{SSL_ca_file} = $args->{tls_ca} if $args->{tls_ca} && -T $args->{tls_ca};
|
||||
$tls->{SSL_cert_file} = $args->{tls_cert} if $args->{tls_cert};
|
||||
$tls->{SSL_cipher_list} = $args->{tls_ciphers} if $args->{tls_ciphers};
|
||||
$tls->{SSL_key_file} = $args->{tls_key} if $args->{tls_key};
|
||||
$tls->{SSL_server} = $args->{server} if $args->{server};
|
||||
$tls->{SSL_verify_mode} = $args->{tls_verify} if defined $args->{tls_verify};
|
||||
$tls->{SSL_version} = $args->{tls_version} if $args->{tls_version};
|
||||
|
||||
if ($args->{server}) {
|
||||
$tls->{SSL_cert_file} ||= $CERT;
|
||||
$tls->{SSL_key_file} ||= $KEY;
|
||||
}
|
||||
else {
|
||||
$tls->{SSL_hostname} = IO::Socket::SSL->can_client_sni ? $args->{address} : '';
|
||||
$tls->{SSL_verifycn_name} = $args->{address};
|
||||
}
|
||||
|
||||
return $tls;
|
||||
}
|
||||
|
||||
sub _tls {
|
||||
my ($self, $handle, $server) = @_;
|
||||
|
||||
# Switch between reading and writing
|
||||
if (!($server ? $handle->accept_SSL : $handle->connect_SSL)) {
|
||||
my $err = $IO::Socket::SSL::SSL_ERROR;
|
||||
if ($err == READ) { $self->reactor->watch($handle, 1, 0) }
|
||||
elsif ($err == WRITE) { $self->reactor->watch($handle, 1, 1) }
|
||||
}
|
||||
|
||||
else { $self->_cleanup->emit(upgrade => delete $self->{handle}) }
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::IOLoop::TLS - Non-blocking TLS handshake
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::IOLoop::TLS;
|
||||
|
||||
# Negotiate TLS
|
||||
my $tls = Mojo::IOLoop::TLS->new($old_handle);
|
||||
$tls->on(upgrade => sub ($tls, $new_handle) {...});
|
||||
$tls->on(error => sub ($tls, $err) {...});
|
||||
$tls->negotiate(server => 1, tls_version => 'TLSv1_2');
|
||||
|
||||
# Start reactor if necessary
|
||||
$tls->reactor->start unless $tls->reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::IOLoop::TLS> negotiates TLS for L<Mojo::IOLoop>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::IOLoop::TLS> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 upgrade
|
||||
|
||||
$tls->on(upgrade => sub ($tls, $handle) {...});
|
||||
|
||||
Emitted once TLS has been negotiated.
|
||||
|
||||
=head2 error
|
||||
|
||||
$tls->on(error => sub ($tls, $err) {...});
|
||||
|
||||
Emitted if an error occurs during negotiation, fatal if unhandled.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::IOLoop::TLS> implements the following attributes.
|
||||
|
||||
=head2 reactor
|
||||
|
||||
my $reactor = $tls->reactor;
|
||||
$tls = $tls->reactor(Mojo::Reactor::Poll->new);
|
||||
|
||||
Low-level event reactor, defaults to the C<reactor> attribute value of the global L<Mojo::IOLoop> singleton. Note that
|
||||
this attribute is weakened.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::IOLoop::TLS> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 can_tls
|
||||
|
||||
my $bool = Mojo::IOLoop::TLS->can_tls;
|
||||
|
||||
True if L<IO::Socket::SSL> 2.009+ is installed and TLS support enabled.
|
||||
|
||||
=head2 negotiate
|
||||
|
||||
$tls->negotiate(server => 1, tls_version => 'TLSv1_2');
|
||||
$tls->negotiate({server => 1, tls_version => 'TLSv1_2'});
|
||||
|
||||
Negotiate TLS.
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item server
|
||||
|
||||
server => 1
|
||||
|
||||
Negotiate TLS from the server-side, defaults to the client-side.
|
||||
|
||||
=item tls_ca
|
||||
|
||||
tls_ca => '/etc/tls/ca.crt'
|
||||
|
||||
Path to TLS certificate authority file.
|
||||
|
||||
=item tls_cert
|
||||
|
||||
tls_cert => '/etc/tls/server.crt'
|
||||
tls_cert => {'mojolicious.org' => '/etc/tls/mojo.crt'}
|
||||
|
||||
Path to the TLS cert file, defaults to a built-in test certificate on the server-side.
|
||||
|
||||
=item tls_ciphers
|
||||
|
||||
tls_ciphers => 'AES128-GCM-SHA256:RC4:HIGH:!MD5:!aNULL:!EDH'
|
||||
|
||||
TLS cipher specification string. For more information about the format see
|
||||
L<https://www.openssl.org/docs/manmaster/apps/ciphers.html#CIPHER-STRINGS>.
|
||||
|
||||
=item tls_key
|
||||
|
||||
tls_key => '/etc/tls/server.key'
|
||||
tls_key => {'mojolicious.org' => '/etc/tls/mojo.key'}
|
||||
|
||||
Path to the TLS key file, defaults to a built-in test key on the server-side.
|
||||
|
||||
=item tls_protocols
|
||||
|
||||
tls_protocols => ['foo', 'bar']
|
||||
|
||||
ALPN protocols to negotiate.
|
||||
|
||||
=item tls_verify
|
||||
|
||||
tls_verify => 0x00
|
||||
|
||||
TLS verification mode.
|
||||
|
||||
=item tls_version
|
||||
|
||||
tls_version => 'TLSv1_2'
|
||||
|
||||
TLS protocol version.
|
||||
|
||||
=back
|
||||
|
||||
=head2 new
|
||||
|
||||
my $tls = Mojo::IOLoop::TLS->new($handle);
|
||||
|
||||
Construct a new L<Mojo::IOLoop::Stream> object.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
27
database/perl/vendor/lib/Mojo/IOLoop/resources/server.crt
vendored
Normal file
27
database/perl/vendor/lib/Mojo/IOLoop/resources/server.crt
vendored
Normal file
@@ -0,0 +1,27 @@
|
||||
-----BEGIN CERTIFICATE-----
|
||||
MIIEpDCCAowCCQD2f63fTFHflTANBgkqhkiG9w0BAQsFADAUMRIwEAYDVQQDDAls
|
||||
b2NhbGhvc3QwHhcNMTkwNjI4MjExNDI5WhcNMzkwNjIzMjExNDI5WjAUMRIwEAYD
|
||||
VQQDDAlsb2NhbGhvc3QwggIiMA0GCSqGSIb3DQEBAQUAA4ICDwAwggIKAoICAQC2
|
||||
lW4DOBswU1YJkekNF6c4b1VVcpOvtqsLHhTxUz538bffcvhI2vv+aCltG6g5mlvJ
|
||||
wo5NEu9l0ZG5TD9Ca4+WOOisVWrAI/i2YxXFQLOdjhKRBB1BvrOxSaFOuCXz9+cj
|
||||
VRo0R8Dq3k+1aSy93Yf+fq9pL7LFJaUOlxcU2FOM+HW9FYPeVbqCzYqpPJoaBnwN
|
||||
tQkQg7i8ufbeMS0bCcFpfTSV4pCgpWg1L9z6cVmBHtxc4MQv7rTTal+BF/iZDfDk
|
||||
qTNFJpuK7IGtSVB5laTcssYKGuY5QhN5BBPoGEMP3f0KiZmgMOUqwR6fMUiidacG
|
||||
iSIcgy05uOJyZ4oroqOzesz8nm2jH1eRPys2WLLFd801GKOZZE2LvNhCVzNIE0s1
|
||||
Rr8yyWBU9jbjQuxlTAtyMUKKOqG9qsfEnKOsl9T9/pFcpJjad3spwhQSWhWEPWca
|
||||
avw0CGVaGQ3nYmr9aJ9vpGBIiIsLQOPTzpOOPCDauMFpAPOoKnvIu+iz3Z8sUrMu
|
||||
Ld+aT/3yxpAtNkmVv5A951XyFt9WDXF7jZOMHdOSZPvvI/Yn7joJUzfP9d7TLKjz
|
||||
Xu+dzQnrAN3xuAXuy+jBpMIl3OPzwER6a8v7gUKRA/achNlIeOOmBdNn1cyHddcn
|
||||
k6wiaXHJlFsl8X6IjCs9ILwv6H+ZGq/5QNU1Nrv5kQIDAQABMA0GCSqGSIb3DQEB
|
||||
CwUAA4ICAQCo3xjINrsIQYvpVwVLpcO1p+oE5NV0ipA30JT+89Dn+vCejel9NzxT
|
||||
msuD9aQSiNaB4znlIDqux4bSKkcRXDGINiaGNIDNXOtO/787LXjUZlljPVVHoPWi
|
||||
hxgwc0nUHz3l/YvoXMKHI8blPkIhXl7xgKSuKQu05evjd//kpdHs1h+7b2vtCB0/
|
||||
VoYTX/NrIX5oMYCvHkZEypQbDJ3VeAkOhRJ4efGEuEskPRm0+eDSL7elas/65saZ
|
||||
l8vgkKDHZ9K0pd8JXc7EKmg3OBS22C5Lfhhy8AgqMa6R9p54oE4rH4yFaTe3BzFL
|
||||
xSA6HWqC987L2OCFr2LJ8hZpawDF1otukGHDou/5+4Q03EZz10RuZfzlCLO5DXzW
|
||||
Q28AtcCxz40n9o1giWzEj4LSYW4qsrpr5cNIhCqMzGPwp2OyS/TazPNJGoT8WKFU
|
||||
Kr+Y/prfkXAwgVkXlUSiu7ukiYslSM4BbYWHDxd75Iv4GzzhUirSuJKN95RglxR8
|
||||
XsJFlQwZ/tLvpflqb1Z8gPIV/4avtF+ybdx1AvqYViBQDf6GmLkM3p6Nwfj1LnCn
|
||||
kFhnqY80gyVjbZXvp9ClypExzgz55/o2ZIijznCaDkFSVBdv+aUIzl98IicZxHqP
|
||||
WREB+GMKmkaYrfKqlliQKdkXd2mXP/N8rv7SJEzHHpGRKBXsIAalrA==
|
||||
-----END CERTIFICATE-----
|
||||
52
database/perl/vendor/lib/Mojo/IOLoop/resources/server.key
vendored
Normal file
52
database/perl/vendor/lib/Mojo/IOLoop/resources/server.key
vendored
Normal file
@@ -0,0 +1,52 @@
|
||||
-----BEGIN PRIVATE KEY-----
|
||||
MIIJQgIBADANBgkqhkiG9w0BAQEFAASCCSwwggkoAgEAAoICAQC2lW4DOBswU1YJ
|
||||
kekNF6c4b1VVcpOvtqsLHhTxUz538bffcvhI2vv+aCltG6g5mlvJwo5NEu9l0ZG5
|
||||
TD9Ca4+WOOisVWrAI/i2YxXFQLOdjhKRBB1BvrOxSaFOuCXz9+cjVRo0R8Dq3k+1
|
||||
aSy93Yf+fq9pL7LFJaUOlxcU2FOM+HW9FYPeVbqCzYqpPJoaBnwNtQkQg7i8ufbe
|
||||
MS0bCcFpfTSV4pCgpWg1L9z6cVmBHtxc4MQv7rTTal+BF/iZDfDkqTNFJpuK7IGt
|
||||
SVB5laTcssYKGuY5QhN5BBPoGEMP3f0KiZmgMOUqwR6fMUiidacGiSIcgy05uOJy
|
||||
Z4oroqOzesz8nm2jH1eRPys2WLLFd801GKOZZE2LvNhCVzNIE0s1Rr8yyWBU9jbj
|
||||
QuxlTAtyMUKKOqG9qsfEnKOsl9T9/pFcpJjad3spwhQSWhWEPWcaavw0CGVaGQ3n
|
||||
Ymr9aJ9vpGBIiIsLQOPTzpOOPCDauMFpAPOoKnvIu+iz3Z8sUrMuLd+aT/3yxpAt
|
||||
NkmVv5A951XyFt9WDXF7jZOMHdOSZPvvI/Yn7joJUzfP9d7TLKjzXu+dzQnrAN3x
|
||||
uAXuy+jBpMIl3OPzwER6a8v7gUKRA/achNlIeOOmBdNn1cyHddcnk6wiaXHJlFsl
|
||||
8X6IjCs9ILwv6H+ZGq/5QNU1Nrv5kQIDAQABAoICAAINoiQVIHElrsUCyA0mo/HF
|
||||
hr8kP7btJfVFDFU+a2hr5nZz04j2NXlB8J1Sf0zOiJO3RWRmfxy1A5+C1P9JOF8n
|
||||
Gq69cyrf/K8IZDlIpfxymZDZ6/5OR7UJr++zsHGS6x2Bmn7WA7xgbaMLoL4t3Jan
|
||||
FA/pwmfnKXkFh/PrDt15+dD7ifUZH7TS3OlUTiNWyVRaIdT2tkAhEz6ibPBt5qfq
|
||||
CYpZ9uhnk8ltVV3XonsKPs4olOw5Ef2Cp7pK67fE6V2Y7YOskHk6eabaOTZ00VrO
|
||||
A94fOVGRhaiJvDOS+kYWZ/8TVw/vHNSjQVXm9vskuZEgP6r0arDIfHtu4KXm+VJJ
|
||||
f6v8VLHdP7EU9ce2COc77iWMpUZrLBGRo0K1aZAVknzIKrt5aiRcG5e/PzPtxh6h
|
||||
eTMHlMak9XLnENDRsbJEMedxLb2VOmqiJOikOPy9U33nt403oi2h2eOZ6+wh+IMK
|
||||
d8EJH7cxbeiq/Aelp3IvwOagCiFpOatYL29zhUC/fufR8/y82Xz1TWlJ/mwZbPqo
|
||||
6R/LPrEBafAilBApzpRvcxs+zofe2FhnSRbk+Hozu5XfmECdivoavr2SZhtDLfrK
|
||||
LaHTUPxVbK4BOSTqoXsUtnUSpiP5F1IYzu59cm4S85KBB95KJuAGAaykeuWRjGXX
|
||||
7kQ4T6vWn9JAdj3QZqVBAoIBAQDt/q3VvuinB2xjJZae2B0XYBXKgGl1svLPjP3w
|
||||
tfQmi+tefjZ+GY8V4L05GraBMi/qcaQmy4wipVdVu7isXF3GancMsCu549ZZSAJO
|
||||
DOv+u6oq0kd4mkiQ1/LUUoTNwwjKpcH6fEsXJHXKdnhUGE15hm+YGh3YrDo6xmpC
|
||||
HoXk9qefDy7xL4mTJAfdr/KGIc1BpXic3VF+S0ewHom1L+dhkdRpew0oeeVTZ10O
|
||||
9NQP4SqI2jIiNTLDSZ37FFJXD3dIxJ1niX3hRlSAKAIRvhzcs9581ea30F2BenhT
|
||||
EuSM89kXJPub/dVG/WWuC5VQBCHmvVtGUWv8u0lacc3Ge4PZAoIBAQDEZZX9l2NN
|
||||
viPwN2joiJa4LLH1+HC7X6MaKXQZ+jPr2ptO5F3ZekJ9W2jJOoXQCso7wnuEGYB5
|
||||
KnbS/NWF3V9NSAWFb4nukXgIvTNudrgXr4bBkXVa26YwfxcCRv9qWtWp3W76K9F6
|
||||
/jRe4MYf7NGbP7SndViGO7u2AhwejsxgqET1AM8eHrdtpkvC/aSqpEAOUWbwSXxc
|
||||
G5dgVzoH0RZV5YVldPbdS7DOUZoh1co92lTB5LfPGOxwsb364nH61+lkhxWAiMe0
|
||||
Q3hG8WLDF3wTRkpTUKAyjuBEE7Ve+bdFaC9cyhRiwgxPjie4qtt100IEHgpF0mw7
|
||||
mWBB6x+pDuh5AoIBAQCs/eMzrAoGZxH023ypR2OV+yS7xi1h/UobbVukXU3zut7C
|
||||
F7HaZQ+pkmtYl78zF9zWZ/YusOPSxyY9Ti9FMfqD4B1a3q9Z9m93BC2QuDnONnDR
|
||||
oXmMA3Fdv2plxPl9axf33Rar0S7vynPIT+bVEbk27W4uPEWXmlDVKiZQm0kuDc/3
|
||||
gRzY+Xnht130WRFLSESfQ/zw4Lp8t5GLRhdI2WIxfMPOTEBbPIdh4Y818OY4CK5X
|
||||
PWsVjF+yrc8kkzfqynYlMa1MdhdG6U1AvlQKu4rVLfU5/m0vDUj6daACmogAoLsa
|
||||
5KnzUEV3zXbcVNUajXZq9xbifQqmcSg3kuNFM8C5AoIBAHRKirPsLlrcWb9lr/Lw
|
||||
3f4USRQSlf39NUDKhvrS0me3u/rM8l1SLYi41aVBx/ZWTUVxdV3VE+OrJ0zrdSuc
|
||||
10+Vc999GjlvXZofHhMsrPkpcCuyC8FPCmrw9hjdHWRGgPniKlJsG9AuMah0hBxn
|
||||
R/4bjMcTjuV8/TtaqHfXqmEZgito3TtCiO6eZ4IAWr7IHz3bKY7ilIadt9bOD4iN
|
||||
YCJgk8ptpbeHmBuy6gda5jQV0dY1rjks0uQv+wRRjZgwvPxPmIXReB7fTJsFV6uZ
|
||||
fliTaHNI7HLDczwcR2sDhmfMty7EYanQqSV6UT7hvK1Z+F8jwoVxgbEQspSVutuJ
|
||||
/lECggEAVdvU6sPQH2QNnN8mxYF5zqST8Fzsi9+O6iQe/aymDKZoHa8/9O/BOx39
|
||||
JSasQCnOt1yhRZwo50WhSUquJ1R0KUiybDyv1jvff7R+i3pl98Czjfc3iZuEDHGI
|
||||
anD3qC9DrbsqotIsnjpxULJ3Hotohhy5NQtoQLsucNzZRWquQGE0sUGes6IIeEJR
|
||||
1NWA6VnGdVrlltm3fkkJMwdn1pbEWXXI3VutEIn9NJfvuVDzPb1f5ih1ChLm5ijf
|
||||
nK13sEavqpo7L8cpeaPeNLY2Tt4mVXw6Ujq1fLM/7VOvmNTQMu3lVXQve32w+gm0
|
||||
0N/URKPaZ8Z9V/c15kNhIZBgJhOoVg==
|
||||
-----END PRIVATE KEY-----
|
||||
377
database/perl/vendor/lib/Mojo/JSON.pm
vendored
Normal file
377
database/perl/vendor/lib/Mojo/JSON.pm
vendored
Normal file
@@ -0,0 +1,377 @@
|
||||
package Mojo::JSON;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Exporter qw(import);
|
||||
use JSON::PP ();
|
||||
use Mojo::Util qw(decode encode monkey_patch);
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
# For better performance Cpanel::JSON::XS is required
|
||||
use constant JSON_XS => $ENV{MOJO_NO_JSON_XS}
|
||||
? 0
|
||||
: eval { require Cpanel::JSON::XS; Cpanel::JSON::XS->VERSION('4.09'); 1 };
|
||||
|
||||
our @EXPORT_OK = qw(decode_json encode_json false from_json j to_json true);
|
||||
|
||||
# Escaped special character map
|
||||
my %ESCAPE
|
||||
= ('"' => '"', '\\' => '\\', '/' => '/', 'b' => "\x08", 'f' => "\x0c", 'n' => "\x0a", 'r' => "\x0d", 't' => "\x09");
|
||||
my %REVERSE = map { $ESCAPE{$_} => "\\$_" } keys %ESCAPE;
|
||||
for (0x00 .. 0x1f) { $REVERSE{pack 'C', $_} //= sprintf '\u%.4X', $_ }
|
||||
|
||||
# Replace pure-Perl fallbacks if Cpanel::JSON::XS is available
|
||||
if (JSON_XS) {
|
||||
my $BINARY = Cpanel::JSON::XS->new->utf8;
|
||||
my $TEXT = Cpanel::JSON::XS->new;
|
||||
$_->canonical->allow_nonref->allow_unknown->allow_blessed->convert_blessed->stringify_infnan->escape_slash
|
||||
->allow_dupkeys
|
||||
for $BINARY, $TEXT;
|
||||
monkey_patch __PACKAGE__, 'encode_json', sub { $BINARY->encode($_[0]) };
|
||||
monkey_patch __PACKAGE__, 'decode_json', sub { $BINARY->decode($_[0]) };
|
||||
monkey_patch __PACKAGE__, 'to_json', sub { $TEXT->encode($_[0]) };
|
||||
monkey_patch __PACKAGE__, 'from_json', sub { $TEXT->decode($_[0]) };
|
||||
}
|
||||
|
||||
sub decode_json {
|
||||
my $err = _decode(\my $value, shift);
|
||||
return defined $err ? croak $err : $value;
|
||||
}
|
||||
|
||||
sub encode_json { encode('UTF-8', _encode_value(shift)) }
|
||||
|
||||
sub false () {JSON::PP::false}
|
||||
|
||||
sub from_json {
|
||||
my $err = _decode(\my $value, shift, 1);
|
||||
return defined $err ? croak $err : $value;
|
||||
}
|
||||
|
||||
sub j {
|
||||
return encode_json($_[0]) if ref $_[0] eq 'ARRAY' || ref $_[0] eq 'HASH';
|
||||
return eval { decode_json($_[0]) };
|
||||
}
|
||||
|
||||
sub to_json { _encode_value(shift) }
|
||||
|
||||
sub true () {JSON::PP::true}
|
||||
|
||||
sub _decode {
|
||||
my $valueref = shift;
|
||||
|
||||
eval {
|
||||
|
||||
# Missing input
|
||||
die "Missing or empty input at offset 0\n" unless length(local $_ = shift);
|
||||
|
||||
# UTF-8
|
||||
$_ = decode('UTF-8', $_) unless shift;
|
||||
die "Input is not UTF-8 encoded\n" unless defined;
|
||||
|
||||
# Value
|
||||
$$valueref = _decode_value();
|
||||
|
||||
# Leftover data
|
||||
/\G[\x20\x09\x0a\x0d]*\z/gc or _throw('Unexpected data');
|
||||
} ? return undef : chomp $@;
|
||||
|
||||
return $@;
|
||||
}
|
||||
|
||||
sub _decode_array {
|
||||
my @array;
|
||||
until (m/\G[\x20\x09\x0a\x0d]*\]/gc) {
|
||||
|
||||
# Value
|
||||
push @array, _decode_value();
|
||||
|
||||
# Separator
|
||||
redo if /\G[\x20\x09\x0a\x0d]*,/gc;
|
||||
|
||||
# End
|
||||
last if /\G[\x20\x09\x0a\x0d]*\]/gc;
|
||||
|
||||
# Invalid character
|
||||
_throw('Expected comma or right square bracket while parsing array');
|
||||
}
|
||||
|
||||
return \@array;
|
||||
}
|
||||
|
||||
sub _decode_object {
|
||||
my %hash;
|
||||
until (m/\G[\x20\x09\x0a\x0d]*\}/gc) {
|
||||
|
||||
# Quote
|
||||
/\G[\x20\x09\x0a\x0d]*"/gc or _throw('Expected string while parsing object');
|
||||
|
||||
# Key
|
||||
my $key = _decode_string();
|
||||
|
||||
# Colon
|
||||
/\G[\x20\x09\x0a\x0d]*:/gc or _throw('Expected colon while parsing object');
|
||||
|
||||
# Value
|
||||
$hash{$key} = _decode_value();
|
||||
|
||||
# Separator
|
||||
redo if /\G[\x20\x09\x0a\x0d]*,/gc;
|
||||
|
||||
# End
|
||||
last if /\G[\x20\x09\x0a\x0d]*\}/gc;
|
||||
|
||||
# Invalid character
|
||||
_throw('Expected comma or right curly bracket while parsing object');
|
||||
}
|
||||
|
||||
return \%hash;
|
||||
}
|
||||
|
||||
sub _decode_string {
|
||||
my $pos = pos;
|
||||
|
||||
# Extract string with escaped characters
|
||||
m!\G((?:(?:[^\x00-\x1f\\"]|\\(?:["\\/bfnrt]|u[0-9a-fA-F]{4})){0,32766})*)!gc;
|
||||
my $str = $1;
|
||||
|
||||
# Invalid character
|
||||
unless (m/\G"/gc) {
|
||||
_throw('Unexpected character or invalid escape while parsing string') if /\G[\x00-\x1f\\]/;
|
||||
_throw('Unterminated string');
|
||||
}
|
||||
|
||||
# Unescape popular characters
|
||||
if (index($str, '\\u') < 0) {
|
||||
$str =~ s!\\(["\\/bfnrt])!$ESCAPE{$1}!gs;
|
||||
return $str;
|
||||
}
|
||||
|
||||
# Unescape everything else
|
||||
my $buffer = '';
|
||||
while ($str =~ /\G([^\\]*)\\(?:([^u])|u(.{4}))/gc) {
|
||||
$buffer .= $1;
|
||||
|
||||
# Popular character
|
||||
if ($2) { $buffer .= $ESCAPE{$2} }
|
||||
|
||||
# Escaped
|
||||
else {
|
||||
my $ord = hex $3;
|
||||
|
||||
# Surrogate pair
|
||||
if (($ord & 0xf800) == 0xd800) {
|
||||
|
||||
# High surrogate
|
||||
($ord & 0xfc00) == 0xd800 or pos = $pos + pos($str), _throw('Missing high-surrogate');
|
||||
|
||||
# Low surrogate
|
||||
$str =~ /\G\\u([Dd][C-Fc-f]..)/gc or pos = $pos + pos($str), _throw('Missing low-surrogate');
|
||||
|
||||
$ord = 0x10000 + ($ord - 0xd800) * 0x400 + (hex($1) - 0xdc00);
|
||||
}
|
||||
|
||||
# Character
|
||||
$buffer .= pack 'U', $ord;
|
||||
}
|
||||
}
|
||||
|
||||
# The rest
|
||||
return $buffer . substr $str, pos($str), length($str);
|
||||
}
|
||||
|
||||
sub _decode_value {
|
||||
|
||||
# Leading whitespace
|
||||
/\G[\x20\x09\x0a\x0d]*/gc;
|
||||
|
||||
# String
|
||||
return _decode_string() if /\G"/gc;
|
||||
|
||||
# Object
|
||||
return _decode_object() if /\G\{/gc;
|
||||
|
||||
# Array
|
||||
return _decode_array() if /\G\[/gc;
|
||||
|
||||
# Number
|
||||
return 0 + $1 if /\G([-]?(?:0|[1-9][0-9]*)(?:\.[0-9]*)?(?:[eE][+-]?[0-9]+)?)/gc;
|
||||
|
||||
# True
|
||||
return true() if /\Gtrue/gc;
|
||||
|
||||
# False
|
||||
return false() if /\Gfalse/gc;
|
||||
|
||||
# Null
|
||||
return undef if /\Gnull/gc;
|
||||
|
||||
# Invalid character
|
||||
_throw('Expected string, array, object, number, boolean or null');
|
||||
}
|
||||
|
||||
sub _encode_array {
|
||||
'[' . join(',', map { _encode_value($_) } @{$_[0]}) . ']';
|
||||
}
|
||||
|
||||
sub _encode_object {
|
||||
my $object = shift;
|
||||
my @pairs = map { _encode_string($_) . ':' . _encode_value($object->{$_}) } sort keys %$object;
|
||||
return '{' . join(',', @pairs) . '}';
|
||||
}
|
||||
|
||||
sub _encode_string {
|
||||
my $str = shift;
|
||||
$str =~ s!([\x00-\x1f\\"/])!$REVERSE{$1}!gs;
|
||||
return "\"$str\"";
|
||||
}
|
||||
|
||||
sub _encode_value {
|
||||
my $value = shift;
|
||||
|
||||
# Reference
|
||||
if (my $ref = ref $value) {
|
||||
|
||||
# Object
|
||||
return _encode_object($value) if $ref eq 'HASH';
|
||||
|
||||
# Array
|
||||
return _encode_array($value) if $ref eq 'ARRAY';
|
||||
|
||||
# True or false
|
||||
return $$value ? 'true' : 'false' if $ref eq 'SCALAR';
|
||||
return $value ? 'true' : 'false' if $ref eq 'JSON::PP::Boolean';
|
||||
|
||||
# Everything else
|
||||
return 'null' unless blessed $value;
|
||||
return _encode_string($value) unless my $sub = $value->can('TO_JSON');
|
||||
return _encode_value($value->$sub);
|
||||
}
|
||||
|
||||
# Null
|
||||
return 'null' unless defined $value;
|
||||
|
||||
# Number
|
||||
no warnings 'numeric';
|
||||
return $value
|
||||
if !utf8::is_utf8($value) && length((my $dummy = '') & $value) && 0 + $value eq $value && $value * 0 == 0;
|
||||
|
||||
# String
|
||||
return _encode_string($value);
|
||||
}
|
||||
|
||||
sub _throw {
|
||||
|
||||
# Leading whitespace
|
||||
/\G[\x20\x09\x0a\x0d]*/gc;
|
||||
|
||||
# Context
|
||||
my $context = 'Malformed JSON: ' . shift;
|
||||
if (m/\G\z/gc) { $context .= ' before end of data' }
|
||||
else {
|
||||
my @lines = split /\n/, substr($_, 0, pos);
|
||||
$context .= ' at line ' . @lines . ', offset ' . length(pop @lines || '');
|
||||
}
|
||||
|
||||
die "$context\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::JSON - Minimalistic JSON
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::JSON qw(decode_json encode_json);
|
||||
|
||||
my $bytes = encode_json {foo => [1, 2], bar => 'hello!', baz => \1};
|
||||
my $hash = decode_json $bytes;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::JSON> is a minimalistic and possibly the fastest pure-Perl implementation of L<RFC
|
||||
8259|https://tools.ietf.org/html/rfc8259>.
|
||||
|
||||
It supports normal Perl data types like scalar, array reference, hash reference and will try to call the C<TO_JSON>
|
||||
method on blessed references, or stringify them if it doesn't exist. Differentiating between strings and numbers in
|
||||
Perl is hard, depending on how it has been used, a scalar can be both at the same time. The string value has a higher
|
||||
precedence unless both representations are equivalent.
|
||||
|
||||
[1, -2, 3] -> [1, -2, 3]
|
||||
{"foo": "bar"} -> {foo => 'bar'}
|
||||
|
||||
Literal names will be translated to and from L<Mojo::JSON> constants or a similar native Perl value.
|
||||
|
||||
true -> Mojo::JSON->true
|
||||
false -> Mojo::JSON->false
|
||||
null -> undef
|
||||
|
||||
In addition scalar references will be used to generate booleans, based on if their values are true or false.
|
||||
|
||||
\1 -> true
|
||||
\0 -> false
|
||||
|
||||
The character C</> will always be escaped to prevent XSS attacks.
|
||||
|
||||
"</script>" -> "<\/script>"
|
||||
|
||||
For better performance the optional module L<Cpanel::JSON::XS> (4.09+) will be used automatically if possible. This can
|
||||
also be disabled with the C<MOJO_NO_JSON_XS> environment variable.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::JSON> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 decode_json
|
||||
|
||||
my $value = decode_json $bytes;
|
||||
|
||||
Decode JSON to Perl value and die if decoding fails.
|
||||
|
||||
=head2 encode_json
|
||||
|
||||
my $bytes = encode_json {i => '♥ mojolicious'};
|
||||
|
||||
Encode Perl value to JSON.
|
||||
|
||||
=head2 false
|
||||
|
||||
my $false = false;
|
||||
|
||||
False value, used because Perl has no native equivalent.
|
||||
|
||||
=head2 from_json
|
||||
|
||||
my $value = from_json $chars;
|
||||
|
||||
Decode JSON text that is not C<UTF-8> encoded to Perl value and die if decoding fails.
|
||||
|
||||
=head2 j
|
||||
|
||||
my $bytes = j [1, 2, 3];
|
||||
my $bytes = j {i => '♥ mojolicious'};
|
||||
my $value = j $bytes;
|
||||
|
||||
Encode Perl data structure (which may only be an array reference or hash reference) or decode JSON, an C<undef> return
|
||||
value indicates a bare C<null> or that decoding failed.
|
||||
|
||||
=head2 to_json
|
||||
|
||||
my $chars = to_json {i => '♥ mojolicious'};
|
||||
|
||||
Encode Perl value to JSON text without C<UTF-8> encoding it.
|
||||
|
||||
=head2 true
|
||||
|
||||
my $true = true;
|
||||
|
||||
True value, used because Perl has no native equivalent.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
117
database/perl/vendor/lib/Mojo/JSON/Pointer.pm
vendored
Normal file
117
database/perl/vendor/lib/Mojo/JSON/Pointer.pm
vendored
Normal file
@@ -0,0 +1,117 @@
|
||||
package Mojo::JSON::Pointer;
|
||||
use Mojo::Base -base;
|
||||
|
||||
has 'data';
|
||||
|
||||
sub contains { shift->_pointer(0, @_) }
|
||||
sub get { shift->_pointer(1, @_) }
|
||||
|
||||
sub new { @_ > 1 ? shift->SUPER::new(data => shift) : shift->SUPER::new }
|
||||
|
||||
sub _pointer {
|
||||
my ($self, $get, $pointer) = @_;
|
||||
|
||||
my $data = $self->data;
|
||||
return length $pointer ? undef : $get ? $data : 1 unless $pointer =~ s!^/!!;
|
||||
for my $p (length $pointer ? (split /\//, $pointer, -1) : ($pointer)) {
|
||||
$p =~ s!~1!/!g;
|
||||
$p =~ s/~0/~/g;
|
||||
|
||||
# Hash
|
||||
if (ref $data eq 'HASH' && exists $data->{$p}) { $data = $data->{$p} }
|
||||
|
||||
# Array
|
||||
elsif (ref $data eq 'ARRAY' && $p =~ /^\d+$/ && @$data > $p) { $data = $data->[$p] }
|
||||
|
||||
# Nothing
|
||||
else { return undef }
|
||||
}
|
||||
|
||||
return $get ? $data : 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::JSON::Pointer - JSON Pointers
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::JSON::Pointer;
|
||||
|
||||
my $pointer = Mojo::JSON::Pointer->new({foo => [23, 'bar']});
|
||||
say $pointer->get('/foo/1');
|
||||
say 'Contains "/foo".' if $pointer->contains('/foo');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::JSON::Pointer> is an implementation of L<RFC 6901|https://tools.ietf.org/html/rfc6901>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::JSON::Pointer> implements the following attributes.
|
||||
|
||||
=head2 data
|
||||
|
||||
my $data = $pointer->data;
|
||||
$pointer = $pointer->data({foo => 'bar'});
|
||||
|
||||
Data structure to be processed.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::JSON::Pointer> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 contains
|
||||
|
||||
my $bool = $pointer->contains('/foo/1');
|
||||
|
||||
Check if L</"data"> contains a value that can be identified with the given JSON Pointer.
|
||||
|
||||
# True
|
||||
Mojo::JSON::Pointer->new('just a string')->contains('');
|
||||
Mojo::JSON::Pointer->new({'♥' => 'mojolicious'})->contains('/♥');
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5]})->contains('/foo');
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5]})->contains('/baz/1');
|
||||
|
||||
# False
|
||||
Mojo::JSON::Pointer->new({'♥' => 'mojolicious'})->contains('/☃');
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5]})->contains('/bar');
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5]})->contains('/baz/9');
|
||||
|
||||
=head2 get
|
||||
|
||||
my $value = $pointer->get('/foo/bar');
|
||||
|
||||
Extract value from L</"data"> identified by the given JSON Pointer.
|
||||
|
||||
# "just a string"
|
||||
Mojo::JSON::Pointer->new('just a string')->get('');
|
||||
|
||||
# "mojolicious"
|
||||
Mojo::JSON::Pointer->new({'♥' => 'mojolicious'})->get('/♥');
|
||||
|
||||
# "bar"
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5, 6]})->get('/foo');
|
||||
|
||||
# "4"
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5, 6]})->get('/baz/0');
|
||||
|
||||
# "6"
|
||||
Mojo::JSON::Pointer->new({foo => 'bar', baz => [4, 5, 6]})->get('/baz/2');
|
||||
|
||||
=head2 new
|
||||
|
||||
my $pointer = Mojo::JSON::Pointer->new;
|
||||
my $pointer = Mojo::JSON::Pointer->new({foo => 'bar'});
|
||||
|
||||
Build new L<Mojo::JSON::Pointer> object.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
213
database/perl/vendor/lib/Mojo/Loader.pm
vendored
Normal file
213
database/perl/vendor/lib/Mojo/Loader.pm
vendored
Normal file
@@ -0,0 +1,213 @@
|
||||
package Mojo::Loader;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use Exporter qw(import);
|
||||
use Mojo::Exception;
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::Util qw(b64_decode class_to_path);
|
||||
|
||||
our @EXPORT_OK = qw(data_section file_is_binary find_modules find_packages load_class load_classes);
|
||||
|
||||
my (%BIN, %CACHE);
|
||||
|
||||
sub data_section { $_[0] ? $_[1] ? _all($_[0])->{$_[1]} : _all($_[0]) : undef }
|
||||
|
||||
sub file_is_binary { keys %{_all($_[0])} ? !!$BIN{$_[0]}{$_[1]} : undef }
|
||||
|
||||
sub find_modules {
|
||||
my ($ns, $options) = (shift, shift // {});
|
||||
|
||||
my @ns = split /::/, $ns;
|
||||
my @inc = grep { -d $$_ } map { path($_, @ns) } @INC;
|
||||
|
||||
my %modules;
|
||||
for my $dir (@inc) {
|
||||
for my $file ($options->{recursive} ? $dir->list_tree->each : $dir->list->each) {
|
||||
next unless $$file =~ s/\.pm$//;
|
||||
$modules{join('::', $ns, @{$file->to_rel($$dir)})}++;
|
||||
}
|
||||
}
|
||||
|
||||
return sort keys %modules;
|
||||
}
|
||||
|
||||
sub find_packages {
|
||||
my $ns = shift;
|
||||
no strict 'refs';
|
||||
return sort map { /^(.+)::$/ ? "${ns}::$1" : () } keys %{"${ns}::"};
|
||||
}
|
||||
|
||||
sub load_class {
|
||||
my $class = shift;
|
||||
|
||||
# Invalid class name
|
||||
return 1 if ($class || '') !~ /^\w(?:[\w:']*\w)?$/;
|
||||
|
||||
# Load if not already loaded
|
||||
return undef if $class->can('new') || eval "require $class; 1";
|
||||
|
||||
# Does not exist
|
||||
return 1 if $@ =~ /^Can't locate \Q@{[class_to_path $class]}\E in \@INC/;
|
||||
|
||||
# Real error
|
||||
return Mojo::Exception->new($@)->inspect;
|
||||
}
|
||||
|
||||
sub load_classes {
|
||||
my $ns = shift;
|
||||
|
||||
my @classes;
|
||||
for my $module (find_modules($ns, {recursive => 1})) {
|
||||
push @classes, $module unless my $e = load_class($module);
|
||||
die $e if ref $e;
|
||||
}
|
||||
|
||||
return @classes;
|
||||
}
|
||||
|
||||
sub _all {
|
||||
my $class = shift;
|
||||
|
||||
return $CACHE{$class} if $CACHE{$class};
|
||||
local $.;
|
||||
my $handle = do { no strict 'refs'; \*{"${class}::DATA"} };
|
||||
return {} unless fileno $handle;
|
||||
seek $handle, 0, 0;
|
||||
my $data = join '', <$handle>;
|
||||
|
||||
# Ignore everything before __DATA__ (some versions seek to start of file)
|
||||
$data =~ s/^.*\n__DATA__\r?\n/\n/s;
|
||||
|
||||
# Ignore everything after __END__
|
||||
$data =~ s/\n__END__\r?\n.*$/\n/s;
|
||||
|
||||
# Split files
|
||||
(undef, my @files) = split /^@@\s*(.+?)\s*\r?\n/m, $data;
|
||||
|
||||
# Find data
|
||||
my $all = $CACHE{$class} = {};
|
||||
while (@files) {
|
||||
my ($name, $data) = splice @files, 0, 2;
|
||||
$all->{$name} = $name =~ s/\s*\(\s*base64\s*\)$// && ++$BIN{$class}{$name} ? b64_decode $data : $data;
|
||||
}
|
||||
|
||||
return $all;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Loader - Load all kinds of things
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Loader qw(data_section find_modules load_class);
|
||||
|
||||
# Find modules in a namespace
|
||||
for my $module (find_modules 'Some::Namespace') {
|
||||
|
||||
# Load them safely
|
||||
my $e = load_class $module;
|
||||
warn qq{Loading "$module" failed: $e} and next if ref $e;
|
||||
|
||||
# And extract files from the DATA section
|
||||
say data_section($module, 'some_file.txt');
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Loader> is a class loader and plugin framework. Aside from finding modules and loading classes, it allows
|
||||
multiple files to be stored in the C<DATA> section of a class, which can then be accessed individually.
|
||||
|
||||
package Foo;
|
||||
|
||||
1;
|
||||
__DATA__
|
||||
|
||||
@@ test.txt
|
||||
This is the first file.
|
||||
|
||||
@@ test2.html (base64)
|
||||
VGhpcyBpcyB0aGUgc2Vjb25kIGZpbGUu
|
||||
|
||||
@@ test
|
||||
This is the
|
||||
third file.
|
||||
|
||||
Each file has a header starting with C<@@>, followed by the file name and optional instructions for decoding its
|
||||
content. Currently only the Base64 encoding is supported, which can be quite convenient for the storage of binary data.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::Loader> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 data_section
|
||||
|
||||
my $all = data_section 'Foo::Bar';
|
||||
my $index = data_section 'Foo::Bar', 'index.html';
|
||||
|
||||
Extract embedded file from the C<DATA> section of a class, all files will be cached once they have been accessed for
|
||||
the first time.
|
||||
|
||||
# List embedded files
|
||||
say for keys %{data_section 'Foo::Bar'};
|
||||
|
||||
=head2 file_is_binary
|
||||
|
||||
my $bool = file_is_binary 'Foo::Bar', 'test.png';
|
||||
|
||||
Check if embedded file from the C<DATA> section of a class was Base64 encoded.
|
||||
|
||||
=head2 find_packages
|
||||
|
||||
my @pkgs = find_packages 'MyApp::Namespace';
|
||||
|
||||
Search for packages in a namespace non-recursively.
|
||||
|
||||
=head2 find_modules
|
||||
|
||||
my @modules = find_modules 'MyApp::Namespace';
|
||||
my @modules = find_modules 'MyApp::Namespace', {recursive => 1};
|
||||
|
||||
Search for modules in a namespace.
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item recursive
|
||||
|
||||
recursive => 1
|
||||
|
||||
Search namespace recursively.
|
||||
|
||||
=back
|
||||
|
||||
=head2 load_class
|
||||
|
||||
my $e = load_class 'Foo::Bar';
|
||||
|
||||
Load a class and catch exceptions, returns a false value if loading was successful, a true value if the class was not
|
||||
found, or a L<Mojo::Exception> object if loading failed. Note that classes are checked for a C<new> method to see if
|
||||
they are already loaded, so trying to load the same class multiple times may yield different results.
|
||||
|
||||
# Handle exceptions
|
||||
if (my $e = load_class 'Foo::Bar') {
|
||||
die ref $e ? "Exception: $e" : 'Not found!';
|
||||
}
|
||||
|
||||
=head2 load_classes
|
||||
|
||||
my @classes = load_classes 'Foo::Bar';
|
||||
|
||||
Load all classes in a namespace recursively. Note that this function is B<EXPERIMENTAL> and might change without
|
||||
warning!
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
276
database/perl/vendor/lib/Mojo/Log.pm
vendored
Normal file
276
database/perl/vendor/lib/Mojo/Log.pm
vendored
Normal file
@@ -0,0 +1,276 @@
|
||||
package Mojo::Log;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Fcntl qw(:flock);
|
||||
use Mojo::File;
|
||||
use Mojo::Util qw(encode);
|
||||
use Time::HiRes qw(time);
|
||||
|
||||
has format => sub { shift->short ? \&_short : \&_default };
|
||||
has handle => sub {
|
||||
|
||||
# STDERR
|
||||
return \*STDERR unless my $path = shift->path;
|
||||
|
||||
# File
|
||||
return Mojo::File->new($path)->open('>>');
|
||||
};
|
||||
has history => sub { [] };
|
||||
has level => 'debug';
|
||||
has max_history_size => 10;
|
||||
has 'path';
|
||||
has short => sub { $ENV{MOJO_LOG_SHORT} };
|
||||
|
||||
# Supported log levels
|
||||
my %LEVEL = (debug => 1, info => 2, warn => 3, error => 4, fatal => 5);
|
||||
|
||||
# Systemd magic numbers
|
||||
my %MAGIC = (debug => 7, info => 6, warn => 4, error => 3, fatal => 2);
|
||||
|
||||
sub append {
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
return unless my $handle = $self->handle;
|
||||
flock $handle, LOCK_EX;
|
||||
$handle->print(encode('UTF-8', $msg)) or croak "Can't write to log: $!";
|
||||
flock $handle, LOCK_UN;
|
||||
}
|
||||
|
||||
sub debug { 1 >= $LEVEL{$_[0]->level} ? _log(@_, 'debug') : $_[0] }
|
||||
|
||||
sub context { $_[0]->new(parent => $_[0], context => $_[1], level => $_[0]->level) }
|
||||
|
||||
sub error { 4 >= $LEVEL{$_[0]->level} ? _log(@_, 'error') : $_[0] }
|
||||
sub fatal { 5 >= $LEVEL{$_[0]->level} ? _log(@_, 'fatal') : $_[0] }
|
||||
sub info { 2 >= $LEVEL{$_[0]->level} ? _log(@_, 'info') : $_[0] }
|
||||
|
||||
sub is_level { $LEVEL{pop()} >= $LEVEL{shift->level} }
|
||||
|
||||
sub new {
|
||||
my $self = shift->SUPER::new(@_);
|
||||
$self->on(message => \&_message);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub warn { 3 >= $LEVEL{$_[0]->level} ? _log(@_, 'warn') : $_[0] }
|
||||
|
||||
sub _default {
|
||||
my ($time, $level) = (shift, shift);
|
||||
my ($s, $m, $h, $day, $month, $year) = localtime $time;
|
||||
$time = sprintf '%04d-%02d-%02d %02d:%02d:%08.5f', $year + 1900, $month + 1, $day, $h, $m,
|
||||
"$s." . ((split /\./, $time)[1] // 0);
|
||||
return "[$time] [$$] [$level] " . join "\n", @_, '';
|
||||
}
|
||||
|
||||
sub _log {
|
||||
my ($self, $level) = (shift, pop);
|
||||
my @msgs = ref $_[0] eq 'CODE' ? $_[0]() : @_;
|
||||
$msgs[0] = "$self->{context} $msgs[0]" if $self->{context};
|
||||
($self->{parent} || $self)->emit('message', $level, @msgs);
|
||||
}
|
||||
|
||||
sub _message {
|
||||
my ($self, $level) = (shift, shift);
|
||||
|
||||
my $max = $self->max_history_size;
|
||||
my $history = $self->history;
|
||||
push @$history, my $msg = [time, $level, @_];
|
||||
shift @$history while @$history > $max;
|
||||
|
||||
$self->append($self->format->(@$msg));
|
||||
}
|
||||
|
||||
sub _short {
|
||||
my ($time, $level) = (shift, shift);
|
||||
my ($magic, $short) = ("<$MAGIC{$level}>", substr($level, 0, 1));
|
||||
return "${magic}[$$] [$short] " . join("\n$magic", @_) . "\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Log - Simple logger
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Log;
|
||||
|
||||
# Log to STDERR
|
||||
my $log = Mojo::Log->new;
|
||||
|
||||
# Customize log file location and minimum log level
|
||||
my $log = Mojo::Log->new(path => '/var/log/mojo.log', level => 'warn');
|
||||
|
||||
# Log messages
|
||||
$log->debug('Not sure what is happening here');
|
||||
$log->info('FYI: it happened again');
|
||||
$log->warn('This might be a problem');
|
||||
$log->error('Garden variety error');
|
||||
$log->fatal('Boom');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Log> is a simple logger for L<Mojo> projects.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Log> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 message
|
||||
|
||||
$log->on(message => sub ($log, $level, @lines) {...});
|
||||
|
||||
Emitted when a new message gets logged.
|
||||
|
||||
$log->on(message => sub ($log, $level, @lines) { say "$level: ", @lines });
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Log> implements the following attributes.
|
||||
|
||||
=head2 format
|
||||
|
||||
my $cb = $log->format;
|
||||
$log = $log->format(sub {...});
|
||||
|
||||
A callback for formatting log messages.
|
||||
|
||||
$log->format(sub ($time, $level, @lines) { "[2018-11-08 14:20:13.77168] [28320] [info] I ♥ Mojolicious\n" });
|
||||
|
||||
=head2 handle
|
||||
|
||||
my $handle = $log->handle;
|
||||
$log = $log->handle(IO::Handle->new);
|
||||
|
||||
Log filehandle used by default L</"message"> event, defaults to opening L</"path"> or C<STDERR>.
|
||||
|
||||
=head2 history
|
||||
|
||||
my $history = $log->history;
|
||||
$log = $log->history([[time, 'debug', 'That went wrong']]);
|
||||
|
||||
The last few logged messages.
|
||||
|
||||
=head2 level
|
||||
|
||||
my $level = $log->level;
|
||||
$log = $log->level('debug');
|
||||
|
||||
Active log level, defaults to C<debug>. Available log levels are C<debug>, C<info>, C<warn>, C<error> and C<fatal>, in
|
||||
that order.
|
||||
|
||||
=head2 max_history_size
|
||||
|
||||
my $size = $log->max_history_size;
|
||||
$log = $log->max_history_size(5);
|
||||
|
||||
Maximum number of logged messages to store in L</"history">, defaults to C<10>.
|
||||
|
||||
=head2 path
|
||||
|
||||
my $path = $log->path
|
||||
$log = $log->path('/var/log/mojo.log');
|
||||
|
||||
Log file path used by L</"handle">.
|
||||
|
||||
=head2 short
|
||||
|
||||
my $bool = $log->short;
|
||||
$log = $log->short($bool);
|
||||
|
||||
Generate short log messages without a timestamp, suitable for systemd, defaults to the value of the C<MOJO_LOG_SHORT>
|
||||
environment variables.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Log> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 append
|
||||
|
||||
$log->append("[2018-11-08 14:20:13.77168] [28320] [info] I ♥ Mojolicious\n");
|
||||
|
||||
Append message to L</"handle">.
|
||||
|
||||
=head2 context
|
||||
|
||||
my $new = $log->context('[extra] [information]');
|
||||
|
||||
Construct a new child L<Mojo::Log> object that will include context information with every log message.
|
||||
|
||||
# Log with context
|
||||
my $log = Mojo::Log->new;
|
||||
my $context = $log->context('[17a60115]');
|
||||
$context->debug('This is a log message with context information');
|
||||
$context->info('And another');
|
||||
|
||||
=head2 debug
|
||||
|
||||
$log = $log->debug('You screwed up, but that is ok');
|
||||
$log = $log->debug('All', 'cool');
|
||||
$log = $log->debug(sub {...});
|
||||
|
||||
Emit L</"message"> event and log C<debug> message.
|
||||
|
||||
=head2 error
|
||||
|
||||
$log = $log->error('You really screwed up this time');
|
||||
$log = $log->error('Wow', 'seriously');
|
||||
$log = $log->error(sub {...});
|
||||
|
||||
Emit L</"message"> event and log C<error> message.
|
||||
|
||||
=head2 fatal
|
||||
|
||||
$log = $log->fatal('Its over...');
|
||||
$log = $log->fatal('Bye', 'bye');
|
||||
$log = $log->fatal(sub {...});
|
||||
|
||||
Emit L</"message"> event and log C<fatal> message.
|
||||
|
||||
=head2 info
|
||||
|
||||
$log = $log->info('You are bad, but you prolly know already');
|
||||
$log = $log->info('Ok', 'then');
|
||||
$log = $log->info(sub {...});
|
||||
|
||||
Emit L</"message"> event and log C<info> message.
|
||||
|
||||
=head2 is_level
|
||||
|
||||
my $bool = $log->is_level('debug');
|
||||
|
||||
Check active log L</"level">.
|
||||
|
||||
# True
|
||||
$log->level('debug')->is_level('debug');
|
||||
$log->level('debug')->is_level('info');
|
||||
|
||||
# False
|
||||
$log->level('info')->is_level('debug');
|
||||
$log->level('fatal')->is_level('warn');
|
||||
|
||||
=head2 new
|
||||
|
||||
my $log = Mojo::Log->new;
|
||||
my $log = Mojo::Log->new(level => 'warn');
|
||||
my $log = Mojo::Log->new({level => 'warn'});
|
||||
|
||||
Construct a new L<Mojo::Log> object and subscribe to L</"message"> event with default logger.
|
||||
|
||||
=head2 warn
|
||||
|
||||
$log = $log->warn('Dont do that Dave...');
|
||||
$log = $log->warn('No', 'really');
|
||||
$log = $log->warn(sub {...});
|
||||
|
||||
Emit L</"message"> event and log C<warn> message.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
628
database/perl/vendor/lib/Mojo/Message.pm
vendored
Normal file
628
database/perl/vendor/lib/Mojo/Message.pm
vendored
Normal file
@@ -0,0 +1,628 @@
|
||||
package Mojo::Message;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::Asset::Memory;
|
||||
use Mojo::Content::Single;
|
||||
use Mojo::DOM;
|
||||
use Mojo::JSON qw(j);
|
||||
use Mojo::JSON::Pointer;
|
||||
use Mojo::Parameters;
|
||||
use Mojo::Upload;
|
||||
use Mojo::Util qw(decode);
|
||||
|
||||
has content => sub { Mojo::Content::Single->new };
|
||||
has default_charset => 'UTF-8';
|
||||
has max_line_size => sub { $ENV{MOJO_MAX_LINE_SIZE} || 8192 };
|
||||
has max_message_size => sub { $ENV{MOJO_MAX_MESSAGE_SIZE} // 16777216 };
|
||||
has version => '1.1';
|
||||
|
||||
sub body {
|
||||
my $self = shift;
|
||||
|
||||
# Get
|
||||
my $content = $self->content;
|
||||
return $content->is_multipart ? '' : $content->asset->slurp unless @_;
|
||||
|
||||
# Set (multipart content needs to be downgraded)
|
||||
$content = $self->content(Mojo::Content::Single->new)->content if $content->is_multipart;
|
||||
$content->asset(Mojo::Asset::Memory->new->add_chunk(@_));
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub body_params {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{body_params} if $self->{body_params};
|
||||
my $params = $self->{body_params} = Mojo::Parameters->new;
|
||||
$params->charset($self->content->charset || $self->default_charset);
|
||||
|
||||
# "application/x-www-form-urlencoded"
|
||||
my $type = $self->headers->content_type // '';
|
||||
if ($type =~ m!application/x-www-form-urlencoded!i) {
|
||||
$params->parse($self->content->asset->slurp);
|
||||
}
|
||||
|
||||
# "multipart/form-data"
|
||||
elsif ($type =~ m!multipart/form-data!i) {
|
||||
$params->append(@$_[0, 1]) for @{$self->_parse_formdata};
|
||||
}
|
||||
|
||||
return $params;
|
||||
}
|
||||
|
||||
sub body_size { shift->content->body_size }
|
||||
|
||||
sub build_body { shift->_build('get_body_chunk') }
|
||||
sub build_headers { shift->_build('get_header_chunk') }
|
||||
sub build_start_line { shift->_build('get_start_line_chunk') }
|
||||
|
||||
sub cookie { shift->_cache('cookies', 0, @_) }
|
||||
|
||||
sub cookies { croak 'Method "cookies" not implemented by subclass' }
|
||||
|
||||
sub dom {
|
||||
my $self = shift;
|
||||
return undef if $self->content->is_multipart;
|
||||
my $dom = $self->{dom} ||= Mojo::DOM->new($self->text);
|
||||
return @_ ? $dom->find(@_) : $dom;
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $self = shift;
|
||||
return $self->{error} unless @_;
|
||||
$self->{error} = shift;
|
||||
return $self->finish;
|
||||
}
|
||||
|
||||
sub every_cookie { shift->_cache('cookies', 1, @_) }
|
||||
sub every_upload { shift->_cache('uploads', 1, @_) }
|
||||
|
||||
sub extract_start_line { croak 'Method "extract_start_line" not implemented by subclass' }
|
||||
|
||||
sub finish {
|
||||
my $self = shift;
|
||||
$self->{state} = 'finished';
|
||||
return $self->{finished}++ ? $self : $self->emit('finish');
|
||||
}
|
||||
|
||||
sub fix_headers {
|
||||
my $self = shift;
|
||||
return $self if $self->{fix}++;
|
||||
|
||||
# Content-Length or Connection (unless chunked transfer encoding is used)
|
||||
my $content = $self->content;
|
||||
my $headers = $content->headers;
|
||||
if ($content->is_multipart) { $headers->remove('Content-Length') }
|
||||
elsif ($content->is_chunked || $headers->content_length) { return $self }
|
||||
if ($content->is_dynamic) { $headers->connection('close') }
|
||||
else { $headers->content_length($self->body_size) }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub get_body_chunk {
|
||||
my ($self, $offset) = @_;
|
||||
|
||||
$self->emit('progress', 'body', $offset);
|
||||
my $chunk = $self->content->get_body_chunk($offset);
|
||||
return $chunk if !defined $chunk || length $chunk;
|
||||
$self->finish;
|
||||
|
||||
return $chunk;
|
||||
}
|
||||
|
||||
sub get_header_chunk {
|
||||
my ($self, $offset) = @_;
|
||||
$self->emit('progress', 'headers', $offset);
|
||||
return $self->fix_headers->content->get_header_chunk($offset);
|
||||
}
|
||||
|
||||
sub get_start_line_chunk { croak 'Method "get_start_line_chunk" not implemented by subclass' }
|
||||
|
||||
sub header_size { shift->fix_headers->content->header_size }
|
||||
|
||||
sub headers { shift->content->headers }
|
||||
|
||||
sub is_finished { (shift->{state} // '') eq 'finished' }
|
||||
|
||||
sub is_limit_exceeded { !!shift->{limit} }
|
||||
|
||||
sub json {
|
||||
my ($self, $pointer) = @_;
|
||||
return undef if $self->content->is_multipart;
|
||||
my $data = $self->{json} //= j($self->body);
|
||||
return $pointer ? Mojo::JSON::Pointer->new($data)->get($pointer) : $data;
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my ($self, $chunk) = @_;
|
||||
|
||||
return $self if $self->{error};
|
||||
$self->{raw_size} += length $chunk;
|
||||
$self->{buffer} .= $chunk;
|
||||
|
||||
# Start-line
|
||||
unless ($self->{state}) {
|
||||
|
||||
# Check start-line size
|
||||
my $len = index $self->{buffer}, "\x0a";
|
||||
$len = length $self->{buffer} if $len < 0;
|
||||
return $self->_limit('Maximum start-line size exceeded') if $len > $self->max_line_size;
|
||||
|
||||
$self->{state} = 'content' if $self->extract_start_line(\$self->{buffer});
|
||||
}
|
||||
|
||||
# Content
|
||||
my $state = $self->{state} // '';
|
||||
$self->content($self->content->parse(delete $self->{buffer})) if $state eq 'content' || $state eq 'finished';
|
||||
|
||||
# Check message size
|
||||
my $max = $self->max_message_size;
|
||||
return $self->_limit('Maximum message size exceeded') if $max && $max < $self->{raw_size};
|
||||
|
||||
# Check header size
|
||||
return $self->_limit('Maximum header size exceeded') if $self->headers->is_limit_exceeded;
|
||||
|
||||
# Check buffer size
|
||||
return $self->_limit('Maximum buffer size exceeded') if $self->content->is_limit_exceeded;
|
||||
|
||||
return $self->emit('progress')->content->is_finished ? $self->finish : $self;
|
||||
}
|
||||
|
||||
sub save_to {
|
||||
my ($self, $path) = @_;
|
||||
my $content = $self->content;
|
||||
croak 'Multipart content cannot be saved to files' if $content->is_multipart;
|
||||
$content->asset->move_to($path);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub start_line_size { croak 'Method "start_line_size" not implemented by subclass' }
|
||||
|
||||
sub text {
|
||||
my $self = shift;
|
||||
my $body = $self->body;
|
||||
my $charset = $self->content->charset || $self->default_charset;
|
||||
return $charset ? decode($charset, $body) // $body : $body;
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
return $self->build_start_line . $self->build_headers . $self->build_body;
|
||||
}
|
||||
|
||||
sub upload { shift->_cache('uploads', 0, @_) }
|
||||
|
||||
sub uploads {
|
||||
my $self = shift;
|
||||
|
||||
my @uploads;
|
||||
for my $data (@{$self->_parse_formdata(1)}) {
|
||||
my $upload = Mojo::Upload->new(
|
||||
name => $data->[0],
|
||||
filename => $data->[2],
|
||||
asset => $data->[1]->asset,
|
||||
headers => $data->[1]->headers
|
||||
);
|
||||
push @uploads, $upload;
|
||||
}
|
||||
|
||||
return \@uploads;
|
||||
}
|
||||
|
||||
sub _build {
|
||||
my ($self, $method) = @_;
|
||||
|
||||
my ($buffer, $offset) = ('', 0);
|
||||
while (1) {
|
||||
|
||||
# No chunk yet, try again
|
||||
next unless defined(my $chunk = $self->$method($offset));
|
||||
|
||||
# End of part
|
||||
last unless my $len = length $chunk;
|
||||
|
||||
$offset += $len;
|
||||
$buffer .= $chunk;
|
||||
}
|
||||
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
sub _cache {
|
||||
my ($self, $method, $all, $name) = @_;
|
||||
|
||||
# Cache objects by name
|
||||
unless ($self->{$method}) {
|
||||
$self->{$method} = {};
|
||||
push @{$self->{$method}{$_->name}}, $_ for @{$self->$method};
|
||||
}
|
||||
|
||||
my $objects = $self->{$method}{$name} // [];
|
||||
return $all ? $objects : $objects->[-1];
|
||||
}
|
||||
|
||||
sub _limit { ++$_[0]{limit} and return $_[0]->error({message => $_[1]}) }
|
||||
|
||||
sub _parse_formdata {
|
||||
my ($self, $upload) = @_;
|
||||
|
||||
my @formdata;
|
||||
my $content = $self->content;
|
||||
return \@formdata unless $content->is_multipart;
|
||||
my $charset = $content->charset || $self->default_charset;
|
||||
|
||||
# Check all parts recursively
|
||||
my @parts = ($content);
|
||||
while (my $part = shift @parts) {
|
||||
|
||||
if ($part->is_multipart) {
|
||||
unshift @parts, @{$part->parts};
|
||||
next;
|
||||
}
|
||||
|
||||
next unless my $disposition = $part->headers->content_disposition;
|
||||
my ($filename) = $disposition =~ /[; ]filename="((?:\\"|[^"])*)"/;
|
||||
next if $upload && !defined $filename || !$upload && defined $filename;
|
||||
my ($name) = $disposition =~ /[; ]name="((?:\\"|[^;"])*)"/;
|
||||
$part = $part->asset->slurp unless $upload;
|
||||
|
||||
if ($charset) {
|
||||
$name = decode($charset, $name) // $name if $name;
|
||||
$filename = decode($charset, $filename) // $filename if $filename;
|
||||
$part = decode($charset, $part) // $part unless $upload;
|
||||
}
|
||||
|
||||
push @formdata, [$name, $part, $filename];
|
||||
}
|
||||
|
||||
return \@formdata;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Message - HTTP message base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Message::MyMessage;
|
||||
use Mojo::Base 'Mojo::Message';
|
||||
|
||||
sub cookies {...}
|
||||
sub extract_start_line {...}
|
||||
sub get_start_line_chunk {...}
|
||||
sub start_line_size {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Message> is an abstract base class for HTTP message containers, based on L<RFC
|
||||
7230|https://tools.ietf.org/html/rfc7230>, L<RFC 7231|https://tools.ietf.org/html/rfc7231> and L<RFC
|
||||
2388|https://tools.ietf.org/html/rfc2388>, like L<Mojo::Message::Request> and L<Mojo::Message::Response>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Message> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$msg->on(finish => sub ($msg) {...});
|
||||
|
||||
Emitted after message building or parsing is finished.
|
||||
|
||||
my $before = time;
|
||||
$msg->on(finish => sub ($msg) { $msg->headers->header('X-Parser-Time' => time - $before) });
|
||||
|
||||
=head2 progress
|
||||
|
||||
$msg->on(progress => sub ($msg) {...});
|
||||
|
||||
Emitted when message building or parsing makes progress.
|
||||
|
||||
# Building
|
||||
$msg->on(progress => sub ($msg, $state, $offset) { say qq{Building "$state" at offset $offset} });
|
||||
|
||||
# Parsing
|
||||
$msg->on(progress => sub ($msg) {
|
||||
return unless my $len = $msg->headers->content_length;
|
||||
my $size = $msg->content->progress;
|
||||
say 'Progress: ', $size == $len ? 100 : int($size / ($len / 100)), '%';
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Message> implements the following attributes.
|
||||
|
||||
=head2 content
|
||||
|
||||
my $msg = $msg->content;
|
||||
$msg = $msg->content(Mojo::Content::Single->new);
|
||||
|
||||
Message content, defaults to a L<Mojo::Content::Single> object.
|
||||
|
||||
=head2 default_charset
|
||||
|
||||
my $charset = $msg->default_charset;
|
||||
$msg = $msg->default_charset('UTF-8');
|
||||
|
||||
Default charset used by L</"text"> and to extract data from C<application/x-www-form-urlencoded> or
|
||||
C<multipart/form-data> message body, defaults to C<UTF-8>.
|
||||
|
||||
=head2 max_line_size
|
||||
|
||||
my $size = $msg->max_line_size;
|
||||
$msg = $msg->max_line_size(1024);
|
||||
|
||||
Maximum start-line size in bytes, defaults to the value of the C<MOJO_MAX_LINE_SIZE> environment variable or C<8192>
|
||||
(8KiB).
|
||||
|
||||
=head2 max_message_size
|
||||
|
||||
my $size = $msg->max_message_size;
|
||||
$msg = $msg->max_message_size(1024);
|
||||
|
||||
Maximum message size in bytes, defaults to the value of the C<MOJO_MAX_MESSAGE_SIZE> environment variable or
|
||||
C<16777216> (16MiB). Setting the value to C<0> will allow messages of indefinite size.
|
||||
|
||||
=head2 version
|
||||
|
||||
my $version = $msg->version;
|
||||
$msg = $msg->version('1.1');
|
||||
|
||||
HTTP version of message, defaults to C<1.1>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Message> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 body
|
||||
|
||||
my $bytes = $msg->body;
|
||||
$msg = $msg->body('Hello!');
|
||||
|
||||
Slurp or replace L</"content">.
|
||||
|
||||
=head2 body_params
|
||||
|
||||
my $params = $msg->body_params;
|
||||
|
||||
C<POST> parameters extracted from C<application/x-www-form-urlencoded> or C<multipart/form-data> message body, usually
|
||||
a L<Mojo::Parameters> object. Note that this method caches all data, so it should not be called before the entire
|
||||
message body has been received. Parts of the message body need to be loaded into memory to parse C<POST> parameters, so
|
||||
you have to make sure it is not excessively large. There's a 16MiB limit for requests and a 2GiB limit for responses by
|
||||
default.
|
||||
|
||||
# Get POST parameter names and values
|
||||
my $hash = $msg->body_params->to_hash;
|
||||
|
||||
=head2 body_size
|
||||
|
||||
my $size = $msg->body_size;
|
||||
|
||||
Content size in bytes.
|
||||
|
||||
=head2 build_body
|
||||
|
||||
my $bytes = $msg->build_body;
|
||||
|
||||
Render whole body with L</"get_body_chunk">.
|
||||
|
||||
=head2 build_headers
|
||||
|
||||
my $bytes = $msg->build_headers;
|
||||
|
||||
Render all headers with L</"get_header_chunk">.
|
||||
|
||||
=head2 build_start_line
|
||||
|
||||
my $bytes = $msg->build_start_line;
|
||||
|
||||
Render start-line with L</"get_start_line_chunk">.
|
||||
|
||||
=head2 cookie
|
||||
|
||||
my $cookie = $msg->cookie('foo');
|
||||
|
||||
Access message cookies, usually L<Mojo::Cookie::Request> or L<Mojo::Cookie::Response> objects. If there are multiple
|
||||
cookies sharing the same name, and you want to access more than just the last one, you can use L</"every_cookie">. Note
|
||||
that this method caches all data, so it should not be called before all headers have been received.
|
||||
|
||||
# Get cookie value
|
||||
say $msg->cookie('foo')->value;
|
||||
|
||||
=head2 cookies
|
||||
|
||||
my $cookies = $msg->cookies;
|
||||
|
||||
Access message cookies. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 dom
|
||||
|
||||
my $dom = $msg->dom;
|
||||
my $collection = $msg->dom('a[href]');
|
||||
|
||||
Retrieve message body from L</"text"> and turn it into a L<Mojo::DOM> object, an optional selector can be used to call
|
||||
the method L<Mojo::DOM/"find"> on it right away, which then returns a L<Mojo::Collection> object. Note that this method
|
||||
caches all data, so it should not be called before the entire message body has been received. The whole message body
|
||||
needs to be loaded into memory to parse it, so you have to make sure it is not excessively large. There's a 16MiB limit
|
||||
for requests and a 2GiB limit for responses by default.
|
||||
|
||||
# Perform "find" right away
|
||||
say $msg->dom('h1, h2, h3')->map('text')->join("\n");
|
||||
|
||||
# Use everything else Mojo::DOM has to offer
|
||||
say $msg->dom->at('title')->text;
|
||||
say $msg->dom->at('body')->children->map('tag')->uniq->join("\n");
|
||||
|
||||
=head2 error
|
||||
|
||||
my $err = $msg->error;
|
||||
$msg = $msg->error({message => 'Parser error'});
|
||||
|
||||
Get or set message error, an C<undef> return value indicates that there is no error.
|
||||
|
||||
# Connection or parser error
|
||||
$msg->error({message => 'Connection refused'});
|
||||
|
||||
# 4xx/5xx response
|
||||
$msg->error({message => 'Internal Server Error', code => 500});
|
||||
|
||||
=head2 every_cookie
|
||||
|
||||
my $cookies = $msg->every_cookie('foo');
|
||||
|
||||
Similar to L</"cookie">, but returns all message cookies sharing the same name as an array reference.
|
||||
|
||||
# Get first cookie value
|
||||
say $msg->every_cookie('foo')->[0]->value;
|
||||
|
||||
=head2 every_upload
|
||||
|
||||
my $uploads = $msg->every_upload('foo');
|
||||
|
||||
Similar to L</"upload">, but returns all file uploads sharing the same name as an array reference.
|
||||
|
||||
# Get content of first uploaded file
|
||||
say $msg->every_upload('foo')->[0]->asset->slurp;
|
||||
|
||||
=head2 extract_start_line
|
||||
|
||||
my $bool = $msg->extract_start_line(\$str);
|
||||
|
||||
Extract start-line from string. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$msg = $msg->finish;
|
||||
|
||||
Finish message parser/generator.
|
||||
|
||||
=head2 fix_headers
|
||||
|
||||
$msg = $msg->fix_headers;
|
||||
|
||||
Make sure message has all required headers.
|
||||
|
||||
=head2 get_body_chunk
|
||||
|
||||
my $bytes = $msg->get_body_chunk($offset);
|
||||
|
||||
Get a chunk of body data starting from a specific position. Note that it might not be possible to get the same chunk
|
||||
twice if content was generated dynamically.
|
||||
|
||||
=head2 get_header_chunk
|
||||
|
||||
my $bytes = $msg->get_header_chunk($offset);
|
||||
|
||||
Get a chunk of header data, starting from a specific position. Note that this method finalizes the message.
|
||||
|
||||
=head2 get_start_line_chunk
|
||||
|
||||
my $bytes = $msg->get_start_line_chunk($offset);
|
||||
|
||||
Get a chunk of start-line data starting from a specific position. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 header_size
|
||||
|
||||
my $size = $msg->header_size;
|
||||
|
||||
Size of headers in bytes. Note that this method finalizes the message.
|
||||
|
||||
=head2 headers
|
||||
|
||||
my $headers = $msg->headers;
|
||||
|
||||
Message headers, usually a L<Mojo::Headers> object.
|
||||
|
||||
# Longer version
|
||||
my $headers = $msg->content->headers;
|
||||
|
||||
=head2 is_finished
|
||||
|
||||
my $bool = $msg->is_finished;
|
||||
|
||||
Check if message parser/generator is finished.
|
||||
|
||||
=head2 is_limit_exceeded
|
||||
|
||||
my $bool = $msg->is_limit_exceeded;
|
||||
|
||||
Check if message has exceeded L</"max_line_size">, L</"max_message_size">, L<Mojo::Content/"max_buffer_size"> or
|
||||
L<Mojo::Headers/"max_line_size">.
|
||||
|
||||
=head2 json
|
||||
|
||||
my $value = $msg->json;
|
||||
my $value = $msg->json('/foo/bar');
|
||||
|
||||
Decode JSON message body directly using L<Mojo::JSON> if possible, an C<undef> return value indicates a bare C<null> or
|
||||
that decoding failed. An optional JSON Pointer can be used to extract a specific value with L<Mojo::JSON::Pointer>.
|
||||
Note that this method caches all data, so it should not be called before the entire message body has been received. The
|
||||
whole message body needs to be loaded into memory to parse it, so you have to make sure it is not excessively large.
|
||||
There's a 16MiB limit for requests and a 2GiB limit for responses by default.
|
||||
|
||||
# Extract JSON values
|
||||
say $msg->json->{foo}{bar}[23];
|
||||
say $msg->json('/foo/bar/23');
|
||||
|
||||
=head2 parse
|
||||
|
||||
$msg = $msg->parse('HTTP/1.1 200 OK...');
|
||||
|
||||
Parse message chunk.
|
||||
|
||||
=head2 save_to
|
||||
|
||||
$msg = $msg->save_to('/some/path/index.html');
|
||||
|
||||
Save message body to a file.
|
||||
|
||||
=head2 start_line_size
|
||||
|
||||
my $size = $msg->start_line_size;
|
||||
|
||||
Size of the start-line in bytes. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 text
|
||||
|
||||
my $str = $msg->text;
|
||||
|
||||
Retrieve L</"body"> and try to decode it with L<Mojo::Content/"charset"> or L</"default_charset">.
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $msg->to_string;
|
||||
|
||||
Render whole message. Note that this method finalizes the message, and that it might not be possible to render the same
|
||||
message twice if content was generated dynamically.
|
||||
|
||||
=head2 upload
|
||||
|
||||
my $upload = $msg->upload('foo');
|
||||
|
||||
Access C<multipart/form-data> file uploads, usually L<Mojo::Upload> objects. If there are multiple uploads sharing the
|
||||
same name, and you want to access more than just the last one, you can use L</"every_upload">. Note that this method
|
||||
caches all data, so it should not be called before the entire message body has been received.
|
||||
|
||||
# Get content of uploaded file
|
||||
say $msg->upload('foo')->asset->slurp;
|
||||
|
||||
=head2 uploads
|
||||
|
||||
my $uploads = $msg->uploads;
|
||||
|
||||
All C<multipart/form-data> file uploads, usually L<Mojo::Upload> objects.
|
||||
|
||||
# Names of all uploads
|
||||
say $_->name for @{$msg->uploads};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
446
database/perl/vendor/lib/Mojo/Message/Request.pm
vendored
Normal file
446
database/perl/vendor/lib/Mojo/Message/Request.pm
vendored
Normal file
@@ -0,0 +1,446 @@
|
||||
package Mojo::Message::Request;
|
||||
use Mojo::Base 'Mojo::Message';
|
||||
|
||||
use Digest::SHA qw(sha1_base64);
|
||||
use Mojo::Cookie::Request;
|
||||
use Mojo::Util qw(b64_encode b64_decode sha1_sum);
|
||||
use Mojo::URL;
|
||||
|
||||
has env => sub { {} };
|
||||
has method => 'GET';
|
||||
has [qw(proxy reverse_proxy)];
|
||||
has request_id => sub {
|
||||
state $seed = $$ . time . rand;
|
||||
state $counter = int rand 0xffffff;
|
||||
my $b64 = substr(sha1_base64($seed . ($counter = ($counter + 1) % 0xffffff)), 0, 8);
|
||||
$b64 =~ tr!+/!-_!;
|
||||
return $b64;
|
||||
};
|
||||
has url => sub { Mojo::URL->new };
|
||||
has via_proxy => 1;
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
|
||||
# Dynamic requests cannot be cloned
|
||||
return undef unless my $content = $self->content->clone;
|
||||
my $clone
|
||||
= $self->new(content => $content, method => $self->method, url => $self->url->clone, version => $self->version);
|
||||
$clone->{proxy} = $self->{proxy}->clone if $self->{proxy};
|
||||
|
||||
return $clone;
|
||||
}
|
||||
|
||||
sub cookies {
|
||||
my $self = shift;
|
||||
|
||||
# Parse cookies
|
||||
my $headers = $self->headers;
|
||||
return [map { @{Mojo::Cookie::Request->parse($_)} } $headers->cookie] unless @_;
|
||||
|
||||
# Add cookies
|
||||
my @cookies = map { ref $_ eq 'HASH' ? Mojo::Cookie::Request->new($_) : $_ } $headers->cookie || (), @_;
|
||||
$headers->cookie(join '; ', @cookies);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub every_param { shift->params->every_param(@_) }
|
||||
|
||||
sub extract_start_line {
|
||||
my ($self, $bufref) = @_;
|
||||
|
||||
# Ignore any leading empty lines
|
||||
return undef unless $$bufref =~ s/^\s*(.*?)\x0d?\x0a//;
|
||||
|
||||
# We have a (hopefully) full request-line
|
||||
return !$self->error({message => 'Bad request start-line'}) unless $1 =~ /^(\S+)\s+(\S+)\s+HTTP\/(\d\.\d)$/;
|
||||
my $url = $self->method($1)->version($3)->url;
|
||||
my $target = $2;
|
||||
return !!$url->host_port($target) if $1 eq 'CONNECT';
|
||||
return !!$url->parse($target)->fragment(undef) if $target =~ /^[^:\/?#]+:/;
|
||||
return !!$url->path_query($target);
|
||||
}
|
||||
|
||||
sub fix_headers {
|
||||
my $self = shift;
|
||||
$self->{fix} ? return $self : $self->SUPER::fix_headers(@_);
|
||||
|
||||
# Host
|
||||
my $url = $self->url;
|
||||
my $headers = $self->headers;
|
||||
$headers->host($url->host_port) unless $headers->host;
|
||||
|
||||
# Basic authentication
|
||||
if ((my $info = $url->userinfo) && !$headers->authorization) {
|
||||
$headers->authorization('Basic ' . b64_encode($info, ''));
|
||||
}
|
||||
|
||||
# Basic proxy authentication
|
||||
return $self unless (my $proxy = $self->proxy) && $self->via_proxy;
|
||||
return $self unless my $info = $proxy->userinfo;
|
||||
$headers->proxy_authorization('Basic ' . b64_encode($info, '')) unless $headers->proxy_authorization;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub get_start_line_chunk {
|
||||
my ($self, $offset) = @_;
|
||||
$self->_start_line->emit(progress => 'start_line', $offset);
|
||||
return substr $self->{start_buffer}, $offset, 131072;
|
||||
}
|
||||
|
||||
sub is_handshake { lc($_[0]->headers->upgrade // '') eq 'websocket' }
|
||||
|
||||
sub is_secure {
|
||||
my $url = shift->url;
|
||||
return ($url->protocol || $url->base->protocol) eq 'https';
|
||||
}
|
||||
|
||||
sub is_xhr { (shift->headers->header('X-Requested-With') // '') =~ /XMLHttpRequest/i }
|
||||
|
||||
sub param { shift->params->param(@_) }
|
||||
|
||||
sub params { $_[0]->{params} ||= $_[0]->body_params->clone->append($_[0]->query_params) }
|
||||
|
||||
sub parse {
|
||||
my ($self, $env, $chunk) = (shift, ref $_[0] ? (shift, '') : (undef, shift));
|
||||
|
||||
# Parse CGI environment
|
||||
$self->env($env)->_parse_env($env) if $env;
|
||||
|
||||
# Parse normal message
|
||||
if (($self->{state} // '') ne 'cgi') { $self->SUPER::parse($chunk) }
|
||||
|
||||
# Parse CGI content
|
||||
else { $self->content($self->content->parse_body($chunk))->SUPER::parse('') }
|
||||
|
||||
# Check if we can fix things that require all headers
|
||||
return $self unless $self->is_finished;
|
||||
|
||||
# Base URL
|
||||
my $base = $self->url->base;
|
||||
$base->scheme('http') unless $base->scheme;
|
||||
my $headers = $self->headers;
|
||||
if (!$base->host && (my $host = $headers->host)) { $base->host_port($host) }
|
||||
|
||||
# Basic authentication
|
||||
if (my $basic = _basic($headers->authorization)) { $base->userinfo($basic) }
|
||||
|
||||
# Basic proxy authentication
|
||||
my $basic = _basic($headers->proxy_authorization);
|
||||
$self->proxy(Mojo::URL->new->userinfo($basic)) if $basic;
|
||||
|
||||
# "X-Forwarded-Proto"
|
||||
$base->scheme('https') if $self->reverse_proxy && ($headers->header('X-Forwarded-Proto') // '') eq 'https';
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub query_params { shift->url->query }
|
||||
|
||||
sub start_line_size { length shift->_start_line->{start_buffer} }
|
||||
|
||||
sub _basic { $_[0] && $_[0] =~ /Basic (.+)$/ ? b64_decode $1 : undef }
|
||||
|
||||
sub _parse_env {
|
||||
my ($self, $env) = @_;
|
||||
|
||||
# Bypass normal message parser
|
||||
$self->{state} = 'cgi';
|
||||
|
||||
# Extract headers
|
||||
my $headers = $self->headers;
|
||||
my $url = $self->url;
|
||||
my $base = $url->base;
|
||||
for my $name (keys %$env) {
|
||||
my $value = $env->{$name};
|
||||
next unless $name =~ s/^HTTP_//i;
|
||||
$name =~ y/_/-/;
|
||||
$headers->header($name => $value);
|
||||
|
||||
# Host/Port
|
||||
$value =~ s/:(\d+)$// ? $base->host($value)->port($1) : $base->host($value) if $name eq 'HOST';
|
||||
}
|
||||
|
||||
# Content-Type is a special case on some servers
|
||||
$headers->content_type($env->{CONTENT_TYPE}) if $env->{CONTENT_TYPE};
|
||||
|
||||
# Content-Length is a special case on some servers
|
||||
$headers->content_length($env->{CONTENT_LENGTH}) if $env->{CONTENT_LENGTH};
|
||||
|
||||
# Query
|
||||
$url->query->parse($env->{QUERY_STRING}) if $env->{QUERY_STRING};
|
||||
|
||||
# Method
|
||||
$self->method($env->{REQUEST_METHOD}) if $env->{REQUEST_METHOD};
|
||||
|
||||
# Scheme/Version
|
||||
$base->scheme($1) and $self->version($2) if ($env->{SERVER_PROTOCOL} // '') =~ m!^([^/]+)/([^/]+)$!;
|
||||
|
||||
# HTTPS
|
||||
$base->scheme('https') if uc($env->{HTTPS} // '') eq 'ON';
|
||||
|
||||
# Path
|
||||
my $path = $url->path->parse($env->{PATH_INFO} ? $env->{PATH_INFO} : '');
|
||||
|
||||
# Base path
|
||||
if (my $value = $env->{SCRIPT_NAME}) {
|
||||
|
||||
# Make sure there is a trailing slash (important for merging)
|
||||
$base->path->parse($value =~ m!/$! ? $value : "$value/");
|
||||
|
||||
# Remove SCRIPT_NAME prefix if necessary
|
||||
my $buffer = $path->to_string;
|
||||
$value =~ s!^/|/$!!g;
|
||||
$buffer =~ s!^/?\Q$value\E/?!!;
|
||||
$buffer =~ s!^/!!;
|
||||
$path->parse($buffer);
|
||||
}
|
||||
}
|
||||
|
||||
sub _start_line {
|
||||
my $self = shift;
|
||||
|
||||
return $self if defined $self->{start_buffer};
|
||||
|
||||
# Path
|
||||
my $url = $self->url;
|
||||
my $path = $url->path_query;
|
||||
$path = "/$path" unless $path =~ m!^/!;
|
||||
|
||||
# CONNECT
|
||||
my $method = uc $self->method;
|
||||
if ($method eq 'CONNECT') {
|
||||
my $port = $url->port // ($url->protocol eq 'https' ? '443' : '80');
|
||||
$path = $url->ihost . ":$port";
|
||||
}
|
||||
|
||||
# Proxy
|
||||
elsif ($self->proxy && $self->via_proxy && $url->protocol ne 'https') {
|
||||
$path = $url->clone->userinfo(undef) unless $self->is_handshake;
|
||||
}
|
||||
|
||||
$self->{start_buffer} = "$method $path HTTP/@{[$self->version]}\x0d\x0a";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Message::Request - HTTP request
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Message::Request;
|
||||
|
||||
# Parse
|
||||
my $req = Mojo::Message::Request->new;
|
||||
$req->parse("GET /foo HTTP/1.0\x0d\x0a");
|
||||
$req->parse("Content-Length: 12\x0d\x0a");
|
||||
$req->parse("Content-Type: text/plain\x0d\x0a\x0d\x0a");
|
||||
$req->parse('Hello World!');
|
||||
say $req->method;
|
||||
say $req->headers->content_type;
|
||||
say $req->body;
|
||||
|
||||
# Build
|
||||
my $req = Mojo::Message::Request->new;
|
||||
$req->url->parse('http://127.0.0.1/foo/bar');
|
||||
$req->method('GET');
|
||||
say $req->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Message::Request> is a container for HTTP requests, based on L<RFC 7230|https://tools.ietf.org/html/rfc7230>,
|
||||
L<RFC 7231|https://tools.ietf.org/html/rfc7231>, L<RFC 7235|https://tools.ietf.org/html/rfc7235> and L<RFC
|
||||
2817|https://tools.ietf.org/html/rfc2817>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Message::Request> inherits all events from L<Mojo::Message>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Message::Request> inherits all attributes from L<Mojo::Message> and implements the following new ones.
|
||||
|
||||
=head2 env
|
||||
|
||||
my $env = $req->env;
|
||||
$req = $req->env({PATH_INFO => '/'});
|
||||
|
||||
Direct access to the C<CGI> or C<PSGI> environment hash if available.
|
||||
|
||||
# Check CGI version
|
||||
my $version = $req->env->{GATEWAY_INTERFACE};
|
||||
|
||||
# Check PSGI version
|
||||
my $version = $req->env->{'psgi.version'};
|
||||
|
||||
=head2 method
|
||||
|
||||
my $method = $req->method;
|
||||
$req = $req->method('POST');
|
||||
|
||||
HTTP request method, defaults to C<GET>.
|
||||
|
||||
=head2 proxy
|
||||
|
||||
my $url = $req->proxy;
|
||||
$req = $req->proxy(Mojo::URL->new('http://127.0.0.1:3000'));
|
||||
|
||||
Proxy URL for request.
|
||||
|
||||
=head2 reverse_proxy
|
||||
|
||||
my $bool = $req->reverse_proxy;
|
||||
$req = $req->reverse_proxy($bool);
|
||||
|
||||
Request has been performed through a reverse proxy.
|
||||
|
||||
=head2 request_id
|
||||
|
||||
my $id = $req->request_id;
|
||||
$req = $req->request_id('aee7d5d8');
|
||||
|
||||
Request ID, defaults to a reasonably unique value.
|
||||
|
||||
=head2 url
|
||||
|
||||
my $url = $req->url;
|
||||
$req = $req->url(Mojo::URL->new);
|
||||
|
||||
HTTP request URL, defaults to a L<Mojo::URL> object.
|
||||
|
||||
# Get request information
|
||||
my $info = $req->url->to_abs->userinfo;
|
||||
my $host = $req->url->to_abs->host;
|
||||
my $path = $req->url->to_abs->path;
|
||||
|
||||
=head2 via_proxy
|
||||
|
||||
my $bool = $req->via_proxy;
|
||||
$req = $req->via_proxy($bool);
|
||||
|
||||
Request can be performed through a proxy server.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Message::Request> inherits all methods from L<Mojo::Message> and implements the following new ones.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $clone = $req->clone;
|
||||
|
||||
Return a new L<Mojo::Message::Request> object cloned from this request if possible, otherwise return C<undef>.
|
||||
|
||||
=head2 cookies
|
||||
|
||||
my $cookies = $req->cookies;
|
||||
$req = $req->cookies(Mojo::Cookie::Request->new);
|
||||
$req = $req->cookies({name => 'foo', value => 'bar'});
|
||||
|
||||
Access request cookies, usually L<Mojo::Cookie::Request> objects.
|
||||
|
||||
# Names of all cookies
|
||||
say $_->name for @{$req->cookies};
|
||||
|
||||
=head2 every_param
|
||||
|
||||
my $values = $req->every_param('foo');
|
||||
|
||||
Similar to L</"param">, but returns all values sharing the same name as an array reference.
|
||||
|
||||
# Get first value
|
||||
say $req->every_param('foo')->[0];
|
||||
|
||||
=head2 extract_start_line
|
||||
|
||||
my $bool = $req->extract_start_line(\$str);
|
||||
|
||||
Extract request-line from string.
|
||||
|
||||
=head2 fix_headers
|
||||
|
||||
$req = $req->fix_headers;
|
||||
|
||||
Make sure request has all required headers.
|
||||
|
||||
=head2 get_start_line_chunk
|
||||
|
||||
my $bytes = $req->get_start_line_chunk($offset);
|
||||
|
||||
Get a chunk of request-line data starting from a specific position. Note that this method finalizes the request.
|
||||
|
||||
=head2 is_handshake
|
||||
|
||||
my $bool = $req->is_handshake;
|
||||
|
||||
Check C<Upgrade> header for C<websocket> value.
|
||||
|
||||
=head2 is_secure
|
||||
|
||||
my $bool = $req->is_secure;
|
||||
|
||||
Check if connection is secure.
|
||||
|
||||
=head2 is_xhr
|
||||
|
||||
my $bool = $req->is_xhr;
|
||||
|
||||
Check C<X-Requested-With> header for C<XMLHttpRequest> value.
|
||||
|
||||
=head2 param
|
||||
|
||||
my $value = $req->param('foo');
|
||||
|
||||
Access C<GET> and C<POST> parameters extracted from the query string and C<application/x-www-form-urlencoded> or
|
||||
C<multipart/form-data> message body. If there are multiple values sharing the same name, and you want to access more
|
||||
than just the last one, you can use L</"every_param">. Note that this method caches all data, so it should not be
|
||||
called before the entire request body has been received. Parts of the request body need to be loaded into memory to
|
||||
parse C<POST> parameters, so you have to make sure it is not excessively large. There's a 16MiB limit for requests by
|
||||
default.
|
||||
|
||||
=head2 params
|
||||
|
||||
my $params = $req->params;
|
||||
|
||||
All C<GET> and C<POST> parameters extracted from the query string and C<application/x-www-form-urlencoded> or
|
||||
C<multipart/form-data> message body, usually a L<Mojo::Parameters> object. Note that this method caches all data, so it
|
||||
should not be called before the entire request body has been received. Parts of the request body need to be loaded into
|
||||
memory to parse C<POST> parameters, so you have to make sure it is not excessively large. There's a 16MiB limit for
|
||||
requests by default.
|
||||
|
||||
# Get parameter names and values
|
||||
my $hash = $req->params->to_hash;
|
||||
|
||||
=head2 parse
|
||||
|
||||
$req = $req->parse('GET /foo/bar HTTP/1.1');
|
||||
$req = $req->parse({PATH_INFO => '/'});
|
||||
|
||||
Parse HTTP request chunks or environment hash.
|
||||
|
||||
=head2 query_params
|
||||
|
||||
my $params = $req->query_params;
|
||||
|
||||
All C<GET> parameters, usually a L<Mojo::Parameters> object.
|
||||
|
||||
# Turn GET parameters to hash and extract value
|
||||
say $req->query_params->to_hash->{foo};
|
||||
|
||||
=head2 start_line_size
|
||||
|
||||
my $size = $req->start_line_size;
|
||||
|
||||
Size of the request-line in bytes. Note that this method finalizes the request.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
315
database/perl/vendor/lib/Mojo/Message/Response.pm
vendored
Normal file
315
database/perl/vendor/lib/Mojo/Message/Response.pm
vendored
Normal file
@@ -0,0 +1,315 @@
|
||||
package Mojo::Message::Response;
|
||||
use Mojo::Base 'Mojo::Message';
|
||||
|
||||
use Mojo::Cookie::Response;
|
||||
use Mojo::Date;
|
||||
|
||||
has [qw(code message)];
|
||||
has max_message_size => sub { $ENV{MOJO_MAX_MESSAGE_SIZE} // 2147483648 };
|
||||
|
||||
# Unmarked codes are from RFC 7231
|
||||
my %MESSAGES = (
|
||||
100 => 'Continue',
|
||||
101 => 'Switching Protocols',
|
||||
102 => 'Processing', # RFC 2518 (WebDAV)
|
||||
103 => 'Early Hints', # RFC 8297
|
||||
200 => 'OK',
|
||||
201 => 'Created',
|
||||
202 => 'Accepted',
|
||||
203 => 'Non-Authoritative Information',
|
||||
204 => 'No Content',
|
||||
205 => 'Reset Content',
|
||||
206 => 'Partial Content',
|
||||
207 => 'Multi-Status', # RFC 2518 (WebDAV)
|
||||
208 => 'Already Reported', # RFC 5842
|
||||
226 => 'IM Used', # RFC 3229
|
||||
300 => 'Multiple Choices',
|
||||
301 => 'Moved Permanently',
|
||||
302 => 'Found',
|
||||
303 => 'See Other',
|
||||
304 => 'Not Modified',
|
||||
305 => 'Use Proxy',
|
||||
307 => 'Temporary Redirect',
|
||||
308 => 'Permanent Redirect', # RFC 7538
|
||||
400 => 'Bad Request',
|
||||
401 => 'Unauthorized',
|
||||
402 => 'Payment Required',
|
||||
403 => 'Forbidden',
|
||||
404 => 'Not Found',
|
||||
405 => 'Method Not Allowed',
|
||||
406 => 'Not Acceptable',
|
||||
407 => 'Proxy Authentication Required',
|
||||
408 => 'Request Timeout',
|
||||
409 => 'Conflict',
|
||||
410 => 'Gone',
|
||||
411 => 'Length Required',
|
||||
412 => 'Precondition Failed',
|
||||
413 => 'Request Entity Too Large',
|
||||
414 => 'Request-URI Too Long',
|
||||
415 => 'Unsupported Media Type',
|
||||
416 => 'Request Range Not Satisfiable',
|
||||
417 => 'Expectation Failed',
|
||||
418 => "I'm a teapot", # RFC 2324 :)
|
||||
421 => 'Misdirected Request', # RFC 7540
|
||||
422 => 'Unprocessable Entity', # RFC 2518 (WebDAV)
|
||||
423 => 'Locked', # RFC 2518 (WebDAV)
|
||||
424 => 'Failed Dependency', # RFC 2518 (WebDAV)
|
||||
425 => 'Too Early', # RFC 8470
|
||||
426 => 'Upgrade Required', # RFC 2817
|
||||
428 => 'Precondition Required', # RFC 6585
|
||||
429 => 'Too Many Requests', # RFC 6585
|
||||
431 => 'Request Header Fields Too Large', # RFC 6585
|
||||
451 => 'Unavailable For Legal Reasons', # RFC 7725
|
||||
500 => 'Internal Server Error',
|
||||
501 => 'Not Implemented',
|
||||
502 => 'Bad Gateway',
|
||||
503 => 'Service Unavailable',
|
||||
504 => 'Gateway Timeout',
|
||||
505 => 'HTTP Version Not Supported',
|
||||
506 => 'Variant Also Negotiates', # RFC 2295
|
||||
507 => 'Insufficient Storage', # RFC 2518 (WebDAV)
|
||||
508 => 'Loop Detected', # RFC 5842
|
||||
509 => 'Bandwidth Limit Exceeded', # Unofficial
|
||||
510 => 'Not Extended', # RFC 2774
|
||||
511 => 'Network Authentication Required' # RFC 6585
|
||||
);
|
||||
|
||||
sub cookies {
|
||||
my $self = shift;
|
||||
|
||||
# Parse cookies
|
||||
my $headers = $self->headers;
|
||||
return [@{Mojo::Cookie::Response->parse($headers->set_cookie)}] unless @_;
|
||||
|
||||
# Add cookies
|
||||
$headers->add('Set-Cookie' => "$_") for map { ref $_ eq 'HASH' ? Mojo::Cookie::Response->new($_) : $_ } @_;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub default_message { $MESSAGES{$_[1] || $_[0]->code // 404} || '' }
|
||||
|
||||
sub extract_start_line {
|
||||
my ($self, $bufref) = @_;
|
||||
|
||||
# We have a full response line
|
||||
return undef unless $$bufref =~ s/^(.*?)\x0d?\x0a//;
|
||||
return !$self->error({message => 'Bad response start-line'}) unless $1 =~ m!^\s*HTTP/(\d\.\d)\s+(\d\d\d)\s*(.+)?$!;
|
||||
|
||||
my $content = $self->content;
|
||||
$content->skip_body(1) if $self->code($2)->is_empty;
|
||||
defined $content->$_ or $content->$_(1) for qw(auto_decompress auto_relax);
|
||||
return !!$self->version($1)->message($3);
|
||||
}
|
||||
|
||||
sub fix_headers {
|
||||
my $self = shift;
|
||||
$self->{fix} ? return $self : $self->SUPER::fix_headers(@_);
|
||||
|
||||
# Date
|
||||
my $headers = $self->headers;
|
||||
$headers->date(Mojo::Date->new->to_string) unless $headers->date;
|
||||
|
||||
# RFC 7230 3.3.2
|
||||
$headers->remove('Content-Length') if $self->is_empty;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub get_start_line_chunk {
|
||||
my ($self, $offset) = @_;
|
||||
$self->_start_line->emit(progress => 'start_line', $offset);
|
||||
return substr $self->{start_buffer}, $offset, 131072;
|
||||
}
|
||||
|
||||
sub is_client_error { shift->_status_class(400) }
|
||||
|
||||
sub is_empty {
|
||||
my $self = shift;
|
||||
return undef unless my $code = $self->code;
|
||||
return $self->is_info || $code == 204 || $code == 304;
|
||||
}
|
||||
|
||||
sub is_error { shift->_status_class(400, 500) }
|
||||
sub is_info { shift->_status_class(100) }
|
||||
sub is_redirect { shift->_status_class(300) }
|
||||
sub is_server_error { shift->_status_class(500) }
|
||||
|
||||
sub is_success { shift->_status_class(200) }
|
||||
|
||||
sub start_line_size { length shift->_start_line->{start_buffer} }
|
||||
|
||||
sub _start_line {
|
||||
my $self = shift;
|
||||
|
||||
return $self if defined $self->{start_buffer};
|
||||
my $code = $self->code || 404;
|
||||
my $msg = $self->message || $self->default_message;
|
||||
$self->{start_buffer} = "HTTP/@{[$self->version]} $code $msg\x0d\x0a";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _status_class {
|
||||
my ($self, @classes) = @_;
|
||||
return undef unless my $code = $self->code;
|
||||
return !!grep { $code >= $_ && $code < ($_ + 100) } @classes;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Message::Response - HTTP response
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Message::Response;
|
||||
|
||||
# Parse
|
||||
my $res = Mojo::Message::Response->new;
|
||||
$res->parse("HTTP/1.0 200 OK\x0d\x0a");
|
||||
$res->parse("Content-Length: 12\x0d\x0a");
|
||||
$res->parse("Content-Type: text/plain\x0d\x0a\x0d\x0a");
|
||||
$res->parse('Hello World!');
|
||||
say $res->code;
|
||||
say $res->headers->content_type;
|
||||
say $res->body;
|
||||
|
||||
# Build
|
||||
my $res = Mojo::Message::Response->new;
|
||||
$res->code(200);
|
||||
$res->headers->content_type('text/plain');
|
||||
$res->body('Hello World!');
|
||||
say $res->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Message::Response> is a container for HTTP responses, based on L<RFC 7230|https://tools.ietf.org/html/rfc7230>
|
||||
and L<RFC 7231|https://tools.ietf.org/html/rfc7231>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Message::Response> inherits all events from L<Mojo::Message>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Message::Response> inherits all attributes from L<Mojo::Message> and implements the following new ones.
|
||||
|
||||
=head2 code
|
||||
|
||||
my $code = $res->code;
|
||||
$res = $res->code(200);
|
||||
|
||||
HTTP response status code.
|
||||
|
||||
=head2 max_message_size
|
||||
|
||||
my $size = $res->max_message_size;
|
||||
$res = $res->max_message_size(1024);
|
||||
|
||||
Maximum message size in bytes, defaults to the value of the C<MOJO_MAX_MESSAGE_SIZE> environment variable or
|
||||
C<2147483648> (2GiB). Setting the value to C<0> will allow messages of indefinite size.
|
||||
|
||||
=head2 message
|
||||
|
||||
my $msg = $res->message;
|
||||
$res = $res->message('OK');
|
||||
|
||||
HTTP response status message.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Message::Response> inherits all methods from L<Mojo::Message> and implements the following new ones.
|
||||
|
||||
=head2 cookies
|
||||
|
||||
my $cookies = $res->cookies;
|
||||
$res = $res->cookies(Mojo::Cookie::Response->new);
|
||||
$res = $res->cookies({name => 'foo', value => 'bar'});
|
||||
|
||||
Access response cookies, usually L<Mojo::Cookie::Response> objects.
|
||||
|
||||
# Names of all cookies
|
||||
say $_->name for @{$res->cookies};
|
||||
|
||||
=head2 default_message
|
||||
|
||||
my $msg = $res->default_message;
|
||||
my $msg = $res->default_message(418);
|
||||
|
||||
Generate default response message for status code, defaults to using L</"code">.
|
||||
|
||||
=head2 extract_start_line
|
||||
|
||||
my $bool = $res->extract_start_line(\$str);
|
||||
|
||||
Extract status-line from string.
|
||||
|
||||
=head2 fix_headers
|
||||
|
||||
$res = $res->fix_headers;
|
||||
|
||||
Make sure response has all required headers.
|
||||
|
||||
=head2 get_start_line_chunk
|
||||
|
||||
my $bytes = $res->get_start_line_chunk($offset);
|
||||
|
||||
Get a chunk of status-line data starting from a specific position. Note that this method finalizes the response.
|
||||
|
||||
=head2 is_client_error
|
||||
|
||||
my $bool = $res->is_client_error;
|
||||
|
||||
Check if this response has a C<4xx> status L</"code">.
|
||||
|
||||
=head2 is_empty
|
||||
|
||||
my $bool = $res->is_empty;
|
||||
|
||||
Check if this response has a C<1xx>, C<204> or C<304> status L</"code">.
|
||||
|
||||
=head2 is_error
|
||||
|
||||
my $bool = $res->is_error;
|
||||
|
||||
Check if this response has a C<4xx> or C<5xx> status L</"code">.
|
||||
|
||||
=head2 is_info
|
||||
|
||||
my $bool = $res->is_info;
|
||||
|
||||
Check if this response has a C<1xx> status L</"code">.
|
||||
|
||||
=head2 is_redirect
|
||||
|
||||
my $bool = $res->is_redirect;
|
||||
|
||||
Check if this response has a C<3xx> status L</"code">.
|
||||
|
||||
=head2 is_server_error
|
||||
|
||||
my $bool = $res->is_server_error;
|
||||
|
||||
Check if this response has a C<5xx> status L</"code">.
|
||||
|
||||
=head2 is_success
|
||||
|
||||
my $bool = $res->is_success;
|
||||
|
||||
Check if this response has a C<2xx> status L</"code">.
|
||||
|
||||
=head2 start_line_size
|
||||
|
||||
my $size = $req->start_line_size;
|
||||
|
||||
Size of the status-line in bytes. Note that this method finalizes the response.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
376
database/perl/vendor/lib/Mojo/Parameters.pm
vendored
Normal file
376
database/perl/vendor/lib/Mojo/Parameters.pm
vendored
Normal file
@@ -0,0 +1,376 @@
|
||||
package Mojo::Parameters;
|
||||
use Mojo::Base -base;
|
||||
use overload '@{}' => sub { shift->pairs }, bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Mojo::Util qw(decode encode url_escape url_unescape);
|
||||
|
||||
has charset => 'UTF-8';
|
||||
|
||||
sub append {
|
||||
my $self = shift;
|
||||
|
||||
my $old = $self->pairs;
|
||||
my @new = @_ == 1 ? @{shift->pairs} : @_;
|
||||
while (my ($name, $value) = splice @new, 0, 2) {
|
||||
|
||||
# Multiple values
|
||||
if (ref $value eq 'ARRAY') { push @$old, $name => $_ // '' for @$value }
|
||||
|
||||
# Single value
|
||||
elsif (defined $value) { push @$old, $name => $value }
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
|
||||
my $clone = $self->new;
|
||||
if (exists $self->{charset}) { $clone->{charset} = $self->{charset} }
|
||||
if (defined $self->{string}) { $clone->{string} = $self->{string} }
|
||||
else { $clone->{pairs} = [@{$self->pairs}] }
|
||||
|
||||
return $clone;
|
||||
}
|
||||
|
||||
sub every_param {
|
||||
my ($self, $name) = @_;
|
||||
|
||||
my @values;
|
||||
my $pairs = $self->pairs;
|
||||
for (my $i = 0; $i < @$pairs; $i += 2) {
|
||||
push @values, $pairs->[$i + 1] if $pairs->[$i] eq $name;
|
||||
}
|
||||
|
||||
return \@values;
|
||||
}
|
||||
|
||||
sub merge {
|
||||
my $self = shift;
|
||||
|
||||
my $merge = @_ == 1 ? shift->to_hash : {@_};
|
||||
for my $name (sort keys %$merge) {
|
||||
my $value = $merge->{$name};
|
||||
defined $value ? $self->param($name => $value) : $self->remove($name);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub names { [sort keys %{shift->to_hash}] }
|
||||
|
||||
sub new { @_ > 1 ? shift->SUPER::new->parse(@_) : shift->SUPER::new }
|
||||
|
||||
sub pairs {
|
||||
my $self = shift;
|
||||
|
||||
# Replace parameters
|
||||
if (@_) {
|
||||
$self->{pairs} = shift;
|
||||
delete $self->{string};
|
||||
return $self;
|
||||
}
|
||||
|
||||
# Parse string
|
||||
if (defined(my $str = delete $self->{string})) {
|
||||
my $pairs = $self->{pairs} = [];
|
||||
return $pairs unless length $str;
|
||||
|
||||
my $charset = $self->charset;
|
||||
for my $pair (split /&/, $str) {
|
||||
next unless $pair =~ /^([^=]+)(?:=(.*))?$/;
|
||||
my ($name, $value) = ($1, $2 // '');
|
||||
|
||||
# Replace "+" with whitespace, unescape and decode
|
||||
s/\+/ /g for $name, $value;
|
||||
$name = url_unescape $name;
|
||||
$name = decode($charset, $name) // $name if $charset;
|
||||
$value = url_unescape $value;
|
||||
$value = decode($charset, $value) // $value if $charset;
|
||||
|
||||
push @$pairs, $name, $value;
|
||||
}
|
||||
}
|
||||
|
||||
return $self->{pairs} //= [];
|
||||
}
|
||||
|
||||
sub param {
|
||||
my ($self, $name) = (shift, shift);
|
||||
return $self->every_param($name)->[-1] unless @_;
|
||||
$self->remove($name);
|
||||
return $self->append($name => ref $_[0] eq 'ARRAY' ? $_[0] : [@_]);
|
||||
}
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
|
||||
# Pairs
|
||||
return $self->append(@_) if @_ > 1;
|
||||
|
||||
# String
|
||||
$self->{string} = shift;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub remove {
|
||||
my ($self, $name) = @_;
|
||||
my $pairs = $self->pairs;
|
||||
my $i = 0;
|
||||
$pairs->[$i] eq $name ? splice @$pairs, $i, 2 : ($i += 2) while $i < @$pairs;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub to_hash {
|
||||
my $self = shift;
|
||||
|
||||
my %hash;
|
||||
my $pairs = $self->pairs;
|
||||
for (my $i = 0; $i < @$pairs; $i += 2) {
|
||||
my ($name, $value) = @{$pairs}[$i, $i + 1];
|
||||
|
||||
# Array
|
||||
if (exists $hash{$name}) {
|
||||
$hash{$name} = [$hash{$name}] if ref $hash{$name} ne 'ARRAY';
|
||||
push @{$hash{$name}}, $value;
|
||||
}
|
||||
|
||||
# String
|
||||
else { $hash{$name} = $value }
|
||||
}
|
||||
|
||||
return \%hash;
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
# String (RFC 3986)
|
||||
my $charset = $self->charset;
|
||||
if (defined(my $str = $self->{string})) {
|
||||
$str = encode $charset, $str if $charset;
|
||||
return url_escape $str, '^A-Za-z0-9\-._~%!$&\'()*+,;=:@/?';
|
||||
}
|
||||
|
||||
# Build pairs (HTML Living Standard)
|
||||
my $pairs = $self->pairs;
|
||||
return '' unless @$pairs;
|
||||
my @pairs;
|
||||
for (my $i = 0; $i < @$pairs; $i += 2) {
|
||||
my ($name, $value) = @{$pairs}[$i, $i + 1];
|
||||
|
||||
# Escape and replace whitespace with "+"
|
||||
$name = encode $charset, $name if $charset;
|
||||
$name = url_escape $name, '^*\-.0-9A-Z_a-z';
|
||||
$value = encode $charset, $value if $charset;
|
||||
$value = url_escape $value, '^*\-.0-9A-Z_a-z';
|
||||
s/\%20/\+/g for $name, $value;
|
||||
|
||||
push @pairs, "$name=$value";
|
||||
}
|
||||
|
||||
return join '&', @pairs;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Parameters - Parameters
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Parameters;
|
||||
|
||||
# Parse
|
||||
my $params = Mojo::Parameters->new('foo=bar&baz=23');
|
||||
say $params->param('baz');
|
||||
|
||||
# Build
|
||||
my $params = Mojo::Parameters->new(foo => 'bar', baz => 23);
|
||||
push @$params, i => '♥ mojolicious';
|
||||
say "$params";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Parameters> is a container for form parameters used by L<Mojo::URL>, based on L<RFC
|
||||
3986|https://tools.ietf.org/html/rfc3986> and the L<HTML Living Standard|https://html.spec.whatwg.org>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Parameters> implements the following attributes.
|
||||
|
||||
=head2 charset
|
||||
|
||||
my $charset = $params->charset;
|
||||
$params = $params->charset('UTF-8');
|
||||
|
||||
Charset used for encoding and decoding parameters, defaults to C<UTF-8>.
|
||||
|
||||
# Disable encoding and decoding
|
||||
$params->charset(undef);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Parameters> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 append
|
||||
|
||||
$params = $params->append(foo => 'ba&r');
|
||||
$params = $params->append(foo => ['ba&r', 'baz']);
|
||||
$params = $params->append(foo => ['bar', 'baz'], bar => 23);
|
||||
$params = $params->append(Mojo::Parameters->new);
|
||||
|
||||
Append parameters. Note that this method will normalize the parameters.
|
||||
|
||||
# "foo=bar&foo=baz"
|
||||
Mojo::Parameters->new('foo=bar')->append(Mojo::Parameters->new('foo=baz'));
|
||||
|
||||
# "foo=bar&foo=baz"
|
||||
Mojo::Parameters->new('foo=bar')->append(foo => 'baz');
|
||||
|
||||
# "foo=bar&foo=baz&foo=yada"
|
||||
Mojo::Parameters->new('foo=bar')->append(foo => ['baz', 'yada']);
|
||||
|
||||
# "foo=bar&foo=baz&foo=yada&bar=23"
|
||||
Mojo::Parameters->new('foo=bar')->append(foo => ['baz', 'yada'], bar => 23);
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $params2 = $params->clone;
|
||||
|
||||
Return a new L<Mojo::Parameters> object cloned from these parameters.
|
||||
|
||||
=head2 every_param
|
||||
|
||||
my $values = $params->every_param('foo');
|
||||
|
||||
Similar to L</"param">, but returns all values sharing the same name as an array reference. Note that this method will
|
||||
normalize the parameters.
|
||||
|
||||
# Get first value
|
||||
say $params->every_param('foo')->[0];
|
||||
|
||||
=head2 merge
|
||||
|
||||
$params = $params->merge(foo => 'ba&r');
|
||||
$params = $params->merge(foo => ['ba&r', 'baz']);
|
||||
$params = $params->merge(foo => ['bar', 'baz'], bar => 23);
|
||||
$params = $params->merge(Mojo::Parameters->new);
|
||||
|
||||
Merge parameters. Note that this method will normalize the parameters.
|
||||
|
||||
# "foo=baz"
|
||||
Mojo::Parameters->new('foo=bar')->merge(Mojo::Parameters->new('foo=baz'));
|
||||
|
||||
# "yada=yada&foo=baz"
|
||||
Mojo::Parameters->new('foo=bar&yada=yada')->merge(foo => 'baz');
|
||||
|
||||
# "yada=yada"
|
||||
Mojo::Parameters->new('foo=bar&yada=yada')->merge(foo => undef);
|
||||
|
||||
=head2 names
|
||||
|
||||
my $names = $params->names;
|
||||
|
||||
Return an array reference with all parameter names.
|
||||
|
||||
# Names of all parameters
|
||||
say for @{$params->names};
|
||||
|
||||
=head2 new
|
||||
|
||||
my $params = Mojo::Parameters->new;
|
||||
my $params = Mojo::Parameters->new('foo=b%3Bar&baz=23');
|
||||
my $params = Mojo::Parameters->new(foo => 'b&ar');
|
||||
my $params = Mojo::Parameters->new(foo => ['ba&r', 'baz']);
|
||||
my $params = Mojo::Parameters->new(foo => ['bar', 'baz'], bar => 23);
|
||||
|
||||
Construct a new L<Mojo::Parameters> object and L</"parse"> parameters if necessary.
|
||||
|
||||
=head2 pairs
|
||||
|
||||
my $array = $params->pairs;
|
||||
$params = $params->pairs([foo => 'b&ar', baz => 23]);
|
||||
|
||||
Parsed parameter pairs. Note that this method will normalize the parameters.
|
||||
|
||||
# Remove all parameters
|
||||
$params->pairs([]);
|
||||
|
||||
=head2 param
|
||||
|
||||
my $value = $params->param('foo');
|
||||
$params = $params->param(foo => 'ba&r');
|
||||
$params = $params->param(foo => qw(ba&r baz));
|
||||
$params = $params->param(foo => ['ba;r', 'baz']);
|
||||
|
||||
Access parameter values. If there are multiple values sharing the same name, and you want to access more than just the
|
||||
last one, you can use L</"every_param">. Note that this method will normalize the parameters.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$params = $params->parse('foo=b%3Bar&baz=23');
|
||||
|
||||
Parse parameters.
|
||||
|
||||
=head2 remove
|
||||
|
||||
$params = $params->remove('foo');
|
||||
|
||||
Remove parameters. Note that this method will normalize the parameters.
|
||||
|
||||
# "bar=yada"
|
||||
Mojo::Parameters->new('foo=bar&foo=baz&bar=yada')->remove('foo');
|
||||
|
||||
=head2 to_hash
|
||||
|
||||
my $hash = $params->to_hash;
|
||||
|
||||
Turn parameters into a hash reference. Note that this method will normalize the parameters.
|
||||
|
||||
# "baz"
|
||||
Mojo::Parameters->new('foo=bar&foo=baz')->to_hash->{foo}[1];
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $params->to_string;
|
||||
|
||||
Turn parameters into a string.
|
||||
|
||||
# "foo=bar&baz=23"
|
||||
Mojo::Parameters->new->pairs([foo => 'bar', baz => 23])->to_string;
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Parameters> overloads the following operators.
|
||||
|
||||
=head2 array
|
||||
|
||||
my @pairs = @$params;
|
||||
|
||||
Alias for L</"pairs">. Note that this will normalize the parameters.
|
||||
|
||||
say $params->[0];
|
||||
say for @$params;
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$params;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$params";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
343
database/perl/vendor/lib/Mojo/Path.pm
vendored
Normal file
343
database/perl/vendor/lib/Mojo/Path.pm
vendored
Normal file
@@ -0,0 +1,343 @@
|
||||
package Mojo::Path;
|
||||
use Mojo::Base -base;
|
||||
use overload '@{}' => sub { shift->parts }, bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Mojo::Util qw(decode encode url_escape url_unescape);
|
||||
|
||||
has charset => 'UTF-8';
|
||||
|
||||
sub canonicalize {
|
||||
my $self = shift;
|
||||
|
||||
my $parts = $self->parts;
|
||||
for (my $i = 0; $i <= $#$parts;) {
|
||||
if (!length $parts->[$i] || $parts->[$i] eq '.' || $parts->[$i] eq '...') { splice @$parts, $i, 1 }
|
||||
elsif ($i < 1 || $parts->[$i] ne '..' || $parts->[$i - 1] eq '..') { $i++ }
|
||||
else { splice @$parts, --$i, 2 }
|
||||
}
|
||||
|
||||
return @$parts ? $self : $self->trailing_slash(undef);
|
||||
}
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
|
||||
my $clone = $self->new;
|
||||
if (exists $self->{charset}) { $clone->{charset} = $self->{charset} }
|
||||
if (my $parts = $self->{parts}) {
|
||||
$clone->{$_} = $self->{$_} for qw(leading_slash trailing_slash);
|
||||
$clone->{parts} = [@$parts];
|
||||
}
|
||||
else { $clone->{path} = $self->{path} }
|
||||
|
||||
return $clone;
|
||||
}
|
||||
|
||||
sub contains { $_[1] eq '/' || $_[0]->to_route =~ m!^\Q$_[1]\E(?:/|$)! }
|
||||
|
||||
sub leading_slash { shift->_parse(leading_slash => @_) }
|
||||
|
||||
sub merge {
|
||||
my ($self, $path) = @_;
|
||||
|
||||
# Replace
|
||||
return $self->parse($path) if $path =~ m!^/!;
|
||||
|
||||
# Merge
|
||||
pop @{$self->parts} unless $self->trailing_slash;
|
||||
$path = $self->new($path);
|
||||
push @{$self->parts}, @{$path->parts};
|
||||
return $self->trailing_slash($path->trailing_slash);
|
||||
}
|
||||
|
||||
sub new { @_ > 1 ? shift->SUPER::new->parse(@_) : shift->SUPER::new }
|
||||
|
||||
sub parse {
|
||||
my $self = shift;
|
||||
$self->{path} = shift;
|
||||
delete @$self{qw(leading_slash parts trailing_slash)};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub parts { shift->_parse(parts => @_) }
|
||||
|
||||
sub to_abs_string {
|
||||
my $path = shift->to_string;
|
||||
return $path =~ m!^/! ? $path : "/$path";
|
||||
}
|
||||
|
||||
sub to_dir {
|
||||
my $clone = shift->clone;
|
||||
pop @{$clone->parts} unless $clone->trailing_slash;
|
||||
return $clone->trailing_slash(!!@{$clone->parts});
|
||||
}
|
||||
|
||||
sub to_route {
|
||||
my $clone = shift->clone;
|
||||
return '/' . join '/', @{$clone->parts}, $clone->trailing_slash ? '' : ();
|
||||
}
|
||||
|
||||
sub to_string {
|
||||
my $self = shift;
|
||||
|
||||
# Path
|
||||
my $charset = $self->charset;
|
||||
if (defined(my $path = $self->{path})) {
|
||||
$path = encode $charset, $path if $charset;
|
||||
return url_escape $path, '^A-Za-z0-9\-._~!$&\'()*+,;=%:@/';
|
||||
}
|
||||
|
||||
# Build path
|
||||
my @parts = @{$self->parts};
|
||||
@parts = map { encode $charset, $_ } @parts if $charset;
|
||||
my $path = join '/', map { url_escape $_, '^A-Za-z0-9\-._~!$&\'()*+,;=:@' } @parts;
|
||||
$path = "/$path" if $self->leading_slash;
|
||||
$path = "$path/" if $self->trailing_slash;
|
||||
return $path;
|
||||
}
|
||||
|
||||
sub trailing_slash { shift->_parse(trailing_slash => @_) }
|
||||
|
||||
sub _parse {
|
||||
my ($self, $name) = (shift, shift);
|
||||
|
||||
unless ($self->{parts}) {
|
||||
my $path = url_unescape delete($self->{path}) // '';
|
||||
my $charset = $self->charset;
|
||||
$path = decode($charset, $path) // $path if $charset;
|
||||
$self->{leading_slash} = $path =~ s!^/!!;
|
||||
$self->{trailing_slash} = $path =~ s!/$!!;
|
||||
$self->{parts} = [split /\//, $path, -1];
|
||||
}
|
||||
|
||||
return $self->{$name} unless @_;
|
||||
$self->{$name} = shift;
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Path - Path
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Path;
|
||||
|
||||
# Parse
|
||||
my $path = Mojo::Path->new('/foo%2Fbar%3B/baz.html');
|
||||
say $path->[0];
|
||||
|
||||
# Build
|
||||
my $path = Mojo::Path->new('/i/♥');
|
||||
push @$path, 'mojolicious';
|
||||
say "$path";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Path> is a container for paths used by L<Mojo::URL>, based on L<RFC 3986|https://tools.ietf.org/html/rfc3986>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Path> implements the following attributes.
|
||||
|
||||
=head2 charset
|
||||
|
||||
my $charset = $path->charset;
|
||||
$path = $path->charset('UTF-8');
|
||||
|
||||
Charset used for encoding and decoding, defaults to C<UTF-8>.
|
||||
|
||||
# Disable encoding and decoding
|
||||
$path->charset(undef);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Path> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 canonicalize
|
||||
|
||||
$path = $path->canonicalize;
|
||||
|
||||
Canonicalize path by resolving C<.> and C<..>, in addition C<...> will be treated as C<.> to protect from path
|
||||
traversal attacks.
|
||||
|
||||
# "/foo/baz"
|
||||
Mojo::Path->new('/foo/./bar/../baz')->canonicalize;
|
||||
|
||||
# "/../baz"
|
||||
Mojo::Path->new('/foo/../bar/../../baz')->canonicalize;
|
||||
|
||||
# "/foo/bar"
|
||||
Mojo::Path->new('/foo/.../bar')->canonicalize;
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $clone = $path->clone;
|
||||
|
||||
Return a new L<Mojo::Path> object cloned from this path.
|
||||
|
||||
=head2 contains
|
||||
|
||||
my $bool = $path->contains('/i/♥/mojolicious');
|
||||
|
||||
Check if path contains given prefix.
|
||||
|
||||
# True
|
||||
Mojo::Path->new('/foo/bar')->contains('/');
|
||||
Mojo::Path->new('/foo/bar')->contains('/foo');
|
||||
Mojo::Path->new('/foo/bar')->contains('/foo/bar');
|
||||
|
||||
# False
|
||||
Mojo::Path->new('/foo/bar')->contains('/f');
|
||||
Mojo::Path->new('/foo/bar')->contains('/bar');
|
||||
Mojo::Path->new('/foo/bar')->contains('/whatever');
|
||||
|
||||
=head2 leading_slash
|
||||
|
||||
my $bool = $path->leading_slash;
|
||||
$path = $path->leading_slash($bool);
|
||||
|
||||
Path has a leading slash. Note that this method will normalize the path and that C<%2F> will be treated as C</> for
|
||||
security reasons.
|
||||
|
||||
# "/foo/bar"
|
||||
Mojo::Path->new('foo/bar')->leading_slash(1);
|
||||
|
||||
# "foo/bar"
|
||||
Mojo::Path->new('/foo/bar')->leading_slash(0);
|
||||
|
||||
=head2 merge
|
||||
|
||||
$path = $path->merge('/foo/bar');
|
||||
$path = $path->merge('foo/bar');
|
||||
$path = $path->merge(Mojo::Path->new);
|
||||
|
||||
Merge paths. Note that this method will normalize both paths if necessary and that C<%2F> will be treated as C</> for
|
||||
security reasons.
|
||||
|
||||
# "/baz/yada"
|
||||
Mojo::Path->new('/foo/bar')->merge('/baz/yada');
|
||||
|
||||
# "/foo/baz/yada"
|
||||
Mojo::Path->new('/foo/bar')->merge('baz/yada');
|
||||
|
||||
# "/foo/bar/baz/yada"
|
||||
Mojo::Path->new('/foo/bar/')->merge('baz/yada');
|
||||
|
||||
=head2 new
|
||||
|
||||
my $path = Mojo::Path->new;
|
||||
my $path = Mojo::Path->new('/foo%2Fbar%3B/baz.html');
|
||||
|
||||
Construct a new L<Mojo::Path> object and L</"parse"> path if necessary.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$path = $path->parse('/foo%2Fbar%3B/baz.html');
|
||||
|
||||
Parse path.
|
||||
|
||||
=head2 to_abs_string
|
||||
|
||||
my $str = $path->to_abs_string;
|
||||
|
||||
Turn path into an absolute string.
|
||||
|
||||
# "/i/%E2%99%A5/mojolicious"
|
||||
Mojo::Path->new('/i/%E2%99%A5/mojolicious')->to_abs_string;
|
||||
Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_abs_string;
|
||||
|
||||
=head2 parts
|
||||
|
||||
my $parts = $path->parts;
|
||||
$path = $path->parts([qw(foo bar baz)]);
|
||||
|
||||
The path parts. Note that this method will normalize the path and that C<%2F> will be treated as C</> for security
|
||||
reasons.
|
||||
|
||||
# Part with slash
|
||||
push @{$path->parts}, 'foo/bar';
|
||||
|
||||
=head2 to_dir
|
||||
|
||||
my $dir = $route->to_dir;
|
||||
|
||||
Clone path and remove everything after the right-most slash.
|
||||
|
||||
# "/i/%E2%99%A5/"
|
||||
Mojo::Path->new('/i/%E2%99%A5/mojolicious')->to_dir->to_abs_string;
|
||||
|
||||
# "i/%E2%99%A5/"
|
||||
Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_dir->to_abs_string;
|
||||
|
||||
=head2 to_route
|
||||
|
||||
my $route = $path->to_route;
|
||||
|
||||
Turn path into a route.
|
||||
|
||||
# "/i/♥/mojolicious"
|
||||
Mojo::Path->new('/i/%E2%99%A5/mojolicious')->to_route;
|
||||
Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_route;
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $path->to_string;
|
||||
|
||||
Turn path into a string.
|
||||
|
||||
# "/i/%E2%99%A5/mojolicious"
|
||||
Mojo::Path->new('/i/%E2%99%A5/mojolicious')->to_string;
|
||||
|
||||
# "i/%E2%99%A5/mojolicious"
|
||||
Mojo::Path->new('i/%E2%99%A5/mojolicious')->to_string;
|
||||
|
||||
=head2 trailing_slash
|
||||
|
||||
my $bool = $path->trailing_slash;
|
||||
$path = $path->trailing_slash($bool);
|
||||
|
||||
Path has a trailing slash. Note that this method will normalize the path and that C<%2F> will be treated as C</> for
|
||||
security reasons.
|
||||
|
||||
# "/foo/bar/"
|
||||
Mojo::Path->new('/foo/bar')->trailing_slash(1);
|
||||
|
||||
# "/foo/bar"
|
||||
Mojo::Path->new('/foo/bar/')->trailing_slash(0);
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::Path> overloads the following operators.
|
||||
|
||||
=head2 array
|
||||
|
||||
my @parts = @$path;
|
||||
|
||||
Alias for L</"parts">. Note that this will normalize the path and that C<%2F> will be treated as C</> for security
|
||||
reasons.
|
||||
|
||||
say $path->[0];
|
||||
say for @$path;
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$path;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$path";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
541
database/perl/vendor/lib/Mojo/Promise.pm
vendored
Normal file
541
database/perl/vendor/lib/Mojo/Promise.pm
vendored
Normal file
@@ -0,0 +1,541 @@
|
||||
package Mojo::Promise;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Carp qw(carp);
|
||||
use Mojo::Exception;
|
||||
use Mojo::IOLoop;
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_PROMISE_DEBUG} || 0;
|
||||
|
||||
has ioloop => sub { Mojo::IOLoop->singleton }, weak => 1;
|
||||
|
||||
sub AWAIT_CHAIN_CANCEL { }
|
||||
|
||||
sub AWAIT_CLONE { _await('clone', @_) }
|
||||
|
||||
sub AWAIT_DONE { shift->resolve(@_) }
|
||||
sub AWAIT_FAIL { shift->reject(@_) }
|
||||
|
||||
sub AWAIT_GET {
|
||||
my $self = shift;
|
||||
my @results = @{$self->{results} // []};
|
||||
die $results[0] unless $self->{status} eq 'resolve';
|
||||
return wantarray ? @results : $results[0];
|
||||
}
|
||||
|
||||
sub AWAIT_IS_CANCELLED {undef}
|
||||
|
||||
sub AWAIT_IS_READY {
|
||||
my $self = shift;
|
||||
$self->{handled} = 1;
|
||||
return !!$self->{results} && !@{$self->{resolve}} && !@{$self->{reject}};
|
||||
}
|
||||
|
||||
sub AWAIT_NEW_DONE { _await('resolve', @_) }
|
||||
sub AWAIT_NEW_FAIL { _await('reject', @_) }
|
||||
|
||||
sub AWAIT_ON_CANCEL { }
|
||||
|
||||
sub AWAIT_ON_READY {
|
||||
shift->_finally(0, @_)->catch(sub { });
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
return if $self->{handled} || ($self->{status} // '') ne 'reject' || !$self->{results};
|
||||
carp "Unhandled rejected promise: @{$self->{results}}";
|
||||
warn $self->{debug}->message("-- Destroyed promise\n")->verbose(1)->to_string if DEBUG;
|
||||
}
|
||||
|
||||
sub all { _all(2, @_) }
|
||||
sub all_settled { _all(0, @_) }
|
||||
sub any { _all(3, @_) }
|
||||
|
||||
sub catch { shift->then(undef, shift) }
|
||||
|
||||
sub clone { $_[0]->new->ioloop($_[0]->ioloop) }
|
||||
|
||||
sub finally { shift->_finally(1, @_) }
|
||||
|
||||
sub map {
|
||||
my ($class, $options, $cb, @items) = (shift, ref $_[0] eq 'HASH' ? shift : {}, @_);
|
||||
|
||||
return $class->all(map { $_->$cb } @items) if !$options->{concurrency} || @items <= $options->{concurrency};
|
||||
|
||||
my @start = map { $_->$cb } splice @items, 0, $options->{concurrency};
|
||||
my @wait = map { $start[0]->clone } 0 .. $#items;
|
||||
|
||||
my $start_next = sub {
|
||||
return () unless my $item = shift @items;
|
||||
my ($start_next, $chain) = (__SUB__, shift @wait);
|
||||
$_->$cb->then(sub { $chain->resolve(@_); $start_next->() }, sub { $chain->reject(@_); @items = () }) for $item;
|
||||
return ();
|
||||
};
|
||||
|
||||
$_->then($start_next, sub { }) for @start;
|
||||
|
||||
return $class->all(@start, @wait);
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $self = shift->SUPER::new;
|
||||
$self->{debug} = Mojo::Exception->new->trace if DEBUG;
|
||||
shift->(sub { $self->resolve(@_) }, sub { $self->reject(@_) }) if @_;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub race { _all(1, @_) }
|
||||
|
||||
sub reject { shift->_settle('reject', @_) }
|
||||
sub resolve { shift->_settle('resolve', @_) }
|
||||
|
||||
sub then {
|
||||
my ($self, $resolve, $reject) = @_;
|
||||
|
||||
my $new = $self->clone;
|
||||
$self->{handled} = 1;
|
||||
push @{$self->{resolve}}, sub { _then_cb($new, $resolve, 'resolve', @_) };
|
||||
push @{$self->{reject}}, sub { _then_cb($new, $reject, 'reject', @_) };
|
||||
|
||||
$self->_defer if $self->{results};
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub timer { shift->_timer('resolve', @_) }
|
||||
sub timeout { shift->_timer('reject', @_) }
|
||||
|
||||
sub wait {
|
||||
my $self = shift;
|
||||
return if (my $loop = $self->ioloop)->is_running;
|
||||
my $done;
|
||||
$self->_finally(0, sub { $done++; $loop->stop })->catch(sub { });
|
||||
$loop->start until $done;
|
||||
}
|
||||
|
||||
sub _all {
|
||||
my ($type, $class, @promises) = @_;
|
||||
|
||||
my $all = $promises[0]->clone;
|
||||
my $results = [];
|
||||
my $remaining = scalar @promises;
|
||||
for my $i (0 .. $#promises) {
|
||||
|
||||
# "race"
|
||||
if ($type == 1) {
|
||||
$promises[$i]->then(sub { $all->resolve(@_); () }, sub { $all->reject(@_); () });
|
||||
}
|
||||
|
||||
# "all"
|
||||
elsif ($type == 2) {
|
||||
$promises[$i]->then(
|
||||
sub {
|
||||
$results->[$i] = [@_];
|
||||
$all->resolve(@$results) if --$remaining <= 0;
|
||||
return ();
|
||||
},
|
||||
sub { $all->reject(@_); () }
|
||||
);
|
||||
}
|
||||
|
||||
# "any"
|
||||
elsif ($type == 3) {
|
||||
$promises[$i]->then(
|
||||
sub { $all->resolve(@_); () },
|
||||
sub {
|
||||
$results->[$i] = [@_];
|
||||
$all->reject(@$results) if --$remaining <= 0;
|
||||
return ();
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
# "all_settled"
|
||||
else {
|
||||
$promises[$i]->then(
|
||||
sub {
|
||||
$results->[$i] = {status => 'fulfilled', value => [@_]};
|
||||
$all->resolve(@$results) if --$remaining <= 0;
|
||||
return ();
|
||||
},
|
||||
sub {
|
||||
$results->[$i] = {status => 'rejected', reason => [@_]};
|
||||
$all->resolve(@$results) if --$remaining <= 0;
|
||||
return ();
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
return $all;
|
||||
}
|
||||
|
||||
sub _await {
|
||||
my ($method, $class) = (shift, shift);
|
||||
my $promise = $class->$method(@_);
|
||||
$promise->{cycle} = $promise;
|
||||
return $promise;
|
||||
}
|
||||
|
||||
sub _defer {
|
||||
my $self = shift;
|
||||
|
||||
return unless my $results = $self->{results};
|
||||
my $cbs = $self->{status} eq 'resolve' ? $self->{resolve} : $self->{reject};
|
||||
@{$self}{qw(cycle resolve reject)} = (undef, [], []);
|
||||
|
||||
$self->ioloop->next_tick(sub { $_->(@$results) for @$cbs });
|
||||
}
|
||||
|
||||
sub _finally {
|
||||
my ($self, $handled, $finally) = @_;
|
||||
|
||||
my $new = $self->clone;
|
||||
$self->{handled} = 1 if $handled;
|
||||
push @{$self->{resolve}}, sub { _finally_cb($new, $finally, 'resolve', @_) };
|
||||
push @{$self->{reject}}, sub { _finally_cb($new, $finally, 'reject', @_) };
|
||||
|
||||
$self->_defer if $self->{results};
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub _finally_cb {
|
||||
my ($new, $finally, $method, @results) = @_;
|
||||
return $new->reject($@) unless eval { $finally->(); 1 };
|
||||
return $new->$method(@results);
|
||||
}
|
||||
|
||||
sub _settle {
|
||||
my ($self, $status, @results) = @_;
|
||||
|
||||
my $thenable = blessed $results[0] && $results[0]->can('then');
|
||||
unless (ref $self) {
|
||||
return $results[0] if $thenable && $status eq 'resolve' && $results[0]->isa('Mojo::Promise');
|
||||
$self = $self->new;
|
||||
}
|
||||
|
||||
if ($thenable && $status eq 'resolve') {
|
||||
$results[0]->then(sub { $self->resolve(@_); () }, sub { $self->reject(@_); () });
|
||||
}
|
||||
|
||||
elsif (!$self->{results}) {
|
||||
@{$self}{qw(results status)} = (\@results, $status);
|
||||
$self->_defer;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _then_cb {
|
||||
my ($new, $cb, $method, @results) = @_;
|
||||
|
||||
return $new->$method(@results) unless defined $cb;
|
||||
|
||||
my @res;
|
||||
return $new->reject($@) unless eval { @res = $cb->(@results); 1 };
|
||||
return $new->resolve(@res);
|
||||
}
|
||||
|
||||
sub _timer {
|
||||
my ($self, $method, $after, @results) = @_;
|
||||
$self = $self->new unless ref $self;
|
||||
$results[0] = 'Promise timeout' if $method eq 'reject' && !@results;
|
||||
$self->ioloop->timer($after => sub { $self->$method(@results) });
|
||||
return $self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Promise - Promises/A+
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Promise;
|
||||
use Mojo::UserAgent;
|
||||
|
||||
# Wrap continuation-passing style APIs with promises
|
||||
my $ua = Mojo::UserAgent->new;
|
||||
sub get_p {
|
||||
my $promise = Mojo::Promise->new;
|
||||
$ua->get(@_ => sub ($ua, $tx) {
|
||||
my $err = $tx->error;
|
||||
if (!$err || $err->{code}) { $promise->resolve($tx) }
|
||||
else { $promise->reject($err->{message}) }
|
||||
});
|
||||
return $promise;
|
||||
}
|
||||
|
||||
# Perform non-blocking operations sequentially
|
||||
get_p('https://mojolicious.org')->then(sub ($mojo) {
|
||||
say $mojo->res->code;
|
||||
return get_p('https://metacpan.org');
|
||||
})->then(sub ($cpan) {
|
||||
say $cpan->res->code;
|
||||
})->catch(sub ($err) {
|
||||
warn "Something went wrong: $err";
|
||||
})->wait;
|
||||
|
||||
# Synchronize non-blocking operations (all)
|
||||
my $mojo = get_p('https://mojolicious.org');
|
||||
my $cpan = get_p('https://metacpan.org');
|
||||
Mojo::Promise->all($mojo, $cpan)->then(sub ($mojo, $cpan) {
|
||||
say $mojo->[0]->res->code;
|
||||
say $cpan->[0]->res->code;
|
||||
})->catch(sub ($err) {
|
||||
warn "Something went wrong: $err";
|
||||
})->wait;
|
||||
|
||||
# Synchronize non-blocking operations (race)
|
||||
my $mojo = get_p('https://mojolicious.org');
|
||||
my $cpan = get_p('https://metacpan.org');
|
||||
Mojo::Promise->race($mojo, $cpan)->then(sub ($tx) {
|
||||
say $tx->req->url, ' won!';
|
||||
})->catch(sub ($err) {
|
||||
warn "Something went wrong: $err";
|
||||
})->wait;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Promise> is a Perl-ish implementation of L<Promises/A+|https://promisesaplus.com> and a superset of L<ES6
|
||||
Promises|https://duckduckgo.com/?q=\mdn%20Promise>.
|
||||
|
||||
=head1 STATES
|
||||
|
||||
A promise is an object representing the eventual completion or failure of a non-blocking operation. It allows
|
||||
non-blocking functions to return values, like blocking functions. But instead of immediately returning the final value,
|
||||
the non-blocking function returns a promise to supply the value at some point in the future.
|
||||
|
||||
A promise can be in one of three states:
|
||||
|
||||
=over 2
|
||||
|
||||
=item pending
|
||||
|
||||
Initial state, neither fulfilled nor rejected.
|
||||
|
||||
=item fulfilled
|
||||
|
||||
Meaning that the operation completed successfully.
|
||||
|
||||
=item rejected
|
||||
|
||||
Meaning that the operation failed.
|
||||
|
||||
=back
|
||||
|
||||
A pending promise can either be fulfilled with a value or rejected with a reason. When either happens, the associated
|
||||
handlers queued up by a promise's L</"then"> method are called.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Promise> implements the following attributes.
|
||||
|
||||
=head2 ioloop
|
||||
|
||||
my $loop = $promise->ioloop;
|
||||
$promise = $promise->ioloop(Mojo::IOLoop->new);
|
||||
|
||||
Event loop object to control, defaults to the global L<Mojo::IOLoop> singleton. Note that this attribute is weakened.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Promise> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 all
|
||||
|
||||
my $new = Mojo::Promise->all(@promises);
|
||||
|
||||
Returns a new L<Mojo::Promise> object that either fulfills when all of the passed L<Mojo::Promise> objects have
|
||||
fulfilled or rejects as soon as one of them rejects. If the returned promise fulfills, it is fulfilled with the values
|
||||
from the fulfilled promises in the same order as the passed promises.
|
||||
|
||||
=head2 all_settled
|
||||
|
||||
my $new = Mojo::Promise->all_settled(@promises);
|
||||
|
||||
Returns a new L<Mojo::Promise> object that fulfills when all of the passed L<Mojo::Promise> objects have fulfilled or
|
||||
rejected, with hash references that describe the outcome of each promise.
|
||||
|
||||
=head2 any
|
||||
|
||||
my $new = Mojo::Promise->any(@promises);
|
||||
|
||||
Returns a new L<Mojo::Promise> object that fulfills as soon as one of the passed L<Mojo::Promise> objects fulfills,
|
||||
with the value from that promise. If no promises fulfill, it is rejected with the reasons from the rejected promises in
|
||||
the same order as the passed promises. Note that this method is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
=head2 catch
|
||||
|
||||
my $new = $promise->catch(sub {...});
|
||||
|
||||
Appends a rejection handler callback to the promise, and returns a new L<Mojo::Promise> object resolving to the return
|
||||
value of the callback if it is called, or to its original fulfillment value if the promise is instead fulfilled.
|
||||
|
||||
# Longer version
|
||||
my $new = $promise->then(undef, sub {...});
|
||||
|
||||
# Pass along the rejection reason
|
||||
$promise->catch(sub (@reason) {
|
||||
warn "Something went wrong: $reason[0]";
|
||||
return @reason;
|
||||
});
|
||||
|
||||
# Change the rejection reason
|
||||
$promise->catch(sub (@reason) { "This is bad: $reason[0]" });
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $new = $promise->clone;
|
||||
|
||||
Return a new L<Mojo::Promise> object cloned from this promise that is still pending.
|
||||
|
||||
=head2 finally
|
||||
|
||||
my $new = $promise->finally(sub {...});
|
||||
|
||||
Appends a fulfillment and rejection handler to the promise, and returns a new L<Mojo::Promise> object resolving to the
|
||||
original fulfillment value or rejection reason.
|
||||
|
||||
# Do something on fulfillment and rejection
|
||||
$promise->finally(sub { say "We are done!" });
|
||||
|
||||
=head2 map
|
||||
|
||||
my $new = Mojo::Promise->map(sub {...}, @items);
|
||||
my $new = Mojo::Promise->map({concurrency => 3}, sub {...}, @items);
|
||||
|
||||
Apply a function that returns a L<Mojo::Promise> to each item in a list of items while optionally limiting concurrency.
|
||||
Returns a L<Mojo::Promise> that collects the results in the same manner as L</all>. If any item's promise is rejected,
|
||||
any remaining items which have not yet been mapped will not be. Note that this method is B<EXPERIMENTAL> and might
|
||||
change without warning!
|
||||
|
||||
# Perform 3 requests at a time concurrently
|
||||
Mojo::Promise->map({concurrency => 3}, sub { $ua->get_p($_) }, @urls)
|
||||
->then(sub{ say $_->[0]->res->dom->at('title')->text for @_ });
|
||||
|
||||
These options are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item concurrency
|
||||
|
||||
concurrency => 3
|
||||
|
||||
The maximum number of items that are in progress at the same time.
|
||||
|
||||
=back
|
||||
|
||||
=head2 new
|
||||
|
||||
my $promise = Mojo::Promise->new;
|
||||
my $promise = Mojo::Promise->new(sub {...});
|
||||
|
||||
Construct a new L<Mojo::Promise> object.
|
||||
|
||||
# Wrap a continuation-passing style API
|
||||
my $promise = Mojo::Promise->new(sub ($resolve, $reject) {
|
||||
Mojo::IOLoop->timer(5 => sub {
|
||||
if (int rand 2) { $resolve->('Lucky!') }
|
||||
else { $reject->('Unlucky!') }
|
||||
});
|
||||
});
|
||||
|
||||
=head2 race
|
||||
|
||||
my $new = Mojo::Promise->race(@promises);
|
||||
|
||||
Returns a new L<Mojo::Promise> object that fulfills or rejects as soon as one of the passed L<Mojo::Promise> objects
|
||||
fulfills or rejects, with the value or reason from that promise.
|
||||
|
||||
=head2 reject
|
||||
|
||||
my $new = Mojo::Promise->reject(@reason);
|
||||
$promise = $promise->reject(@reason);
|
||||
|
||||
Build rejected L<Mojo::Promise> object or reject the promise with one or more rejection reasons.
|
||||
|
||||
# Longer version
|
||||
my $promise = Mojo::Promise->new->reject(@reason);
|
||||
|
||||
=head2 resolve
|
||||
|
||||
my $new = Mojo::Promise->resolve(@value);
|
||||
$promise = $promise->resolve(@value);
|
||||
|
||||
Build resolved L<Mojo::Promise> object or resolve the promise with one or more fulfillment values.
|
||||
|
||||
# Longer version
|
||||
my $promise = Mojo::Promise->new->resolve(@value);
|
||||
|
||||
=head2 then
|
||||
|
||||
my $new = $promise->then(sub {...});
|
||||
my $new = $promise->then(sub {...}, sub {...});
|
||||
my $new = $promise->then(undef, sub {...});
|
||||
|
||||
Appends fulfillment and rejection handlers to the promise, and returns a new L<Mojo::Promise> object resolving to the
|
||||
return value of the called handler.
|
||||
|
||||
# Pass along the fulfillment value or rejection reason
|
||||
$promise->then(
|
||||
sub (@value) {
|
||||
say "The result is $value[0]";
|
||||
return @value;
|
||||
},
|
||||
sub (@reason) {
|
||||
warn "Something went wrong: $reason[0]";
|
||||
return @reason;
|
||||
}
|
||||
);
|
||||
|
||||
# Change the fulfillment value or rejection reason
|
||||
$promise->then(
|
||||
sub (@value) { return "This is good: $value[0]" },
|
||||
sub (@reason) { return "This is bad: $reason[0]" }
|
||||
);
|
||||
|
||||
=head2 timer
|
||||
|
||||
my $new = Mojo::Promise->timer(5 => 'Success!');
|
||||
$promise = $promise->timer(5 => 'Success!');
|
||||
$promise = $promise->timer(5);
|
||||
|
||||
Create a new L<Mojo::Promise> object with a timer or attach a timer to an existing promise. The promise will be
|
||||
resolved after the given amount of time in seconds with or without a value. Note that this method is B<EXPERIMENTAL>
|
||||
and might change without warning!
|
||||
|
||||
=head2 timeout
|
||||
|
||||
my $new = Mojo::Promise->timeout(5 => 'Timeout!');
|
||||
$promise = $promise->timeout(5 => 'Timeout!');
|
||||
$promise = $promise->timeout(5);
|
||||
|
||||
Create a new L<Mojo::Promise> object with a timeout or attach a timeout to an existing promise. The promise will be
|
||||
rejected after the given amount of time in seconds with a reason, which defaults to C<Promise timeout>. Note that this
|
||||
method is B<EXPERIMENTAL> and might change without warning!
|
||||
|
||||
=head2 wait
|
||||
|
||||
$promise->wait;
|
||||
|
||||
Start L</"ioloop"> and stop it again once the promise has been fulfilled or rejected, does nothing when L</"ioloop"> is
|
||||
already running.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_PROMISE_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_PROMISE_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
199
database/perl/vendor/lib/Mojo/Reactor.pm
vendored
Normal file
199
database/perl/vendor/lib/Mojo/Reactor.pm
vendored
Normal file
@@ -0,0 +1,199 @@
|
||||
package Mojo::Reactor;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Config;
|
||||
use Mojo::Loader qw(load_class);
|
||||
|
||||
my %DETECTED;
|
||||
|
||||
sub again { croak 'Method "again" not implemented by subclass' }
|
||||
|
||||
sub detect {
|
||||
my $default = 'Mojo::Reactor::' . ($Config{d_pseudofork} ? 'Poll' : 'EV');
|
||||
my $try = $ENV{MOJO_REACTOR} || $default;
|
||||
return $DETECTED{$try} ||= load_class($try) ? 'Mojo::Reactor::Poll' : $try;
|
||||
}
|
||||
|
||||
sub io { croak 'Method "io" not implemented by subclass' }
|
||||
sub is_running { croak 'Method "is_running" not implemented by subclass' }
|
||||
sub next_tick { croak 'Method "next_tick" not implemented by subclass' }
|
||||
sub one_tick { croak 'Method "one_tick" not implemented by subclass' }
|
||||
sub recurring { croak 'Method "recurring" not implemented by subclass' }
|
||||
sub remove { croak 'Method "remove" not implemented by subclass' }
|
||||
sub reset { croak 'Method "reset" not implemented by subclass' }
|
||||
sub start { croak 'Method "start" not implemented by subclass' }
|
||||
sub stop { croak 'Method "stop" not implemented by subclass' }
|
||||
sub timer { croak 'Method "timer" not implemented by subclass' }
|
||||
sub watch { croak 'Method "watch" not implemented by subclass' }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Reactor - Low-level event reactor base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Reactor::MyEventLoop;
|
||||
use Mojo::Base 'Mojo::Reactor';
|
||||
|
||||
sub again {...}
|
||||
sub io {...}
|
||||
sub is_running {...}
|
||||
sub next_tick {...}
|
||||
sub one_tick {...}
|
||||
sub recurring {...}
|
||||
sub remove {...}
|
||||
sub reset {...}
|
||||
sub start {...}
|
||||
sub stop {...}
|
||||
sub timer {...}
|
||||
sub watch {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Reactor> is an abstract base class for low-level event reactors, like L<Mojo::Reactor::EV> and
|
||||
L<Mojo::Reactor::Poll>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Reactor> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 error
|
||||
|
||||
$reactor->on(error => sub ($reactor, $err) {...});
|
||||
|
||||
Emitted for exceptions caught in callbacks, fatal if unhandled. Note that if this event is unhandled or fails it might
|
||||
kill your program, so you need to be careful.
|
||||
|
||||
$reactor->on(error => sub ($reactor, $err) { say "Something very bad happened: $err" });
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Reactor> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 again
|
||||
|
||||
$reactor->again($id);
|
||||
$reactor->again($id, 0.5);
|
||||
|
||||
Restart timer and optionally change the invocation time. Meant to be overloaded in a subclass. Note that this method
|
||||
requires an active timer.
|
||||
|
||||
=head2 detect
|
||||
|
||||
my $class = Mojo::Reactor->detect;
|
||||
|
||||
Detect and load the best reactor implementation available, will try the value of the C<MOJO_REACTOR> environment
|
||||
variable, L<Mojo::Reactor::EV> or L<Mojo::Reactor::Poll>.
|
||||
|
||||
# Instantiate best reactor implementation available
|
||||
my $reactor = Mojo::Reactor->detect->new;
|
||||
|
||||
=head2 io
|
||||
|
||||
$reactor = $reactor->io($handle => sub {...});
|
||||
|
||||
Watch handle for I/O events, invoking the callback whenever handle becomes readable or writable. Meant to be overloaded
|
||||
in a subclass.
|
||||
|
||||
# Callback will be executed twice if handle becomes readable and writable
|
||||
$reactor->io($handle => sub ($reactor, $writable) {
|
||||
say $writable ? 'Handle is writable' : 'Handle is readable';
|
||||
});
|
||||
|
||||
=head2 is_running
|
||||
|
||||
my $bool = $reactor->is_running;
|
||||
|
||||
Check if reactor is running. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 next_tick
|
||||
|
||||
my $undef = $reactor->next_tick(sub {...});
|
||||
|
||||
Execute callback as soon as possible, but not before returning or other callbacks that have been registered with this
|
||||
method, always returns C<undef>. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 one_tick
|
||||
|
||||
$reactor->one_tick;
|
||||
|
||||
Run reactor until an event occurs. Note that this method can recurse back into the reactor, so you need to be careful.
|
||||
Meant to be overloaded in a subclass.
|
||||
|
||||
# Don't block longer than 0.5 seconds
|
||||
my $id = $reactor->timer(0.5 => sub {});
|
||||
$reactor->one_tick;
|
||||
$reactor->remove($id);
|
||||
|
||||
=head2 recurring
|
||||
|
||||
my $id = $reactor->recurring(0.25 => sub {...});
|
||||
|
||||
Create a new recurring timer, invoking the callback repeatedly after a given amount of time in seconds. Meant to be
|
||||
overloaded in a subclass.
|
||||
|
||||
=head2 remove
|
||||
|
||||
my $bool = $reactor->remove($handle);
|
||||
my $bool = $reactor->remove($id);
|
||||
|
||||
Remove handle or timer. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 reset
|
||||
|
||||
$reactor->reset;
|
||||
|
||||
Remove all handles and timers. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 start
|
||||
|
||||
$reactor->start;
|
||||
|
||||
Start watching for I/O and timer events, this will block until L</"stop"> is called. Note that some reactors stop
|
||||
automatically if there are no events being watched anymore. Meant to be overloaded in a subclass.
|
||||
|
||||
# Start reactor only if it is not running already
|
||||
$reactor->start unless $reactor->is_running;
|
||||
|
||||
=head2 stop
|
||||
|
||||
$reactor->stop;
|
||||
|
||||
Stop watching for I/O and timer events. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 timer
|
||||
|
||||
my $id = $reactor->timer(0.5 => sub {...});
|
||||
|
||||
Create a new timer, invoking the callback after a given amount of time in seconds. Meant to be overloaded in a
|
||||
subclass.
|
||||
|
||||
=head2 watch
|
||||
|
||||
$reactor = $reactor->watch($handle, $readable, $writable);
|
||||
|
||||
Change I/O events to watch handle for with true and false values. Meant to be overloaded in a subclass. Note that this
|
||||
method requires an active I/O watcher.
|
||||
|
||||
# Watch only for readable events
|
||||
$reactor->watch($handle, 1, 0);
|
||||
|
||||
# Watch only for writable events
|
||||
$reactor->watch($handle, 0, 1);
|
||||
|
||||
# Watch for readable and writable events
|
||||
$reactor->watch($handle, 1, 1);
|
||||
|
||||
# Pause watching for events
|
||||
$reactor->watch($handle, 0, 0);
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
201
database/perl/vendor/lib/Mojo/Reactor/EV.pm
vendored
Normal file
201
database/perl/vendor/lib/Mojo/Reactor/EV.pm
vendored
Normal file
@@ -0,0 +1,201 @@
|
||||
package Mojo::Reactor::EV;
|
||||
use Mojo::Base 'Mojo::Reactor::Poll';
|
||||
|
||||
use Carp qw(croak);
|
||||
use EV 4.32;
|
||||
|
||||
my $EV;
|
||||
|
||||
sub DESTROY { undef $EV }
|
||||
|
||||
sub again {
|
||||
my ($self, $id, $after) = @_;
|
||||
croak 'Timer not active' unless my $timer = $self->{timers}{$id};
|
||||
my $w = $timer->{watcher};
|
||||
defined $after ? $w->set($after, $w->repeat ? $after : 0) : $w->again;
|
||||
}
|
||||
|
||||
# We have to fall back to Mojo::Reactor::Poll, since EV is unique
|
||||
sub new { $EV++ ? Mojo::Reactor::Poll->new : shift->SUPER::new }
|
||||
|
||||
sub one_tick {
|
||||
my $self = shift;
|
||||
local $self->{running} = 1 unless $self->{running};
|
||||
EV::run(EV::RUN_ONCE);
|
||||
}
|
||||
|
||||
sub recurring { shift->_timer(1, @_) }
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
local $self->{running} = 1 unless $self->{running};
|
||||
EV::run;
|
||||
}
|
||||
|
||||
sub stop { EV::break(EV::BREAK_ALL) }
|
||||
|
||||
sub timer { shift->_timer(0, @_) }
|
||||
|
||||
sub watch {
|
||||
my ($self, $handle, $read, $write) = @_;
|
||||
|
||||
my $fd = fileno $handle;
|
||||
croak 'I/O watcher not active' unless my $io = $self->{io}{$fd};
|
||||
|
||||
my $mode = 0;
|
||||
$mode |= EV::READ if $read;
|
||||
$mode |= EV::WRITE if $write;
|
||||
|
||||
if ($mode == 0) { delete $io->{watcher} }
|
||||
elsif (my $w = $io->{watcher}) { $w->events($mode) }
|
||||
else {
|
||||
my $cb = sub {
|
||||
my ($w, $revents) = @_;
|
||||
$self->_try('I/O watcher', $self->{io}{$fd}{cb}, 0) if EV::READ & $revents;
|
||||
$self->_try('I/O watcher', $self->{io}{$fd}{cb}, 1) if EV::WRITE & $revents && $self->{io}{$fd};
|
||||
};
|
||||
$io->{watcher} = EV::io($fd, $mode, $cb);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _timer {
|
||||
my ($self, $recurring, $after, $cb) = @_;
|
||||
$after ||= 0.0001 if $recurring;
|
||||
|
||||
my $id = $self->_id;
|
||||
my $wrapper = sub {
|
||||
delete $self->{timers}{$id} unless $recurring;
|
||||
$self->_try('Timer', $cb);
|
||||
};
|
||||
EV::now_update() if $after > 0;
|
||||
$self->{timers}{$id}{watcher} = EV::timer($after, $after, $wrapper);
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Reactor::EV - Low-level event reactor with libev support
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Reactor::EV;
|
||||
|
||||
# Watch if handle becomes readable or writable
|
||||
my $reactor = Mojo::Reactor::EV->new;
|
||||
$reactor->io($first => sub ($reactor, $writable) {
|
||||
say $writable ? 'First handle is writable' : 'First handle is readable';
|
||||
});
|
||||
|
||||
# Change to watching only if handle becomes writable
|
||||
$reactor->watch($first, 0, 1);
|
||||
|
||||
# Turn file descriptor into handle and watch if it becomes readable
|
||||
my $second = IO::Handle->new_from_fd($fd, 'r');
|
||||
$reactor->io($second => sub ($reactor, $writable) {
|
||||
say $writable ? 'Second handle is writable' : 'Second handle is readable';
|
||||
})->watch($second, 1, 0);
|
||||
|
||||
# Add a timer
|
||||
$reactor->timer(15 => sub ($reactor) {
|
||||
$reactor->remove($first);
|
||||
$reactor->remove($second);
|
||||
say 'Timeout!';
|
||||
});
|
||||
|
||||
# Start reactor if necessary
|
||||
$reactor->start unless $reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Reactor::EV> is a low-level event reactor based on L<EV> (4.32+).
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Reactor::EV> inherits all events from L<Mojo::Reactor::Poll>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Reactor::EV> inherits all methods from L<Mojo::Reactor::Poll> and implements the following new ones.
|
||||
|
||||
=head2 again
|
||||
|
||||
$reactor->again($id);
|
||||
$reactor->again($id, 0.5);
|
||||
|
||||
Restart timer and optionally change the invocation time. Note that this method requires an active timer.
|
||||
|
||||
=head2 new
|
||||
|
||||
my $reactor = Mojo::Reactor::EV->new;
|
||||
|
||||
Construct a new L<Mojo::Reactor::EV> object.
|
||||
|
||||
=head2 one_tick
|
||||
|
||||
$reactor->one_tick;
|
||||
|
||||
Run reactor until an event occurs or no events are being watched anymore.
|
||||
|
||||
# Don't block longer than 0.5 seconds
|
||||
my $id = $reactor->timer(0.5 => sub {});
|
||||
$reactor->one_tick;
|
||||
$reactor->remove($id);
|
||||
|
||||
=head2 recurring
|
||||
|
||||
my $id = $reactor->recurring(0.25 => sub {...});
|
||||
|
||||
Create a new recurring timer, invoking the callback repeatedly after a given amount of time in seconds.
|
||||
|
||||
=head2 start
|
||||
|
||||
$reactor->start;
|
||||
|
||||
Start watching for I/O and timer events, this will block until L</"stop"> is called or no events are being watched
|
||||
anymore.
|
||||
|
||||
# Start reactor only if it is not running already
|
||||
$reactor->start unless $reactor->is_running;
|
||||
|
||||
=head2 stop
|
||||
|
||||
$reactor->stop;
|
||||
|
||||
Stop watching for I/O and timer events.
|
||||
|
||||
=head2 timer
|
||||
|
||||
my $id = $reactor->timer(0.5 => sub {...});
|
||||
|
||||
Create a new timer, invoking the callback after a given amount of time in seconds.
|
||||
|
||||
=head2 watch
|
||||
|
||||
$reactor = $reactor->watch($handle, $readable, $writable);
|
||||
|
||||
Change I/O events to watch handle for with true and false values. Note that this method requires an active I/O watcher.
|
||||
|
||||
# Watch only for readable events
|
||||
$reactor->watch($handle, 1, 0);
|
||||
|
||||
# Watch only for writable events
|
||||
$reactor->watch($handle, 0, 1);
|
||||
|
||||
# Watch for readable and writable events
|
||||
$reactor->watch($handle, 1, 1);
|
||||
|
||||
# Pause watching for events
|
||||
$reactor->watch($handle, 0, 0);
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
303
database/perl/vendor/lib/Mojo/Reactor/Poll.pm
vendored
Normal file
303
database/perl/vendor/lib/Mojo/Reactor/Poll.pm
vendored
Normal file
@@ -0,0 +1,303 @@
|
||||
package Mojo::Reactor::Poll;
|
||||
use Mojo::Base 'Mojo::Reactor';
|
||||
|
||||
use Carp qw(croak);
|
||||
use IO::Poll qw(POLLERR POLLHUP POLLIN POLLNVAL POLLOUT POLLPRI);
|
||||
use List::Util qw(min);
|
||||
use Mojo::Util qw(md5_sum steady_time);
|
||||
use Time::HiRes qw(usleep);
|
||||
|
||||
sub again {
|
||||
my ($self, $id, $after) = @_;
|
||||
croak 'Timer not active' unless my $timer = $self->{timers}{$id};
|
||||
$timer->{after} = $after if defined $after;
|
||||
$timer->{time} = steady_time + $timer->{after};
|
||||
}
|
||||
|
||||
sub io {
|
||||
my ($self, $handle, $cb) = @_;
|
||||
$self->{io}{fileno($handle) // croak 'Handle is closed'} = {cb => $cb};
|
||||
return $self->watch($handle, 1, 1);
|
||||
}
|
||||
|
||||
sub is_running { !!shift->{running} }
|
||||
|
||||
sub next_tick {
|
||||
my ($self, $cb) = @_;
|
||||
push @{$self->{next_tick}}, $cb;
|
||||
$self->{next_timer} //= $self->timer(0 => \&_next);
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub one_tick {
|
||||
my $self = shift;
|
||||
|
||||
# Just one tick
|
||||
local $self->{running} = 1 unless $self->{running};
|
||||
|
||||
# Wait for one event
|
||||
my $i;
|
||||
until ($i || !$self->{running}) {
|
||||
|
||||
# Stop automatically if there is nothing to watch
|
||||
return $self->stop unless keys %{$self->{timers}} || keys %{$self->{io}};
|
||||
|
||||
# Calculate ideal timeout based on timers and round up to next millisecond
|
||||
my $min = min map { $_->{time} } values %{$self->{timers}};
|
||||
my $timeout = defined $min ? $min - steady_time : 0.5;
|
||||
$timeout = $timeout <= 0 ? 0 : int($timeout * 1000) + 1;
|
||||
|
||||
# I/O
|
||||
if (keys %{$self->{io}}) {
|
||||
my @poll = map { $_ => $self->{io}{$_}{mode} } keys %{$self->{io}};
|
||||
|
||||
# This may break in the future, but is worth it for performance
|
||||
if (IO::Poll::_poll($timeout, @poll) > 0) {
|
||||
while (my ($fd, $mode) = splice @poll, 0, 2) {
|
||||
|
||||
if ($mode & (POLLIN | POLLPRI | POLLNVAL | POLLHUP | POLLERR)) {
|
||||
next unless my $io = $self->{io}{$fd};
|
||||
++$i and $self->_try('I/O watcher', $io->{cb}, 0);
|
||||
}
|
||||
next unless $mode & POLLOUT && (my $io = $self->{io}{$fd});
|
||||
++$i and $self->_try('I/O watcher', $io->{cb}, 1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Wait for timeout if poll can't be used
|
||||
elsif ($timeout) { usleep($timeout * 1000) }
|
||||
|
||||
# Timers (time should not change in between timers)
|
||||
my $now = steady_time;
|
||||
for my $id (keys %{$self->{timers}}) {
|
||||
next unless my $t = $self->{timers}{$id};
|
||||
next unless $t->{time} <= $now;
|
||||
|
||||
# Recurring timer
|
||||
if ($t->{recurring}) { $t->{time} = $now + $t->{after} }
|
||||
|
||||
# Normal timer
|
||||
else { $self->remove($id) }
|
||||
|
||||
++$i and $self->_try('Timer', $t->{cb}) if $t->{cb};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub recurring { shift->_timer(1, @_) }
|
||||
|
||||
sub remove {
|
||||
my ($self, $remove) = @_;
|
||||
return !!delete $self->{timers}{$remove} unless ref $remove;
|
||||
return !!delete $self->{io}{fileno($remove) // croak 'Handle is closed'};
|
||||
}
|
||||
|
||||
sub reset {
|
||||
delete @{shift()}{qw(events io next_tick next_timer running timers)};
|
||||
}
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
local $self->{running} = ($self->{running} || 0) + 1;
|
||||
$self->one_tick while $self->{running};
|
||||
}
|
||||
|
||||
sub stop { delete shift->{running} }
|
||||
|
||||
sub timer { shift->_timer(0, @_) }
|
||||
|
||||
sub watch {
|
||||
my ($self, $handle, $read, $write) = @_;
|
||||
|
||||
croak 'I/O watcher not active' unless my $io = $self->{io}{fileno $handle};
|
||||
$io->{mode} = 0;
|
||||
$io->{mode} |= POLLIN | POLLPRI if $read;
|
||||
$io->{mode} |= POLLOUT if $write;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _id {
|
||||
my $self = shift;
|
||||
my $id;
|
||||
do { $id = md5_sum 't' . steady_time . rand } while $self->{timers}{$id};
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub _next {
|
||||
my $self = shift;
|
||||
delete $self->{next_timer};
|
||||
while (my $cb = shift @{$self->{next_tick}}) { $self->$cb }
|
||||
}
|
||||
|
||||
sub _timer {
|
||||
my ($self, $recurring, $after, $cb) = @_;
|
||||
|
||||
my $id = $self->_id;
|
||||
my $timer = $self->{timers}{$id}
|
||||
= {cb => $cb, after => $after, recurring => $recurring, time => steady_time + $after};
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub _try {
|
||||
my ($self, $what, $cb) = (shift, shift, shift);
|
||||
eval { $self->$cb(@_); 1 } or $self->emit(error => "$what failed: $@");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Reactor::Poll - Low-level event reactor with poll support
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Reactor::Poll;
|
||||
|
||||
# Watch if handle becomes readable or writable
|
||||
my $reactor = Mojo::Reactor::Poll->new;
|
||||
$reactor->io($first => sub ($reactor, $writable) {
|
||||
say $writable ? 'First handle is writable' : 'First handle is readable';
|
||||
});
|
||||
|
||||
# Change to watching only if handle becomes writable
|
||||
$reactor->watch($first, 0, 1);
|
||||
|
||||
# Turn file descriptor into handle and watch if it becomes readable
|
||||
my $second = IO::Handle->new_from_fd($fd, 'r');
|
||||
$reactor->io($second => sub ($reactor, $writable) {
|
||||
say $writable ? 'Second handle is writable' : 'Second handle is readable';
|
||||
})->watch($second, 1, 0);
|
||||
|
||||
# Add a timer
|
||||
$reactor->timer(15 => sub ($reactor) {
|
||||
$reactor->remove($first);
|
||||
$reactor->remove($second);
|
||||
say 'Timeout!';
|
||||
});
|
||||
|
||||
# Start reactor if necessary
|
||||
$reactor->start unless $reactor->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Reactor::Poll> is a low-level event reactor based on L<IO::Poll>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Reactor::Poll> inherits all events from L<Mojo::Reactor>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Reactor::Poll> inherits all methods from L<Mojo::Reactor> and implements the following new ones.
|
||||
|
||||
=head2 again
|
||||
|
||||
$reactor->again($id);
|
||||
$reactor->again($id, 0.5);
|
||||
|
||||
Restart timer and optionally change the invocation time. Note that this method requires an active timer.
|
||||
|
||||
=head2 io
|
||||
|
||||
$reactor = $reactor->io($handle => sub {...});
|
||||
|
||||
Watch handle for I/O events, invoking the callback whenever handle becomes readable or writable.
|
||||
|
||||
# Callback will be executed twice if handle becomes readable and writable
|
||||
$reactor->io($handle => sub ($reactor, $writable) {
|
||||
say $writable ? 'Handle is writable' : 'Handle is readable';
|
||||
});
|
||||
|
||||
=head2 is_running
|
||||
|
||||
my $bool = $reactor->is_running;
|
||||
|
||||
Check if reactor is running.
|
||||
|
||||
=head2 next_tick
|
||||
|
||||
my $undef = $reactor->next_tick(sub {...});
|
||||
|
||||
Execute callback as soon as possible, but not before returning or other callbacks that have been registered with this
|
||||
method, always returns C<undef>.
|
||||
|
||||
=head2 one_tick
|
||||
|
||||
$reactor->one_tick;
|
||||
|
||||
Run reactor until an event occurs or no events are being watched anymore.
|
||||
|
||||
# Don't block longer than 0.5 seconds
|
||||
my $id = $reactor->timer(0.5 => sub {});
|
||||
$reactor->one_tick;
|
||||
$reactor->remove($id);
|
||||
|
||||
=head2 recurring
|
||||
|
||||
my $id = $reactor->recurring(0.25 => sub {...});
|
||||
|
||||
Create a new recurring timer, invoking the callback repeatedly after a given amount of time in seconds.
|
||||
|
||||
=head2 remove
|
||||
|
||||
my $bool = $reactor->remove($handle);
|
||||
my $bool = $reactor->remove($id);
|
||||
|
||||
Remove handle or timer.
|
||||
|
||||
=head2 reset
|
||||
|
||||
$reactor->reset;
|
||||
|
||||
Remove all handles and timers.
|
||||
|
||||
=head2 start
|
||||
|
||||
$reactor->start;
|
||||
|
||||
Start watching for I/O and timer events, this will block until L</"stop"> is called or no events are being watched
|
||||
anymore.
|
||||
|
||||
# Start reactor only if it is not running already
|
||||
$reactor->start unless $reactor->is_running;
|
||||
|
||||
=head2 stop
|
||||
|
||||
$reactor->stop;
|
||||
|
||||
Stop watching for I/O and timer events.
|
||||
|
||||
=head2 timer
|
||||
|
||||
my $id = $reactor->timer(0.5 => sub {...});
|
||||
|
||||
Create a new timer, invoking the callback after a given amount of time in seconds.
|
||||
|
||||
=head2 watch
|
||||
|
||||
$reactor = $reactor->watch($handle, $readable, $writable);
|
||||
|
||||
Change I/O events to watch handle for with true and false values. Note that this method requires an active I/O watcher.
|
||||
|
||||
# Watch only for readable events
|
||||
$reactor->watch($handle, 1, 0);
|
||||
|
||||
# Watch only for writable events
|
||||
$reactor->watch($handle, 0, 1);
|
||||
|
||||
# Watch for readable and writable events
|
||||
$reactor->watch($handle, 1, 1);
|
||||
|
||||
# Pause watching for events
|
||||
$reactor->watch($handle, 0, 0);
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
185
database/perl/vendor/lib/Mojo/Server.pm
vendored
Normal file
185
database/perl/vendor/lib/Mojo/Server.pm
vendored
Normal file
@@ -0,0 +1,185 @@
|
||||
package Mojo::Server;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::Loader qw(load_class);
|
||||
use Mojo::Util qw(md5_sum);
|
||||
use POSIX ();
|
||||
use Scalar::Util qw(blessed);
|
||||
|
||||
has app => sub { shift->build_app('Mojo::HelloWorld') };
|
||||
has reverse_proxy => sub { $ENV{MOJO_REVERSE_PROXY} };
|
||||
|
||||
sub build_app {
|
||||
my ($self, $app) = (shift, shift);
|
||||
local $ENV{MOJO_EXE};
|
||||
return $self->app($app->new(@_))->app unless my $e = load_class $app;
|
||||
die ref $e ? $e : qq{Can't find application class "$app" in \@INC. (@INC)\n};
|
||||
}
|
||||
|
||||
sub build_tx {
|
||||
my $self = shift;
|
||||
my $tx = $self->app->build_tx;
|
||||
$tx->req->reverse_proxy(1) if $self->reverse_proxy;
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub daemonize {
|
||||
|
||||
# Fork and kill parent
|
||||
die "Can't fork: $!" unless defined(my $pid = fork);
|
||||
exit 0 if $pid;
|
||||
POSIX::setsid == -1 and die "Can't start a new session: $!";
|
||||
|
||||
# Close filehandles
|
||||
open STDIN, '<', '/dev/null';
|
||||
open STDOUT, '>', '/dev/null';
|
||||
open STDERR, '>&', STDOUT;
|
||||
}
|
||||
|
||||
sub load_app {
|
||||
my ($self, $path) = @_;
|
||||
|
||||
# Clean environment (reset FindBin defensively)
|
||||
{
|
||||
local $0 = $path = path($path)->to_abs->to_string;
|
||||
require FindBin;
|
||||
FindBin->again;
|
||||
local $ENV{MOJO_APP_LOADER} = 1;
|
||||
local $ENV{MOJO_EXE};
|
||||
|
||||
# Try to load application from script into sandbox
|
||||
delete $INC{$path};
|
||||
my $app = eval "package Mojo::Server::Sandbox::@{[md5_sum $path]}; require \$path";
|
||||
die qq{Can't load application from file "$path": $@} if $@;
|
||||
die qq{File "$path" did not return an application object.\n} unless blessed $app && $app->can('handler');
|
||||
$self->app($app);
|
||||
};
|
||||
FindBin->again;
|
||||
|
||||
return $self->app;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $self = shift->SUPER::new(@_);
|
||||
$self->on(request => sub { shift->app->handler(shift) });
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub run { croak 'Method "run" not implemented by subclass' }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server - HTTP/WebSocket server base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Server::MyServer;
|
||||
use Mojo::Base 'Mojo::Server', -signatures;
|
||||
|
||||
sub run ($self) {
|
||||
|
||||
# Get a transaction
|
||||
my $tx = $self->build_tx;
|
||||
|
||||
# Emit "request" event
|
||||
$self->emit(request => $tx);
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server> is an abstract base class for HTTP/WebSocket servers and server interfaces, like L<Mojo::Server::CGI>,
|
||||
L<Mojo::Server::Daemon>, L<Mojo::Server::Hypnotoad>, L<Mojo::Server::Morbo>, L<Mojo::Server::Prefork> and
|
||||
L<Mojo::Server::PSGI>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Server> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 request
|
||||
|
||||
$server->on(request => sub ($server, $tx) {...});
|
||||
|
||||
Emitted when a request is ready and needs to be handled.
|
||||
|
||||
$server->on(request => sub ($server, $tx) {
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body('Hello World!');
|
||||
$tx->resume;
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server> implements the following attributes.
|
||||
|
||||
=head2 app
|
||||
|
||||
my $app = $server->app;
|
||||
$server = $server->app(MojoSubclass->new);
|
||||
|
||||
Application this server handles, defaults to a L<Mojo::HelloWorld> object.
|
||||
|
||||
=head2 reverse_proxy
|
||||
|
||||
my $bool = $server->reverse_proxy;
|
||||
$server = $server->reverse_proxy($bool);
|
||||
|
||||
This server operates behind a reverse proxy, defaults to the value of the C<MOJO_REVERSE_PROXY> environment variable.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 build_app
|
||||
|
||||
my $app = $server->build_app('MyApp');
|
||||
my $app = $server->build_app('MyApp', log => Mojo::Log->new);
|
||||
my $app = $server->build_app('MyApp', {log => Mojo::Log->new});
|
||||
|
||||
Build application from class and assign it to L</"app">.
|
||||
|
||||
=head2 build_tx
|
||||
|
||||
my $tx = $server->build_tx;
|
||||
|
||||
Let application build a transaction.
|
||||
|
||||
=head2 daemonize
|
||||
|
||||
$server->daemonize;
|
||||
|
||||
Daemonize server process.
|
||||
|
||||
=head2 load_app
|
||||
|
||||
my $app = $server->load_app('/home/sri/myapp.pl');
|
||||
|
||||
Load application from script and assign it to L</"app">.
|
||||
|
||||
say Mojo::Server->new->load_app('./myapp.pl')->home;
|
||||
|
||||
=head2 new
|
||||
|
||||
my $server = Mojo::Server->new;
|
||||
my $server = Mojo::Server->new(reverse_proxy => 1);
|
||||
my $server = Mojo::Server->new({reverse_proxy => 1});
|
||||
|
||||
Construct a new L<Mojo::Server> object and subscribe to L</"request"> event with default request handling.
|
||||
|
||||
=head2 run
|
||||
|
||||
$server->run;
|
||||
|
||||
Run server. Meant to be overloaded in a subclass.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
131
database/perl/vendor/lib/Mojo/Server/CGI.pm
vendored
Normal file
131
database/perl/vendor/lib/Mojo/Server/CGI.pm
vendored
Normal file
@@ -0,0 +1,131 @@
|
||||
package Mojo::Server::CGI;
|
||||
use Mojo::Base 'Mojo::Server';
|
||||
|
||||
has 'nph';
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
|
||||
my $tx = $self->build_tx;
|
||||
my $req = $tx->req->parse(\%ENV);
|
||||
$tx->local_port($ENV{SERVER_PORT})->remote_address($ENV{REMOTE_ADDR});
|
||||
|
||||
# Request body (may block if we try to read too much)
|
||||
binmode STDIN;
|
||||
my $len = $req->headers->content_length;
|
||||
until ($req->is_finished) {
|
||||
my $chunk = ($len && $len < 131072) ? $len : 131072;
|
||||
last unless my $read = STDIN->read(my $buffer, $chunk, 0);
|
||||
$req->parse($buffer);
|
||||
last if ($len -= $read) <= 0;
|
||||
}
|
||||
|
||||
$self->emit(request => $tx);
|
||||
|
||||
# Response start-line
|
||||
STDOUT->autoflush(1);
|
||||
binmode STDOUT;
|
||||
my $res = $tx->res->fix_headers;
|
||||
return undef if $self->nph && !_write($res, 'get_start_line_chunk');
|
||||
|
||||
# Response headers
|
||||
my $code = $res->code || 404;
|
||||
my $msg = $res->message || $res->default_message;
|
||||
$res->headers->status("$code $msg") unless $self->nph;
|
||||
return undef unless _write($res, 'get_header_chunk');
|
||||
|
||||
# Response body
|
||||
return undef unless $tx->is_empty || _write($res, 'get_body_chunk');
|
||||
|
||||
# Finish transaction
|
||||
$tx->closed;
|
||||
|
||||
return $res->code;
|
||||
}
|
||||
|
||||
sub _write {
|
||||
my ($res, $method) = @_;
|
||||
|
||||
my $offset = 0;
|
||||
while (1) {
|
||||
|
||||
# No chunk yet, try again
|
||||
sleep 1 and next unless defined(my $chunk = $res->$method($offset));
|
||||
|
||||
# End of part
|
||||
last unless my $len = length $chunk;
|
||||
|
||||
# Make sure we can still write
|
||||
$offset += $len;
|
||||
return undef unless STDOUT->opened;
|
||||
print STDOUT $chunk;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::CGI - CGI server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::CGI;
|
||||
|
||||
my $cgi = Mojo::Server::CGI->new;
|
||||
$cgi->unsubscribe('request')->on(request => sub ($cgi, $tx) {
|
||||
|
||||
# Request
|
||||
my $method = $tx->req->method;
|
||||
my $path = $tx->req->url->path;
|
||||
|
||||
# Response
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body("$method request for $path!");
|
||||
|
||||
# Resume transaction
|
||||
$tx->resume;
|
||||
});
|
||||
$cgi->run;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::CGI> is a simple and portable implementation of L<RFC 3875|https://tools.ietf.org/html/rfc3875>.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Server::CGI> inherits all events from L<Mojo::Server>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::CGI> inherits all attributes from L<Mojo::Server> and implements the following new ones.
|
||||
|
||||
=head2 nph
|
||||
|
||||
my $bool = $cgi->nph;
|
||||
$cgi = $cgi->nph($bool);
|
||||
|
||||
Activate non-parsed header mode.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::CGI> inherits all methods from L<Mojo::Server> and implements the following new ones.
|
||||
|
||||
=head2 run
|
||||
|
||||
my $status = $cgi->run;
|
||||
|
||||
Run CGI.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
521
database/perl/vendor/lib/Mojo/Server/Daemon.pm
vendored
Normal file
521
database/perl/vendor/lib/Mojo/Server/Daemon.pm
vendored
Normal file
@@ -0,0 +1,521 @@
|
||||
package Mojo::Server::Daemon;
|
||||
use Mojo::Base 'Mojo::Server';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::Transaction::WebSocket;
|
||||
use Mojo::URL;
|
||||
use Mojo::Util qw(term_escape);
|
||||
use Mojo::WebSocket qw(server_handshake);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_SERVER_DEBUG} || 0;
|
||||
|
||||
has acceptors => sub { [] };
|
||||
has [qw(backlog max_clients silent)];
|
||||
has inactivity_timeout => sub { $ENV{MOJO_INACTIVITY_TIMEOUT} // 30 };
|
||||
has ioloop => sub { Mojo::IOLoop->singleton };
|
||||
has keep_alive_timeout => sub { $ENV{MOJO_KEEP_ALIVE_TIMEOUT} // 5 };
|
||||
has listen => sub { [split /,/, $ENV{MOJO_LISTEN} || 'http://*:3000'] };
|
||||
has max_requests => 100;
|
||||
|
||||
sub DESTROY {
|
||||
return if Mojo::Util::_global_destruction();
|
||||
my $self = shift;
|
||||
my $loop = $self->ioloop;
|
||||
$loop->remove($_) for keys %{$self->{connections} // {}}, @{$self->acceptors};
|
||||
}
|
||||
|
||||
sub ports { [map { $_[0]->ioloop->acceptor($_)->port } @{$_[0]->acceptors}] }
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
|
||||
# Make sure the event loop can be stopped in regular intervals
|
||||
my $loop = $self->ioloop;
|
||||
my $int = $loop->recurring(1 => sub { });
|
||||
local $SIG{INT} = local $SIG{TERM} = sub { $loop->stop };
|
||||
$self->start->ioloop->start;
|
||||
$loop->remove($int);
|
||||
}
|
||||
|
||||
sub start {
|
||||
my $self = shift;
|
||||
|
||||
my $loop = $self->ioloop;
|
||||
if (my $max = $self->max_clients) { $loop->max_connections($max) }
|
||||
|
||||
# Resume accepting connections
|
||||
if (my $servers = $self->{servers}) {
|
||||
push @{$self->acceptors}, $loop->acceptor(delete $servers->{$_}) for keys %$servers;
|
||||
}
|
||||
|
||||
# Start listening
|
||||
elsif (!@{$self->acceptors}) {
|
||||
$self->app->server($self);
|
||||
$self->_listen($_) for @{$self->listen};
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub stop {
|
||||
my $self = shift;
|
||||
|
||||
# Suspend accepting connections but keep listen sockets open
|
||||
my $loop = $self->ioloop;
|
||||
while (my $id = shift @{$self->acceptors}) {
|
||||
my $server = $self->{servers}{$id} = $loop->acceptor($id);
|
||||
$loop->remove($id);
|
||||
$server->stop;
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _build_tx {
|
||||
my ($self, $id, $c) = @_;
|
||||
|
||||
my $tx = $self->build_tx->connection($id);
|
||||
$tx->res->headers->server('Mojolicious (Perl)');
|
||||
my $handle = $self->ioloop->stream($id)->timeout($self->inactivity_timeout)->handle;
|
||||
unless ($handle->isa('IO::Socket::UNIX')) {
|
||||
$tx->local_address($handle->sockhost)->local_port($handle->sockport);
|
||||
$tx->remote_address($handle->peerhost)->remote_port($handle->peerport);
|
||||
}
|
||||
$tx->req->url->base->scheme('https') if $c->{tls};
|
||||
|
||||
weaken $self;
|
||||
$tx->on(
|
||||
request => sub {
|
||||
my $tx = shift;
|
||||
|
||||
my $req = $tx->req;
|
||||
if (my $error = $req->error) { $self->_debug($id, $error->{message}) }
|
||||
|
||||
# WebSocket
|
||||
if ($req->is_handshake) {
|
||||
my $ws = $self->{connections}{$id}{next} = Mojo::Transaction::WebSocket->new(handshake => $tx);
|
||||
$self->emit(request => server_handshake $ws);
|
||||
}
|
||||
|
||||
# HTTP
|
||||
else { $self->emit(request => $tx) }
|
||||
|
||||
# Last keep-alive request or corrupted connection
|
||||
my $c = $self->{connections}{$id};
|
||||
$tx->res->headers->connection('close') if ($c->{requests} || 1) >= $self->max_requests || $req->error;
|
||||
|
||||
$tx->on(resume => sub { $self->_write($id) });
|
||||
$self->_write($id);
|
||||
}
|
||||
);
|
||||
|
||||
# Kept alive if we have more than one request on the connection
|
||||
return ++$c->{requests} > 1 ? $tx->kept_alive(1) : $tx;
|
||||
}
|
||||
|
||||
sub _close {
|
||||
my ($self, $id) = @_;
|
||||
if (my $tx = $self->{connections}{$id}{tx}) { $tx->closed }
|
||||
delete $self->{connections}{$id};
|
||||
}
|
||||
|
||||
sub _debug { $_[0]->app->log->debug($_[2]) if $_[0]{connections}{$_[1]}{tx} }
|
||||
|
||||
sub _finish {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
# Always remove connection for WebSockets
|
||||
my $c = $self->{connections}{$id};
|
||||
return unless my $tx = $c->{tx};
|
||||
return $self->_remove($id) if $tx->is_websocket;
|
||||
|
||||
# Finish transaction
|
||||
delete($c->{tx})->closed;
|
||||
|
||||
# Upgrade connection to WebSocket
|
||||
if (my $ws = delete $c->{next}) {
|
||||
|
||||
# Successful upgrade
|
||||
if ($ws->handshake->res->code == 101) {
|
||||
$c->{tx} = $ws->established(1);
|
||||
weaken $self;
|
||||
$ws->on(resume => sub { $self->_write($id) });
|
||||
$self->_write($id);
|
||||
}
|
||||
|
||||
# Failed upgrade
|
||||
else { $ws->closed }
|
||||
}
|
||||
|
||||
# Close connection if necessary
|
||||
return $self->_remove($id) if $tx->error || !$tx->keep_alive;
|
||||
|
||||
# Build new transaction for leftovers
|
||||
if (length(my $leftovers = $tx->req->content->leftovers)) {
|
||||
$tx = $c->{tx} = $self->_build_tx($id, $c);
|
||||
$tx->server_read($leftovers);
|
||||
}
|
||||
|
||||
# Keep-alive connection
|
||||
$self->ioloop->stream($id)->timeout($self->keep_alive_timeout) unless $c->{tx};
|
||||
}
|
||||
|
||||
sub _listen {
|
||||
my ($self, $listen) = @_;
|
||||
|
||||
my $url = Mojo::URL->new($listen);
|
||||
my $proto = $url->protocol;
|
||||
croak qq{Invalid listen location "$listen"} unless $proto eq 'http' || $proto eq 'https' || $proto eq 'http+unix';
|
||||
|
||||
my $query = $url->query;
|
||||
my $options = {backlog => $self->backlog};
|
||||
$options->{$_} = $query->param($_) for qw(fd single_accept reuse);
|
||||
if ($proto eq 'http+unix') { $options->{path} = $url->host }
|
||||
else {
|
||||
if ((my $host = $url->host) ne '*') { $options->{address} = $host }
|
||||
if (my $port = $url->port) { $options->{port} = $port }
|
||||
}
|
||||
$options->{"tls_$_"} = $query->param($_) for qw(ca ciphers version);
|
||||
/^(.*)_(cert|key)$/ and $options->{"tls_$2"}{$1} = $query->param($_) for @{$query->names};
|
||||
if (my $cert = $query->param('cert')) { $options->{'tls_cert'}{''} = $cert }
|
||||
if (my $key = $query->param('key')) { $options->{'tls_key'}{''} = $key }
|
||||
my $verify = $query->param('verify');
|
||||
$options->{tls_verify} = hex $verify if defined $verify;
|
||||
my $tls = $options->{tls} = $proto eq 'https';
|
||||
|
||||
weaken $self;
|
||||
push @{$self->acceptors}, $self->ioloop->server(
|
||||
$options => sub {
|
||||
my ($loop, $stream, $id) = @_;
|
||||
|
||||
$self->{connections}{$id} = {tls => $tls};
|
||||
warn "-- Accept $id (@{[$stream->handle->peerhost]})\n" if DEBUG;
|
||||
$stream->timeout($self->inactivity_timeout);
|
||||
|
||||
$stream->on(close => sub { $self && $self->_close($id) });
|
||||
$stream->on(error => sub { $self && $self->app->log->error(pop) && $self->_close($id) });
|
||||
$stream->on(read => sub { $self->_read($id => pop) });
|
||||
$stream->on(timeout => sub { $self->_debug($id, 'Inactivity timeout') });
|
||||
}
|
||||
);
|
||||
|
||||
return if $self->silent;
|
||||
$self->app->log->info(qq{Listening at "$url"});
|
||||
$query->pairs([]);
|
||||
$url->host('127.0.0.1') if $url->host eq '*';
|
||||
say 'Web application available at ', $options->{path} // $url;
|
||||
}
|
||||
|
||||
sub _read {
|
||||
my ($self, $id, $chunk) = @_;
|
||||
|
||||
# Make sure we have a transaction
|
||||
my $c = $self->{connections}{$id};
|
||||
my $tx = $c->{tx} ||= $self->_build_tx($id, $c);
|
||||
warn term_escape "-- Server <<< Client (@{[_url($tx)]})\n$chunk\n" if DEBUG;
|
||||
$tx->server_read($chunk);
|
||||
}
|
||||
|
||||
sub _remove {
|
||||
my ($self, $id) = @_;
|
||||
$self->ioloop->remove($id);
|
||||
$self->_close($id);
|
||||
}
|
||||
|
||||
sub _url { shift->req->url->to_abs }
|
||||
|
||||
sub _write {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
# Protect from resume event recursion
|
||||
my $c = $self->{connections}{$id};
|
||||
return if !(my $tx = $c->{tx}) || $c->{writing};
|
||||
local $c->{writing} = 1;
|
||||
my $chunk = $tx->server_write;
|
||||
warn term_escape "-- Server >>> Client (@{[_url($tx)]})\n$chunk\n" if DEBUG;
|
||||
my $next = $tx->is_finished ? '_finish' : length $chunk ? '_write' : undef;
|
||||
return $self->ioloop->stream($id)->write($chunk) unless $next;
|
||||
weaken $self;
|
||||
$self->ioloop->stream($id)->write($chunk => sub { $self->$next($id) });
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Daemon - Non-blocking I/O HTTP and WebSocket server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::Daemon;
|
||||
|
||||
my $daemon = Mojo::Server::Daemon->new(listen => ['http://*:8080']);
|
||||
$daemon->unsubscribe('request')->on(request => sub ($daemon, $tx) {
|
||||
|
||||
# Request
|
||||
my $method = $tx->req->method;
|
||||
my $path = $tx->req->url->path;
|
||||
|
||||
# Response
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body("$method request for $path!");
|
||||
|
||||
# Resume transaction
|
||||
$tx->resume;
|
||||
});
|
||||
$daemon->run;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Daemon> is a full featured, highly portable non-blocking I/O HTTP and WebSocket server, with IPv6, TLS,
|
||||
SNI, Comet (long polling), keep-alive and multiple event loop support.
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(2.009+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 SIGNALS
|
||||
|
||||
The L<Mojo::Server::Daemon> process can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 INT, TERM
|
||||
|
||||
Shut down server immediately.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Server::Daemon> inherits all events from L<Mojo::Server>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Daemon> inherits all attributes from L<Mojo::Server> and implements the following new ones.
|
||||
|
||||
=head2 acceptors
|
||||
|
||||
my $acceptors = $daemon->acceptors;
|
||||
$daemon = $daemon->acceptors(['6be0c140ef00a389c5d039536b56d139']);
|
||||
|
||||
Active acceptor ids.
|
||||
|
||||
# Check port
|
||||
mu $port = $daemon->ioloop->acceptor($daemon->acceptors->[0])->port;
|
||||
|
||||
=head2 backlog
|
||||
|
||||
my $backlog = $daemon->backlog;
|
||||
$daemon = $daemon->backlog(128);
|
||||
|
||||
Listen backlog size, defaults to C<SOMAXCONN>.
|
||||
|
||||
=head2 inactivity_timeout
|
||||
|
||||
my $timeout = $daemon->inactivity_timeout;
|
||||
$daemon = $daemon->inactivity_timeout(5);
|
||||
|
||||
Maximum amount of time in seconds a connection with an active request can be inactive before getting closed, defaults
|
||||
to the value of the C<MOJO_INACTIVITY_TIMEOUT> environment variable or C<30>. Setting the value to C<0> will allow
|
||||
connections to be inactive indefinitely.
|
||||
|
||||
=head2 ioloop
|
||||
|
||||
my $loop = $daemon->ioloop;
|
||||
$daemon = $daemon->ioloop(Mojo::IOLoop->new);
|
||||
|
||||
Event loop object to use for I/O operations, defaults to the global L<Mojo::IOLoop> singleton.
|
||||
|
||||
=head2 keep_alive_timeout
|
||||
|
||||
my $timeout = $daemon->keep_alive_timeout;
|
||||
$daemon = $daemon->keep_alive_timeout(10);
|
||||
|
||||
Maximum amount of time in seconds a connection without an active request can be inactive before getting closed,
|
||||
defaults to the value of the C<MOJO_KEEP_ALIVE_TIMEOUT> environment variable or C<5>. Setting the value to C<0> will
|
||||
allow connections to be inactive indefinitely.
|
||||
|
||||
=head2 listen
|
||||
|
||||
my $listen = $daemon->listen;
|
||||
$daemon = $daemon->listen(['https://127.0.0.1:8080']);
|
||||
|
||||
Array reference with one or more locations to listen on, defaults to the value of the C<MOJO_LISTEN> environment
|
||||
variable or C<http://*:3000> (shortcut for C<http://0.0.0.0:3000>).
|
||||
|
||||
# Listen on all IPv4 interfaces
|
||||
$daemon->listen(['http://*:3000']);
|
||||
|
||||
# Listen on all IPv4 and IPv6 interfaces
|
||||
$daemon->listen(['http://[::]:3000']);
|
||||
|
||||
# Listen on IPv6 interface
|
||||
$daemon->listen(['http://[::1]:4000']);
|
||||
|
||||
# Listen on IPv4 and IPv6 interfaces
|
||||
$daemon->listen(['http://127.0.0.1:3000', 'http://[::1]:3000']);
|
||||
|
||||
# Listen on UNIX domain socket "/tmp/myapp.sock" (percent encoded slash)
|
||||
$daemon->listen(['http+unix://%2Ftmp%2Fmyapp.sock']);
|
||||
|
||||
# File descriptor, as used by systemd
|
||||
$daemon->listen(['http://127.0.0.1?fd=3']);
|
||||
|
||||
# Allow multiple servers to use the same port (SO_REUSEPORT)
|
||||
$daemon->listen(['http://*:8080?reuse=1']);
|
||||
|
||||
# Listen on two ports with HTTP and HTTPS at the same time
|
||||
$daemon->listen(['http://*:3000', 'https://*:4000']);
|
||||
|
||||
# Use a custom certificate and key
|
||||
$daemon->listen(['https://*:3000?cert=/x/server.crt&key=/y/server.key']);
|
||||
|
||||
# Domain specific certificates and keys (SNI)
|
||||
$daemon->listen(
|
||||
['https://*:3000?example.com_cert=/x/my.crt&example.com_key=/y/my.key']);
|
||||
|
||||
# Or even a custom certificate authority
|
||||
$daemon->listen(
|
||||
['https://*:3000?cert=/x/server.crt&key=/y/server.key&ca=/z/ca.crt']);
|
||||
|
||||
These parameters are currently available:
|
||||
|
||||
=over 2
|
||||
|
||||
=item ca
|
||||
|
||||
ca=/etc/tls/ca.crt
|
||||
|
||||
Path to TLS certificate authority file used to verify the peer certificate.
|
||||
|
||||
=item cert
|
||||
|
||||
cert=/etc/tls/server.crt
|
||||
mojolicious.org_cert=/etc/tls/mojo.crt
|
||||
|
||||
Path to the TLS cert file, defaults to a built-in test certificate.
|
||||
|
||||
=item ciphers
|
||||
|
||||
ciphers=AES128-GCM-SHA256:RC4:HIGH:!MD5:!aNULL:!EDH
|
||||
|
||||
TLS cipher specification string. For more information about the format see
|
||||
L<https://www.openssl.org/docs/manmaster/man1/ciphers.html#CIPHER-STRINGS>.
|
||||
|
||||
=item fd
|
||||
|
||||
fd=3
|
||||
|
||||
File descriptor with an already prepared listen socket.
|
||||
|
||||
=item key
|
||||
|
||||
key=/etc/tls/server.key
|
||||
mojolicious.org_key=/etc/tls/mojo.key
|
||||
|
||||
Path to the TLS key file, defaults to a built-in test key.
|
||||
|
||||
=item reuse
|
||||
|
||||
reuse=1
|
||||
|
||||
Allow multiple servers to use the same port with the C<SO_REUSEPORT> socket option.
|
||||
|
||||
=item single_accept
|
||||
|
||||
single_accept=1
|
||||
|
||||
Only accept one connection at a time.
|
||||
|
||||
=item verify
|
||||
|
||||
verify=0x00
|
||||
|
||||
TLS verification mode.
|
||||
|
||||
=item version
|
||||
|
||||
version=TLSv1_2
|
||||
|
||||
TLS protocol version.
|
||||
|
||||
=back
|
||||
|
||||
=head2 max_clients
|
||||
|
||||
my $max = $daemon->max_clients;
|
||||
$daemon = $daemon->max_clients(100);
|
||||
|
||||
Maximum number of accepted connections this server is allowed to handle concurrently, before stopping to accept new
|
||||
incoming connections, passed along to L<Mojo::IOLoop/"max_connections">.
|
||||
|
||||
=head2 max_requests
|
||||
|
||||
my $max = $daemon->max_requests;
|
||||
$daemon = $daemon->max_requests(250);
|
||||
|
||||
Maximum number of keep-alive requests per connection, defaults to C<100>.
|
||||
|
||||
=head2 silent
|
||||
|
||||
my $bool = $daemon->silent;
|
||||
$daemon = $daemon->silent($bool);
|
||||
|
||||
Disable console messages.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Daemon> inherits all methods from L<Mojo::Server> and implements the following new ones.
|
||||
|
||||
=head2 ports
|
||||
|
||||
my $ports = $daemon->ports;
|
||||
|
||||
Get all ports this server is currently listening on.
|
||||
|
||||
# All ports
|
||||
say for @{$daemon->ports};
|
||||
|
||||
=head2 run
|
||||
|
||||
$daemon->run;
|
||||
|
||||
Run server and wait for L</"SIGNALS">.
|
||||
|
||||
=head2 start
|
||||
|
||||
$daemon = $daemon->start;
|
||||
|
||||
Start or resume accepting connections through L</"ioloop">.
|
||||
|
||||
# Listen on random port
|
||||
my $port = $daemon->listen(['http://127.0.0.1'])->start->ports->[0];
|
||||
|
||||
# Run multiple web servers concurrently
|
||||
my $daemon1 = Mojo::Server::Daemon->new(listen => ['http://*:3000'])->start;
|
||||
my $daemon2 = Mojo::Server::Daemon->new(listen => ['http://*:4000'])->start;
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 stop
|
||||
|
||||
$daemon = $daemon->stop;
|
||||
|
||||
Stop accepting connections through L</"ioloop">.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_SERVER_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_SERVER_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
389
database/perl/vendor/lib/Mojo/Server/Hypnotoad.pm
vendored
Normal file
389
database/perl/vendor/lib/Mojo/Server/Hypnotoad.pm
vendored
Normal file
@@ -0,0 +1,389 @@
|
||||
package Mojo::Server::Hypnotoad;
|
||||
use Mojo::Base -base;
|
||||
|
||||
# "Bender: I was God once.
|
||||
# God: Yes, I saw. You were doing well, until everyone died."
|
||||
use Config;
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::Server::Prefork;
|
||||
use Mojo::Util qw(steady_time);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
has prefork => sub { Mojo::Server::Prefork->new(listen => ['http://*:8080']) };
|
||||
has upgrade_timeout => 180;
|
||||
|
||||
sub configure {
|
||||
my ($self, $name) = @_;
|
||||
|
||||
# Hypnotoad settings
|
||||
my $prefork = $self->prefork;
|
||||
my $c = $prefork->app->config($name) // {};
|
||||
$self->upgrade_timeout($c->{upgrade_timeout}) if $c->{upgrade_timeout};
|
||||
|
||||
# Pre-fork settings
|
||||
$prefork->reverse_proxy($c->{proxy}) if defined $c->{proxy};
|
||||
$prefork->max_clients($c->{clients}) if $c->{clients};
|
||||
$prefork->max_requests($c->{requests}) if $c->{requests};
|
||||
defined $c->{$_} and $prefork->$_($c->{$_})
|
||||
for qw(accepts backlog graceful_timeout heartbeat_interval heartbeat_timeout inactivity_timeout keep_alive_timeout),
|
||||
qw(listen pid_file spare workers);
|
||||
}
|
||||
|
||||
sub run {
|
||||
my ($self, $app) = @_;
|
||||
|
||||
# No fork emulation support
|
||||
_exit('Hypnotoad does not support fork emulation.') if $Config{d_pseudofork};
|
||||
|
||||
# Remember executable and application for later
|
||||
$ENV{HYPNOTOAD_EXE} ||= $0;
|
||||
$0 = $ENV{HYPNOTOAD_APP} ||= path($app)->to_abs->to_string;
|
||||
|
||||
# This is a production server
|
||||
$ENV{MOJO_MODE} ||= 'production';
|
||||
|
||||
# Clean start (to make sure everything works)
|
||||
die "Can't exec: $!" if !$ENV{HYPNOTOAD_REV}++ && !exec $^X, $ENV{HYPNOTOAD_EXE};
|
||||
|
||||
# Preload application and configure server
|
||||
my $prefork = $self->prefork->cleanup(0);
|
||||
$app = $prefork->load_app($app);
|
||||
$app->config->{hypnotoad}{pid_file} //= path($ENV{HYPNOTOAD_APP})->sibling('hypnotoad.pid')->to_string;
|
||||
$self->configure('hypnotoad');
|
||||
weaken $self;
|
||||
$prefork->on(wait => sub { $self->_manage });
|
||||
$prefork->on(reap => sub { $self->_cleanup(pop) });
|
||||
$prefork->on(finish => sub { $self->_finish });
|
||||
|
||||
# Testing
|
||||
_exit('Everything looks good!') if $ENV{HYPNOTOAD_TEST};
|
||||
|
||||
# Stop running server
|
||||
$self->_stop if $ENV{HYPNOTOAD_STOP};
|
||||
|
||||
# Initiate hot deployment
|
||||
$self->_hot_deploy unless $ENV{HYPNOTOAD_PID};
|
||||
|
||||
# Daemonize as early as possible (but not for restarts)
|
||||
local $SIG{USR2} = sub { $self->{upgrade} ||= steady_time };
|
||||
$prefork->start;
|
||||
$prefork->daemonize if !$ENV{HYPNOTOAD_FOREGROUND} && $ENV{HYPNOTOAD_REV} < 3;
|
||||
|
||||
# Start accepting connections
|
||||
$prefork->cleanup(1)->run;
|
||||
}
|
||||
|
||||
sub _cleanup {
|
||||
my ($self, $pid) = @_;
|
||||
|
||||
# Clean up failed upgrade
|
||||
return unless ($self->{new} || '') eq $pid;
|
||||
$self->prefork->app->log->error('Zero downtime software upgrade failed');
|
||||
delete @$self{qw(new upgrade)};
|
||||
}
|
||||
|
||||
sub _exit { say shift and exit 0 }
|
||||
|
||||
sub _finish {
|
||||
my $self = shift;
|
||||
|
||||
$self->{finish} = 1;
|
||||
return unless my $new = $self->{new};
|
||||
|
||||
my $prefork = $self->prefork->cleanup(0);
|
||||
path($prefork->pid_file)->remove;
|
||||
$prefork->ensure_pid_file($new);
|
||||
}
|
||||
|
||||
sub _hot_deploy {
|
||||
|
||||
# Make sure server is running
|
||||
return unless my $pid = shift->prefork->check_pid;
|
||||
|
||||
# Start hot deployment
|
||||
kill 'USR2', $pid;
|
||||
_exit("Starting hot deployment for Hypnotoad server $pid.");
|
||||
}
|
||||
|
||||
sub _manage {
|
||||
my $self = shift;
|
||||
|
||||
# Upgraded (wait for all workers to send a heartbeat)
|
||||
my $prefork = $self->prefork;
|
||||
my $log = $prefork->app->log;
|
||||
if ($ENV{HYPNOTOAD_PID} && $ENV{HYPNOTOAD_PID} ne $$) {
|
||||
return unless $prefork->healthy == $prefork->workers;
|
||||
$log->info("Upgrade successful, stopping $ENV{HYPNOTOAD_PID}");
|
||||
kill 'QUIT', $ENV{HYPNOTOAD_PID};
|
||||
}
|
||||
$ENV{HYPNOTOAD_PID} = $$ unless ($ENV{HYPNOTOAD_PID} // '') eq $$;
|
||||
|
||||
# Upgrade
|
||||
if ($self->{upgrade} && !$self->{finished}) {
|
||||
|
||||
# Fresh start
|
||||
my $ut = $self->upgrade_timeout;
|
||||
unless ($self->{new}) {
|
||||
$log->info("Starting zero downtime software upgrade ($ut seconds)");
|
||||
die "Can't fork: $!" unless defined(my $pid = $self->{new} = fork);
|
||||
exec $^X, $ENV{HYPNOTOAD_EXE} or die "Can't exec: $!" unless $pid;
|
||||
}
|
||||
|
||||
# Timeout
|
||||
kill 'KILL', $self->{new} if $self->{upgrade} + $ut <= steady_time;
|
||||
}
|
||||
}
|
||||
|
||||
sub _stop {
|
||||
_exit('Hypnotoad server not running.') unless my $pid = shift->prefork->check_pid;
|
||||
kill 'QUIT', $pid;
|
||||
_exit("Stopping Hypnotoad server $pid gracefully.");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Hypnotoad - A production web serv...ALL GLORY TO THE HYPNOTOAD!
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::Hypnotoad;
|
||||
|
||||
my $hypnotoad = Mojo::Server::Hypnotoad->new;
|
||||
$hypnotoad->run('/home/sri/myapp.pl');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Hypnotoad> is a full featured, UNIX optimized, pre-forking non-blocking I/O HTTP and WebSocket server,
|
||||
built around the very well tested and reliable L<Mojo::Server::Prefork>, with IPv6, TLS, SNI, UNIX domain socket, Comet
|
||||
(long polling), keep-alive, multiple event loop and hot deployment support that just works. Note that the server uses
|
||||
signals for process management, so you should avoid modifying signal handlers in your applications.
|
||||
|
||||
To start applications with it you can use the L<hypnotoad> script, which listens on port C<8080>, automatically
|
||||
daemonizes the server process and defaults to C<production> mode for L<Mojolicious> and L<Mojolicious::Lite>
|
||||
applications.
|
||||
|
||||
$ hypnotoad ./myapp.pl
|
||||
|
||||
You can run the same command again for automatic hot deployment.
|
||||
|
||||
$ hypnotoad ./myapp.pl
|
||||
Starting hot deployment for Hypnotoad server 31841.
|
||||
|
||||
This second invocation will load the application again, detect the process id file with it, and send a L</"USR2">
|
||||
signal to the already running server.
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(2.009+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 MANAGER SIGNALS
|
||||
|
||||
The L<Mojo::Server::Hypnotoad> manager process can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 INT, TERM
|
||||
|
||||
Shut down server immediately.
|
||||
|
||||
=head2 QUIT
|
||||
|
||||
Shut down server gracefully.
|
||||
|
||||
=head2 TTIN
|
||||
|
||||
Increase worker pool by one.
|
||||
|
||||
=head2 TTOU
|
||||
|
||||
Decrease worker pool by one.
|
||||
|
||||
=head2 USR2
|
||||
|
||||
Attempt zero downtime software upgrade (hot deployment) without losing any incoming connections.
|
||||
|
||||
Manager (old)
|
||||
|- Worker [1]
|
||||
|- Worker [2]
|
||||
|- Worker [3]
|
||||
|- Worker [4]
|
||||
+- Manager (new)
|
||||
|- Worker [1]
|
||||
|- Worker [2]
|
||||
|- Worker [3]
|
||||
+- Worker [4]
|
||||
|
||||
The new manager will automatically send a L</"QUIT"> signal to the old manager and take over serving requests after
|
||||
starting up successfully.
|
||||
|
||||
=head1 WORKER SIGNALS
|
||||
|
||||
L<Mojo::Server::Hypnotoad> worker processes can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 QUIT
|
||||
|
||||
Stop worker gracefully.
|
||||
|
||||
=head1 SETTINGS
|
||||
|
||||
L<Mojo::Server::Hypnotoad> can be configured with the following settings, see
|
||||
L<Mojolicious::Guides::Cookbook/"Hypnotoad"> for examples.
|
||||
|
||||
=head2 accepts
|
||||
|
||||
accepts => 100
|
||||
|
||||
Maximum number of connections a worker is allowed to accept, before stopping gracefully and then getting replaced with
|
||||
a newly started worker, defaults to the value of L<Mojo::Server::Prefork/"accepts">. Setting the value to C<0> will
|
||||
allow workers to accept new connections indefinitely. Note that up to half of this value can be subtracted randomly to
|
||||
improve load balancing, and to make sure that not all workers restart at the same time.
|
||||
|
||||
=head2 backlog
|
||||
|
||||
backlog => 128
|
||||
|
||||
Listen backlog size, defaults to the value of L<Mojo::Server::Daemon/"backlog">.
|
||||
|
||||
=head2 clients
|
||||
|
||||
clients => 100
|
||||
|
||||
Maximum number of accepted connections each worker process is allowed to handle concurrently, before stopping to accept
|
||||
new incoming connections, defaults to the value of L<Mojo::IOLoop/"max_connections">. Note that high concurrency works
|
||||
best with applications that perform mostly non-blocking operations, to optimize for blocking operations you can
|
||||
decrease this value and increase L</"workers"> instead for better performance.
|
||||
|
||||
=head2 graceful_timeout
|
||||
|
||||
graceful_timeout => 15
|
||||
|
||||
Maximum amount of time in seconds stopping a worker gracefully may take before being forced, defaults to the value of
|
||||
L<Mojo::Server::Prefork/"graceful_timeout">. Note that this value should usually be a little larger than the maximum
|
||||
amount of time you expect any one request to take.
|
||||
|
||||
=head2 heartbeat_interval
|
||||
|
||||
heartbeat_interval => 3
|
||||
|
||||
Heartbeat interval in seconds, defaults to the value of L<Mojo::Server::Prefork/"heartbeat_interval">.
|
||||
|
||||
=head2 heartbeat_timeout
|
||||
|
||||
heartbeat_timeout => 2
|
||||
|
||||
Maximum amount of time in seconds before a worker without a heartbeat will be stopped gracefully, defaults to the value
|
||||
of L<Mojo::Server::Prefork/"heartbeat_timeout">. Note that this value should usually be a little larger than the
|
||||
maximum amount of time you expect any one operation to block the event loop.
|
||||
|
||||
=head2 inactivity_timeout
|
||||
|
||||
inactivity_timeout => 10
|
||||
|
||||
Maximum amount of time in seconds a connection with an active request can be inactive before getting closed, defaults
|
||||
to the value of L<Mojo::Server::Daemon/"inactivity_timeout">. Setting the value to C<0> will allow connections to be
|
||||
inactive indefinitely.
|
||||
|
||||
=head2 keep_alive_timeout
|
||||
|
||||
keep_alive_timeout => 10
|
||||
|
||||
Maximum amount of time in seconds a connection without an active request can be inactive before getting closed,
|
||||
defaults to the value of L<Mojo::Server::Daemon/"keep_alive_timeout">. Setting the value to C<0> will allow connections
|
||||
to be inactive indefinitely.
|
||||
|
||||
=head2 listen
|
||||
|
||||
listen => ['http://*:80']
|
||||
|
||||
Array reference with one or more locations to listen on, defaults to C<http://*:8080>. See also
|
||||
L<Mojo::Server::Daemon/"listen"> for more examples.
|
||||
|
||||
=head2 pid_file
|
||||
|
||||
pid_file => '/var/run/hypnotoad.pid'
|
||||
|
||||
Full path to process id file, defaults to C<hypnotoad.pid> in the same directory as the application. Note that this
|
||||
value can only be changed after the server has been stopped.
|
||||
|
||||
=head2 proxy
|
||||
|
||||
proxy => 1
|
||||
|
||||
Activate reverse proxy support, which allows for the C<X-Forwarded-For> and C<X-Forwarded-Proto> headers to be picked
|
||||
up automatically, defaults to the value of L<Mojo::Server/"reverse_proxy">.
|
||||
|
||||
=head2 requests
|
||||
|
||||
requests => 50
|
||||
|
||||
Number of keep-alive requests per connection, defaults to the value of L<Mojo::Server::Daemon/"max_requests">.
|
||||
|
||||
=head2 spare
|
||||
|
||||
spare => 4
|
||||
|
||||
Temporarily spawn up to this number of additional workers if there is a need, defaults to the value of
|
||||
L<Mojo::Server::Prefork/"spare">. This allows for new workers to be started while old ones are still shutting down
|
||||
gracefully, drastically reducing the performance cost of worker restarts.
|
||||
|
||||
=head2 upgrade_timeout
|
||||
|
||||
upgrade_timeout => 45
|
||||
|
||||
Maximum amount of time in seconds a zero downtime software upgrade may take before getting canceled, defaults to
|
||||
C<180>.
|
||||
|
||||
=head2 workers
|
||||
|
||||
workers => 10
|
||||
|
||||
Number of worker processes, defaults to the value of L<Mojo::Server::Prefork/"workers">. A good rule of thumb is two
|
||||
worker processes per CPU core for applications that perform mostly non-blocking operations, blocking operations often
|
||||
require more and benefit from decreasing concurrency with L</"clients"> (often as low as C<1>). Note that during zero
|
||||
downtime software upgrades there will be twice as many workers active for a short amount of time.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Hypnotoad> implements the following attributes.
|
||||
|
||||
=head2 prefork
|
||||
|
||||
my $prefork = $hypnotoad->prefork;
|
||||
$hypnotoad = $hypnotoad->prefork(Mojo::Server::Prefork->new);
|
||||
|
||||
L<Mojo::Server::Prefork> object this server manages.
|
||||
|
||||
=head2 upgrade_timeout
|
||||
|
||||
my $timeout = $hypnotoad->upgrade_timeout;
|
||||
$hypnotoad = $hypnotoad->upgrade_timeout(15);
|
||||
|
||||
Maximum amount of time in seconds a zero downtime software upgrade may take before getting canceled, defaults to
|
||||
C<180>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Hypnotoad> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 configure
|
||||
|
||||
$hypnotoad->configure('hypnotoad');
|
||||
|
||||
Configure server from application settings.
|
||||
|
||||
=head2 run
|
||||
|
||||
$hypnotoad->run('script/my_app');
|
||||
|
||||
Run server for application and wait for L</"MANAGER SIGNALS">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
147
database/perl/vendor/lib/Mojo/Server/Morbo.pm
vendored
Normal file
147
database/perl/vendor/lib/Mojo/Server/Morbo.pm
vendored
Normal file
@@ -0,0 +1,147 @@
|
||||
package Mojo::Server::Morbo;
|
||||
use Mojo::Base -base;
|
||||
|
||||
# "Linda: With Haley's Comet out of ice, Earth is experiencing the devastating
|
||||
# effects of sudden, intense global warming.
|
||||
# Morbo: Morbo is pleased but sticky."
|
||||
use Mojo::Loader qw(load_class);
|
||||
use Mojo::Server::Daemon;
|
||||
use POSIX qw(WNOHANG);
|
||||
|
||||
has backend => sub {
|
||||
my $backend = $ENV{MOJO_MORBO_BACKEND} || 'Poll';
|
||||
$backend = "Mojo::Server::Morbo::Backend::$backend";
|
||||
return $backend->new unless my $e = load_class $backend;
|
||||
die $e if ref $e;
|
||||
die qq{Can't find Morbo backend class "$backend" in \@INC. (@INC)\n};
|
||||
};
|
||||
has daemon => sub { Mojo::Server::Daemon->new };
|
||||
|
||||
sub run {
|
||||
my ($self, $app) = @_;
|
||||
|
||||
# Clean manager environment
|
||||
local $SIG{INT} = local $SIG{TERM} = sub {
|
||||
$self->{finished} = 1;
|
||||
kill 'TERM', $self->{worker} if $self->{worker};
|
||||
};
|
||||
unshift @{$self->backend->watch}, $0 = $app;
|
||||
$self->{modified} = 1;
|
||||
|
||||
# Prepare and cache listen sockets for smooth restarting
|
||||
$self->daemon->start->stop;
|
||||
|
||||
$self->_manage until $self->{finished} && !$self->{worker};
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub _manage {
|
||||
my $self = shift;
|
||||
|
||||
if (my @files = @{$self->backend->modified_files}) {
|
||||
say @files == 1
|
||||
? qq{File "@{[$files[0]]}" changed, restarting.}
|
||||
: qq{@{[scalar @files]} files changed, restarting.}
|
||||
if $ENV{MORBO_VERBOSE};
|
||||
kill 'TERM', $self->{worker} if $self->{worker};
|
||||
$self->{modified} = 1;
|
||||
}
|
||||
|
||||
if (my $pid = $self->{worker}) {
|
||||
delete $self->{worker} if waitpid($pid, WNOHANG) == $pid;
|
||||
}
|
||||
|
||||
$self->_spawn if !$self->{worker} && delete $self->{modified};
|
||||
}
|
||||
|
||||
sub _spawn {
|
||||
my $self = shift;
|
||||
|
||||
# Manager
|
||||
my $manager = $$;
|
||||
die "Can't fork: $!" unless defined(my $pid = $self->{worker} = fork);
|
||||
return if $pid;
|
||||
|
||||
# Worker
|
||||
my $daemon = $self->daemon;
|
||||
$daemon->load_app($self->backend->watch->[0])->server($daemon);
|
||||
$daemon->ioloop->recurring(1 => sub { shift->stop unless kill 0, $manager });
|
||||
$daemon->run;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Morbo - Tonight at 11...DOOOOOOOOOOOOOOOM!
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::Morbo;
|
||||
|
||||
my $morbo = Mojo::Server::Morbo->new;
|
||||
$morbo->run('/home/sri/myapp.pl');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Morbo> is a full featured, self-restart capable non-blocking I/O HTTP and WebSocket server, built
|
||||
around the very well tested and reliable L<Mojo::Server::Daemon>, with IPv6, TLS, SNI, UNIX domain socket, Comet (long
|
||||
polling), keep-alive and multiple event loop support. Note that the server uses signals for process management, so you
|
||||
should avoid modifying signal handlers in your applications.
|
||||
|
||||
To start applications with it you can use the L<morbo> script.
|
||||
|
||||
$ morbo ./myapp.pl
|
||||
Web application available at http://127.0.0.1:3000
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(2.009+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 SIGNALS
|
||||
|
||||
The L<Mojo::Server::Morbo> process can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 INT, TERM
|
||||
|
||||
Shut down server immediately.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Morbo> implements the following attributes.
|
||||
|
||||
=head2 backend
|
||||
|
||||
my $backend = $morbo->backend;
|
||||
$morbo = $morbo->backend(Mojo::Server::Morbo::Backend::Poll->new);
|
||||
|
||||
Backend, usually a L<Mojo::Server::Morbo::Backend::Poll> object.
|
||||
|
||||
=head2 daemon
|
||||
|
||||
my $daemon = $morbo->daemon;
|
||||
$morbo = $morbo->daemon(Mojo::Server::Daemon->new);
|
||||
|
||||
L<Mojo::Server::Daemon> object this server manages.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Morbo> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 run
|
||||
|
||||
$morbo->run('script/my_app');
|
||||
|
||||
Run server for application and wait for L</"SIGNALS">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
69
database/perl/vendor/lib/Mojo/Server/Morbo/Backend.pm
vendored
Normal file
69
database/perl/vendor/lib/Mojo/Server/Morbo/Backend.pm
vendored
Normal file
@@ -0,0 +1,69 @@
|
||||
package Mojo::Server::Morbo::Backend;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Carp qw(croak);
|
||||
|
||||
has watch => sub { [qw(lib templates)] };
|
||||
has watch_timeout => sub { $ENV{MOJO_MORBO_TIMEOUT} || 1 };
|
||||
|
||||
sub modified_files { croak 'Method "modified_files" not implemented by subclass' }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Morbo::Backend - Morbo backend base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Server::Morbo::Backend::Inotify:
|
||||
use Mojo::Base 'Mojo::Server::Morbo::Backend';
|
||||
|
||||
sub modified_files {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Morbo::Backend> is an abstract base class for Morbo backends, like
|
||||
L<Mojo::Server::Morbo::Backend::Poll>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Morbo::Backend> implements the following attributes.
|
||||
|
||||
=head2 watch
|
||||
|
||||
my $watch = $backend->watch;
|
||||
$backend = $backend->watch(['/home/sri/my_app']);
|
||||
|
||||
Files and directories to watch for changes, defaults to the application script as well as the C<lib> and C<templates>
|
||||
directories in the current working directory.
|
||||
|
||||
=head2 watch_timeout
|
||||
|
||||
my $timeout = $backend->watch_timeout;
|
||||
$backend = $backend->watch_timeout(10);
|
||||
|
||||
Maximum amount of time in seconds a backend may block when waiting for files to change, defaults to the value of the
|
||||
C<MOJO_MORBO_TIMEOUT> environment variable or C<1>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Morbo::Backend> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 modified_files
|
||||
|
||||
my $files = $backend->modified_files;
|
||||
|
||||
Check if files from L</"watch"> have been modified since the last check and return an array reference with the results.
|
||||
Meant to be overloaded in a subclass.
|
||||
|
||||
# All files that have been modified
|
||||
say for @{$backend->modified_files};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
69
database/perl/vendor/lib/Mojo/Server/Morbo/Backend/Poll.pm
vendored
Normal file
69
database/perl/vendor/lib/Mojo/Server/Morbo/Backend/Poll.pm
vendored
Normal file
@@ -0,0 +1,69 @@
|
||||
package Mojo::Server::Morbo::Backend::Poll;
|
||||
use Mojo::Base 'Mojo::Server::Morbo::Backend';
|
||||
|
||||
use Mojo::File qw(path);
|
||||
|
||||
sub modified_files {
|
||||
my $self = shift;
|
||||
|
||||
my $cache = $self->{cache} //= {};
|
||||
my @files;
|
||||
for my $file (map { -f $_ && -r _ ? $_ : _list($_) } @{$self->watch}) {
|
||||
my ($size, $mtime) = (stat $file)[7, 9];
|
||||
next unless defined $size and defined $mtime;
|
||||
my $stats = $cache->{$file} ||= [$^T, $size];
|
||||
next if $mtime <= $stats->[0] && $size == $stats->[1];
|
||||
@$stats = ($mtime, $size);
|
||||
push @files, $file;
|
||||
}
|
||||
sleep $self->watch_timeout unless @files;
|
||||
|
||||
return \@files;
|
||||
}
|
||||
|
||||
sub _list { path(shift)->list_tree->map('to_string')->each }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Morbo::Backend::Poll - Morbo default backend
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::Morbo::Backend::Poll;
|
||||
|
||||
my $backend = Mojo::Server::Morbo::Backend::Poll->new;
|
||||
if (my $files = $backend->modified_files) {
|
||||
...
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Morbo::Backend:Poll> is the default backend for L<Mojo::Server::Morbo>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Morbo::Backend::Poll> inherits all attributes from L<Mojo::Server::Morbo::Backend>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Morbo::Backend::Poll> inherits all methods from L<Mojo::Server::Morbo::Backend> and implements the
|
||||
following new ones.
|
||||
|
||||
=head2 modified_files
|
||||
|
||||
my $files = $backend->modified_files;
|
||||
|
||||
Check file size and mtime to determine which files have changed, this is not particularly efficient, but very portable.
|
||||
|
||||
# All files that have been modified
|
||||
say for @{$backend->modified_files};
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
127
database/perl/vendor/lib/Mojo/Server/PSGI.pm
vendored
Normal file
127
database/perl/vendor/lib/Mojo/Server/PSGI.pm
vendored
Normal file
@@ -0,0 +1,127 @@
|
||||
package Mojo::Server::PSGI;
|
||||
use Mojo::Base 'Mojo::Server';
|
||||
|
||||
sub run {
|
||||
my ($self, $env) = @_;
|
||||
|
||||
my $tx = $self->build_tx;
|
||||
my $req = $tx->req->parse($env);
|
||||
$tx->local_port($env->{SERVER_PORT})->remote_address($env->{REMOTE_ADDR});
|
||||
|
||||
# Request body (may block if we try to read too much)
|
||||
my $len = $env->{CONTENT_LENGTH};
|
||||
until ($req->is_finished) {
|
||||
my $chunk = ($len && $len < 131072) ? $len : 131072;
|
||||
last unless my $read = $env->{'psgi.input'}->read(my $buffer, $chunk, 0);
|
||||
$req->parse($buffer);
|
||||
last if ($len -= $read) <= 0;
|
||||
}
|
||||
|
||||
$self->emit(request => $tx);
|
||||
|
||||
# Response headers
|
||||
my $res = $tx->res->fix_headers;
|
||||
my $hash = $res->headers->to_hash(1);
|
||||
my @headers;
|
||||
for my $name (keys %$hash) { push @headers, $name, $_ for @{$hash->{$name}} }
|
||||
|
||||
# PSGI response
|
||||
my $io = Mojo::Server::PSGI::_IO->new(tx => $tx, empty => $tx->is_empty);
|
||||
return [$res->code // 404, \@headers, $io];
|
||||
}
|
||||
|
||||
sub to_psgi_app {
|
||||
my $self = shift;
|
||||
|
||||
# Preload application and wrap it
|
||||
$self->app->server($self);
|
||||
return sub { $self->run(@_) }
|
||||
}
|
||||
|
||||
package Mojo::Server::PSGI::_IO;
|
||||
use Mojo::Base -base;
|
||||
|
||||
# Finish transaction
|
||||
sub close { shift->{tx}->closed }
|
||||
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
|
||||
# Empty
|
||||
return undef if $self->{empty};
|
||||
|
||||
# No content yet, try again later
|
||||
my $chunk = $self->{tx}->res->get_body_chunk($self->{offset} //= 0);
|
||||
return '' unless defined $chunk;
|
||||
|
||||
# End of content
|
||||
return undef unless length $chunk;
|
||||
|
||||
$self->{offset} += length $chunk;
|
||||
return $chunk;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::PSGI - PSGI server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::PSGI;
|
||||
|
||||
my $psgi = Mojo::Server::PSGI->new;
|
||||
$psgi->unsubscribe('request')->on(request => sub ($psgi, $tx) {
|
||||
|
||||
# Request
|
||||
my $method = $tx->req->method;
|
||||
my $path = $tx->req->url->path;
|
||||
|
||||
# Response
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body("$method request for $path!");
|
||||
|
||||
# Resume transaction
|
||||
$tx->resume;
|
||||
});
|
||||
my $app = $psgi->to_psgi_app;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::PSGI> allows L<Mojolicious> applications to run on all L<PSGI> compatible servers.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Server::PSGI> inherits all events from L<Mojo::Server>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::PSGI> inherits all attributes from L<Mojo::Server>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::PSGI> inherits all methods from L<Mojo::Server> and implements the following new ones.
|
||||
|
||||
=head2 run
|
||||
|
||||
my $res = $psgi->run($env);
|
||||
|
||||
Run L<PSGI>.
|
||||
|
||||
=head2 to_psgi_app
|
||||
|
||||
my $app = $psgi->to_psgi_app;
|
||||
|
||||
Turn L<Mojolicious> application into L<PSGI> application.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
412
database/perl/vendor/lib/Mojo/Server/Prefork.pm
vendored
Normal file
412
database/perl/vendor/lib/Mojo/Server/Prefork.pm
vendored
Normal file
@@ -0,0 +1,412 @@
|
||||
package Mojo::Server::Prefork;
|
||||
use Mojo::Base 'Mojo::Server::Daemon';
|
||||
|
||||
use Config;
|
||||
use File::Spec::Functions qw(tmpdir);
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::Util qw(steady_time);
|
||||
use POSIX qw(WNOHANG);
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
has accepts => 10000;
|
||||
has cleanup => 1;
|
||||
has graceful_timeout => 120;
|
||||
has heartbeat_timeout => 50;
|
||||
has heartbeat_interval => 5;
|
||||
has pid_file => sub { path(tmpdir, 'prefork.pid')->to_string };
|
||||
has spare => 2;
|
||||
has workers => 4;
|
||||
|
||||
sub DESTROY { path($_[0]->pid_file)->remove if $_[0]->cleanup }
|
||||
|
||||
sub check_pid {
|
||||
return undef unless -r (my $file = path(shift->pid_file));
|
||||
my $pid = $file->slurp;
|
||||
chomp $pid;
|
||||
|
||||
# Running
|
||||
return $pid if $pid && kill 0, $pid;
|
||||
|
||||
# Not running
|
||||
$file->remove;
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub ensure_pid_file {
|
||||
my ($self, $pid) = @_;
|
||||
|
||||
# Check if PID file already exists
|
||||
return if -e (my $file = path($self->pid_file));
|
||||
|
||||
# Create PID file
|
||||
if (my $err = eval { $file->spurt("$pid\n")->chmod(0644) } ? undef : $@) {
|
||||
$self->app->log->error(qq{Can't create process id file "$file": $err})
|
||||
and die qq{Can't create process id file "$file": $err};
|
||||
}
|
||||
$self->app->log->info(qq{Creating process id file "$file"});
|
||||
}
|
||||
|
||||
sub healthy {
|
||||
scalar grep { $_->{healthy} } values %{shift->{pool}};
|
||||
}
|
||||
|
||||
sub run {
|
||||
my $self = shift;
|
||||
|
||||
# No fork emulation support
|
||||
say 'Pre-forking does not support fork emulation.' and exit 0 if $Config{d_pseudofork};
|
||||
|
||||
# Pipe for worker communication
|
||||
pipe($self->{reader}, $self->{writer}) or die "Can't create pipe: $!";
|
||||
|
||||
# Clean manager environment
|
||||
local $SIG{CHLD} = sub {
|
||||
while ((my $pid = waitpid -1, WNOHANG) > 0) { $self->emit(reap => $pid)->_stopped($pid) }
|
||||
};
|
||||
local $SIG{INT} = local $SIG{TERM} = sub { $self->_term };
|
||||
local $SIG{QUIT} = sub { $self->_term(1) };
|
||||
local $SIG{TTIN} = sub { $self->workers($self->workers + 1) };
|
||||
local $SIG{TTOU} = sub {
|
||||
$self->workers > 0 ? $self->workers($self->workers - 1) : return;
|
||||
for my $w (values %{$self->{pool}}) { ($w->{graceful} = steady_time) and last unless $w->{graceful} }
|
||||
};
|
||||
|
||||
# Preload application before starting workers
|
||||
$self->start->app->log->info("Manager $$ started");
|
||||
$self->ioloop->max_accepts($self->accepts);
|
||||
$self->{running} = 1;
|
||||
$self->_manage while $self->{running};
|
||||
$self->app->log->info("Manager $$ stopped");
|
||||
}
|
||||
|
||||
sub _heartbeat { shift->{writer}->syswrite("$$:$_[0]\n") or exit 0 }
|
||||
|
||||
sub _manage {
|
||||
my $self = shift;
|
||||
|
||||
# Spawn more workers if necessary and check PID file
|
||||
if (!$self->{finished}) {
|
||||
my $graceful = grep { $_->{graceful} } values %{$self->{pool}};
|
||||
my $spare = $self->spare;
|
||||
$spare = $graceful ? $graceful > $spare ? $spare : $graceful : 0;
|
||||
my $need = ($self->workers - keys %{$self->{pool}}) + $spare;
|
||||
$self->_spawn while $need-- > 0;
|
||||
$self->ensure_pid_file($$);
|
||||
}
|
||||
|
||||
# Shutdown
|
||||
elsif (!keys %{$self->{pool}}) { return delete $self->{running} }
|
||||
|
||||
# Wait for heartbeats
|
||||
$self->_wait;
|
||||
|
||||
my $interval = $self->heartbeat_interval;
|
||||
my $ht = $self->heartbeat_timeout;
|
||||
my $gt = $self->graceful_timeout;
|
||||
my $log = $self->app->log;
|
||||
my $time = steady_time;
|
||||
|
||||
for my $pid (keys %{$self->{pool}}) {
|
||||
next unless my $w = $self->{pool}{$pid};
|
||||
|
||||
# No heartbeat (graceful stop)
|
||||
$log->error("Worker $pid has no heartbeat ($ht seconds), restarting") and $w->{graceful} = $time
|
||||
if !$w->{graceful} && ($w->{time} + $interval + $ht <= $time);
|
||||
|
||||
# Graceful stop with timeout
|
||||
my $graceful = $w->{graceful} ||= $self->{graceful} ? $time : undef;
|
||||
$log->info("Stopping worker $pid gracefully ($gt seconds)") and (kill 'QUIT', $pid or $self->_stopped($pid))
|
||||
if $graceful && !$w->{quit}++;
|
||||
$w->{force} = 1 if $graceful && $graceful + $gt <= $time;
|
||||
|
||||
# Normal stop
|
||||
$log->warn("Stopping worker $pid immediately") and (kill 'KILL', $pid or $self->_stopped($pid))
|
||||
if $w->{force} || ($self->{finished} && !$graceful);
|
||||
}
|
||||
}
|
||||
|
||||
sub _spawn {
|
||||
my $self = shift;
|
||||
|
||||
# Manager
|
||||
die "Can't fork: $!" unless defined(my $pid = fork);
|
||||
return $self->emit(spawn => $pid)->{pool}{$pid} = {time => steady_time} if $pid;
|
||||
|
||||
# Heartbeat messages
|
||||
my $loop = $self->cleanup(0)->ioloop;
|
||||
my $finished = 0;
|
||||
$loop->on(finish => sub { $finished = 1 });
|
||||
weaken $self;
|
||||
my $cb = sub { $self->_heartbeat($finished) };
|
||||
$loop->next_tick($cb);
|
||||
$loop->recurring($self->heartbeat_interval => $cb);
|
||||
|
||||
# Clean worker environment
|
||||
$SIG{$_} = 'DEFAULT' for qw(CHLD INT TERM TTIN TTOU);
|
||||
$SIG{QUIT} = sub { $loop->stop_gracefully };
|
||||
$loop->on(finish => sub { $self->max_requests(1) });
|
||||
delete $self->{reader};
|
||||
srand;
|
||||
|
||||
$self->app->log->info("Worker $$ started");
|
||||
$loop->start;
|
||||
exit 0;
|
||||
}
|
||||
|
||||
sub _stopped {
|
||||
my ($self, $pid) = @_;
|
||||
|
||||
return unless my $w = delete $self->{pool}{$pid};
|
||||
|
||||
my $log = $self->app->log;
|
||||
$log->info("Worker $pid stopped");
|
||||
$log->error("Worker $pid stopped too early, shutting down") and $self->_term unless $w->{healthy};
|
||||
}
|
||||
|
||||
sub _term {
|
||||
my ($self, $graceful) = @_;
|
||||
@{$self->emit(finish => $graceful)}{qw(finished graceful)} = (1, $graceful);
|
||||
}
|
||||
|
||||
sub _wait {
|
||||
my $self = shift;
|
||||
|
||||
# Poll for heartbeats
|
||||
my $reader = $self->emit('wait')->{reader};
|
||||
return unless Mojo::Util::_readable(1000, fileno($reader));
|
||||
return unless $reader->sysread(my $chunk, 4194304);
|
||||
|
||||
# Update heartbeats (and stop gracefully if necessary)
|
||||
my $time = steady_time;
|
||||
while ($chunk =~ /(\d+):(\d)\n/g) {
|
||||
next unless my $w = $self->{pool}{$1};
|
||||
@$w{qw(healthy time)} = (1, $time) and $self->emit(heartbeat => $1);
|
||||
$w->{graceful} ||= $time if $2;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Server::Prefork - Pre-forking non-blocking I/O HTTP and WebSocket server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Server::Prefork;
|
||||
|
||||
my $prefork = Mojo::Server::Prefork->new(listen => ['http://*:8080']);
|
||||
$prefork->unsubscribe('request')->on(request => sub ($prefork, $tx) {
|
||||
|
||||
# Request
|
||||
my $method = $tx->req->method;
|
||||
my $path = $tx->req->url->path;
|
||||
|
||||
# Response
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body("$method request for $path!");
|
||||
|
||||
# Resume transaction
|
||||
$tx->resume;
|
||||
});
|
||||
$prefork->run;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Server::Prefork> is a full featured, UNIX optimized, pre-forking non-blocking I/O HTTP and WebSocket server,
|
||||
built around the very well tested and reliable L<Mojo::Server::Daemon>, with IPv6, TLS, SNI, UNIX domain socket, Comet
|
||||
(long polling), keep-alive and multiple event loop support. Note that the server uses signals for process management,
|
||||
so you should avoid modifying signal handlers in your applications.
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(1.84+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"DEPLOYMENT"> for more.
|
||||
|
||||
=head1 MANAGER SIGNALS
|
||||
|
||||
The L<Mojo::Server::Prefork> manager process can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 INT, TERM
|
||||
|
||||
Shut down server immediately.
|
||||
|
||||
=head2 QUIT
|
||||
|
||||
Shut down server gracefully.
|
||||
|
||||
=head2 TTIN
|
||||
|
||||
Increase worker pool by one.
|
||||
|
||||
=head2 TTOU
|
||||
|
||||
Decrease worker pool by one.
|
||||
|
||||
=head1 WORKER SIGNALS
|
||||
|
||||
L<Mojo::Server::Prefork> worker processes can be controlled at runtime with the following signals.
|
||||
|
||||
=head2 QUIT
|
||||
|
||||
Stop worker gracefully.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Server::Prefork> inherits all events from L<Mojo::Server::Daemon> and can emit the following new ones.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$prefork->on(finish => sub ($prefork, $graceful) {...});
|
||||
|
||||
Emitted when the server shuts down.
|
||||
|
||||
$prefork->on(finish => sub ($prefork, $graceful) {
|
||||
say $graceful ? 'Graceful server shutdown' : 'Server shutdown';
|
||||
});
|
||||
|
||||
=head2 heartbeat
|
||||
|
||||
$prefork->on(heartbeat => sub ($prefork, $pid) {...});
|
||||
|
||||
Emitted when a heartbeat message has been received from a worker.
|
||||
|
||||
$prefork->on(heartbeat => sub ($prefork, $pid) { say "Worker $pid has a heartbeat" });
|
||||
|
||||
=head2 reap
|
||||
|
||||
$prefork->on(reap => sub ($prefork, $pid) {...});
|
||||
|
||||
Emitted when a child process exited.
|
||||
|
||||
$prefork->on(reap => sub ($prefork, $pid) { say "Worker $pid stopped" });
|
||||
|
||||
=head2 spawn
|
||||
|
||||
$prefork->on(spawn => sub ($prefork, $pid) {...});
|
||||
|
||||
Emitted when a worker process is spawned.
|
||||
|
||||
$prefork->on(spawn => sub ($prefork, $pid) { say "Worker $pid started" });
|
||||
|
||||
=head2 wait
|
||||
|
||||
$prefork->on(wait => sub ($prefork) {...});
|
||||
|
||||
Emitted when the manager starts waiting for new heartbeat messages.
|
||||
|
||||
$prefork->on(wait => sub ($prefork) {
|
||||
my $workers = $prefork->workers;
|
||||
say "Waiting for heartbeat messages from $workers workers";
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Server::Prefork> inherits all attributes from L<Mojo::Server::Daemon> and implements the following new ones.
|
||||
|
||||
=head2 accepts
|
||||
|
||||
my $accepts = $prefork->accepts;
|
||||
$prefork = $prefork->accepts(100);
|
||||
|
||||
Maximum number of connections a worker is allowed to accept, before stopping gracefully and then getting replaced with
|
||||
a newly started worker, passed along to L<Mojo::IOLoop/"max_accepts">, defaults to C<10000>. Setting the value to C<0>
|
||||
will allow workers to accept new connections indefinitely. Note that up to half of this value can be subtracted
|
||||
randomly to improve load balancing, and to make sure that not all workers restart at the same time.
|
||||
|
||||
=head2 cleanup
|
||||
|
||||
my $bool = $prefork->cleanup;
|
||||
$prefork = $prefork->cleanup($bool);
|
||||
|
||||
Delete L</"pid_file"> automatically once it is not needed anymore, defaults to a true value.
|
||||
|
||||
=head2 graceful_timeout
|
||||
|
||||
my $timeout = $prefork->graceful_timeout;
|
||||
$prefork = $prefork->graceful_timeout(15);
|
||||
|
||||
Maximum amount of time in seconds stopping a worker gracefully may take before being forced, defaults to C<120>. Note
|
||||
that this value should usually be a little larger than the maximum amount of time you expect any one request to take.
|
||||
|
||||
=head2 heartbeat_interval
|
||||
|
||||
my $interval = $prefork->heartbeat_interval;
|
||||
$prefork = $prefork->heartbeat_interval(3);
|
||||
|
||||
Heartbeat interval in seconds, defaults to C<5>.
|
||||
|
||||
=head2 heartbeat_timeout
|
||||
|
||||
my $timeout = $prefork->heartbeat_timeout;
|
||||
$prefork = $prefork->heartbeat_timeout(2);
|
||||
|
||||
Maximum amount of time in seconds before a worker without a heartbeat will be stopped gracefully, defaults to C<50>.
|
||||
Note that this value should usually be a little larger than the maximum amount of time you expect any one operation to
|
||||
block the event loop.
|
||||
|
||||
=head2 pid_file
|
||||
|
||||
my $file = $prefork->pid_file;
|
||||
$prefork = $prefork->pid_file('/tmp/prefork.pid');
|
||||
|
||||
Full path of process id file, defaults to C<prefork.pid> in a temporary directory.
|
||||
|
||||
=head2 spare
|
||||
|
||||
my $spare = $prefork->spare;
|
||||
$prefork = $prefork->spare(4);
|
||||
|
||||
Temporarily spawn up to this number of additional workers if there is a need, defaults to C<2>. This allows for new
|
||||
workers to be started while old ones are still shutting down gracefully, drastically reducing the performance cost of
|
||||
worker restarts.
|
||||
|
||||
=head2 workers
|
||||
|
||||
my $workers = $prefork->workers;
|
||||
$prefork = $prefork->workers(10);
|
||||
|
||||
Number of worker processes, defaults to C<4>. A good rule of thumb is two worker processes per CPU core for
|
||||
applications that perform mostly non-blocking operations, blocking operations often require more and benefit from
|
||||
decreasing concurrency with L<Mojo::Server::Daemon/"max_clients"> (often as low as C<1>).
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Server::Prefork> inherits all methods from L<Mojo::Server::Daemon> and implements the following new ones.
|
||||
|
||||
=head2 check_pid
|
||||
|
||||
my $pid = $prefork->check_pid;
|
||||
|
||||
Get process id for running server from L</"pid_file"> or delete it if server is not running.
|
||||
|
||||
say 'Server is not running' unless $prefork->check_pid;
|
||||
|
||||
=head2 ensure_pid_file
|
||||
|
||||
$prefork->ensure_pid_file($pid);
|
||||
|
||||
Ensure L</"pid_file"> exists.
|
||||
|
||||
=head2 healthy
|
||||
|
||||
my $healthy = $prefork->healthy;
|
||||
|
||||
Number of currently active worker processes with a heartbeat.
|
||||
|
||||
=head2 run
|
||||
|
||||
$prefork->run;
|
||||
|
||||
Run server and wait for L</"MANAGER SIGNALS">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
672
database/perl/vendor/lib/Mojo/Template.pm
vendored
Normal file
672
database/perl/vendor/lib/Mojo/Template.pm
vendored
Normal file
@@ -0,0 +1,672 @@
|
||||
package Mojo::Template;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::ByteStream;
|
||||
use Mojo::Exception;
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::Util qw(decode encode monkey_patch);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_TEMPLATE_DEBUG} || 0;
|
||||
|
||||
has [qw(append code prepend unparsed)] => '';
|
||||
has [qw(auto_escape compiled vars)];
|
||||
has capture_end => 'end';
|
||||
has capture_start => 'begin';
|
||||
has comment_mark => '#';
|
||||
has encoding => 'UTF-8';
|
||||
has escape => sub { \&Mojo::Util::xml_escape };
|
||||
has [qw(escape_mark expression_mark trim_mark)] => '=';
|
||||
has [qw(line_start replace_mark)] => '%';
|
||||
has name => 'template';
|
||||
has namespace => 'Mojo::Template::Sandbox';
|
||||
has tag_start => '<%';
|
||||
has tag_end => '%>';
|
||||
has tree => sub { [] };
|
||||
|
||||
sub parse {
|
||||
my ($self, $template) = @_;
|
||||
|
||||
# Clean start
|
||||
$self->unparsed($template)->tree(\my @tree)->compiled(undef);
|
||||
|
||||
my $tag = $self->tag_start;
|
||||
my $replace = $self->replace_mark;
|
||||
my $expr = $self->expression_mark;
|
||||
my $escp = $self->escape_mark;
|
||||
my $cpen = $self->capture_end;
|
||||
my $cmnt = $self->comment_mark;
|
||||
my $cpst = $self->capture_start;
|
||||
my $trim = $self->trim_mark;
|
||||
my $end = $self->tag_end;
|
||||
my $start = $self->line_start;
|
||||
|
||||
my $line_re = qr/^(\s*)\Q$start\E(?:(\Q$replace\E)|(\Q$cmnt\E)|(\Q$expr\E))?(.*)$/;
|
||||
my $token_re = qr/
|
||||
(
|
||||
\Q$tag\E(?:\Q$replace\E|\Q$cmnt\E) # Replace
|
||||
|
|
||||
\Q$tag$expr\E(?:\Q$escp\E)?(?:\s*\Q$cpen\E(?!\w))? # Expression
|
||||
|
|
||||
\Q$tag\E(?:\s*\Q$cpen\E(?!\w))? # Code
|
||||
|
|
||||
(?:(?<!\w)\Q$cpst\E\s*)?(?:\Q$trim\E)?\Q$end\E # End
|
||||
)
|
||||
/x;
|
||||
my $cpen_re = qr/^\Q$tag\E(?:\Q$expr\E)?(?:\Q$escp\E)?\s*\Q$cpen\E(.*)$/;
|
||||
my $end_re = qr/^(?:(\Q$cpst\E)\s*)?(\Q$trim\E)?\Q$end\E$/;
|
||||
|
||||
# Split lines
|
||||
my $op = 'text';
|
||||
my ($trimming, $capture);
|
||||
for my $line (split /\n/, $template) {
|
||||
|
||||
# Turn Perl line into mixed line
|
||||
if ($op eq 'text' && $line =~ $line_re) {
|
||||
|
||||
# Escaped start
|
||||
if ($2) { $line = "$1$start$5" }
|
||||
|
||||
# Comment
|
||||
elsif ($3) { $line = "$tag$3 $trim$end" }
|
||||
|
||||
# Expression or code
|
||||
else { $line = $4 ? "$1$tag$4$5 $end" : "$tag$5 $trim$end" }
|
||||
}
|
||||
|
||||
# Escaped line ending
|
||||
$line .= "\n" if $line !~ s/\\\\$/\\\n/ && $line !~ s/\\$//;
|
||||
|
||||
# Mixed line
|
||||
for my $token (split $token_re, $line) {
|
||||
|
||||
# Capture end
|
||||
($token, $capture) = ("$tag$1", 1) if $token =~ $cpen_re;
|
||||
|
||||
# End
|
||||
if ($op ne 'text' && $token =~ $end_re) {
|
||||
|
||||
# Capture start
|
||||
splice @tree, -1, 0, ['cpst'] if $1;
|
||||
|
||||
# Trim left side
|
||||
_trim(\@tree) if ($trimming = $2) && @tree > 1;
|
||||
|
||||
# Hint at end
|
||||
push @tree, [$op = 'text', ''];
|
||||
}
|
||||
|
||||
# Code
|
||||
elsif ($token eq $tag) { $op = 'code' }
|
||||
|
||||
# Expression
|
||||
elsif ($token eq "$tag$expr") { $op = 'expr' }
|
||||
|
||||
# Expression that needs to be escaped
|
||||
elsif ($token eq "$tag$expr$escp") { $op = 'escp' }
|
||||
|
||||
# Comment
|
||||
elsif ($token eq "$tag$cmnt") { $op = 'cmnt' }
|
||||
|
||||
# Text (comments are just ignored)
|
||||
elsif ($op ne 'cmnt') {
|
||||
|
||||
# Replace
|
||||
$token = $tag if $token eq "$tag$replace";
|
||||
|
||||
# Trim right side (convert whitespace to line noise)
|
||||
if ($trimming && $token =~ s/^(\s+)//) {
|
||||
push @tree, ['code', $1];
|
||||
$trimming = 0;
|
||||
}
|
||||
|
||||
# Token (with optional capture end)
|
||||
push @tree, $capture ? ['cpen'] : (), [$op, $token];
|
||||
$capture = 0;
|
||||
}
|
||||
}
|
||||
|
||||
# Optimize successive text lines separated by a newline
|
||||
push @tree, ['line'] and next
|
||||
if $tree[-4] && $tree[-4][0] ne 'line'
|
||||
|| (!$tree[-3] || $tree[-3][0] ne 'text' || $tree[-3][1] !~ /\n$/)
|
||||
|| ($tree[-2][0] ne 'line' || $tree[-1][0] ne 'text');
|
||||
$tree[-3][1] .= pop(@tree)->[1];
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub process {
|
||||
my $self = shift;
|
||||
|
||||
# Use a local stack trace for compile exceptions
|
||||
my $compiled = $self->compiled;
|
||||
unless ($compiled) {
|
||||
my $code = $self->_compile->code;
|
||||
monkey_patch $self->namespace, '_escape', $self->escape;
|
||||
return Mojo::Exception->new($@)->inspect($self->unparsed, $code)->trace->verbose(1)
|
||||
unless $compiled = eval $self->_wrap($code, @_);
|
||||
$self->compiled($compiled);
|
||||
}
|
||||
|
||||
# Use a real stack trace for normal exceptions
|
||||
local $SIG{__DIE__} = sub {
|
||||
CORE::die $_[0] if ref $_[0];
|
||||
CORE::die Mojo::Exception->new(shift)->trace->inspect($self->unparsed, $self->code)->verbose(1);
|
||||
};
|
||||
|
||||
my $output;
|
||||
return eval { $output = $compiled->(@_); 1 } ? $output : $@;
|
||||
}
|
||||
|
||||
sub render { shift->parse(shift)->process(@_) }
|
||||
|
||||
sub render_file {
|
||||
my ($self, $path) = (shift, shift);
|
||||
|
||||
$self->name($path) unless defined $self->{name};
|
||||
my $template = path($path)->slurp;
|
||||
my $encoding = $self->encoding;
|
||||
croak qq{Template "$path" has invalid encoding} if $encoding && !defined($template = decode $encoding, $template);
|
||||
|
||||
return $self->render($template, @_);
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
my $self = shift;
|
||||
|
||||
my $tree = $self->tree;
|
||||
my $escape = $self->auto_escape;
|
||||
|
||||
my @blocks = ('');
|
||||
my ($i, $capture, $multi);
|
||||
while (++$i <= @$tree && (my $next = $tree->[$i])) {
|
||||
my ($op, $value) = @{$tree->[$i - 1]};
|
||||
push @blocks, '' and next if $op eq 'line';
|
||||
my $newline = chomp($value //= '');
|
||||
|
||||
# Text (quote and fix line ending)
|
||||
if ($op eq 'text') {
|
||||
$value = join "\n", map { quotemeta $_ } split(/\n/, $value, -1);
|
||||
$value .= '\n' if $newline;
|
||||
$blocks[-1] .= "\$_O .= \"" . $value . "\";" if length $value;
|
||||
}
|
||||
|
||||
# Code or multi-line expression
|
||||
elsif ($op eq 'code' || $multi) { $blocks[-1] .= $value }
|
||||
|
||||
# Capture end
|
||||
elsif ($op eq 'cpen') {
|
||||
$blocks[-1] .= 'return Mojo::ByteStream->new($_O) }';
|
||||
|
||||
# No following code
|
||||
$blocks[-1] .= ';' if $next->[0] ne 'cpst' && ($next->[1] // '') =~ /^\s*$/;
|
||||
}
|
||||
|
||||
# Expression
|
||||
if ($op eq 'expr' || $op eq 'escp') {
|
||||
|
||||
# Escaped
|
||||
if (!$multi && ($op eq 'escp' && !$escape || $op eq 'expr' && $escape)) {
|
||||
$blocks[-1] .= "\$_O .= _escape scalar + $value";
|
||||
}
|
||||
|
||||
# Raw
|
||||
elsif (!$multi) { $blocks[-1] .= "\$_O .= scalar + $value" }
|
||||
|
||||
# Multi-line
|
||||
$multi = !$next || $next->[0] ne 'text';
|
||||
|
||||
# Append semicolon
|
||||
$blocks[-1] .= ';' unless $multi || $capture;
|
||||
}
|
||||
|
||||
# Capture start
|
||||
if ($op eq 'cpst') { $capture = 1 }
|
||||
elsif ($capture) {
|
||||
$blocks[-1] .= "sub { my \$_O = ''; ";
|
||||
$capture = 0;
|
||||
}
|
||||
}
|
||||
|
||||
return $self->code(join "\n", @blocks)->tree([]);
|
||||
}
|
||||
|
||||
sub _line {
|
||||
my $name = shift->name;
|
||||
$name =~ y/"//d;
|
||||
return qq{#line @{[shift]} "$name"};
|
||||
}
|
||||
|
||||
sub _trim {
|
||||
my $tree = shift;
|
||||
|
||||
# Skip captures
|
||||
my $i = $tree->[-2][0] eq 'cpst' || $tree->[-2][0] eq 'cpen' ? -3 : -2;
|
||||
|
||||
# Only trim text
|
||||
return unless $tree->[$i][0] eq 'text';
|
||||
|
||||
# Convert whitespace text to line noise
|
||||
splice @$tree, $i, 0, ['code', $1] if $tree->[$i][1] =~ s/(\s+)$//;
|
||||
}
|
||||
|
||||
sub _wrap {
|
||||
my ($self, $body, $vars) = @_;
|
||||
|
||||
# Variables
|
||||
my $args = '';
|
||||
if ($self->vars && (my @vars = grep {/^\w+$/} keys %$vars)) {
|
||||
$args = 'my (' . join(',', map {"\$$_"} @vars) . ')';
|
||||
$args .= '= @{shift()}{qw(' . join(' ', @vars) . ')};';
|
||||
}
|
||||
|
||||
# Wrap lines
|
||||
my $num = () = $body =~ /\n/g;
|
||||
my $code = $self->_line(1) . "\npackage @{[$self->namespace]};";
|
||||
$code .= "use Mojo::Base -strict; no warnings 'ambiguous';";
|
||||
$code .= "sub { my \$_O = ''; @{[$self->prepend]};{ $args { $body\n";
|
||||
$code .= $self->_line($num + 1) . "\n;}@{[$self->append]}; } \$_O };";
|
||||
|
||||
warn "-- Code for @{[$self->name]}\n@{[encode 'UTF-8', $code]}\n\n" if DEBUG;
|
||||
return $code;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Template - Perl-ish templates
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Template;
|
||||
|
||||
# Use Perl modules
|
||||
my $mt = Mojo::Template->new;
|
||||
say $mt->render(<<'EOF');
|
||||
% use Time::Piece;
|
||||
<div>
|
||||
% my $now = localtime;
|
||||
Time: <%= $now->hms %>
|
||||
</div>
|
||||
EOF
|
||||
|
||||
# Render with arguments
|
||||
say $mt->render(<<'EOF', [1 .. 13], 'Hello World!');
|
||||
% my ($numbers, $title) = @_;
|
||||
<div>
|
||||
<h1><%= $title %></h1>
|
||||
% for my $i (@$numbers) {
|
||||
Test <%= $i %>
|
||||
% }
|
||||
</div>
|
||||
EOF
|
||||
|
||||
# Render with named variables
|
||||
say $mt->vars(1)->render(<<'EOF', {title => 'Hello World!'});
|
||||
<div>
|
||||
<h1><%= $title %></h1>
|
||||
%= 5 + 5
|
||||
</div>
|
||||
EOF
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Template> is a minimalistic, fast, and very Perl-ish template engine, designed specifically for all those small
|
||||
tasks that come up during big projects. Like preprocessing a configuration file, generating text from heredocs and
|
||||
stuff like that.
|
||||
|
||||
See L<Mojolicious::Guides::Rendering> for information on how to generate content with the L<Mojolicious> renderer.
|
||||
|
||||
=head1 SYNTAX
|
||||
|
||||
For all templates L<strict>, L<warnings>, L<utf8> and Perl 5.16 L<features|feature> are automatically enabled.
|
||||
|
||||
<% Perl code %>
|
||||
<%= Perl expression, replaced with result %>
|
||||
<%== Perl expression, replaced with XML escaped result %>
|
||||
<%# Comment, useful for debugging %>
|
||||
<%% Replaced with "<%", useful for generating templates %>
|
||||
% Perl code line, treated as "<% line =%>" (explained later)
|
||||
%= Perl expression line, treated as "<%= line %>"
|
||||
%== Perl expression line, treated as "<%== line %>"
|
||||
%# Comment line, useful for debugging
|
||||
%% Replaced with "%", useful for generating templates
|
||||
|
||||
Escaping behavior can be reversed with the L</"auto_escape"> attribute, this is the default in L<Mojolicious> C<.ep>
|
||||
templates, for example.
|
||||
|
||||
<%= Perl expression, replaced with XML escaped result %>
|
||||
<%== Perl expression, replaced with result %>
|
||||
|
||||
L<Mojo::ByteStream> objects are always excluded from automatic escaping.
|
||||
|
||||
% use Mojo::ByteStream qw(b);
|
||||
<%= b('<div>excluded!</div>') %>
|
||||
|
||||
Whitespace characters around tags can be trimmed by adding an additional equal sign to the end of a tag.
|
||||
|
||||
<% for (1 .. 3) { %>
|
||||
<%= 'Trim all whitespace characters around this expression' =%>
|
||||
<% } %>
|
||||
|
||||
Newline characters can be escaped with a backslash.
|
||||
|
||||
This is <%= 1 + 1 %> a\
|
||||
single line
|
||||
|
||||
And a backslash in front of a newline character can be escaped with another backslash.
|
||||
|
||||
This will <%= 1 + 1 %> result\\
|
||||
in multiple\\
|
||||
lines
|
||||
|
||||
A newline character gets appended automatically to every template, unless the last character is a backslash. And empty
|
||||
lines at the end of a template are ignored.
|
||||
|
||||
There is <%= 1 + 1 %> no newline at the end here\
|
||||
|
||||
You can capture whole template blocks for reuse later with the C<begin> and C<end> keywords. Just be aware that both
|
||||
keywords are part of the surrounding tag and not actual Perl code, so there can only be whitespace after C<begin> and
|
||||
before C<end>.
|
||||
|
||||
<% my $block = begin %>
|
||||
<% my $name = shift; =%>
|
||||
Hello <%= $name %>.
|
||||
<% end %>
|
||||
<%= $block->('Baerbel') %>
|
||||
<%= $block->('Wolfgang') %>
|
||||
|
||||
Perl lines can also be indented freely.
|
||||
|
||||
% my $block = begin
|
||||
% my $name = shift;
|
||||
Hello <%= $name %>.
|
||||
% end
|
||||
%= $block->('Baerbel')
|
||||
%= $block->('Wolfgang')
|
||||
|
||||
L<Mojo::Template> templates get compiled to a Perl subroutine, that means you can access arguments simply via C<@_>.
|
||||
|
||||
% my ($foo, $bar) = @_;
|
||||
% my $x = shift;
|
||||
test 123 <%= $foo %>
|
||||
|
||||
The compilation of templates to Perl code can make debugging a bit tricky, but L<Mojo::Template> will return
|
||||
L<Mojo::Exception> objects that stringify to error messages with context.
|
||||
|
||||
Bareword "xx" not allowed while "strict subs" in use at template line 4.
|
||||
Context:
|
||||
2: </head>
|
||||
3: <body>
|
||||
4: % my $i = 2; xx
|
||||
5: %= $i * 2
|
||||
6: </body>
|
||||
Traceback (most recent call first):
|
||||
File "template", line 4, in "Mojo::Template::Sandbox"
|
||||
File "path/to/Mojo/Template.pm", line 123, in "Mojo::Template"
|
||||
File "path/to/myapp.pl", line 123, in "main"
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Template> implements the following attributes.
|
||||
|
||||
=head2 auto_escape
|
||||
|
||||
my $bool = $mt->auto_escape;
|
||||
$mt = $mt->auto_escape($bool);
|
||||
|
||||
Activate automatic escaping.
|
||||
|
||||
# "<html>"
|
||||
Mojo::Template->new(auto_escape => 1)->render("<%= '<html>' %>");
|
||||
|
||||
=head2 append
|
||||
|
||||
my $code = $mt->append;
|
||||
$mt = $mt->append('warn "Processed template"');
|
||||
|
||||
Append Perl code to compiled template. Note that this code should not contain newline characters, or line numbers in
|
||||
error messages might end up being wrong.
|
||||
|
||||
=head2 capture_end
|
||||
|
||||
my $end = $mt->capture_end;
|
||||
$mt = $mt->capture_end('end');
|
||||
|
||||
Keyword indicating the end of a capture block, defaults to C<end>.
|
||||
|
||||
<% my $block = begin %>
|
||||
Some data!
|
||||
<% end %>
|
||||
|
||||
=head2 capture_start
|
||||
|
||||
my $start = $mt->capture_start;
|
||||
$mt = $mt->capture_start('begin');
|
||||
|
||||
Keyword indicating the start of a capture block, defaults to C<begin>.
|
||||
|
||||
<% my $block = begin %>
|
||||
Some data!
|
||||
<% end %>
|
||||
|
||||
=head2 code
|
||||
|
||||
my $code = $mt->code;
|
||||
$mt = $mt->code($code);
|
||||
|
||||
Perl code for template if available.
|
||||
|
||||
=head2 comment_mark
|
||||
|
||||
my $mark = $mt->comment_mark;
|
||||
$mt = $mt->comment_mark('#');
|
||||
|
||||
Character indicating the start of a comment, defaults to C<#>.
|
||||
|
||||
<%# This is a comment %>
|
||||
|
||||
=head2 compiled
|
||||
|
||||
my $compiled = $mt->compiled;
|
||||
$mt = $mt->compiled($compiled);
|
||||
|
||||
Compiled template code if available.
|
||||
|
||||
=head2 encoding
|
||||
|
||||
my $encoding = $mt->encoding;
|
||||
$mt = $mt->encoding('UTF-8');
|
||||
|
||||
Encoding used for template files, defaults to C<UTF-8>.
|
||||
|
||||
=head2 escape
|
||||
|
||||
my $cb = $mt->escape;
|
||||
$mt = $mt->escape(sub {...});
|
||||
|
||||
A callback used to escape the results of escaped expressions, defaults to L<Mojo::Util/"xml_escape">.
|
||||
|
||||
$mt->escape(sub ($str) { return reverse $str });
|
||||
|
||||
=head2 escape_mark
|
||||
|
||||
my $mark = $mt->escape_mark;
|
||||
$mt = $mt->escape_mark('=');
|
||||
|
||||
Character indicating the start of an escaped expression, defaults to C<=>.
|
||||
|
||||
<%== $foo %>
|
||||
|
||||
=head2 expression_mark
|
||||
|
||||
my $mark = $mt->expression_mark;
|
||||
$mt = $mt->expression_mark('=');
|
||||
|
||||
Character indicating the start of an expression, defaults to C<=>.
|
||||
|
||||
<%= $foo %>
|
||||
|
||||
=head2 line_start
|
||||
|
||||
my $start = $mt->line_start;
|
||||
$mt = $mt->line_start('%');
|
||||
|
||||
Character indicating the start of a code line, defaults to C<%>.
|
||||
|
||||
% $foo = 23;
|
||||
|
||||
=head2 name
|
||||
|
||||
my $name = $mt->name;
|
||||
$mt = $mt->name('foo.mt');
|
||||
|
||||
Name of template currently being processed, defaults to C<template>. Note that this value should not contain quotes or
|
||||
newline characters, or error messages might end up being wrong.
|
||||
|
||||
=head2 namespace
|
||||
|
||||
my $namespace = $mt->namespace;
|
||||
$mt = $mt->namespace('main');
|
||||
|
||||
Namespace used to compile templates, defaults to C<Mojo::Template::Sandbox>. Note that namespaces should only be shared
|
||||
very carefully between templates, since functions and global variables will not be cleared automatically.
|
||||
|
||||
=head2 prepend
|
||||
|
||||
my $code = $mt->prepend;
|
||||
$mt = $mt->prepend('my $self = shift;');
|
||||
|
||||
Prepend Perl code to compiled template. Note that this code should not contain newline characters, or line numbers in
|
||||
error messages might end up being wrong.
|
||||
|
||||
=head2 replace_mark
|
||||
|
||||
my $mark = $mt->replace_mark;
|
||||
$mt = $mt->replace_mark('%');
|
||||
|
||||
Character used for escaping the start of a tag or line, defaults to C<%>.
|
||||
|
||||
<%% my $foo = 23; %>
|
||||
|
||||
=head2 tag_start
|
||||
|
||||
my $start = $mt->tag_start;
|
||||
$mt = $mt->tag_start('<%');
|
||||
|
||||
Characters indicating the start of a tag, defaults to C<E<lt>%>.
|
||||
|
||||
<% $foo = 23; %>
|
||||
|
||||
=head2 tag_end
|
||||
|
||||
my $end = $mt->tag_end;
|
||||
$mt = $mt->tag_end('%>');
|
||||
|
||||
Characters indicating the end of a tag, defaults to C<%E<gt>>.
|
||||
|
||||
<%= $foo %>
|
||||
|
||||
=head2 tree
|
||||
|
||||
my $tree = $mt->tree;
|
||||
$mt = $mt->tree([['text', 'foo'], ['line']]);
|
||||
|
||||
Template in parsed form if available. Note that this structure should only be used very carefully since it is very
|
||||
dynamic.
|
||||
|
||||
=head2 trim_mark
|
||||
|
||||
my $mark = $mt->trim_mark;
|
||||
$mt = $mt->trim_mark('-');
|
||||
|
||||
Character activating automatic whitespace trimming, defaults to C<=>.
|
||||
|
||||
<%= $foo =%>
|
||||
|
||||
=head2 unparsed
|
||||
|
||||
my $unparsed = $mt->unparsed;
|
||||
$mt = $mt->unparsed('<%= 1 + 1 %>');
|
||||
|
||||
Raw unparsed template if available.
|
||||
|
||||
=head2 vars
|
||||
|
||||
my $bool = $mt->vars;
|
||||
$mt = $mt->vars($bool);
|
||||
|
||||
Instead of a list of values, use a hash reference with named variables to pass data to templates.
|
||||
|
||||
# "works!"
|
||||
Mojo::Template->new(vars => 1)->render('<%= $test %>!', {test => 'works'});
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Template> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$mt = $mt->parse('<%= 1 + 1 %>');
|
||||
|
||||
Parse template into L</"tree">.
|
||||
|
||||
=head2 process
|
||||
|
||||
my $output = $mt->process;
|
||||
my $output = $mt->process(@args);
|
||||
my $output = $mt->process({foo => 'bar'});
|
||||
|
||||
Process previously parsed template and return the result, or a L<Mojo::Exception> object if rendering failed.
|
||||
|
||||
# Parse and process
|
||||
say Mojo::Template->new->parse('Hello <%= $_[0] %>')->process('Bender');
|
||||
|
||||
# Reuse template (for much better performance)
|
||||
my $mt = Mojo::Template->new;
|
||||
say $mt->render('Hello <%= $_[0] %>!', 'Bender');
|
||||
say $mt->process('Fry');
|
||||
say $mt->process('Leela');
|
||||
|
||||
=head2 render
|
||||
|
||||
my $output = $mt->render('<%= 1 + 1 %>');
|
||||
my $output = $mt->render('<%= shift() + shift() %>', @args);
|
||||
my $output = $mt->render('<%= $foo %>', {foo => 'bar'});
|
||||
|
||||
Render template and return the result, or a L<Mojo::Exception> object if rendering failed.
|
||||
|
||||
# Longer version
|
||||
my $output = $mt->parse('<%= 1 + 1 %>')->process;
|
||||
|
||||
# Render with arguments
|
||||
say Mojo::Template->new->render('<%= $_[0] %>', 'bar');
|
||||
|
||||
# Render with named variables
|
||||
say Mojo::Template->new(vars => 1)->render('<%= $foo %>', {foo => 'bar'});
|
||||
|
||||
=head2 render_file
|
||||
|
||||
my $output = $mt->render_file('/tmp/foo.mt');
|
||||
my $output = $mt->render_file('/tmp/foo.mt', @args);
|
||||
my $output = $mt->render_file('/tmp/bar.mt', {foo => 'bar'});
|
||||
|
||||
Same as L</"render">, but renders a template file.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_TEMPLATE_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_TEMPLATE_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
279
database/perl/vendor/lib/Mojo/Transaction.pm
vendored
Normal file
279
database/perl/vendor/lib/Mojo/Transaction.pm
vendored
Normal file
@@ -0,0 +1,279 @@
|
||||
package Mojo::Transaction;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
use Carp qw(croak);
|
||||
use Mojo::Message::Request;
|
||||
use Mojo::Message::Response;
|
||||
use Mojo::Util qw(deprecated);
|
||||
|
||||
has [qw(kept_alive local_address local_port original_remote_address remote_port)];
|
||||
has req => sub { Mojo::Message::Request->new };
|
||||
has res => sub { Mojo::Message::Response->new };
|
||||
|
||||
sub client_read { croak 'Method "client_read" not implemented by subclass' }
|
||||
sub client_write { croak 'Method "client_write" not implemented by subclass' }
|
||||
|
||||
sub closed { shift->completed->emit('finish') }
|
||||
|
||||
sub completed { ++$_[0]{completed} and return $_[0] }
|
||||
|
||||
sub connection {
|
||||
my $self = shift;
|
||||
return $self->emit(connection => $self->{connection} = shift) if @_;
|
||||
return $self->{connection};
|
||||
}
|
||||
|
||||
sub error { $_[0]->req->error || $_[0]->res->error }
|
||||
|
||||
sub is_finished { !!shift->{completed} }
|
||||
|
||||
sub is_websocket {undef}
|
||||
|
||||
sub remote_address {
|
||||
my $self = shift;
|
||||
|
||||
return $self->original_remote_address(@_) if @_;
|
||||
return $self->original_remote_address unless $self->req->reverse_proxy;
|
||||
|
||||
# Reverse proxy
|
||||
return ($self->req->headers->header('X-Forwarded-For') // '') =~ /([^,\s]+)$/ ? $1 : $self->original_remote_address;
|
||||
}
|
||||
|
||||
sub result {
|
||||
my $self = shift;
|
||||
my $err = $self->error;
|
||||
return !$err || $err->{code} ? $self->res : croak $err->{message};
|
||||
}
|
||||
|
||||
sub server_read { croak 'Method "server_read" not implemented by subclass' }
|
||||
sub server_write { croak 'Method "server_write" not implemented by subclass' }
|
||||
|
||||
# DEPRECATED!
|
||||
sub success {
|
||||
deprecated 'Mojo::Transaction::success is DEPRECATED'
|
||||
. ' in favor of Mojo::Transaction::result and Mojo::Transaction::error';
|
||||
$_[0]->error ? undef : $_[0]->res;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Transaction - Transaction base class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Mojo::Transaction::MyTransaction;
|
||||
use Mojo::Base 'Mojo::Transaction';
|
||||
|
||||
sub client_read {...}
|
||||
sub client_write {...}
|
||||
sub server_read {...}
|
||||
sub server_write {...}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Transaction> is an abstract base class for transactions, like L<Mojo::Transaction::HTTP> and
|
||||
L<Mojo::Transaction::WebSocket>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Transaction> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 connection
|
||||
|
||||
$tx->on(connection => sub ($tx, $connection) {...});
|
||||
|
||||
Emitted when a connection has been assigned to transaction.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$tx->on(finish => sub ($tx) {...});
|
||||
|
||||
Emitted when transaction is finished.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Transaction> implements the following attributes.
|
||||
|
||||
=head2 kept_alive
|
||||
|
||||
my $bool = $tx->kept_alive;
|
||||
$tx = $tx->kept_alive($bool);
|
||||
|
||||
Connection has been kept alive.
|
||||
|
||||
=head2 local_address
|
||||
|
||||
my $address = $tx->local_address;
|
||||
$tx = $tx->local_address('127.0.0.1');
|
||||
|
||||
Local interface address.
|
||||
|
||||
=head2 local_port
|
||||
|
||||
my $port = $tx->local_port;
|
||||
$tx = $tx->local_port(8080);
|
||||
|
||||
Local interface port.
|
||||
|
||||
=head2 original_remote_address
|
||||
|
||||
my $address = $tx->original_remote_address;
|
||||
$tx = $tx->original_remote_address('127.0.0.1');
|
||||
|
||||
Remote interface address.
|
||||
|
||||
=head2 remote_port
|
||||
|
||||
my $port = $tx->remote_port;
|
||||
$tx = $tx->remote_port(8081);
|
||||
|
||||
Remote interface port.
|
||||
|
||||
=head2 req
|
||||
|
||||
my $req = $tx->req;
|
||||
$tx = $tx->req(Mojo::Message::Request->new);
|
||||
|
||||
HTTP request, defaults to a L<Mojo::Message::Request> object.
|
||||
|
||||
# Access request information
|
||||
my $method = $tx->req->method;
|
||||
my $url = $tx->req->url->to_abs;
|
||||
my $info = $tx->req->url->to_abs->userinfo;
|
||||
my $host = $tx->req->url->to_abs->host;
|
||||
my $agent = $tx->req->headers->user_agent;
|
||||
my $custom = $tx->req->headers->header('Custom-Header');
|
||||
my $bytes = $tx->req->body;
|
||||
my $str = $tx->req->text;
|
||||
my $hash = $tx->req->params->to_hash;
|
||||
my $all = $tx->req->uploads;
|
||||
my $value = $tx->req->json;
|
||||
my $foo = $tx->req->json('/23/foo');
|
||||
my $dom = $tx->req->dom;
|
||||
my $bar = $tx->req->dom('div.bar')->first->text;
|
||||
|
||||
=head2 res
|
||||
|
||||
my $res = $tx->res;
|
||||
$tx = $tx->res(Mojo::Message::Response->new);
|
||||
|
||||
HTTP response, defaults to a L<Mojo::Message::Response> object.
|
||||
|
||||
# Access response information
|
||||
my $code = $tx->res->code;
|
||||
my $message = $tx->res->message;
|
||||
my $server = $tx->res->headers->server;
|
||||
my $custom = $tx->res->headers->header('Custom-Header');
|
||||
my $bytes = $tx->res->body;
|
||||
my $str = $tx->res->text;
|
||||
my $value = $tx->res->json;
|
||||
my $foo = $tx->res->json('/23/foo');
|
||||
my $dom = $tx->res->dom;
|
||||
my $bar = $tx->res->dom('div.bar')->first->text;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Transaction> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 client_read
|
||||
|
||||
$tx->client_read($bytes);
|
||||
|
||||
Read data client-side, used to implement user agents such as L<Mojo::UserAgent>. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 client_write
|
||||
|
||||
my $bytes = $tx->client_write;
|
||||
|
||||
Write data client-side, used to implement user agents such as L<Mojo::UserAgent>. Meant to be overloaded in a subclass.
|
||||
|
||||
=head2 closed
|
||||
|
||||
$tx = $tx->closed;
|
||||
|
||||
Same as L</"completed">, but also indicates that all transaction data has been sent.
|
||||
|
||||
=head2 completed
|
||||
|
||||
$tx = $tx->completed;
|
||||
|
||||
Low-level method to finalize transaction.
|
||||
|
||||
=head2 connection
|
||||
|
||||
my $id = $tx->connection;
|
||||
$tx = $tx->connection($id);
|
||||
|
||||
Connection identifier.
|
||||
|
||||
=head2 error
|
||||
|
||||
my $err = $tx->error;
|
||||
|
||||
Get request or response error and return C<undef> if there is no error.
|
||||
|
||||
# Longer version
|
||||
my $err = $tx->req->error || $tx->res->error;
|
||||
|
||||
# Check for 4xx/5xx response and connection errors
|
||||
if (my $err = $tx->error) {
|
||||
die "$err->{code} response: $err->{message}" if $err->{code};
|
||||
die "Connection error: $err->{message}";
|
||||
}
|
||||
|
||||
=head2 is_finished
|
||||
|
||||
my $bool = $tx->is_finished;
|
||||
|
||||
Check if transaction is finished.
|
||||
|
||||
=head2 is_websocket
|
||||
|
||||
my $bool = $tx->is_websocket;
|
||||
|
||||
False, this is not a L<Mojo::Transaction::WebSocket> object.
|
||||
|
||||
=head2 remote_address
|
||||
|
||||
my $address = $tx->remote_address;
|
||||
$tx = $tx->remote_address('127.0.0.1');
|
||||
|
||||
Same as L</"original_remote_address"> or the last value of the C<X-Forwarded-For> header if L</"req"> has been
|
||||
performed through a reverse proxy.
|
||||
|
||||
=head2 result
|
||||
|
||||
my $res = $tx->result;
|
||||
|
||||
Returns the L<Mojo::Message::Response> object from L</"res"> or dies if a connection error has occurred.
|
||||
|
||||
# Fine grained response handling (dies on connection errors)
|
||||
my $res = $tx->result;
|
||||
if ($res->is_success) { say $res->body }
|
||||
elsif ($res->is_error) { say $res->message }
|
||||
elsif ($res->code == 301) { say $res->headers->location }
|
||||
else { say 'Whatever...' }
|
||||
|
||||
=head2 server_read
|
||||
|
||||
$tx->server_read($bytes);
|
||||
|
||||
Read data server-side, used to implement web servers such as L<Mojo::Server::Daemon>. Meant to be overloaded in a
|
||||
subclass.
|
||||
|
||||
=head2 server_write
|
||||
|
||||
my $bytes = $tx->server_write;
|
||||
|
||||
Write data server-side, used to implement web servers such as L<Mojo::Server::Daemon>. Meant to be overloaded in a
|
||||
subclass.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
277
database/perl/vendor/lib/Mojo/Transaction/HTTP.pm
vendored
Normal file
277
database/perl/vendor/lib/Mojo/Transaction/HTTP.pm
vendored
Normal file
@@ -0,0 +1,277 @@
|
||||
package Mojo::Transaction::HTTP;
|
||||
use Mojo::Base 'Mojo::Transaction';
|
||||
|
||||
has 'previous';
|
||||
|
||||
sub client_read {
|
||||
my ($self, $chunk) = @_;
|
||||
|
||||
# Skip body for HEAD request
|
||||
my $res = $self->res;
|
||||
$res->content->skip_body(1) if uc $self->req->method eq 'HEAD';
|
||||
return undef unless $res->parse($chunk)->is_finished;
|
||||
|
||||
# Unexpected 1xx response
|
||||
return $self->completed if !$res->is_info || $res->headers->upgrade;
|
||||
$self->res($res->new)->emit(unexpected => $res);
|
||||
return undef unless length(my $leftovers = $res->content->leftovers);
|
||||
$self->client_read($leftovers);
|
||||
}
|
||||
|
||||
sub client_write { shift->_write(0) }
|
||||
|
||||
sub is_empty { !!(uc $_[0]->req->method eq 'HEAD' || $_[0]->res->is_empty) }
|
||||
|
||||
sub keep_alive {
|
||||
my $self = shift;
|
||||
|
||||
# Close
|
||||
my $req = $self->req;
|
||||
my $res = $self->res;
|
||||
my $req_conn = lc($req->headers->connection // '');
|
||||
my $res_conn = lc($res->headers->connection // '');
|
||||
return undef if $req_conn eq 'close' || $res_conn eq 'close';
|
||||
|
||||
# Keep-alive is optional for 1.0
|
||||
return $res_conn eq 'keep-alive' if $res->version eq '1.0';
|
||||
return $req_conn eq 'keep-alive' if $req->version eq '1.0';
|
||||
|
||||
# Keep-alive is the default for 1.1
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub redirects {
|
||||
my $previous = shift;
|
||||
my @redirects;
|
||||
unshift @redirects, $previous while $previous = $previous->previous;
|
||||
return \@redirects;
|
||||
}
|
||||
|
||||
sub resume { ++$_[0]{writing} and return $_[0]->emit('resume') }
|
||||
|
||||
sub server_read {
|
||||
my ($self, $chunk) = @_;
|
||||
|
||||
# Parse request
|
||||
my $req = $self->req;
|
||||
$req->parse($chunk) unless $req->error;
|
||||
|
||||
# Generate response
|
||||
$self->emit('request') if $req->is_finished && !$self->{handled}++;
|
||||
}
|
||||
|
||||
sub server_write { shift->_write(1) }
|
||||
|
||||
sub _body {
|
||||
my ($self, $msg, $finish) = @_;
|
||||
|
||||
# Prepare body chunk
|
||||
my $buffer = $msg->get_body_chunk($self->{offset});
|
||||
$self->{offset} += defined $buffer ? length $buffer : 0;
|
||||
|
||||
# Delayed
|
||||
$self->{writing} = 0 unless defined $buffer;
|
||||
|
||||
# Finished
|
||||
$finish ? $self->completed : ($self->{writing} = 0) if defined $buffer && !length $buffer;
|
||||
|
||||
return $buffer // '';
|
||||
}
|
||||
|
||||
sub _headers {
|
||||
my ($self, $msg, $head) = @_;
|
||||
|
||||
# Prepare header chunk
|
||||
my $buffer = $msg->get_header_chunk($self->{offset});
|
||||
my $written = defined $buffer ? length $buffer : 0;
|
||||
$self->{write} -= $written;
|
||||
$self->{offset} += $written;
|
||||
|
||||
# Switch to body
|
||||
if ($self->{write} <= 0) {
|
||||
@$self{qw(http_state offset)} = ('body', 0);
|
||||
|
||||
# Response without body
|
||||
$self->completed->{http_state} = 'empty' if $head && $self->is_empty;
|
||||
}
|
||||
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
sub _start_line {
|
||||
my ($self, $msg) = @_;
|
||||
|
||||
# Prepare start-line chunk
|
||||
my $buffer = $msg->get_start_line_chunk($self->{offset});
|
||||
my $written = defined $buffer ? length $buffer : 0;
|
||||
$self->{write} -= $written;
|
||||
$self->{offset} += $written;
|
||||
|
||||
# Switch to headers
|
||||
@$self{qw(http_state write offset)} = ('headers', $msg->header_size, 0) if $self->{write} <= 0;
|
||||
|
||||
return $buffer;
|
||||
}
|
||||
|
||||
sub _write {
|
||||
my ($self, $server) = @_;
|
||||
|
||||
# Client starts writing right away
|
||||
return '' unless $server ? $self->{writing} : ($self->{writing} //= 1);
|
||||
|
||||
# Nothing written yet
|
||||
$self->{$_} ||= 0 for qw(offset write);
|
||||
my $msg = $server ? $self->res : $self->req;
|
||||
@$self{qw(http_state write)} = ('start_line', $msg->start_line_size) unless $self->{http_state};
|
||||
|
||||
# Start-line
|
||||
my $chunk = '';
|
||||
$chunk .= $self->_start_line($msg) if $self->{http_state} eq 'start_line';
|
||||
|
||||
# Headers
|
||||
$chunk .= $self->_headers($msg, $server) if $self->{http_state} eq 'headers';
|
||||
|
||||
# Body
|
||||
$chunk .= $self->_body($msg, $server) if $self->{http_state} eq 'body';
|
||||
|
||||
return $chunk;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Transaction::HTTP - HTTP transaction
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Transaction::HTTP;
|
||||
|
||||
# Client
|
||||
my $tx = Mojo::Transaction::HTTP->new;
|
||||
$tx->req->method('GET');
|
||||
$tx->req->url->parse('http://example.com');
|
||||
$tx->req->headers->accept('application/json');
|
||||
say $tx->res->code;
|
||||
say $tx->res->headers->content_type;
|
||||
say $tx->res->body;
|
||||
say $tx->remote_address;
|
||||
|
||||
# Server
|
||||
my $tx = Mojo::Transaction::HTTP->new;
|
||||
say $tx->req->method;
|
||||
say $tx->req->url->to_abs;
|
||||
say $tx->req->headers->accept;
|
||||
say $tx->remote_address;
|
||||
$tx->res->code(200);
|
||||
$tx->res->headers->content_type('text/plain');
|
||||
$tx->res->body('Hello World!');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Transaction::HTTP> is a container for HTTP transactions, based on L<RFC
|
||||
7230|https://tools.ietf.org/html/rfc7230> and L<RFC 7231|https://tools.ietf.org/html/rfc7231>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Transaction::HTTP> inherits all events from L<Mojo::Transaction> and can emit the following new ones.
|
||||
|
||||
=head2 request
|
||||
|
||||
$tx->on(request => sub ($tx) {...});
|
||||
|
||||
Emitted when a request is ready and needs to be handled.
|
||||
|
||||
$tx->on(request => sub ($tx) { $tx->res->headers->header('X-Bender' => 'Bite my shiny metal ass!') });
|
||||
|
||||
=head2 resume
|
||||
|
||||
$tx->on(resume => sub ($tx) {...});
|
||||
|
||||
Emitted when transaction is resumed.
|
||||
|
||||
=head2 unexpected
|
||||
|
||||
$tx->on(unexpected => sub ($tx, $res) {...});
|
||||
|
||||
Emitted for unexpected C<1xx> responses that will be ignored.
|
||||
|
||||
$tx->on(unexpected => sub ($tx) { $tx->res->on(finish => sub { say 'Follow-up response is finished.' }) });
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Transaction::HTTP> inherits all attributes from L<Mojo::Transaction> and implements the following new ones.
|
||||
|
||||
=head2 previous
|
||||
|
||||
my $previous = $tx->previous;
|
||||
$tx = $tx->previous(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Previous transaction that triggered this follow-up transaction, usually a L<Mojo::Transaction::HTTP> object.
|
||||
|
||||
# Paths of previous requests
|
||||
say $tx->previous->previous->req->url->path;
|
||||
say $tx->previous->req->url->path;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Transaction::HTTP> inherits all methods from L<Mojo::Transaction> and implements the following new ones.
|
||||
|
||||
=head2 client_read
|
||||
|
||||
$tx->client_read($bytes);
|
||||
|
||||
Read data client-side, used to implement user agents such as L<Mojo::UserAgent>.
|
||||
|
||||
=head2 client_write
|
||||
|
||||
my $bytes = $tx->client_write;
|
||||
|
||||
Write data client-side, used to implement user agents such as L<Mojo::UserAgent>.
|
||||
|
||||
=head2 is_empty
|
||||
|
||||
my $bool = $tx->is_empty;
|
||||
|
||||
Check transaction for C<HEAD> request and C<1xx>, C<204> or C<304> response.
|
||||
|
||||
=head2 keep_alive
|
||||
|
||||
my $bool = $tx->keep_alive;
|
||||
|
||||
Check if connection can be kept alive.
|
||||
|
||||
=head2 redirects
|
||||
|
||||
my $redirects = $tx->redirects;
|
||||
|
||||
Return an array reference with all previous transactions that preceded this follow-up transaction.
|
||||
|
||||
# Paths of all previous requests
|
||||
say $_->req->url->path for @{$tx->redirects};
|
||||
|
||||
=head2 resume
|
||||
|
||||
$tx = $tx->resume;
|
||||
|
||||
Resume transaction.
|
||||
|
||||
=head2 server_read
|
||||
|
||||
$tx->server_read($bytes);
|
||||
|
||||
Read data server-side, used to implement web servers such as L<Mojo::Server::Daemon>.
|
||||
|
||||
=head2 server_write
|
||||
|
||||
my $bytes = $tx->server_write;
|
||||
|
||||
Write data server-side, used to implement web servers such as L<Mojo::Server::Daemon>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
453
database/perl/vendor/lib/Mojo/Transaction/WebSocket.pm
vendored
Normal file
453
database/perl/vendor/lib/Mojo/Transaction/WebSocket.pm
vendored
Normal file
@@ -0,0 +1,453 @@
|
||||
package Mojo::Transaction::WebSocket;
|
||||
use Mojo::Base 'Mojo::Transaction';
|
||||
|
||||
use Compress::Raw::Zlib qw(Z_SYNC_FLUSH);
|
||||
use List::Util qw(first);
|
||||
use Mojo::JSON qw(encode_json j);
|
||||
use Mojo::Util qw(decode encode trim);
|
||||
use Mojo::WebSocket qw(WS_BINARY WS_CLOSE WS_CONTINUATION WS_PING WS_PONG WS_TEXT);
|
||||
|
||||
has [qw(compressed established handshake masked)];
|
||||
has max_websocket_size => sub { $ENV{MOJO_MAX_WEBSOCKET_SIZE} || 262144 };
|
||||
|
||||
sub build_message {
|
||||
my ($self, $frame) = @_;
|
||||
|
||||
# Text
|
||||
$frame = {text => encode('UTF-8', $frame)} if ref $frame ne 'HASH';
|
||||
|
||||
# JSON
|
||||
$frame->{text} = encode_json($frame->{json}) if exists $frame->{json};
|
||||
|
||||
# Raw text or binary
|
||||
if (exists $frame->{text}) { $frame = [1, 0, 0, 0, WS_TEXT, $frame->{text}] }
|
||||
else { $frame = [1, 0, 0, 0, WS_BINARY, $frame->{binary}] }
|
||||
|
||||
# "permessage-deflate" extension
|
||||
return $frame unless $self->compressed;
|
||||
my $deflate = $self->{deflate}
|
||||
||= Compress::Raw::Zlib::Deflate->new(AppendOutput => 1, MemLevel => 8, WindowBits => -15);
|
||||
$deflate->deflate($frame->[5], my $out);
|
||||
$deflate->flush($out, Z_SYNC_FLUSH);
|
||||
@$frame[1, 5] = (1, substr($out, 0, length($out) - 4));
|
||||
|
||||
return $frame;
|
||||
}
|
||||
|
||||
sub client_read { shift->server_read(@_) }
|
||||
sub client_write { shift->server_write(@_) }
|
||||
|
||||
sub closed {
|
||||
my $self = shift->completed;
|
||||
return $self->emit(finish => $self->{close} ? (@{$self->{close}}) : 1006);
|
||||
}
|
||||
|
||||
sub connection { shift->handshake->connection }
|
||||
|
||||
sub finish {
|
||||
my $self = shift;
|
||||
|
||||
my $close = $self->{close} = [@_];
|
||||
my $payload = $close->[0] ? pack('n', $close->[0]) : '';
|
||||
$payload .= encode 'UTF-8', $close->[1] if defined $close->[1];
|
||||
$close->[0] //= 1005;
|
||||
$self->send([1, 0, 0, 0, WS_CLOSE, $payload])->{closing} = 1;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub is_websocket {1}
|
||||
|
||||
sub kept_alive { shift->handshake->kept_alive }
|
||||
sub local_address { shift->handshake->local_address }
|
||||
sub local_port { shift->handshake->local_port }
|
||||
|
||||
sub parse_message {
|
||||
my ($self, $frame) = @_;
|
||||
|
||||
$self->emit(frame => $frame);
|
||||
|
||||
# Ping/Pong
|
||||
my $op = $frame->[4];
|
||||
return $self->send([1, 0, 0, 0, WS_PONG, $frame->[5]]) if $op == WS_PING;
|
||||
return undef if $op == WS_PONG;
|
||||
|
||||
# Close
|
||||
if ($op == WS_CLOSE) {
|
||||
return $self->finish unless length $frame->[5] >= 2;
|
||||
return $self->finish(unpack('n', substr($frame->[5], 0, 2, '')), decode('UTF-8', $frame->[5]));
|
||||
}
|
||||
|
||||
# Append chunk and check message size
|
||||
@{$self}{qw(op pmc)} = ($op, $self->compressed && $frame->[1]) unless exists $self->{op};
|
||||
$self->{message} .= $frame->[5];
|
||||
my $max = $self->max_websocket_size;
|
||||
return $self->finish(1009) if length $self->{message} > $max;
|
||||
|
||||
# No FIN bit (Continuation)
|
||||
return undef unless $frame->[0];
|
||||
|
||||
# "permessage-deflate" extension (handshake and RSV1)
|
||||
my $msg = delete $self->{message};
|
||||
if ($self->compressed && $self->{pmc}) {
|
||||
my $inflate = $self->{inflate}
|
||||
||= Compress::Raw::Zlib::Inflate->new(Bufsize => $max, LimitOutput => 1, WindowBits => -15);
|
||||
$inflate->inflate(($msg .= "\x00\x00\xff\xff"), my $out);
|
||||
return $self->finish(1009) if length $msg;
|
||||
$msg = $out;
|
||||
}
|
||||
|
||||
$self->emit(json => j($msg)) if $self->has_subscribers('json');
|
||||
$op = delete $self->{op};
|
||||
$self->emit($op == WS_TEXT ? 'text' : 'binary' => $msg);
|
||||
$self->emit(message => $op == WS_TEXT ? decode 'UTF-8', $msg : $msg) if $self->has_subscribers('message');
|
||||
}
|
||||
|
||||
sub protocol { shift->res->headers->sec_websocket_protocol }
|
||||
|
||||
sub remote_address { shift->handshake->remote_address }
|
||||
sub remote_port { shift->handshake->remote_port }
|
||||
sub req { shift->handshake->req }
|
||||
sub res { shift->handshake->res }
|
||||
|
||||
sub resume { $_[0]->handshake->resume and return $_[0] }
|
||||
|
||||
sub send {
|
||||
my ($self, $msg, $cb) = @_;
|
||||
$self->once(drain => $cb) if $cb;
|
||||
$msg = $self->build_message($msg) unless ref $msg eq 'ARRAY';
|
||||
$self->{write} .= Mojo::WebSocket::build_frame($self->masked, @$msg);
|
||||
return $self->emit('resume');
|
||||
}
|
||||
|
||||
sub server_read {
|
||||
my ($self, $chunk) = @_;
|
||||
|
||||
$self->{read} .= $chunk;
|
||||
my $max = $self->max_websocket_size;
|
||||
while (my $frame = Mojo::WebSocket::parse_frame(\$self->{read}, $max)) {
|
||||
$self->finish(1009) and last unless ref $frame;
|
||||
$self->parse_message($frame);
|
||||
}
|
||||
|
||||
$self->emit('resume');
|
||||
}
|
||||
|
||||
sub server_write {
|
||||
my $self = shift;
|
||||
$self->emit('drain') unless length($self->{write} //= '');
|
||||
$self->completed if !length $self->{write} && $self->{closing};
|
||||
return delete $self->{write};
|
||||
}
|
||||
|
||||
sub with_compression {
|
||||
my $self = shift;
|
||||
|
||||
# "permessage-deflate" extension
|
||||
$self->compressed(1) and $self->res->headers->sec_websocket_extensions('permessage-deflate')
|
||||
if ($self->req->headers->sec_websocket_extensions // '') =~ /permessage-deflate/;
|
||||
}
|
||||
|
||||
sub with_protocols {
|
||||
my $self = shift;
|
||||
|
||||
my %protos = map { trim($_) => 1 } split /,/, $self->req->headers->sec_websocket_protocol // '';
|
||||
return undef unless defined(my $proto = first { $protos{$_} } @_);
|
||||
|
||||
$self->res->headers->sec_websocket_protocol($proto);
|
||||
return $proto;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Transaction::WebSocket - WebSocket transaction
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Transaction::WebSocket;
|
||||
|
||||
# Send and receive WebSocket messages
|
||||
my $ws = Mojo::Transaction::WebSocket->new;
|
||||
$ws->send('Hello World!');
|
||||
$ws->on(message => sub ($ws, $msg) { say "Message: $msg" });
|
||||
$ws->on(finish => sub ($ws, $code, $reason) { say "WebSocket closed with status $code." });
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Transaction::WebSocket> is a container for WebSocket transactions, based on L<RFC
|
||||
6455|https://tools.ietf.org/html/rfc6455> and L<RFC 7692|https://tools.ietf.org/html/rfc7692>.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::Transaction::WebSocket> inherits all events from L<Mojo::Transaction> and can emit the following new ones.
|
||||
|
||||
=head2 binary
|
||||
|
||||
$ws->on(binary => sub ($ws, $bytes) {...});
|
||||
|
||||
Emitted when a complete WebSocket binary message has been received.
|
||||
|
||||
$ws->on(binary => sub ($ws, $bytes) { say "Binary: $bytes" });
|
||||
|
||||
=head2 drain
|
||||
|
||||
$ws->on(drain => sub ($ws) {...});
|
||||
|
||||
Emitted once all data has been sent.
|
||||
|
||||
$ws->on(drain => sub ($ws) { $ws->send(time) });
|
||||
|
||||
=head2 finish
|
||||
|
||||
$ws->on(finish => sub ($ws, $code, $reason) {...});
|
||||
|
||||
Emitted when the WebSocket connection has been closed.
|
||||
|
||||
=head2 frame
|
||||
|
||||
$ws->on(frame => sub ($ws, $frame) {...});
|
||||
|
||||
Emitted when a WebSocket frame has been received.
|
||||
|
||||
$ws->on(frame => sub ($ws, $frame) {
|
||||
say "FIN: $frame->[0]";
|
||||
say "RSV1: $frame->[1]";
|
||||
say "RSV2: $frame->[2]";
|
||||
say "RSV3: $frame->[3]";
|
||||
say "Opcode: $frame->[4]";
|
||||
say "Payload: $frame->[5]";
|
||||
});
|
||||
|
||||
=head2 json
|
||||
|
||||
$ws->on(json => sub ($ws, $json) {...});
|
||||
|
||||
Emitted when a complete WebSocket message has been received, all text and binary messages will be automatically JSON
|
||||
decoded. Note that this event only gets emitted when it has at least one subscriber.
|
||||
|
||||
$ws->on(json => sub ($ws, $hash) { say "Message: $hash->{msg}" });
|
||||
|
||||
=head2 message
|
||||
|
||||
$ws->on(message => sub ($ws, $msg) {...});
|
||||
|
||||
Emitted when a complete WebSocket message has been received, text messages will be automatically decoded. Note that
|
||||
this event only gets emitted when it has at least one subscriber.
|
||||
|
||||
$ws->on(message => sub ($ws, $msg) { say "Message: $msg" });
|
||||
|
||||
=head2 resume
|
||||
|
||||
$tx->on(resume => sub ($tx) {...});
|
||||
|
||||
Emitted when transaction is resumed.
|
||||
|
||||
=head2 text
|
||||
|
||||
$ws->on(text => sub ($ws, $bytes) {...});
|
||||
|
||||
Emitted when a complete WebSocket text message has been received.
|
||||
|
||||
$ws->on(text => sub ($ws, $bytes) { say "Text: $bytes" });
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Transaction::WebSocket> inherits all attributes from L<Mojo::Transaction> and implements the following new
|
||||
ones.
|
||||
|
||||
=head2 compressed
|
||||
|
||||
my $bool = $ws->compressed;
|
||||
$ws = $ws->compressed($bool);
|
||||
|
||||
Compress messages with C<permessage-deflate> extension.
|
||||
|
||||
=head2 established
|
||||
|
||||
my $bool = $ws->established;
|
||||
$ws = $ws->established($bool);
|
||||
|
||||
WebSocket connection established.
|
||||
|
||||
=head2 handshake
|
||||
|
||||
my $handshake = $ws->handshake;
|
||||
$ws = $ws->handshake(Mojo::Transaction::HTTP->new);
|
||||
|
||||
The original handshake transaction, usually a L<Mojo::Transaction::HTTP> object.
|
||||
|
||||
=head2 masked
|
||||
|
||||
my $bool = $ws->masked;
|
||||
$ws = $ws->masked($bool);
|
||||
|
||||
Mask outgoing frames with XOR cipher and a random 32-bit key.
|
||||
|
||||
=head2 max_websocket_size
|
||||
|
||||
my $size = $ws->max_websocket_size;
|
||||
$ws = $ws->max_websocket_size(1024);
|
||||
|
||||
Maximum WebSocket message size in bytes, defaults to the value of the C<MOJO_MAX_WEBSOCKET_SIZE> environment variable
|
||||
or C<262144> (256KiB).
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Transaction::WebSocket> inherits all methods from L<Mojo::Transaction> and implements the following new ones.
|
||||
|
||||
=head2 build_message
|
||||
|
||||
my $frame = $ws->build_message({binary => $bytes});
|
||||
my $frame = $ws->build_message({text => $bytes});
|
||||
my $frame = $ws->build_message({json => {test => [1, 2, 3]}});
|
||||
my $frame = $ws->build_message($chars);
|
||||
|
||||
Build WebSocket message.
|
||||
|
||||
=head2 client_read
|
||||
|
||||
$ws->client_read($data);
|
||||
|
||||
Read data client-side, used to implement user agents such as L<Mojo::UserAgent>.
|
||||
|
||||
=head2 client_write
|
||||
|
||||
my $bytes = $ws->client_write;
|
||||
|
||||
Write data client-side, used to implement user agents such as L<Mojo::UserAgent>.
|
||||
|
||||
=head2 closed
|
||||
|
||||
$tx = $tx->closed;
|
||||
|
||||
Same as L<Mojo::Transaction/"completed">, but also indicates that all transaction data has been sent.
|
||||
|
||||
=head2 connection
|
||||
|
||||
my $id = $ws->connection;
|
||||
|
||||
Connection identifier.
|
||||
|
||||
=head2 finish
|
||||
|
||||
$ws = $ws->finish;
|
||||
$ws = $ws->finish(1000);
|
||||
$ws = $ws->finish(1003 => 'Cannot accept data!');
|
||||
|
||||
Close WebSocket connection gracefully.
|
||||
|
||||
=head2 is_websocket
|
||||
|
||||
my $bool = $ws->is_websocket;
|
||||
|
||||
True, this is a L<Mojo::Transaction::WebSocket> object.
|
||||
|
||||
=head2 kept_alive
|
||||
|
||||
my $bool = $ws->kept_alive;
|
||||
|
||||
Connection has been kept alive.
|
||||
|
||||
=head2 local_address
|
||||
|
||||
my $address = $ws->local_address;
|
||||
|
||||
Local interface address.
|
||||
|
||||
=head2 local_port
|
||||
|
||||
my $port = $ws->local_port;
|
||||
|
||||
Local interface port.
|
||||
|
||||
=head2 parse_message
|
||||
|
||||
$ws->parse_message([$fin, $rsv1, $rsv2, $rsv3, $op, $payload]);
|
||||
|
||||
Parse WebSocket message.
|
||||
|
||||
=head2 protocol
|
||||
|
||||
my $proto = $ws->protocol;
|
||||
|
||||
Return negotiated subprotocol or C<undef>.
|
||||
|
||||
=head2 remote_address
|
||||
|
||||
my $address = $ws->remote_address;
|
||||
|
||||
Remote interface address.
|
||||
|
||||
=head2 remote_port
|
||||
|
||||
my $port = $ws->remote_port;
|
||||
|
||||
Remote interface port.
|
||||
|
||||
=head2 req
|
||||
|
||||
my $req = $ws->req;
|
||||
|
||||
Handshake request, usually a L<Mojo::Message::Request> object.
|
||||
|
||||
=head2 res
|
||||
|
||||
my $res = $ws->res;
|
||||
|
||||
Handshake response, usually a L<Mojo::Message::Response> object.
|
||||
|
||||
=head2 resume
|
||||
|
||||
$ws = $ws->resume;
|
||||
|
||||
Resume L</"handshake"> transaction.
|
||||
|
||||
=head2 send
|
||||
|
||||
$ws = $ws->send({binary => $bytes});
|
||||
$ws = $ws->send({text => $bytes});
|
||||
$ws = $ws->send({json => {test => [1, 2, 3]}});
|
||||
$ws = $ws->send([$fin, $rsv1, $rsv2, $rsv3, $op, $payload]);
|
||||
$ws = $ws->send($chars);
|
||||
$ws = $ws->send($chars => sub {...});
|
||||
|
||||
Send message or frame non-blocking via WebSocket, the optional drain callback will be executed once all data has been
|
||||
written.
|
||||
|
||||
# Send "Ping" frame
|
||||
use Mojo::WebSocket qw(WS_PING);
|
||||
$ws->send([1, 0, 0, 0, WS_PING, 'Hello World!']);
|
||||
|
||||
=head2 server_read
|
||||
|
||||
$ws->server_read($data);
|
||||
|
||||
Read data server-side, used to implement web servers such as L<Mojo::Server::Daemon>.
|
||||
|
||||
=head2 server_write
|
||||
|
||||
my $bytes = $ws->server_write;
|
||||
|
||||
Write data server-side, used to implement web servers such as L<Mojo::Server::Daemon>.
|
||||
|
||||
=head2 with_compression
|
||||
|
||||
$ws->with_compression;
|
||||
|
||||
Negotiate C<permessage-deflate> extension for this WebSocket connection.
|
||||
|
||||
=head2 with_protocols
|
||||
|
||||
my $proto = $ws->with_protocols('v2.proto', 'v1.proto');
|
||||
|
||||
Negotiate subprotocol for this WebSocket connection.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
521
database/perl/vendor/lib/Mojo/URL.pm
vendored
Normal file
521
database/perl/vendor/lib/Mojo/URL.pm
vendored
Normal file
@@ -0,0 +1,521 @@
|
||||
package Mojo::URL;
|
||||
use Mojo::Base -base;
|
||||
use overload bool => sub {1}, '""' => sub { shift->to_string }, fallback => 1;
|
||||
|
||||
use Mojo::Parameters;
|
||||
use Mojo::Path;
|
||||
use Mojo::Util qw(decode encode punycode_decode punycode_encode url_escape url_unescape);
|
||||
|
||||
has base => sub { Mojo::URL->new };
|
||||
has [qw(fragment host port scheme userinfo)];
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $clone = $self->new;
|
||||
@$clone{keys %$self} = values %$self;
|
||||
$clone->{$_} && ($clone->{$_} = $clone->{$_}->clone) for qw(base path query);
|
||||
return $clone;
|
||||
}
|
||||
|
||||
sub host_port {
|
||||
my ($self, $host_port) = @_;
|
||||
|
||||
if (defined $host_port) {
|
||||
$self->port($1) if $host_port =~ s/:(\d+)$//;
|
||||
my $host = url_unescape $host_port;
|
||||
return $host =~ /[^\x00-\x7f]/ ? $self->ihost($host) : $self->host($host);
|
||||
}
|
||||
|
||||
return undef unless defined(my $host = $self->ihost);
|
||||
return $host unless defined(my $port = $self->port);
|
||||
return "$host:$port";
|
||||
}
|
||||
|
||||
sub ihost {
|
||||
my $self = shift;
|
||||
|
||||
# Decode
|
||||
return $self->host(join '.', map { /^xn--(.+)$/ ? punycode_decode $1 : $_ } split(/\./, shift, -1)) if @_;
|
||||
|
||||
# Check if host needs to be encoded
|
||||
return undef unless defined(my $host = $self->host);
|
||||
return $host unless $host =~ /[^\x00-\x7f]/;
|
||||
|
||||
# Encode
|
||||
return join '.', map { /[^\x00-\x7f]/ ? ('xn--' . punycode_encode $_) : $_ } split(/\./, $host, -1);
|
||||
}
|
||||
|
||||
sub is_abs { !!shift->scheme }
|
||||
|
||||
sub new { @_ > 1 ? shift->SUPER::new->parse(@_) : shift->SUPER::new }
|
||||
|
||||
sub parse {
|
||||
my ($self, $url) = @_;
|
||||
|
||||
# Official regex from RFC 3986
|
||||
$url =~ m!^(([^:/?#]+):)?(//([^/?#]*))?([^?#]*)(\?([^#]*))?(#(.*))?!;
|
||||
$self->scheme($2) if defined $2;
|
||||
$self->path($5) if defined $5;
|
||||
$self->query($7) if defined $7;
|
||||
$self->fragment(_decode(url_unescape $9)) if defined $9;
|
||||
if (defined(my $auth = $4)) {
|
||||
$self->userinfo(_decode(url_unescape $1)) if $auth =~ s/^([^\@]+)\@//;
|
||||
$self->host_port($auth);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub password { (shift->userinfo // '') =~ /:(.*)$/ ? $1 : undef }
|
||||
|
||||
sub path {
|
||||
my $self = shift;
|
||||
|
||||
# Old path
|
||||
$self->{path} ||= Mojo::Path->new;
|
||||
return $self->{path} unless @_;
|
||||
|
||||
# New path
|
||||
$self->{path} = ref $_[0] ? $_[0] : $self->{path}->merge($_[0]);
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub path_query {
|
||||
my ($self, $pq) = @_;
|
||||
|
||||
if (defined $pq) {
|
||||
return $self unless $pq =~ /^([^?#]*)(?:\?([^#]*))?/;
|
||||
return defined $2 ? $self->path($1)->query($2) : $self->path($1);
|
||||
}
|
||||
|
||||
my $query = $self->query->to_string;
|
||||
return $self->path->to_string . (length $query ? "?$query" : '');
|
||||
}
|
||||
|
||||
sub protocol { lc(shift->scheme // '') }
|
||||
|
||||
sub query {
|
||||
my $self = shift;
|
||||
|
||||
# Old parameters
|
||||
my $q = $self->{query} ||= Mojo::Parameters->new;
|
||||
return $q unless @_;
|
||||
|
||||
# Replace with list
|
||||
if (@_ > 1) { $q->pairs([])->parse(@_) }
|
||||
|
||||
# Merge with hash
|
||||
elsif (ref $_[0] eq 'HASH') { $q->merge(%{$_[0]}) }
|
||||
|
||||
# Append array
|
||||
elsif (ref $_[0] eq 'ARRAY') { $q->append(@{$_[0]}) }
|
||||
|
||||
# New parameters
|
||||
else { $self->{query} = ref $_[0] ? $_[0] : $q->parse($_[0]) }
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub to_abs {
|
||||
my $self = shift;
|
||||
|
||||
my $abs = $self->clone;
|
||||
return $abs if $abs->is_abs;
|
||||
|
||||
# Scheme
|
||||
my $base = shift || $abs->base;
|
||||
$abs->base($base)->scheme($base->scheme);
|
||||
|
||||
# Authority
|
||||
return $abs if $abs->host;
|
||||
$abs->userinfo($base->userinfo)->host($base->host)->port($base->port);
|
||||
|
||||
# Absolute path
|
||||
my $path = $abs->path;
|
||||
return $abs if $path->leading_slash;
|
||||
|
||||
# Inherit path
|
||||
if (!@{$path->parts}) {
|
||||
$abs->path($base->path->clone->canonicalize);
|
||||
|
||||
# Query
|
||||
$abs->query($base->query->clone) unless length $abs->query->to_string;
|
||||
}
|
||||
|
||||
# Merge paths
|
||||
else { $abs->path($base->path->clone->merge($path)->canonicalize) }
|
||||
|
||||
return $abs;
|
||||
}
|
||||
|
||||
sub to_string { shift->_string(0) }
|
||||
sub to_unsafe_string { shift->_string(1) }
|
||||
|
||||
sub username { (shift->userinfo // '') =~ /^([^:]+)/ ? $1 : undef }
|
||||
|
||||
sub _decode { decode('UTF-8', $_[0]) // $_[0] }
|
||||
|
||||
sub _encode { url_escape encode('UTF-8', $_[0]), $_[1] }
|
||||
|
||||
sub _string {
|
||||
my ($self, $unsafe) = @_;
|
||||
|
||||
# Scheme
|
||||
my $url = '';
|
||||
if (my $proto = $self->protocol) { $url .= "$proto:" }
|
||||
|
||||
# Authority
|
||||
my $auth = $self->host_port;
|
||||
$auth = _encode($auth, '^A-Za-z0-9\-._~!$&\'()*+,;=:\[\]') if defined $auth;
|
||||
if ($unsafe && defined(my $info = $self->userinfo)) {
|
||||
$auth = _encode($info, '^A-Za-z0-9\-._~!$&\'()*+,;=:') . '@' . $auth;
|
||||
}
|
||||
$url .= "//$auth" if defined $auth;
|
||||
|
||||
# Path and query
|
||||
my $path = $self->path_query;
|
||||
$url .= !$auth || !length $path || $path =~ m!^[/?]! ? $path : "/$path";
|
||||
|
||||
# Fragment
|
||||
return $url unless defined(my $fragment = $self->fragment);
|
||||
return $url . '#' . _encode($fragment, '^A-Za-z0-9\-._~!$&\'()*+,;=:@/?');
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::URL - Uniform Resource Locator
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::URL;
|
||||
|
||||
# Parse
|
||||
my $url = Mojo::URL->new('http://sri:foo@example.com:3000/foo?foo=bar#23');
|
||||
say $url->scheme;
|
||||
say $url->userinfo;
|
||||
say $url->host;
|
||||
say $url->port;
|
||||
say $url->path;
|
||||
say $url->query;
|
||||
say $url->fragment;
|
||||
|
||||
# Build
|
||||
my $url = Mojo::URL->new;
|
||||
$url->scheme('http');
|
||||
$url->host('example.com');
|
||||
$url->port(3000);
|
||||
$url->path('/foo/bar');
|
||||
$url->query(foo => 'bar');
|
||||
$url->fragment(23);
|
||||
say "$url";
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::URL> implements a subset of L<RFC 3986|https://tools.ietf.org/html/rfc3986>, L<RFC
|
||||
3987|https://tools.ietf.org/html/rfc3987> and the L<URL Living Standard|https://url.spec.whatwg.org> for Uniform
|
||||
Resource Locators with support for IDNA and IRIs.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::URL> implements the following attributes.
|
||||
|
||||
=head2 base
|
||||
|
||||
my $base = $url->base;
|
||||
$url = $url->base(Mojo::URL->new);
|
||||
|
||||
Base of this URL, defaults to a L<Mojo::URL> object.
|
||||
|
||||
"http://example.com/a/b?c"
|
||||
Mojo::URL->new("/a/b?c")->base(Mojo::URL->new("http://example.com"))->to_abs;
|
||||
|
||||
=head2 fragment
|
||||
|
||||
my $fragment = $url->fragment;
|
||||
$url = $url->fragment('♥mojolicious♥');
|
||||
|
||||
Fragment part of this URL.
|
||||
|
||||
# "yada"
|
||||
Mojo::URL->new('http://example.com/foo?bar=baz#yada')->fragment;
|
||||
|
||||
=head2 host
|
||||
|
||||
my $host = $url->host;
|
||||
$url = $url->host('127.0.0.1');
|
||||
|
||||
Host part of this URL.
|
||||
|
||||
# "example.com"
|
||||
Mojo::URL->new('http://sri:t3st@example.com:8080/foo')->host;
|
||||
|
||||
=head2 port
|
||||
|
||||
my $port = $url->port;
|
||||
$url = $url->port(8080);
|
||||
|
||||
Port part of this URL.
|
||||
|
||||
# "8080"
|
||||
Mojo::URL->new('http://sri:t3st@example.com:8080/foo')->port;
|
||||
|
||||
=head2 scheme
|
||||
|
||||
my $scheme = $url->scheme;
|
||||
$url = $url->scheme('http');
|
||||
|
||||
Scheme part of this URL.
|
||||
|
||||
# "http"
|
||||
Mojo::URL->new('http://example.com/foo')->scheme;
|
||||
|
||||
=head2 userinfo
|
||||
|
||||
my $info = $url->userinfo;
|
||||
$url = $url->userinfo('root:♥');
|
||||
|
||||
Userinfo part of this URL.
|
||||
|
||||
# "sri:t3st"
|
||||
Mojo::URL->new('https://sri:t3st@example.com/foo')->userinfo;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::URL> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 clone
|
||||
|
||||
my $url2 = $url->clone;
|
||||
|
||||
Return a new L<Mojo::URL> object cloned from this URL.
|
||||
|
||||
=head2 host_port
|
||||
|
||||
my $host_port = $url->host_port;
|
||||
$url = $url->host_port('example.com:8080');
|
||||
|
||||
Normalized version of L</"host"> and L</"port">.
|
||||
|
||||
# "xn--n3h.net:8080"
|
||||
Mojo::URL->new('http://☃.net:8080/test')->host_port;
|
||||
|
||||
# "example.com"
|
||||
Mojo::URL->new('http://example.com/test')->host_port;
|
||||
|
||||
=head2 ihost
|
||||
|
||||
my $ihost = $url->ihost;
|
||||
$url = $url->ihost('xn--bcher-kva.ch');
|
||||
|
||||
Host part of this URL in punycode format.
|
||||
|
||||
# "xn--n3h.net"
|
||||
Mojo::URL->new('http://☃.net')->ihost;
|
||||
|
||||
# "example.com"
|
||||
Mojo::URL->new('http://example.com')->ihost;
|
||||
|
||||
=head2 is_abs
|
||||
|
||||
my $bool = $url->is_abs;
|
||||
|
||||
Check if URL is absolute.
|
||||
|
||||
# True
|
||||
Mojo::URL->new('http://example.com')->is_abs;
|
||||
Mojo::URL->new('http://example.com/test/index.html')->is_abs;
|
||||
|
||||
# False
|
||||
Mojo::URL->new('test/index.html')->is_abs;
|
||||
Mojo::URL->new('/test/index.html')->is_abs;
|
||||
Mojo::URL->new('//example.com/test/index.html')->is_abs;
|
||||
|
||||
=head2 new
|
||||
|
||||
my $url = Mojo::URL->new;
|
||||
my $url = Mojo::URL->new('http://127.0.0.1:3000/foo?f=b&baz=2#foo');
|
||||
|
||||
Construct a new L<Mojo::URL> object and L</"parse"> URL if necessary.
|
||||
|
||||
=head2 parse
|
||||
|
||||
$url = $url->parse('http://127.0.0.1:3000/foo/bar?fo=o&baz=23#foo');
|
||||
|
||||
Parse relative or absolute URL.
|
||||
|
||||
# "/test/123"
|
||||
$url->parse('/test/123?foo=bar')->path;
|
||||
|
||||
# "example.com"
|
||||
$url->parse('http://example.com/test/123?foo=bar')->host;
|
||||
|
||||
# "sri@example.com"
|
||||
$url->parse('mailto:sri@example.com')->path;
|
||||
|
||||
=head2 password
|
||||
|
||||
my $password = $url->password;
|
||||
|
||||
Password part of L</"userinfo">.
|
||||
|
||||
# "s3cret"
|
||||
Mojo::URL->new('http://isabel:s3cret@mojolicious.org')->password;
|
||||
|
||||
# "s:3:c:r:e:t"
|
||||
Mojo::URL->new('http://isabel:s:3:c:r:e:t@mojolicious.org')->password;
|
||||
|
||||
=head2 path
|
||||
|
||||
my $path = $url->path;
|
||||
$url = $url->path('foo/bar');
|
||||
$url = $url->path('/foo/bar');
|
||||
$url = $url->path(Mojo::Path->new);
|
||||
|
||||
Path part of this URL, relative paths will be merged with L<Mojo::Path/"merge">, defaults to a L<Mojo::Path> object.
|
||||
|
||||
# "test"
|
||||
Mojo::URL->new('http://example.com/test/Mojo')->path->parts->[0];
|
||||
|
||||
# "/test/DOM/HTML"
|
||||
Mojo::URL->new('http://example.com/test/Mojo')->path->merge('DOM/HTML');
|
||||
|
||||
# "http://example.com/DOM/HTML"
|
||||
Mojo::URL->new('http://example.com/test/Mojo')->path('/DOM/HTML');
|
||||
|
||||
# "http://example.com/test/DOM/HTML"
|
||||
Mojo::URL->new('http://example.com/test/Mojo')->path('DOM/HTML');
|
||||
|
||||
# "http://example.com/test/Mojo/DOM/HTML"
|
||||
Mojo::URL->new('http://example.com/test/Mojo/')->path('DOM/HTML');
|
||||
|
||||
=head2 path_query
|
||||
|
||||
my $path_query = $url->path_query;
|
||||
$url = $url->path_query('/foo/bar?a=1&b=2');
|
||||
|
||||
Normalized version of L</"path"> and L</"query">.
|
||||
|
||||
# "/test?a=1&b=2"
|
||||
Mojo::URL->new('http://example.com/test?a=1&b=2')->path_query;
|
||||
|
||||
# "/"
|
||||
Mojo::URL->new('http://example.com/')->path_query;
|
||||
|
||||
=head2 protocol
|
||||
|
||||
my $proto = $url->protocol;
|
||||
|
||||
Normalized version of L</"scheme">.
|
||||
|
||||
# "http"
|
||||
Mojo::URL->new('HtTp://example.com')->protocol;
|
||||
|
||||
=head2 query
|
||||
|
||||
my $query = $url->query;
|
||||
$url = $url->query({merge => 'to'});
|
||||
$url = $url->query([append => 'with']);
|
||||
$url = $url->query(replace => 'with');
|
||||
$url = $url->query('a=1&b=2');
|
||||
$url = $url->query(Mojo::Parameters->new);
|
||||
|
||||
Query part of this URL, key/value pairs in an array reference will be appended with L<Mojo::Parameters/"append">, and
|
||||
key/value pairs in a hash reference merged with L<Mojo::Parameters/"merge">, defaults to a L<Mojo::Parameters> object.
|
||||
|
||||
# "2"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query->param('b');
|
||||
|
||||
# "a=2&b=2&c=3"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query->merge(a => 2, c => 3);
|
||||
|
||||
# "http://example.com?a=2&c=3"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query(a => 2, c => 3);
|
||||
|
||||
# "http://example.com?a=2&a=3"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query(a => [2, 3]);
|
||||
|
||||
# "http://example.com?a=2&b=2&c=3"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query({a => 2, c => 3});
|
||||
|
||||
# "http://example.com?b=2"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query({a => undef});
|
||||
|
||||
# "http://example.com?a=1&b=2&a=2&c=3"
|
||||
Mojo::URL->new('http://example.com?a=1&b=2')->query([a => 2, c => 3]);
|
||||
|
||||
=head2 to_abs
|
||||
|
||||
my $abs = $url->to_abs;
|
||||
my $abs = $url->to_abs(Mojo::URL->new('http://example.com/foo'));
|
||||
|
||||
Return a new L<Mojo::URL> object cloned from this relative URL and turn it into an absolute one using L</"base"> or
|
||||
provided base URL.
|
||||
|
||||
# "http://example.com/foo/baz.xml?test=123"
|
||||
Mojo::URL->new('baz.xml?test=123')
|
||||
->to_abs(Mojo::URL->new('http://example.com/foo/bar.html'));
|
||||
|
||||
# "http://example.com/baz.xml?test=123"
|
||||
Mojo::URL->new('/baz.xml?test=123')
|
||||
->to_abs(Mojo::URL->new('http://example.com/foo/bar.html'));
|
||||
|
||||
# "http://example.com/foo/baz.xml?test=123"
|
||||
Mojo::URL->new('//example.com/foo/baz.xml?test=123')
|
||||
->to_abs(Mojo::URL->new('http://example.com/foo/bar.html'));
|
||||
|
||||
=head2 to_string
|
||||
|
||||
my $str = $url->to_string;
|
||||
|
||||
Turn URL into a string. Note that L</"userinfo"> will not be included for security reasons.
|
||||
|
||||
# "http://mojolicious.org"
|
||||
Mojo::URL->new->scheme('http')->host('mojolicious.org')->to_string;
|
||||
|
||||
# "http://mojolicious.org"
|
||||
Mojo::URL->new('http://daniel:s3cret@mojolicious.org')->to_string;
|
||||
|
||||
=head2 to_unsafe_string
|
||||
|
||||
my $str = $url->to_unsafe_string;
|
||||
|
||||
Same as L</"to_string">, but includes L</"userinfo">.
|
||||
|
||||
# "http://daniel:s3cret@mojolicious.org"
|
||||
Mojo::URL->new('http://daniel:s3cret@mojolicious.org')->to_unsafe_string;
|
||||
|
||||
=head2 username
|
||||
|
||||
my $username = $url->username;
|
||||
|
||||
Username part of L</"userinfo">.
|
||||
|
||||
# "isabel"
|
||||
Mojo::URL->new('http://isabel:s3cret@mojolicious.org')->username;
|
||||
|
||||
=head1 OPERATORS
|
||||
|
||||
L<Mojo::URL> overloads the following operators.
|
||||
|
||||
=head2 bool
|
||||
|
||||
my $bool = !!$url;
|
||||
|
||||
Always true.
|
||||
|
||||
=head2 stringify
|
||||
|
||||
my $str = "$url";
|
||||
|
||||
Alias for L</"to_string">.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
89
database/perl/vendor/lib/Mojo/Upload.pm
vendored
Normal file
89
database/perl/vendor/lib/Mojo/Upload.pm
vendored
Normal file
@@ -0,0 +1,89 @@
|
||||
package Mojo::Upload;
|
||||
use Mojo::Base -base;
|
||||
|
||||
has [qw(asset filename headers name)];
|
||||
|
||||
sub move_to { $_[0]->asset->move_to($_[1]) and return $_[0] }
|
||||
|
||||
sub size { shift->asset->size }
|
||||
sub slurp { shift->asset->slurp }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Upload - Upload
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Upload;
|
||||
|
||||
my $upload = Mojo::Upload->new;
|
||||
say $upload->filename;
|
||||
$upload->move_to('/home/sri/foo.txt');
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Upload> is a container for uploaded files.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::Upload> implements the following attributes.
|
||||
|
||||
=head2 asset
|
||||
|
||||
my $asset = $upload->asset;
|
||||
$upload = $upload->asset(Mojo::Asset::File->new);
|
||||
|
||||
Asset containing the uploaded data, usually a L<Mojo::Asset::File> or L<Mojo::Asset::Memory> object.
|
||||
|
||||
=head2 filename
|
||||
|
||||
my $filename = $upload->filename;
|
||||
$upload = $upload->filename('foo.txt');
|
||||
|
||||
Name of the uploaded file.
|
||||
|
||||
=head2 headers
|
||||
|
||||
my $headers = $upload->headers;
|
||||
$upload = $upload->headers(Mojo::Headers->new);
|
||||
|
||||
Headers for upload, usually a L<Mojo::Headers> object.
|
||||
|
||||
=head2 name
|
||||
|
||||
my $name = $upload->name;
|
||||
$upload = $upload->name('foo');
|
||||
|
||||
Name of the upload.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::Upload> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 move_to
|
||||
|
||||
$upload = $upload->move_to('/home/sri/foo.txt');
|
||||
|
||||
Move uploaded data into a specific file.
|
||||
|
||||
=head2 size
|
||||
|
||||
my $size = $upload->size;
|
||||
|
||||
Size of uploaded data in bytes.
|
||||
|
||||
=head2 slurp
|
||||
|
||||
my $bytes = $upload->slurp;
|
||||
|
||||
Read all uploaded data at once.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
986
database/perl/vendor/lib/Mojo/UserAgent.pm
vendored
Normal file
986
database/perl/vendor/lib/Mojo/UserAgent.pm
vendored
Normal file
@@ -0,0 +1,986 @@
|
||||
package Mojo::UserAgent;
|
||||
use Mojo::Base 'Mojo::EventEmitter';
|
||||
|
||||
# "Fry: Since when is the Internet about robbing people of their privacy?
|
||||
# Bender: August 6, 1991."
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::Promise;
|
||||
use Mojo::Util qw(monkey_patch term_escape);
|
||||
use Mojo::UserAgent::CookieJar;
|
||||
use Mojo::UserAgent::Proxy;
|
||||
use Mojo::UserAgent::Server;
|
||||
use Mojo::UserAgent::Transactor;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_CLIENT_DEBUG} || 0;
|
||||
|
||||
has ca => sub { $ENV{MOJO_CA_FILE} };
|
||||
has cert => sub { $ENV{MOJO_CERT_FILE} };
|
||||
has connect_timeout => sub { $ENV{MOJO_CONNECT_TIMEOUT} || 10 };
|
||||
has cookie_jar => sub { Mojo::UserAgent::CookieJar->new };
|
||||
has inactivity_timeout => sub { $ENV{MOJO_INACTIVITY_TIMEOUT} // 40 };
|
||||
has insecure => sub { $ENV{MOJO_INSECURE} };
|
||||
has [qw(local_address max_response_size)];
|
||||
has ioloop => sub { Mojo::IOLoop->new };
|
||||
has key => sub { $ENV{MOJO_KEY_FILE} };
|
||||
has max_connections => 5;
|
||||
has max_redirects => sub { $ENV{MOJO_MAX_REDIRECTS} || 0 };
|
||||
has proxy => sub { Mojo::UserAgent::Proxy->new };
|
||||
has request_timeout => sub { $ENV{MOJO_REQUEST_TIMEOUT} // 0 };
|
||||
has server => sub { Mojo::UserAgent::Server->new(ioloop => shift->ioloop) };
|
||||
has transactor => sub { Mojo::UserAgent::Transactor->new };
|
||||
|
||||
# Common HTTP methods
|
||||
for my $name (qw(DELETE GET HEAD OPTIONS PATCH POST PUT)) {
|
||||
monkey_patch __PACKAGE__, lc $name, sub {
|
||||
my ($self, $cb) = (shift, ref $_[-1] eq 'CODE' ? pop : undef);
|
||||
return $self->start($self->build_tx($name, @_), $cb);
|
||||
};
|
||||
monkey_patch __PACKAGE__, lc($name) . '_p', sub {
|
||||
my $self = shift;
|
||||
return $self->start_p($self->build_tx($name, @_));
|
||||
};
|
||||
}
|
||||
|
||||
sub DESTROY { Mojo::Util::_global_destruction() or shift->_cleanup }
|
||||
|
||||
sub build_tx { shift->transactor->tx(@_) }
|
||||
sub build_websocket_tx { shift->transactor->websocket(@_) }
|
||||
|
||||
sub start {
|
||||
my ($self, $tx, $cb) = @_;
|
||||
|
||||
# Fork-safety
|
||||
$self->_cleanup->server->restart if $self->{pid} && $self->{pid} ne $$;
|
||||
$self->{pid} //= $$;
|
||||
|
||||
# Non-blocking
|
||||
if ($cb) {
|
||||
warn "-- Non-blocking request (@{[_url($tx)]})\n" if DEBUG;
|
||||
return $self->_start(Mojo::IOLoop->singleton, $tx, $cb);
|
||||
}
|
||||
|
||||
# Blocking
|
||||
warn "-- Blocking request (@{[_url($tx)]})\n" if DEBUG;
|
||||
$self->_start($self->ioloop, $tx => sub { shift->ioloop->stop; $tx = shift });
|
||||
$self->ioloop->start;
|
||||
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub start_p {
|
||||
my ($self, $tx) = @_;
|
||||
my $promise = Mojo::Promise->new;
|
||||
$self->start($tx => sub { shift->transactor->promisify($promise, shift) });
|
||||
return $promise;
|
||||
}
|
||||
|
||||
sub websocket {
|
||||
my ($self, $cb) = (shift, pop);
|
||||
$self->start($self->build_websocket_tx(@_), $cb);
|
||||
}
|
||||
|
||||
sub websocket_p {
|
||||
my $self = shift;
|
||||
return $self->start_p($self->build_websocket_tx(@_));
|
||||
}
|
||||
|
||||
sub _cleanup {
|
||||
my $self = shift;
|
||||
delete $self->{pid};
|
||||
$self->_finish($_, 1) for keys %{$self->{connections} // {}};
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _connect {
|
||||
my ($self, $loop, $tx, $handle) = @_;
|
||||
|
||||
my $t = $self->transactor;
|
||||
my ($proto, $host, $port) = $handle ? $t->endpoint($tx) : $t->peer($tx);
|
||||
|
||||
my %options = (timeout => $self->connect_timeout);
|
||||
if ($proto eq 'http+unix') { $options{path} = $host }
|
||||
else { @options{qw(address port)} = ($host, $port) }
|
||||
if (my $local = $self->local_address) { $options{local_address} = $local }
|
||||
$options{handle} = $handle if $handle;
|
||||
|
||||
# SOCKS
|
||||
if ($proto eq 'socks') {
|
||||
@options{qw(socks_address socks_port)} = @options{qw(address port)};
|
||||
($proto, @options{qw(address port)}) = $t->endpoint($tx);
|
||||
my $userinfo = $tx->req->via_proxy(0)->proxy->userinfo;
|
||||
@options{qw(socks_user socks_pass)} = split /:/, $userinfo if $userinfo;
|
||||
}
|
||||
|
||||
# TLS
|
||||
if ($options{tls} = $proto eq 'https') {
|
||||
map { $options{"tls_$_"} = $self->$_ } qw(ca cert key);
|
||||
$options{tls_verify} = 0x00 if $self->insecure;
|
||||
}
|
||||
|
||||
weaken $self;
|
||||
my $id;
|
||||
return $id = $loop->client(
|
||||
%options => sub {
|
||||
my ($loop, $err, $stream) = @_;
|
||||
|
||||
# Connection error
|
||||
return unless $self;
|
||||
return $self->_error($id, $err) if $err;
|
||||
|
||||
# Connection established
|
||||
$stream->on(timeout => sub { $self->_error($id, 'Inactivity timeout') });
|
||||
$stream->on(close => sub { $self && $self->_finish($id, 1) });
|
||||
$stream->on(error => sub { $self && $self->_error($id, pop) });
|
||||
$stream->on(read => sub { $self->_read($id, pop) });
|
||||
$self->_process($id);
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub _connect_proxy {
|
||||
my ($self, $loop, $old, $cb) = @_;
|
||||
|
||||
# Start CONNECT request
|
||||
return undef unless my $new = $self->transactor->proxy_connect($old);
|
||||
my $id;
|
||||
return $id = $self->_start(
|
||||
($loop, $new) => sub {
|
||||
my ($self, $tx) = @_;
|
||||
|
||||
# Real transaction
|
||||
$old->previous($tx)->req->via_proxy(0);
|
||||
my $c = $self->{connections}{$id} = {cb => $cb, ioloop => $loop, tx => $old};
|
||||
|
||||
# CONNECT failed
|
||||
return $self->_error($id, 'Proxy connection failed') if $tx->error || !$tx->res->is_success || !$tx->keep_alive;
|
||||
|
||||
# Start real transaction without TLS upgrade
|
||||
return $self->_process($id) unless $tx->req->url->protocol eq 'https';
|
||||
|
||||
# TLS upgrade before starting the real transaction
|
||||
my $handle = $loop->stream($id)->steal_handle;
|
||||
$self->_remove($id);
|
||||
$id = $self->_connect($loop, $old, $handle);
|
||||
$self->{connections}{$id} = $c;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub _connection {
|
||||
my ($self, $loop, $tx, $cb) = @_;
|
||||
|
||||
# Reuse connection
|
||||
my ($proto, $host, $port) = $self->transactor->endpoint($tx);
|
||||
my $id;
|
||||
if ($id = $self->_dequeue($loop, "$proto:$host:$port", 1)) {
|
||||
warn "-- Reusing connection $id ($proto://$host:$port)\n" if DEBUG;
|
||||
@{$self->{connections}{$id}}{qw(cb tx)} = ($cb, $tx);
|
||||
$tx->kept_alive(1) unless $tx->connection;
|
||||
$self->_process($id);
|
||||
return $id;
|
||||
}
|
||||
|
||||
# CONNECT request to proxy required
|
||||
if (my $id = $self->_connect_proxy($loop, $tx, $cb)) { return $id }
|
||||
|
||||
# New connection
|
||||
$tx->res->error({message => "Unsupported protocol: $proto"}) and return $loop->next_tick(sub { $self->$cb($tx) })
|
||||
unless $proto eq 'http' || $proto eq 'https' || $proto eq 'http+unix';
|
||||
$id = $self->_connect($loop, $tx);
|
||||
warn "-- Connect $id ($proto://$host:$port)\n" if DEBUG;
|
||||
$self->{connections}{$id} = {cb => $cb, ioloop => $loop, tx => $tx};
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub _dequeue {
|
||||
my ($self, $loop, $name, $test) = @_;
|
||||
|
||||
my $old = $self->{queue}{$loop} //= [];
|
||||
my ($found, @new);
|
||||
for my $queued (@$old) {
|
||||
push @new, $queued and next if $found || !grep { $_ eq $name } @$queued;
|
||||
|
||||
# Search for id/name and sort out corrupted connections if necessary
|
||||
next unless my $stream = $loop->stream($queued->[1]);
|
||||
$test && $stream->is_readable ? $stream->close : ($found = $queued->[1]);
|
||||
}
|
||||
@$old = @new;
|
||||
|
||||
return $found;
|
||||
}
|
||||
|
||||
sub _error {
|
||||
my ($self, $id, $err) = @_;
|
||||
my $tx = $self->{connections}{$id}{tx};
|
||||
$tx->res->error({message => $err}) if $tx;
|
||||
$self->_finish($id, 1);
|
||||
}
|
||||
|
||||
sub _finish {
|
||||
my ($self, $id, $close) = @_;
|
||||
|
||||
# Remove request timeout and finish transaction
|
||||
return undef unless my $c = $self->{connections}{$id};
|
||||
$c->{ioloop}->remove(delete $c->{timeout}) if $c->{timeout};
|
||||
return $self->_reuse($id, $close) unless my $old = $c->{tx};
|
||||
|
||||
# Premature connection close
|
||||
my $res = $old->closed->res->finish;
|
||||
$res->error({message => 'Premature connection close'}) if $close && !$res->code && !$res->error;
|
||||
|
||||
# Always remove connection for WebSockets
|
||||
return $self->_remove($id) if $old->is_websocket;
|
||||
$self->cookie_jar->collect($old);
|
||||
|
||||
# Upgrade connection to WebSocket
|
||||
if (my $new = $self->transactor->upgrade($old)) {
|
||||
weaken $self;
|
||||
$new->on(resume => sub { $self->_write($id) });
|
||||
$c->{cb}($self, $c->{tx} = $new);
|
||||
return $new->client_read($old->res->content->leftovers);
|
||||
}
|
||||
|
||||
# CONNECT requests always have a follow-up request
|
||||
$self->_reuse($id, $close) unless uc $old->req->method eq 'CONNECT';
|
||||
$res->error({message => $res->message, code => $res->code}) if $res->is_error;
|
||||
$c->{cb}($self, $old) unless $self->_redirect($c, $old);
|
||||
}
|
||||
|
||||
sub _process {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
my $c = $self->{connections}{$id};
|
||||
my $stream = $c->{ioloop}->stream($id)->timeout($self->inactivity_timeout);
|
||||
my $tx = $c->{tx}->connection($id);
|
||||
my $handle = $stream->handle;
|
||||
unless ($handle->isa('IO::Socket::UNIX')) {
|
||||
$tx->local_address($handle->sockhost)->local_port($handle->sockport);
|
||||
$tx->remote_address($handle->peerhost)->remote_port($handle->peerport);
|
||||
}
|
||||
|
||||
weaken $self;
|
||||
$tx->on(resume => sub { $self->_write($id) });
|
||||
$self->_write($id);
|
||||
}
|
||||
|
||||
sub _read {
|
||||
my ($self, $id, $chunk) = @_;
|
||||
|
||||
# Corrupted connection
|
||||
return $self->_remove($id) unless my $tx = $self->{connections}{$id}{tx};
|
||||
warn term_escape "-- Client <<< Server (@{[_url($tx)]})\n$chunk\n" if DEBUG;
|
||||
$tx->client_read($chunk);
|
||||
$self->_finish($id) if $tx->is_finished;
|
||||
}
|
||||
|
||||
sub _redirect {
|
||||
my ($self, $c, $old) = @_;
|
||||
return undef unless my $new = $self->transactor->redirect($old);
|
||||
return undef unless @{$old->redirects} < $self->max_redirects;
|
||||
return $self->_start($c->{ioloop}, $new, delete $c->{cb});
|
||||
}
|
||||
|
||||
sub _remove {
|
||||
my ($self, $id) = @_;
|
||||
my $c = delete $self->{connections}{$id};
|
||||
$self->_dequeue($c->{ioloop}, $id);
|
||||
$c->{ioloop}->remove($id);
|
||||
}
|
||||
|
||||
sub _reuse {
|
||||
my ($self, $id, $close) = @_;
|
||||
|
||||
# Connection close
|
||||
my $c = $self->{connections}{$id};
|
||||
my $tx = delete $c->{tx};
|
||||
my $max = $self->max_connections;
|
||||
return $self->_remove($id) if $close || !$tx || !$max || !$tx->keep_alive || $tx->error;
|
||||
|
||||
# Keep connection alive
|
||||
my $queue = $self->{queue}{$c->{ioloop}} //= [];
|
||||
$self->_remove(shift(@$queue)->[1]) while @$queue && @$queue >= $max;
|
||||
push @$queue, [join(':', $self->transactor->endpoint($tx)), $id];
|
||||
}
|
||||
|
||||
sub _start {
|
||||
my ($self, $loop, $tx, $cb) = @_;
|
||||
|
||||
# Application server
|
||||
$self->emit(prepare => $tx);
|
||||
my $url = $tx->req->url;
|
||||
if (!$url->is_abs && (my $server = $self->server)) {
|
||||
my $base = $loop == $self->ioloop ? $server->url : $server->nb_url;
|
||||
$url->scheme($base->scheme)->host($base->host)->port($base->port);
|
||||
}
|
||||
|
||||
$_->prepare($tx) for $self->proxy, $self->cookie_jar;
|
||||
my $max = $self->max_response_size;
|
||||
$tx->res->max_message_size($max) if defined $max;
|
||||
$self->emit(start => $tx);
|
||||
|
||||
# Allow test servers sharing the same event loop to clean up connections
|
||||
!$loop->next_tick(sub { }) and $loop->one_tick unless $loop->is_running;
|
||||
return undef unless my $id = $self->_connection($loop, $tx, $cb);
|
||||
|
||||
if (my $t = $self->request_timeout) {
|
||||
weaken $self;
|
||||
$self->{connections}{$id}{timeout} ||= $loop->timer($t => sub { $self->_error($id, 'Request timeout') });
|
||||
}
|
||||
|
||||
return $id;
|
||||
}
|
||||
|
||||
sub _url { shift->req->url->to_abs }
|
||||
|
||||
sub _write {
|
||||
my ($self, $id) = @_;
|
||||
|
||||
# Protect from resume event recursion
|
||||
my $c = $self->{connections}{$id};
|
||||
return if !(my $tx = $c->{tx}) || $c->{writing};
|
||||
local $c->{writing} = 1;
|
||||
my $chunk = $tx->client_write;
|
||||
warn term_escape "-- Client >>> Server (@{[_url($tx)]})\n$chunk\n" if DEBUG;
|
||||
return unless length $chunk;
|
||||
|
||||
weaken $self;
|
||||
$c->{ioloop}->stream($id)->write($chunk => sub { $self->_write($id) });
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::UserAgent - Non-blocking I/O HTTP and WebSocket user agent
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::UserAgent;
|
||||
|
||||
# Fine grained response handling (dies on connection errors)
|
||||
my $ua = Mojo::UserAgent->new;
|
||||
my $res = $ua->get('docs.mojolicious.org')->result;
|
||||
if ($res->is_success) { say $res->body }
|
||||
elsif ($res->is_error) { say $res->message }
|
||||
elsif ($res->code == 301) { say $res->headers->location }
|
||||
else { say 'Whatever...' }
|
||||
|
||||
# Say hello to the Unicode snowman and include an Accept header
|
||||
say $ua->get('www.☃.net?hello=there' => {Accept => '*/*'})->result->body;
|
||||
|
||||
# Extract data from HTML and XML resources with CSS selectors
|
||||
say $ua->get('www.perl.org')->result->dom->at('title')->text;
|
||||
|
||||
# Scrape the latest headlines from a news site
|
||||
say $ua->get('blogs.perl.org')->result->dom->find('h2 > a')->map('text')->join("\n");
|
||||
|
||||
# IPv6 PUT request with Content-Type header and content
|
||||
my $tx = $ua->put('[::1]:3000' => {'Content-Type' => 'text/plain'} => 'Hi!');
|
||||
|
||||
# Quick JSON API request with Basic authentication
|
||||
my $url = Mojo::URL->new('https://example.com/test.json')->userinfo('sri:☃');
|
||||
my $value = $ua->get($url)->result->json;
|
||||
|
||||
# JSON POST (application/json) with TLS certificate authentication
|
||||
my $tx = $ua->cert('tls.crt')->key('tls.key')->post('https://example.com' => json => {top => 'secret'});
|
||||
|
||||
# Form POST (application/x-www-form-urlencoded)
|
||||
my $tx = $ua->post('https://metacpan.org/search' => form => {q => 'mojo'});
|
||||
|
||||
# Search DuckDuckGo anonymously through Tor
|
||||
$ua->proxy->http('socks://127.0.0.1:9050');
|
||||
say $ua->get('api.3g2upl4pq6kufc4m.onion/?q=mojolicious&format=json')->result->json('/Abstract');
|
||||
|
||||
# GET request via UNIX domain socket "/tmp/myapp.sock" (percent encoded slash)
|
||||
say $ua->get('http+unix://%2Ftmp%2Fmyapp.sock/test')->result->body;
|
||||
|
||||
# Follow redirects to download Mojolicious from GitHub
|
||||
$ua->max_redirects(5)
|
||||
->get('https://www.github.com/mojolicious/mojo/tarball/master')
|
||||
->result->save_to('/home/sri/mojo.tar.gz');
|
||||
|
||||
# Non-blocking request
|
||||
$ua->get('mojolicious.org' => sub ($ua, $tx) { say $tx->result->dom->at('title')->text });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
# Concurrent non-blocking requests (synchronized with promises)
|
||||
my $mojo_promise = $ua->get_p('mojolicious.org');
|
||||
my $cpan_promise = $ua->get_p('cpan.org');
|
||||
Mojo::Promise->all($mojo_promise, $cpan_promise)->then(sub ($mojo, $cpan) {
|
||||
say $mojo->[0]->result->dom->at('title')->text;
|
||||
say $cpan->[0]->result->dom->at('title')->text;
|
||||
})->wait;
|
||||
|
||||
# WebSocket connection sending and receiving JSON via UNIX domain socket
|
||||
$ua->websocket('ws+unix://%2Ftmp%2Fmyapp.sock/echo.json' => sub ($ua, $tx) {
|
||||
say 'WebSocket handshake failed!' and return unless $tx->is_websocket;
|
||||
$tx->on(json => sub ($tx, $hash) {
|
||||
say "WebSocket message via JSON: $hash->{msg}";
|
||||
$tx->finish;
|
||||
});
|
||||
$tx->send({json => {msg => 'Hello World!'}});
|
||||
});
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::UserAgent> is a full featured non-blocking I/O HTTP and WebSocket user agent, with IPv6, TLS, SNI, IDNA,
|
||||
HTTP/SOCKS5 proxy, UNIX domain socket, Comet (long polling), Promises/A+, keep-alive, connection pooling, timeout,
|
||||
cookie, multipart, gzip compression and multiple event loop support.
|
||||
|
||||
All connections will be reset automatically if a new process has been forked, this allows multiple processes to share
|
||||
the same L<Mojo::UserAgent> object safely.
|
||||
|
||||
For better scalability (epoll, kqueue) and to provide non-blocking name resolution, SOCKS5 as well as TLS support, the
|
||||
optional modules L<EV> (4.32+), L<Net::DNS::Native> (0.15+), L<IO::Socket::Socks> (0.64+) and L<IO::Socket::SSL>
|
||||
(2.009+) will be used automatically if possible. Individual features can also be disabled with the C<MOJO_NO_NNR>,
|
||||
C<MOJO_NO_SOCKS> and C<MOJO_NO_TLS> environment variables.
|
||||
|
||||
See L<Mojolicious::Guides::Cookbook/"USER AGENT"> for more.
|
||||
|
||||
=head1 EVENTS
|
||||
|
||||
L<Mojo::UserAgent> inherits all events from L<Mojo::EventEmitter> and can emit the following new ones.
|
||||
|
||||
=head2 prepare
|
||||
|
||||
$ua->on(prepare => sub ($ua, $tx) {...});
|
||||
|
||||
Emitted whenever a new transaction is being prepared, before relative URLs are rewritten and cookies added. This
|
||||
includes automatically prepared proxy C<CONNECT> requests and followed redirects.
|
||||
|
||||
$ua->on(prepare => sub ($ua, $tx) {
|
||||
$tx->req->url(Mojo::URL->new('/mock-mojolicious')) if $tx->req->url->host eq 'mojolicious.org';
|
||||
});
|
||||
|
||||
=head2 start
|
||||
|
||||
$ua->on(start => sub ($ua, $tx) {...});
|
||||
|
||||
Emitted whenever a new transaction is about to start. This includes automatically prepared proxy C<CONNECT> requests
|
||||
and followed redirects.
|
||||
|
||||
$ua->on(start => sub ($ua, $tx) {
|
||||
$tx->req->headers->header('X-Bender' => 'Bite my shiny metal ass!');
|
||||
});
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::UserAgent> implements the following attributes.
|
||||
|
||||
=head2 ca
|
||||
|
||||
my $ca = $ua->ca;
|
||||
$ua = $ua->ca('/etc/tls/ca.crt');
|
||||
|
||||
Path to TLS certificate authority file used to verify the peer certificate, defaults to the value of the
|
||||
C<MOJO_CA_FILE> environment variable.
|
||||
|
||||
# Show certificate authorities for debugging
|
||||
IO::Socket::SSL::set_defaults(SSL_verify_callback => sub { say "Authority: $_[2]" and return $_[0] });
|
||||
|
||||
=head2 cert
|
||||
|
||||
my $cert = $ua->cert;
|
||||
$ua = $ua->cert('/etc/tls/client.crt');
|
||||
|
||||
Path to TLS certificate file, defaults to the value of the C<MOJO_CERT_FILE> environment variable.
|
||||
|
||||
=head2 connect_timeout
|
||||
|
||||
my $timeout = $ua->connect_timeout;
|
||||
$ua = $ua->connect_timeout(5);
|
||||
|
||||
Maximum amount of time in seconds establishing a connection may take before getting canceled, defaults to the value of
|
||||
the C<MOJO_CONNECT_TIMEOUT> environment variable or C<10>.
|
||||
|
||||
=head2 cookie_jar
|
||||
|
||||
my $cookie_jar = $ua->cookie_jar;
|
||||
$ua = $ua->cookie_jar(Mojo::UserAgent::CookieJar->new);
|
||||
|
||||
Cookie jar to use for requests performed by this user agent, defaults to a L<Mojo::UserAgent::CookieJar> object.
|
||||
|
||||
# Ignore all cookies
|
||||
$ua->cookie_jar->ignore(sub { 1 });
|
||||
|
||||
# Ignore cookies for public suffixes
|
||||
my $ps = IO::Socket::SSL::PublicSuffix->default;
|
||||
$ua->cookie_jar->ignore(sub ($cookie) {
|
||||
return undef unless my $domain = $cookie->domain;
|
||||
return ($ps->public_suffix($domain))[0] eq '';
|
||||
});
|
||||
|
||||
# Add custom cookie to the jar
|
||||
$ua->cookie_jar->add(
|
||||
Mojo::Cookie::Response->new(
|
||||
name => 'foo',
|
||||
value => 'bar',
|
||||
domain => 'docs.mojolicious.org',
|
||||
path => '/Mojolicious'
|
||||
)
|
||||
);
|
||||
|
||||
=head2 inactivity_timeout
|
||||
|
||||
my $timeout = $ua->inactivity_timeout;
|
||||
$ua = $ua->inactivity_timeout(15);
|
||||
|
||||
Maximum amount of time in seconds a connection can be inactive before getting closed, defaults to the value of the
|
||||
C<MOJO_INACTIVITY_TIMEOUT> environment variable or C<40>. Setting the value to C<0> will allow connections to be
|
||||
inactive indefinitely.
|
||||
|
||||
=head2 insecure
|
||||
|
||||
my $bool = $ua->insecure;
|
||||
$ua = $ua->insecure($bool);
|
||||
|
||||
Do not require a valid TLS certificate to access HTTPS/WSS sites, defaults to the value of the C<MOJO_INSECURE>
|
||||
environment variable.
|
||||
|
||||
# Disable TLS certificate verification for testing
|
||||
say $ua->insecure(1)->get('https://127.0.0.1:3000')->result->code;
|
||||
|
||||
=head2 ioloop
|
||||
|
||||
my $loop = $ua->ioloop;
|
||||
$ua = $ua->ioloop(Mojo::IOLoop->new);
|
||||
|
||||
Event loop object to use for blocking I/O operations, defaults to a L<Mojo::IOLoop> object.
|
||||
|
||||
=head2 key
|
||||
|
||||
my $key = $ua->key;
|
||||
$ua = $ua->key('/etc/tls/client.crt');
|
||||
|
||||
Path to TLS key file, defaults to the value of the C<MOJO_KEY_FILE> environment variable.
|
||||
|
||||
=head2 local_address
|
||||
|
||||
my $address = $ua->local_address;
|
||||
$ua = $ua->local_address('127.0.0.1');
|
||||
|
||||
Local address to bind to.
|
||||
|
||||
=head2 max_connections
|
||||
|
||||
my $max = $ua->max_connections;
|
||||
$ua = $ua->max_connections(5);
|
||||
|
||||
Maximum number of keep-alive connections that the user agent will retain before it starts closing the oldest ones,
|
||||
defaults to C<5>. Setting the value to C<0> will prevent any connections from being kept alive.
|
||||
|
||||
=head2 max_redirects
|
||||
|
||||
my $max = $ua->max_redirects;
|
||||
$ua = $ua->max_redirects(3);
|
||||
|
||||
Maximum number of redirects the user agent will follow before it fails, defaults to the value of the
|
||||
C<MOJO_MAX_REDIRECTS> environment variable or C<0>.
|
||||
|
||||
=head2 max_response_size
|
||||
|
||||
my $max = $ua->max_response_size;
|
||||
$ua = $ua->max_response_size(16777216);
|
||||
|
||||
Maximum response size in bytes, defaults to the value of L<Mojo::Message::Response/"max_message_size">. Setting the
|
||||
value to C<0> will allow responses of indefinite size. Note that increasing this value can also drastically increase
|
||||
memory usage, should you for example attempt to parse an excessively large response body with the methods
|
||||
L<Mojo::Message/"dom"> or L<Mojo::Message/"json">.
|
||||
|
||||
=head2 proxy
|
||||
|
||||
my $proxy = $ua->proxy;
|
||||
$ua = $ua->proxy(Mojo::UserAgent::Proxy->new);
|
||||
|
||||
Proxy manager, defaults to a L<Mojo::UserAgent::Proxy> object.
|
||||
|
||||
# Detect proxy servers from environment
|
||||
$ua->proxy->detect;
|
||||
|
||||
# Manually configure HTTP proxy (using CONNECT for HTTPS/WebSockets)
|
||||
$ua->proxy->http('http://127.0.0.1:8080')->https('http://127.0.0.1:8080');
|
||||
|
||||
# Manually configure Tor (SOCKS5)
|
||||
$ua->proxy->http('socks://127.0.0.1:9050')->https('socks://127.0.0.1:9050');
|
||||
|
||||
# Manually configure UNIX domain socket (using CONNECT for HTTPS/WebSockets)
|
||||
$ua->proxy->http('http+unix://%2Ftmp%2Fproxy.sock') ->https('http+unix://%2Ftmp%2Fproxy.sock');
|
||||
|
||||
=head2 request_timeout
|
||||
|
||||
my $timeout = $ua->request_timeout;
|
||||
$ua = $ua->request_timeout(5);
|
||||
|
||||
Maximum amount of time in seconds establishing a connection, sending the request and receiving a whole response may
|
||||
take before getting canceled, defaults to the value of the C<MOJO_REQUEST_TIMEOUT> environment variable or C<0>.
|
||||
Setting the value to C<0> will allow the user agent to wait indefinitely. The timeout will reset for every followed
|
||||
redirect.
|
||||
|
||||
# Total limit of 5 seconds, of which 3 seconds may be spent connecting
|
||||
$ua->max_redirects(0)->connect_timeout(3)->request_timeout(5);
|
||||
|
||||
=head2 server
|
||||
|
||||
my $server = $ua->server;
|
||||
$ua = $ua->server(Mojo::UserAgent::Server->new);
|
||||
|
||||
Application server relative URLs will be processed with, defaults to a L<Mojo::UserAgent::Server> object.
|
||||
|
||||
# Mock web service
|
||||
$ua->server->app(Mojolicious->new);
|
||||
$ua->server->app->routes->get('/time' => sub ($c) {
|
||||
$c->render(json => {now => time});
|
||||
});
|
||||
my $time = $ua->get('/time')->result->json->{now};
|
||||
|
||||
# Change log level
|
||||
$ua->server->app->log->level('fatal');
|
||||
|
||||
# Port currently used for processing relative URLs blocking
|
||||
say $ua->server->url->port;
|
||||
|
||||
# Port currently used for processing relative URLs non-blocking
|
||||
say $ua->server->nb_url->port;
|
||||
|
||||
=head2 transactor
|
||||
|
||||
my $t = $ua->transactor;
|
||||
$ua = $ua->transactor(Mojo::UserAgent::Transactor->new);
|
||||
|
||||
Transaction builder, defaults to a L<Mojo::UserAgent::Transactor> object.
|
||||
|
||||
# Change name of user agent
|
||||
$ua->transactor->name('MyUA 1.0');
|
||||
|
||||
# Disable compression
|
||||
$ua->transactor->compressed(0);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::UserAgent> inherits all methods from L<Mojo::EventEmitter> and implements the following new ones.
|
||||
|
||||
=head2 build_tx
|
||||
|
||||
my $tx = $ua->build_tx(GET => 'example.com');
|
||||
my $tx = $ua->build_tx(PUT => 'http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->build_tx(PUT => 'http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->build_tx(PUT => 'http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Generate L<Mojo::Transaction::HTTP> object with L<Mojo::UserAgent::Transactor/"tx">.
|
||||
|
||||
# Request with custom cookie
|
||||
my $tx = $ua->build_tx(GET => 'https://example.com/account');
|
||||
$tx->req->cookies({name => 'user', value => 'sri'});
|
||||
$tx = $ua->start($tx);
|
||||
|
||||
# Deactivate gzip compression
|
||||
my $tx = $ua->build_tx(GET => 'example.com');
|
||||
$tx->req->headers->remove('Accept-Encoding');
|
||||
$tx = $ua->start($tx);
|
||||
|
||||
# Interrupt response by raising an error
|
||||
my $tx = $ua->build_tx(GET => 'http://example.com');
|
||||
$tx->res->on(progress => sub ($res) {
|
||||
return unless my $server = $res->headers->server;
|
||||
$res->error({message => 'Oh noes, it is IIS!'}) if $server =~ /IIS/;
|
||||
});
|
||||
$tx = $ua->start($tx);
|
||||
|
||||
=head2 build_websocket_tx
|
||||
|
||||
my $tx = $ua->build_websocket_tx('ws://example.com');
|
||||
my $tx = $ua->build_websocket_tx( 'ws://example.com' => {DNT => 1} => ['v1.proto']);
|
||||
|
||||
Generate L<Mojo::Transaction::HTTP> object with L<Mojo::UserAgent::Transactor/"websocket">.
|
||||
|
||||
# Custom WebSocket handshake with cookie
|
||||
my $tx = $ua->build_websocket_tx('wss://example.com/echo');
|
||||
$tx->req->cookies({name => 'user', value => 'sri'});
|
||||
$ua->start($tx => sub ($ua, $tx) {
|
||||
say 'WebSocket handshake failed!' and return unless $tx->is_websocket;
|
||||
$tx->on(message => sub ($tx, $msg) {
|
||||
say "WebSocket message: $msg";
|
||||
$tx->finish;
|
||||
});
|
||||
$tx->send('Hi!');
|
||||
});
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 delete
|
||||
|
||||
my $tx = $ua->delete('example.com');
|
||||
my $tx = $ua->delete('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->delete('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->delete('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<DELETE> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<DELETE> method, which is implied). You can also append a callback
|
||||
to perform requests non-blocking.
|
||||
|
||||
$ua->delete('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 delete_p
|
||||
|
||||
my $promise = $ua->delete_p('http://example.com');
|
||||
|
||||
Same as L</"delete">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting
|
||||
a callback.
|
||||
|
||||
$ua->delete_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 get
|
||||
|
||||
my $tx = $ua->get('example.com');
|
||||
my $tx = $ua->get('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->get('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->get('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<GET> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<GET> method, which is implied). You can also append a callback to
|
||||
perform requests non-blocking.
|
||||
|
||||
$ua->get('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 get_p
|
||||
|
||||
my $promise = $ua->get_p('http://example.com');
|
||||
|
||||
Same as L</"get">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting a
|
||||
callback.
|
||||
|
||||
$ua->get_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 head
|
||||
|
||||
my $tx = $ua->head('example.com');
|
||||
my $tx = $ua->head('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->head('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->head('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<HEAD> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<HEAD> method, which is implied). You can also append a callback
|
||||
to perform requests non-blocking.
|
||||
|
||||
$ua->head('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 head_p
|
||||
|
||||
my $promise = $ua->head_p('http://example.com');
|
||||
|
||||
Same as L</"head">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting a
|
||||
callback.
|
||||
|
||||
$ua->head_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 options
|
||||
|
||||
my $tx = $ua->options('example.com');
|
||||
my $tx = $ua->options('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->options('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->options('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<OPTIONS> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<OPTIONS> method, which is implied). You can also append a
|
||||
callback to perform requests non-blocking.
|
||||
|
||||
$ua->options('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 options_p
|
||||
|
||||
my $promise = $ua->options_p('http://example.com');
|
||||
|
||||
Same as L</"options">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of
|
||||
accepting a callback.
|
||||
|
||||
$ua->options_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 patch
|
||||
|
||||
my $tx = $ua->patch('example.com');
|
||||
my $tx = $ua->patch('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->patch('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->patch('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<PATCH> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<PATCH> method, which is implied). You can also append a callback
|
||||
to perform requests non-blocking.
|
||||
|
||||
$ua->patch('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 patch_p
|
||||
|
||||
my $promise = $ua->patch_p('http://example.com');
|
||||
|
||||
Same as L</"patch">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting
|
||||
a callback.
|
||||
|
||||
$ua->patch_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 post
|
||||
|
||||
my $tx = $ua->post('example.com');
|
||||
my $tx = $ua->post('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->post('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->post('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<POST> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<POST> method, which is implied). You can also append a callback
|
||||
to perform requests non-blocking.
|
||||
|
||||
$ua->post('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 post_p
|
||||
|
||||
my $promise = $ua->post_p('http://example.com');
|
||||
|
||||
Same as L</"post">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting a
|
||||
callback.
|
||||
|
||||
$ua->post_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 put
|
||||
|
||||
my $tx = $ua->put('example.com');
|
||||
my $tx = $ua->put('http://example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $ua->put('http://example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $ua->put('http://example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
|
||||
Perform blocking C<PUT> request and return resulting L<Mojo::Transaction::HTTP> object, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"tx"> (except for the C<PUT> method, which is implied). You can also append a callback to
|
||||
perform requests non-blocking.
|
||||
|
||||
$ua->put('http://example.com' => json => {a => 'b'} => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 put_p
|
||||
|
||||
my $promise = $ua->put_p('http://example.com');
|
||||
|
||||
Same as L</"put">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting a
|
||||
callback.
|
||||
|
||||
$ua->put_p('http://example.com' => json => {a => 'b'})->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 start
|
||||
|
||||
my $tx = $ua->start(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Perform blocking request for a custom L<Mojo::Transaction::HTTP> object, which can be prepared manually or with
|
||||
L</"build_tx">. You can also append a callback to perform requests non-blocking.
|
||||
|
||||
my $tx = $ua->build_tx(GET => 'http://example.com');
|
||||
$ua->start($tx => sub ($ua, $tx) { say $tx->result->body });
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
=head2 start_p
|
||||
|
||||
my $promise = $ua->start_p(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Same as L</"start">, but performs all requests non-blocking and returns a L<Mojo::Promise> object instead of accepting
|
||||
a callback.
|
||||
|
||||
my $tx = $ua->build_tx(GET => 'http://example.com');
|
||||
$ua->start_p($tx)->then(sub ($tx) {
|
||||
say $tx->result->body;
|
||||
})->catch(sub ($err) {
|
||||
warn "Connection error: $err";
|
||||
})->wait;
|
||||
|
||||
=head2 websocket
|
||||
|
||||
$ua->websocket('ws://example.com' => sub {...});
|
||||
$ua->websocket('ws://example.com' => {DNT => 1} => ['v1.proto'] => sub {...});
|
||||
|
||||
Open a non-blocking WebSocket connection with transparent handshake, takes the same arguments as
|
||||
L<Mojo::UserAgent::Transactor/"websocket">. The callback will receive either a L<Mojo::Transaction::WebSocket> or
|
||||
L<Mojo::Transaction::HTTP> object, depending on if the handshake was successful.
|
||||
|
||||
$ua->websocket('wss://example.com/echo' => ['v1.proto'] => sub ($ua, $tx) {
|
||||
say 'WebSocket handshake failed!' and return unless $tx->is_websocket;
|
||||
say 'Subprotocol negotiation failed!' and return unless $tx->protocol;
|
||||
$tx->on(finish => sub ($tx, $code, $reason) { say "WebSocket closed with status $code." });
|
||||
$tx->on(message => sub ($tx, $msg) {
|
||||
say "WebSocket message: $msg";
|
||||
$tx->finish;
|
||||
});
|
||||
$tx->send('Hi!');
|
||||
});
|
||||
Mojo::IOLoop->start unless Mojo::IOLoop->is_running;
|
||||
|
||||
You can activate C<permessage-deflate> compression by setting the C<Sec-WebSocket-Extensions> header, this can result
|
||||
in much better performance, but also increases memory usage by up to 300KiB per connection.
|
||||
|
||||
$ua->websocket('ws://example.com/foo' => {
|
||||
'Sec-WebSocket-Extensions' => 'permessage-deflate'
|
||||
} => sub {...});
|
||||
|
||||
=head2 websocket_p
|
||||
|
||||
my $promise = $ua->websocket_p('ws://example.com');
|
||||
|
||||
Same as L</"websocket">, but returns a L<Mojo::Promise> object instead of accepting a callback.
|
||||
|
||||
$ua->websocket_p('wss://example.com/echo')->then(sub ($tx) {
|
||||
my $promise = Mojo::Promise->new;
|
||||
$tx->on(finish => sub { $promise->resolve });
|
||||
$tx->on(message => sub ($tx, $msg) {
|
||||
say "WebSocket message: $msg";
|
||||
$tx->finish;
|
||||
});
|
||||
$tx->send('Hi!');
|
||||
return $promise;
|
||||
})->catch(sub ($err) {
|
||||
warn "WebSocket error: $err";
|
||||
})->wait;
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_CLIENT_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_CLIENT_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
221
database/perl/vendor/lib/Mojo/UserAgent/CookieJar.pm
vendored
Normal file
221
database/perl/vendor/lib/Mojo/UserAgent/CookieJar.pm
vendored
Normal file
@@ -0,0 +1,221 @@
|
||||
package Mojo::UserAgent::CookieJar;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Mojo::Cookie::Request;
|
||||
use Mojo::Path;
|
||||
use Scalar::Util qw(looks_like_number);
|
||||
|
||||
has 'ignore';
|
||||
has max_cookie_size => 4096;
|
||||
|
||||
sub add {
|
||||
my ($self, @cookies) = @_;
|
||||
|
||||
my $size = $self->max_cookie_size;
|
||||
for my $cookie (@cookies) {
|
||||
|
||||
# Convert max age to expires
|
||||
my $age = $cookie->max_age;
|
||||
$cookie->expires($age <= 0 ? 0 : $age + time) if looks_like_number $age;
|
||||
|
||||
# Check cookie size
|
||||
next if length($cookie->value // '') > $size;
|
||||
|
||||
# Replace cookie
|
||||
next unless my $domain = lc($cookie->domain // '');
|
||||
next unless my $path = $cookie->path;
|
||||
next unless length(my $name = $cookie->name // '');
|
||||
my $jar = $self->{jar}{$domain} //= [];
|
||||
@$jar = (grep({ _compare($_, $path, $name, $domain) } @$jar), $cookie);
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub all {
|
||||
my $jar = shift->{jar};
|
||||
return [map { @{$jar->{$_}} } sort keys %$jar];
|
||||
}
|
||||
|
||||
sub collect {
|
||||
my ($self, $tx) = @_;
|
||||
|
||||
my $url = $tx->req->url;
|
||||
for my $cookie (@{$tx->res->cookies}) {
|
||||
|
||||
# Validate domain
|
||||
my $host = lc $url->ihost;
|
||||
$cookie->domain($host)->host_only(1) unless $cookie->domain;
|
||||
my $domain = lc $cookie->domain;
|
||||
if (my $cb = $self->ignore) { next if $cb->($cookie) }
|
||||
next if $host ne $domain && ($host !~ /\Q.$domain\E$/ || $host =~ /\.\d+$/);
|
||||
|
||||
# Validate path
|
||||
my $path = $cookie->path // $url->path->to_dir->to_abs_string;
|
||||
$path = Mojo::Path->new($path)->trailing_slash(0)->to_abs_string;
|
||||
next unless _path($path, $url->path->to_abs_string);
|
||||
$self->add($cookie->path($path));
|
||||
}
|
||||
}
|
||||
|
||||
sub empty { delete shift->{jar} }
|
||||
|
||||
sub find {
|
||||
my ($self, $url) = @_;
|
||||
|
||||
my @found;
|
||||
my $domain = my $host = lc $url->ihost;
|
||||
my $path = $url->path->to_abs_string;
|
||||
while ($domain) {
|
||||
next unless my $old = $self->{jar}{$domain};
|
||||
|
||||
# Grab cookies
|
||||
my $new = $self->{jar}{$domain} = [];
|
||||
for my $cookie (@$old) {
|
||||
next if $cookie->host_only && $host ne $cookie->domain;
|
||||
|
||||
# Check if cookie has expired
|
||||
if (defined(my $expires = $cookie->expires)) { next if time > $expires }
|
||||
push @$new, $cookie;
|
||||
|
||||
# Taste cookie
|
||||
next if $cookie->secure && $url->protocol ne 'https';
|
||||
next unless _path($cookie->path, $path);
|
||||
my $name = $cookie->name;
|
||||
my $value = $cookie->value;
|
||||
push @found, Mojo::Cookie::Request->new(name => $name, value => $value);
|
||||
}
|
||||
}
|
||||
|
||||
# Remove another part
|
||||
continue { $domain =~ s/^[^.]*\.*// }
|
||||
|
||||
return \@found;
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
my ($self, $tx) = @_;
|
||||
return unless keys %{$self->{jar}};
|
||||
my $req = $tx->req;
|
||||
$req->cookies(@{$self->find($req->url)});
|
||||
}
|
||||
|
||||
sub _compare {
|
||||
my ($cookie, $path, $name, $domain) = @_;
|
||||
return $cookie->path ne $path || $cookie->name ne $name || $cookie->domain ne $domain;
|
||||
}
|
||||
|
||||
sub _path { $_[0] eq '/' || $_[0] eq $_[1] || index($_[1], "$_[0]/") == 0 }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::UserAgent::CookieJar - Cookie jar for HTTP user agents
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::UserAgent::CookieJar;
|
||||
|
||||
# Add response cookies
|
||||
my $jar = Mojo::UserAgent::CookieJar->new;
|
||||
$jar->add(
|
||||
Mojo::Cookie::Response->new(
|
||||
name => 'foo',
|
||||
value => 'bar',
|
||||
domain => 'localhost',
|
||||
path => '/test'
|
||||
)
|
||||
);
|
||||
|
||||
# Find request cookies
|
||||
for my $cookie (@{$jar->find(Mojo::URL->new('http://localhost/test'))}) {
|
||||
say $cookie->name;
|
||||
say $cookie->value;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::UserAgent::CookieJar> is a minimalistic and relaxed cookie jar used by L<Mojo::UserAgent>, based on L<RFC
|
||||
6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::UserAgent::CookieJar> implements the following attributes.
|
||||
|
||||
=head2 ignore
|
||||
|
||||
my $ignore = $jar->ignore;
|
||||
$jar = $jar->ignore(sub {...});
|
||||
|
||||
A callback used to decide if a cookie should be ignored by L</"collect">.
|
||||
|
||||
# Ignore all cookies
|
||||
$jar->ignore(sub { 1 });
|
||||
|
||||
# Ignore cookies for domains "com", "net" and "org"
|
||||
$jar->ignore(sub ($cookie) {
|
||||
return undef unless my $domain = $cookie->domain;
|
||||
return $domain eq 'com' || $domain eq 'net' || $domain eq 'org';
|
||||
});
|
||||
|
||||
=head2 max_cookie_size
|
||||
|
||||
my $size = $jar->max_cookie_size;
|
||||
$jar = $jar->max_cookie_size(4096);
|
||||
|
||||
Maximum cookie size in bytes, defaults to C<4096> (4KiB).
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::UserAgent::CookieJar> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 add
|
||||
|
||||
$jar = $jar->add(@cookies);
|
||||
|
||||
Add multiple L<Mojo::Cookie::Response> objects to the jar.
|
||||
|
||||
=head2 all
|
||||
|
||||
my $cookies = $jar->all;
|
||||
|
||||
Return all L<Mojo::Cookie::Response> objects that are currently stored in the jar.
|
||||
|
||||
# Names of all cookies
|
||||
say $_->name for @{$jar->all};
|
||||
|
||||
=head2 collect
|
||||
|
||||
$jar->collect(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Collect response cookies from transaction.
|
||||
|
||||
=head2 empty
|
||||
|
||||
$jar->empty;
|
||||
|
||||
Empty the jar.
|
||||
|
||||
=head2 find
|
||||
|
||||
my $cookies = $jar->find(Mojo::URL->new);
|
||||
|
||||
Find L<Mojo::Cookie::Request> objects in the jar for L<Mojo::URL> object.
|
||||
|
||||
# Names of all cookies found
|
||||
say $_->name for @{$jar->find(Mojo::URL->new('http://example.com/foo'))};
|
||||
|
||||
=head2 prepare
|
||||
|
||||
$jar->prepare(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Prepare request cookies for transaction.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
109
database/perl/vendor/lib/Mojo/UserAgent/Proxy.pm
vendored
Normal file
109
database/perl/vendor/lib/Mojo/UserAgent/Proxy.pm
vendored
Normal file
@@ -0,0 +1,109 @@
|
||||
package Mojo::UserAgent::Proxy;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Mojo::URL;
|
||||
|
||||
has [qw(http https not)];
|
||||
|
||||
sub detect {
|
||||
my $self = shift;
|
||||
$self->http($ENV{HTTP_PROXY} || $ENV{http_proxy});
|
||||
$self->https($ENV{HTTPS_PROXY} || $ENV{https_proxy});
|
||||
return $self->not([split /,/, $ENV{NO_PROXY} || $ENV{no_proxy} || '']);
|
||||
}
|
||||
|
||||
sub is_needed {
|
||||
!grep { $_[1] =~ /\Q$_\E$/ } @{$_[0]->not // []};
|
||||
}
|
||||
|
||||
sub prepare {
|
||||
my ($self, $tx) = @_;
|
||||
|
||||
$self->detect if $ENV{MOJO_PROXY};
|
||||
my $req = $tx->req;
|
||||
my $url = $req->url;
|
||||
return unless $self->is_needed($url->host);
|
||||
|
||||
# HTTP proxy
|
||||
my $proto = $url->protocol;
|
||||
my $http = $self->http;
|
||||
$req->proxy(Mojo::URL->new($http)) if $http && $proto eq 'http';
|
||||
|
||||
# HTTPS proxy
|
||||
my $https = $self->https;
|
||||
$req->proxy(Mojo::URL->new($https)) if $https && $proto eq 'https';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::UserAgent::Proxy - User agent proxy manager
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::UserAgent::Proxy;
|
||||
|
||||
my $proxy = Mojo::UserAgent::Proxy->new;
|
||||
$proxy->detect;
|
||||
say $proxy->http;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::UserAgent::Proxy> manages proxy servers for L<Mojo::UserAgent>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::UserAgent::Proxy> implements the following attributes.
|
||||
|
||||
=head2 http
|
||||
|
||||
my $http = $proxy->http;
|
||||
$proxy = $proxy->http('socks://sri:secret@127.0.0.1:8080');
|
||||
|
||||
Proxy server to use for HTTP and WebSocket requests.
|
||||
|
||||
=head2 https
|
||||
|
||||
my $https = $proxy->https;
|
||||
$proxy = $proxy->https('http://sri:secret@127.0.0.1:8080');
|
||||
|
||||
Proxy server to use for HTTPS and WebSocket requests.
|
||||
|
||||
=head2 not
|
||||
|
||||
my $not = $proxy->not;
|
||||
$proxy = $proxy->not(['localhost', 'intranet.mojolicious.org']);
|
||||
|
||||
Domains that don't require a proxy server to be used.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::UserAgent::Proxy> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 detect
|
||||
|
||||
$proxy = $proxy->detect;
|
||||
|
||||
Check environment variables C<HTTP_PROXY>, C<http_proxy>, C<HTTPS_PROXY>, C<https_proxy>, C<NO_PROXY> and C<no_proxy>
|
||||
for proxy information. Automatic proxy detection can be enabled with the C<MOJO_PROXY> environment variable.
|
||||
|
||||
=head2 is_needed
|
||||
|
||||
my $bool = $proxy->is_needed('intranet.example.com');
|
||||
|
||||
Check if request for domain would use a proxy server.
|
||||
|
||||
=head2 prepare
|
||||
|
||||
$proxy->prepare(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Prepare proxy server information for transaction.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
127
database/perl/vendor/lib/Mojo/UserAgent/Server.pm
vendored
Normal file
127
database/perl/vendor/lib/Mojo/UserAgent/Server.pm
vendored
Normal file
@@ -0,0 +1,127 @@
|
||||
package Mojo::UserAgent::Server;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Mojo::IOLoop;
|
||||
use Mojo::Server::Daemon;
|
||||
use Scalar::Util qw(weaken);
|
||||
|
||||
has ioloop => sub { Mojo::IOLoop->singleton };
|
||||
|
||||
sub app {
|
||||
my ($self, $app) = @_;
|
||||
|
||||
# Singleton application
|
||||
state $singleton;
|
||||
return $singleton = $app ? $app : $singleton unless ref $self;
|
||||
|
||||
# Default to singleton application
|
||||
return $self->{app} || $singleton unless $app;
|
||||
$self->{app} = $app;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub nb_url { shift->_url(1, @_) }
|
||||
|
||||
sub restart { delete @{$_[0]}{qw(nb_port nb_server port server)} }
|
||||
|
||||
sub url { shift->_url(0, @_) }
|
||||
|
||||
sub _url {
|
||||
my ($self, $nb, $proto) = @_;
|
||||
|
||||
if (!$self->{server} || $proto) {
|
||||
$proto = $self->{proto} = $proto || 'http';
|
||||
|
||||
# Blocking
|
||||
my $server = $self->{server} = Mojo::Server::Daemon->new(ioloop => $self->ioloop, silent => 1);
|
||||
weaken $server->app($self->app)->{app};
|
||||
my $port = $self->{port} ? ":$self->{port}" : '';
|
||||
$self->{port} = $server->listen(["$proto://127.0.0.1$port"])->start->ports->[0];
|
||||
|
||||
# Non-blocking
|
||||
$server = $self->{nb_server} = Mojo::Server::Daemon->new(silent => 1);
|
||||
weaken $server->app($self->app)->{app};
|
||||
$port = $self->{nb_port} ? ":$self->{nb_port}" : '';
|
||||
$self->{nb_port} = $server->listen(["$proto://127.0.0.1$port"])->start->ports->[0];
|
||||
}
|
||||
|
||||
my $port = $nb ? $self->{nb_port} : $self->{port};
|
||||
return Mojo::URL->new("$self->{proto}://127.0.0.1:$port/");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::UserAgent::Server - Application server
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::UserAgent::Server;
|
||||
|
||||
my $server = Mojo::UserAgent::Server->new;
|
||||
say $server->url;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::UserAgent::Server> is an embedded web server based on L<Mojo::Server::Daemon> that processes requests for
|
||||
L<Mojo::UserAgent>.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::UserAgent::Server> implements the following attributes.
|
||||
|
||||
=head2 ioloop
|
||||
|
||||
my $loop = $server->ioloop;
|
||||
$server = $server->ioloop(Mojo::IOLoop->new);
|
||||
|
||||
Event loop object to use for I/O operations, defaults to the global L<Mojo::IOLoop> singleton.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::UserAgent::Server> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 app
|
||||
|
||||
my $app = Mojo::UserAgent::Server->app;
|
||||
Mojo::UserAgent::Server->app(Mojolicious->new);
|
||||
my $app = $server->app;
|
||||
$server = $server->app(Mojolicious->new);
|
||||
|
||||
Application this server handles, instance specific applications override the global default.
|
||||
|
||||
# Change application behavior
|
||||
$server->app->defaults(testing => 'oh yea!');
|
||||
|
||||
=head2 nb_url
|
||||
|
||||
my $url = $server->nb_url;
|
||||
my $url = $server->nb_url('http');
|
||||
my $url = $server->nb_url('https');
|
||||
|
||||
Get absolute L<Mojo::URL> object for server processing non-blocking requests with L</"app"> and switch protocol if
|
||||
necessary.
|
||||
|
||||
=head2 restart
|
||||
|
||||
$server->restart;
|
||||
|
||||
Restart server with new port.
|
||||
|
||||
=head2 url
|
||||
|
||||
my $url = $server->url;
|
||||
my $url = $server->url('http');
|
||||
my $url = $server->url('https');
|
||||
|
||||
Get absolute L<Mojo::URL> object for server processing blocking requests with L</"app"> and switch protocol if
|
||||
necessary.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
544
database/perl/vendor/lib/Mojo/UserAgent/Transactor.pm
vendored
Normal file
544
database/perl/vendor/lib/Mojo/UserAgent/Transactor.pm
vendored
Normal file
@@ -0,0 +1,544 @@
|
||||
package Mojo::UserAgent::Transactor;
|
||||
use Mojo::Base -base;
|
||||
|
||||
use Mojo::Asset::File;
|
||||
use Mojo::Asset::Memory;
|
||||
use Mojo::Content::MultiPart;
|
||||
use Mojo::Content::Single;
|
||||
use Mojo::File qw(path);
|
||||
use Mojo::JSON qw(encode_json);
|
||||
use Mojo::Parameters;
|
||||
use Mojo::Transaction::HTTP;
|
||||
use Mojo::Transaction::WebSocket;
|
||||
use Mojo::URL;
|
||||
use Mojo::Util qw(encode url_escape);
|
||||
use Mojo::WebSocket qw(challenge client_handshake);
|
||||
|
||||
has compressed => sub { $ENV{MOJO_GZIP} // 1 };
|
||||
has generators => sub { {form => \&_form, json => \&_json, multipart => \&_multipart} };
|
||||
has name => 'Mojolicious (Perl)';
|
||||
|
||||
sub add_generator { $_[0]->generators->{$_[1]} = $_[2] and return $_[0] }
|
||||
|
||||
sub endpoint {
|
||||
my ($self, $tx) = @_;
|
||||
|
||||
# Basic endpoint
|
||||
my $req = $tx->req;
|
||||
my $url = $req->url;
|
||||
my $proto = $url->protocol || 'http';
|
||||
my $host = $url->ihost;
|
||||
my $port = $url->port // ($proto eq 'https' ? 443 : 80);
|
||||
|
||||
# Proxy for normal HTTP requests
|
||||
my $socks;
|
||||
if (my $proxy = $req->proxy) { $socks = $proxy->protocol eq 'socks' }
|
||||
return _proxy($tx, $proto, $host, $port) if $proto eq 'http' && !$req->is_handshake && !$socks;
|
||||
|
||||
return $proto, $host, $port;
|
||||
}
|
||||
|
||||
sub peer { _proxy($_[1], $_[0]->endpoint($_[1])) }
|
||||
|
||||
sub promisify {
|
||||
my ($self, $promise, $tx) = @_;
|
||||
my $err = $tx->error;
|
||||
return $promise->reject($err->{message}) if $err && !$err->{code};
|
||||
return $promise->reject('WebSocket handshake failed') if $tx->req->is_handshake && !$tx->is_websocket;
|
||||
$promise->resolve($tx);
|
||||
}
|
||||
|
||||
sub proxy_connect {
|
||||
my ($self, $old) = @_;
|
||||
|
||||
# Already a CONNECT request
|
||||
my $req = $old->req;
|
||||
return undef if uc $req->method eq 'CONNECT';
|
||||
|
||||
# No proxy
|
||||
return undef unless (my $proxy = $req->proxy) && $req->via_proxy;
|
||||
return undef if $proxy->protocol eq 'socks';
|
||||
|
||||
# WebSocket and/or HTTPS
|
||||
my $url = $req->url;
|
||||
return undef unless $req->is_handshake || $url->protocol eq 'https';
|
||||
|
||||
# CONNECT request (expect a bad response)
|
||||
my $new = $self->tx(CONNECT => $url->clone->userinfo(undef));
|
||||
$new->req->proxy($proxy);
|
||||
$new->res->content->auto_relax(0)->headers->connection('keep-alive');
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub redirect {
|
||||
my ($self, $old) = @_;
|
||||
|
||||
# Commonly used codes
|
||||
my $res = $old->res;
|
||||
my $code = $res->code // 0;
|
||||
return undef unless grep { $_ == $code } 301, 302, 303, 307, 308;
|
||||
|
||||
# CONNECT requests cannot be redirected
|
||||
my $req = $old->req;
|
||||
return undef if uc $req->method eq 'CONNECT';
|
||||
|
||||
# Fix location without authority and/or scheme
|
||||
return undef unless my $location = $res->headers->every_header('Location')->[0];
|
||||
$location = Mojo::URL->new($location);
|
||||
$location = $location->base($req->url)->to_abs unless $location->is_abs;
|
||||
my $proto = $location->protocol;
|
||||
return undef if ($proto ne 'http' && $proto ne 'https') || !$location->host;
|
||||
|
||||
# Clone request if necessary
|
||||
my $new = Mojo::Transaction::HTTP->new;
|
||||
if ($code == 307 || $code == 308) {
|
||||
return undef unless my $clone = $req->clone;
|
||||
$new->req($clone);
|
||||
}
|
||||
else {
|
||||
my $method = uc $req->method;
|
||||
$method = $code == 303 || $method eq 'POST' ? 'GET' : $method;
|
||||
$new->req->method($method)->content->headers(my $headers = $req->headers->clone);
|
||||
$headers->remove($_) for grep {/^content-/i} @{$headers->names};
|
||||
}
|
||||
|
||||
$new->res->content->auto_decompress(0) unless $self->compressed;
|
||||
my $headers = $new->req->url($location)->headers;
|
||||
$headers->remove($_) for qw(Authorization Cookie Host Referer);
|
||||
|
||||
return $new->previous($old);
|
||||
}
|
||||
|
||||
sub tx {
|
||||
my ($self, $method, $url) = (shift, shift, shift);
|
||||
|
||||
# Method and URL
|
||||
my $tx = Mojo::Transaction::HTTP->new;
|
||||
my $req = $tx->req->method($method);
|
||||
ref $url ? $req->url($url) : $req->url->parse($url =~ m!^/|://! ? $url : "http://$url");
|
||||
|
||||
# Headers (we identify ourselves and accept gzip compression)
|
||||
my $headers = $req->headers;
|
||||
$headers->from_hash(shift) if ref $_[0] eq 'HASH';
|
||||
$headers->user_agent($self->name) unless $headers->user_agent;
|
||||
if (!$self->compressed) { $tx->res->content->auto_decompress(0) }
|
||||
elsif (!$headers->accept_encoding) { $headers->accept_encoding('gzip') }
|
||||
|
||||
# Generator
|
||||
if (@_ > 1) {
|
||||
my $cb = $self->generators->{shift()};
|
||||
$self->$cb($tx, @_);
|
||||
}
|
||||
|
||||
# Body
|
||||
elsif (@_) { $req->body(shift) }
|
||||
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub upgrade {
|
||||
my ($self, $tx) = @_;
|
||||
my $code = $tx->res->code // 0;
|
||||
return undef unless $tx->req->is_handshake && $code == 101;
|
||||
my $ws = Mojo::Transaction::WebSocket->new(handshake => $tx, masked => 1);
|
||||
return challenge($ws) ? $ws->established(1) : undef;
|
||||
}
|
||||
|
||||
sub websocket {
|
||||
my $self = shift;
|
||||
|
||||
# New WebSocket transaction
|
||||
my $sub = ref $_[-1] eq 'ARRAY' ? pop : [];
|
||||
my $tx = $self->tx(GET => @_);
|
||||
my $req = $tx->req;
|
||||
$req->headers->sec_websocket_protocol(join ', ', @$sub) if @$sub;
|
||||
|
||||
# Handshake protocol
|
||||
my $url = $req->url;
|
||||
my $proto = $url->protocol // '';
|
||||
if ($proto eq 'ws') { $url->scheme('http') }
|
||||
elsif ($proto eq 'wss') { $url->scheme('https') }
|
||||
elsif ($proto eq 'ws+unix') { $url->scheme('http+unix') }
|
||||
|
||||
return client_handshake $tx;
|
||||
}
|
||||
|
||||
sub _content { Mojo::Content::MultiPart->new(headers => $_[0], parts => $_[1]) }
|
||||
|
||||
sub _form {
|
||||
my ($self, $tx, $form, %options) = @_;
|
||||
$options{charset} = 'UTF-8' unless exists $options{charset};
|
||||
|
||||
# Check for uploads and force multipart if necessary
|
||||
my $req = $tx->req;
|
||||
my $headers = $req->headers;
|
||||
my $multipart = ($headers->content_type // '') =~ m!multipart/form-data!i;
|
||||
for my $value (map { ref $_ eq 'ARRAY' ? @$_ : $_ } values %$form) {
|
||||
++$multipart and last if ref $value eq 'HASH';
|
||||
}
|
||||
|
||||
# Multipart
|
||||
if ($multipart) {
|
||||
$req->content(_content($headers, _form_parts($options{charset}, $form)));
|
||||
_type($headers, 'multipart/form-data');
|
||||
return $tx;
|
||||
}
|
||||
|
||||
# Query parameters or urlencoded
|
||||
my $method = uc $req->method;
|
||||
my @form = map { $_ => $form->{$_} } sort keys %$form;
|
||||
if ($method eq 'GET' || $method eq 'HEAD') { $req->url->query->merge(@form) }
|
||||
else {
|
||||
$req->body(Mojo::Parameters->new(@form)->charset($options{charset})->to_string);
|
||||
_type($headers, 'application/x-www-form-urlencoded');
|
||||
}
|
||||
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub _form_parts {
|
||||
my ($charset, $form) = @_;
|
||||
|
||||
my @parts;
|
||||
for my $name (sort keys %$form) {
|
||||
next unless defined(my $values = $form->{$name});
|
||||
$values = [$values] unless ref $values eq 'ARRAY';
|
||||
push @parts, @{_parts($charset, $name, $values)};
|
||||
}
|
||||
|
||||
return \@parts;
|
||||
}
|
||||
|
||||
sub _json {
|
||||
my ($self, $tx, $data) = @_;
|
||||
_type($tx->req->body(encode_json $data)->headers, 'application/json');
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub _multipart {
|
||||
my ($self, $tx, $parts) = @_;
|
||||
my $req = $tx->req;
|
||||
$req->content(_content($req->headers, _parts(undef, undef, $parts)));
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub _parts {
|
||||
my ($charset, $name, $values) = @_;
|
||||
|
||||
my @parts;
|
||||
for my $value (@$values) {
|
||||
push @parts, my $part = Mojo::Content::Single->new;
|
||||
|
||||
my $filename;
|
||||
my $headers = $part->headers;
|
||||
if (ref $value eq 'HASH') {
|
||||
|
||||
# File
|
||||
if (my $file = delete $value->{file}) {
|
||||
$file = Mojo::Asset::File->new(path => $file) unless ref $file;
|
||||
$part->asset($file);
|
||||
$value->{filename} //= path($file->path)->basename if $file->isa('Mojo::Asset::File');
|
||||
}
|
||||
|
||||
# Memory
|
||||
elsif (defined(my $content = delete $value->{content})) {
|
||||
$part->asset(Mojo::Asset::Memory->new->add_chunk($content));
|
||||
}
|
||||
|
||||
# Filename and headers
|
||||
$filename = delete $value->{filename};
|
||||
$headers->from_hash($value);
|
||||
next unless defined $name;
|
||||
$filename = url_escape $filename // $name, '"';
|
||||
$filename = encode $charset, $filename if $charset;
|
||||
}
|
||||
|
||||
# Field
|
||||
else {
|
||||
$value = encode $charset, $value if $charset;
|
||||
$part->asset(Mojo::Asset::Memory->new->add_chunk($value));
|
||||
}
|
||||
|
||||
# Content-Disposition
|
||||
next unless defined $name;
|
||||
$name = url_escape $name, '"';
|
||||
$name = encode $charset, $name if $charset;
|
||||
my $disposition = qq{form-data; name="$name"};
|
||||
$disposition .= qq{; filename="$filename"} if defined $filename;
|
||||
$headers->content_disposition($disposition);
|
||||
}
|
||||
|
||||
return \@parts;
|
||||
}
|
||||
|
||||
sub _proxy {
|
||||
my ($tx, $proto, $host, $port) = @_;
|
||||
|
||||
my $req = $tx->req;
|
||||
if ($req->via_proxy && (my $proxy = $req->proxy)) {
|
||||
return $proxy->protocol, $proxy->ihost, $proxy->port // ($proto eq 'https' ? 443 : 80);
|
||||
}
|
||||
|
||||
return $proto, $host, $port;
|
||||
}
|
||||
|
||||
sub _type { $_[0]->content_type($_[1]) unless $_[0]->content_type }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::UserAgent::Transactor - User agent transactor
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::UserAgent::Transactor;
|
||||
|
||||
# GET request with Accept header
|
||||
my $t = Mojo::UserAgent::Transactor->new;
|
||||
say $t->tx(GET => 'http://example.com' => {Accept => '*/*'})->req->to_string;
|
||||
|
||||
# POST request with form-data
|
||||
say $t->tx(POST => 'example.com' => form => {a => 'b'})->req->to_string;
|
||||
|
||||
# PUT request with JSON data
|
||||
say $t->tx(PUT => 'example.com' => json => {a => 'b'})->req->to_string;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::UserAgent::Transactor> is the transaction building and manipulation framework used by L<Mojo::UserAgent>.
|
||||
|
||||
=head1 GENERATORS
|
||||
|
||||
These content generators are available by default.
|
||||
|
||||
=head2 form
|
||||
|
||||
$t->tx(POST => 'http://example.com' => form => {a => 'b'});
|
||||
|
||||
Generate query string, C<application/x-www-form-urlencoded> or C<multipart/form-data> content. See L</"tx"> for more.
|
||||
|
||||
=head2 json
|
||||
|
||||
$t->tx(PATCH => 'http://example.com' => json => {a => 'b'});
|
||||
|
||||
Generate JSON content with L<Mojo::JSON>. See L</"tx"> for more.
|
||||
|
||||
=head2 multipart
|
||||
|
||||
$t->tx(PUT => 'http://example.com' => multipart => ['Hello', 'World!']);
|
||||
|
||||
Generate multipart content. See L</"tx"> for more.
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
L<Mojo::UserAgent::Transactor> implements the following attributes.
|
||||
|
||||
=head2 compressed
|
||||
|
||||
my $bool = $t->compressed;
|
||||
$t = $t->compressed($bool);
|
||||
|
||||
Try to negotiate compression for the response content and decompress it automatically, defaults to the value of the
|
||||
C<MOJO_GZIP> environment variable or true.
|
||||
|
||||
=head2 generators
|
||||
|
||||
my $generators = $t->generators;
|
||||
$t = $t->generators({foo => sub {...}});
|
||||
|
||||
Registered content generators, by default only C<form>, C<json> and C<multipart> are already defined.
|
||||
|
||||
=head2 name
|
||||
|
||||
my $name = $t->name;
|
||||
$t = $t->name('Mojolicious');
|
||||
|
||||
Value for C<User-Agent> request header of generated transactions, defaults to C<Mojolicious (Perl)>.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
L<Mojo::UserAgent::Transactor> inherits all methods from L<Mojo::Base> and implements the following new ones.
|
||||
|
||||
=head2 add_generator
|
||||
|
||||
$t = $t->add_generator(foo => sub {...});
|
||||
|
||||
Register a content generator.
|
||||
|
||||
$t->add_generator(foo => sub ($t, $tx, @args) {...});
|
||||
|
||||
=head2 endpoint
|
||||
|
||||
my ($proto, $host, $port) = $t->endpoint(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Actual endpoint for transaction.
|
||||
|
||||
=head2 peer
|
||||
|
||||
my ($proto, $host, $port) = $t->peer(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Actual peer for transaction.
|
||||
|
||||
=head2 promisify
|
||||
|
||||
$t->promisify(Mojo::Promise->new, Mojo::Transaction::HTTP->new);
|
||||
|
||||
Resolve or reject L<Mojo::Promise> object with L<Mojo::Transaction::HTTP> object.
|
||||
|
||||
=head2 proxy_connect
|
||||
|
||||
my $tx = $t->proxy_connect(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Build L<Mojo::Transaction::HTTP> proxy C<CONNECT> request for transaction if possible.
|
||||
|
||||
=head2 redirect
|
||||
|
||||
my $tx = $t->redirect(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Build L<Mojo::Transaction::HTTP> follow-up request for C<301>, C<302>, C<303>, C<307> or C<308> redirect response if
|
||||
possible.
|
||||
|
||||
=head2 tx
|
||||
|
||||
my $tx = $t->tx(GET => 'example.com');
|
||||
my $tx = $t->tx(POST => 'http://example.com');
|
||||
my $tx = $t->tx(GET => 'http://example.com' => {Accept => '*/*'});
|
||||
my $tx = $t->tx(PUT => 'http://example.com' => 'Content!');
|
||||
my $tx = $t->tx(PUT => 'http://example.com' => form => {a => 'b'});
|
||||
my $tx = $t->tx(PUT => 'http://example.com' => json => {a => 'b'});
|
||||
my $tx = $t->tx(PUT => 'https://example.com' => multipart => ['a', 'b']);
|
||||
my $tx = $t->tx(POST => 'example.com' => {Accept => '*/*'} => 'Content!');
|
||||
my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => form => {a => 'b'});
|
||||
my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => json => {a => 'b'});
|
||||
my $tx = $t->tx(PUT => 'example.com' => {Accept => '*/*'} => multipart => ['a', 'b']);
|
||||
|
||||
Versatile general purpose L<Mojo::Transaction::HTTP> transaction builder for requests, with support for
|
||||
L</"GENERATORS">.
|
||||
|
||||
# Generate and inspect custom GET request with DNT header and content
|
||||
say $t->tx(GET => 'example.com' => {DNT => 1} => 'Bye!')->req->to_string;
|
||||
|
||||
# Stream response content to STDOUT
|
||||
my $tx = $t->tx(GET => 'http://example.com');
|
||||
$tx->res->content->unsubscribe('read')->on(read => sub { say $_[1] });
|
||||
|
||||
# PUT request with content streamed from file
|
||||
my $tx = $t->tx(PUT => 'http://example.com');
|
||||
$tx->req->content->asset(Mojo::Asset::File->new(path => '/foo.txt'));
|
||||
|
||||
The C<json> content generator uses L<Mojo::JSON> for encoding and sets the content type to C<application/json>.
|
||||
|
||||
# POST request with "application/json" content
|
||||
my $tx = $t->tx(POST => 'http://example.com' => json => {a => 'b', c => [1, 2, 3]});
|
||||
|
||||
The C<form> content generator will automatically use query parameters for C<GET> and C<HEAD> requests.
|
||||
|
||||
# GET request with query parameters
|
||||
my $tx = $t->tx(GET => 'http://example.com' => form => {a => 'b'});
|
||||
|
||||
For all other request methods the C<application/x-www-form-urlencoded> content type is used.
|
||||
|
||||
# POST request with "application/x-www-form-urlencoded" content
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {a => 'b', c => 'd'});
|
||||
|
||||
Parameters may be encoded with the C<charset> option.
|
||||
|
||||
# PUT request with Shift_JIS encoded form values
|
||||
my $tx = $t->tx(PUT => 'example.com' => form => {a => 'b'} => charset => 'Shift_JIS');
|
||||
|
||||
An array reference can be used for multiple form values sharing the same name.
|
||||
|
||||
# POST request with form values sharing the same name
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {a => ['b', 'c', 'd']});
|
||||
|
||||
A hash reference with a C<content> or C<file> value can be used to switch to the C<multipart/form-data> content type
|
||||
for file uploads.
|
||||
|
||||
# POST request with "multipart/form-data" content
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {content => 'lala'}});
|
||||
|
||||
# POST request with multiple files sharing the same name
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => [{content => 'first'}, {content => 'second'}]});
|
||||
|
||||
The C<file> value should contain the path to the file you want to upload or an asset object, like L<Mojo::Asset::File>
|
||||
or L<Mojo::Asset::Memory>.
|
||||
|
||||
# POST request with upload streamed from file
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => '/foo.txt'}});
|
||||
|
||||
# POST request with upload streamed from asset
|
||||
my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {mytext => {file => $asset}});
|
||||
|
||||
A C<filename> value will be generated automatically, but can also be set manually if necessary. All remaining values in
|
||||
the hash reference get merged into the C<multipart/form-data> content as headers.
|
||||
|
||||
# POST request with form values and customized upload (filename and header)
|
||||
my $tx = $t->tx(POST => 'http://example.com' => form => {
|
||||
a => 'b',
|
||||
c => 'd',
|
||||
mytext => {
|
||||
content => 'lalala',
|
||||
filename => 'foo.txt',
|
||||
'Content-Type' => 'text/plain'
|
||||
}
|
||||
});
|
||||
|
||||
The C<multipart/form-data> content type can also be enforced by setting the C<Content-Type> header manually.
|
||||
|
||||
# Force "multipart/form-data"
|
||||
my $headers = {'Content-Type' => 'multipart/form-data'};
|
||||
my $tx = $t->tx(POST => 'example.com' => $headers => form => {a => 'b'});
|
||||
|
||||
The C<multipart> content generator can be used to build custom multipart requests and does not set a content type.
|
||||
|
||||
# POST request with multipart content ("foo" and "bar")
|
||||
my $tx = $t->tx(POST => 'http://example.com' => multipart => ['foo', 'bar']);
|
||||
|
||||
Similar to the C<form> content generator you can also pass hash references with C<content> or C<file> values, as well
|
||||
as headers.
|
||||
|
||||
# POST request with multipart content streamed from file
|
||||
my $tx = $t->tx(POST => 'http://example.com' => multipart => [{file => '/foo.txt'}]);
|
||||
|
||||
# PUT request with multipart content streamed from asset
|
||||
my $headers = {'Content-Type' => 'multipart/custom'};
|
||||
my $asset = Mojo::Asset::Memory->new->add_chunk('lalala');
|
||||
my $tx = $t->tx(PUT => 'http://example.com' => $headers => multipart => [{file => $asset}]);
|
||||
|
||||
# POST request with multipart content and custom headers
|
||||
my $tx = $t->tx(POST => 'http://example.com' => multipart => [
|
||||
{
|
||||
content => 'Hello',
|
||||
'Content-Type' => 'text/plain',
|
||||
'Content-Language' => 'en-US'
|
||||
},
|
||||
{
|
||||
content => 'World!',
|
||||
'Content-Type' => 'text/plain',
|
||||
'Content-Language' => 'en-US'
|
||||
}
|
||||
]);
|
||||
|
||||
=head2 upgrade
|
||||
|
||||
my $tx = $t->upgrade(Mojo::Transaction::HTTP->new);
|
||||
|
||||
Build L<Mojo::Transaction::WebSocket> follow-up transaction for WebSocket handshake if possible.
|
||||
|
||||
=head2 websocket
|
||||
|
||||
my $tx = $t->websocket('ws://example.com');
|
||||
my $tx = $t->websocket('ws://example.com' => {DNT => 1} => ['v1.proto']);
|
||||
|
||||
Versatile L<Mojo::Transaction::HTTP> transaction builder for WebSocket handshake requests.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
950
database/perl/vendor/lib/Mojo/Util.pm
vendored
Normal file
950
database/perl/vendor/lib/Mojo/Util.pm
vendored
Normal file
@@ -0,0 +1,950 @@
|
||||
package Mojo::Util;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use Carp qw(carp croak);
|
||||
use Data::Dumper ();
|
||||
use Digest::MD5 qw(md5 md5_hex);
|
||||
use Digest::SHA qw(hmac_sha1_hex sha1 sha1_hex);
|
||||
use Encode qw(find_encoding);
|
||||
use Exporter qw(import);
|
||||
use File::Basename qw(dirname);
|
||||
use Getopt::Long qw(GetOptionsFromArray);
|
||||
use IO::Compress::Gzip;
|
||||
use IO::Poll qw(POLLIN POLLPRI);
|
||||
use IO::Uncompress::Gunzip;
|
||||
use List::Util qw(min);
|
||||
use MIME::Base64 qw(decode_base64 encode_base64);
|
||||
use Pod::Usage qw(pod2usage);
|
||||
use Sub::Util qw(set_subname);
|
||||
use Symbol qw(delete_package);
|
||||
use Time::HiRes ();
|
||||
use Unicode::Normalize ();
|
||||
|
||||
# Check for monotonic clock support
|
||||
use constant MONOTONIC => eval { !!Time::HiRes::clock_gettime(Time::HiRes::CLOCK_MONOTONIC()) };
|
||||
|
||||
# Punycode bootstring parameters
|
||||
use constant {
|
||||
PC_BASE => 36,
|
||||
PC_TMIN => 1,
|
||||
PC_TMAX => 26,
|
||||
PC_SKEW => 38,
|
||||
PC_DAMP => 700,
|
||||
PC_INITIAL_BIAS => 72,
|
||||
PC_INITIAL_N => 128
|
||||
};
|
||||
|
||||
# To generate a new HTML entity table run this command
|
||||
# perl examples/entities.pl > lib/Mojo/resources/html_entities.txt
|
||||
my %ENTITIES;
|
||||
{
|
||||
# Don't use Mojo::File here due to circular dependencies
|
||||
my $path = File::Spec->catfile(dirname(__FILE__), 'resources', 'html_entities.txt');
|
||||
|
||||
open my $file, '<', $path or croak "Unable to open html entities file ($path): $!";
|
||||
my $lines = do { local $/; <$file> };
|
||||
|
||||
for my $line (split /\n/, $lines) {
|
||||
next unless $line =~ /^(\S+)\s+U\+(\S+)(?:\s+U\+(\S+))?/;
|
||||
$ENTITIES{$1} = defined $3 ? (chr(hex $2) . chr(hex $3)) : chr(hex $2);
|
||||
}
|
||||
}
|
||||
|
||||
# Characters that should be escaped in XML
|
||||
my %XML = ('&' => '&', '<' => '<', '>' => '>', '"' => '"', '\'' => ''');
|
||||
|
||||
# "Sun, 06 Nov 1994 08:49:37 GMT" and "Sunday, 06-Nov-94 08:49:37 GMT"
|
||||
my $EXPIRES_RE = qr/(\w+\W+\d+\W+\w+\W+\d+\W+\d+:\d+:\d+\W*\w+)/;
|
||||
|
||||
# HTML entities
|
||||
my $ENTITY_RE = qr/&(?:\#((?:[0-9]{1,7}|x[0-9a-fA-F]{1,6}));|(\w+[;=]?))/;
|
||||
|
||||
# Encoding and pattern cache
|
||||
my (%ENCODING, %PATTERN);
|
||||
|
||||
our @EXPORT_OK = (
|
||||
qw(b64_decode b64_encode camelize class_to_file class_to_path decamelize decode deprecated dumper encode),
|
||||
qw(extract_usage getopt gunzip gzip hmac_sha1_sum html_attr_unescape html_unescape humanize_bytes md5_bytes md5_sum),
|
||||
qw(monkey_patch punycode_decode punycode_encode quote scope_guard secure_compare sha1_bytes sha1_sum slugify),
|
||||
qw(split_cookie_header split_header steady_time tablify term_escape trim unindent unquote url_escape url_unescape),
|
||||
qw(xml_escape xor_encode)
|
||||
);
|
||||
|
||||
# Aliases
|
||||
monkey_patch(__PACKAGE__, 'b64_decode', \&decode_base64);
|
||||
monkey_patch(__PACKAGE__, 'b64_encode', \&encode_base64);
|
||||
monkey_patch(__PACKAGE__, 'hmac_sha1_sum', \&hmac_sha1_hex);
|
||||
monkey_patch(__PACKAGE__, 'md5_bytes', \&md5);
|
||||
monkey_patch(__PACKAGE__, 'md5_sum', \&md5_hex);
|
||||
monkey_patch(__PACKAGE__, 'sha1_bytes', \&sha1);
|
||||
monkey_patch(__PACKAGE__, 'sha1_sum', \&sha1_hex);
|
||||
|
||||
# Use a monotonic clock if possible
|
||||
monkey_patch(__PACKAGE__, 'steady_time',
|
||||
MONOTONIC ? sub () { Time::HiRes::clock_gettime(Time::HiRes::CLOCK_MONOTONIC()) } : \&Time::HiRes::time);
|
||||
|
||||
sub camelize {
|
||||
my $str = shift;
|
||||
return $str if $str =~ /^[A-Z]/;
|
||||
|
||||
# CamelCase words
|
||||
return join '::', map {
|
||||
join('', map { ucfirst lc } split /_/)
|
||||
} split /-/, $str;
|
||||
}
|
||||
|
||||
sub class_to_file {
|
||||
my $class = shift;
|
||||
$class =~ s/::|'//g;
|
||||
$class =~ s/([A-Z])([A-Z]*)/$1 . lc $2/ge;
|
||||
return decamelize($class);
|
||||
}
|
||||
|
||||
sub class_to_path { join '.', join('/', split(/::|'/, shift)), 'pm' }
|
||||
|
||||
sub decamelize {
|
||||
my $str = shift;
|
||||
return $str if $str !~ /^[A-Z]/;
|
||||
|
||||
# snake_case words
|
||||
return join '-', map {
|
||||
join('_', map {lc} grep {length} split /([A-Z]{1}[^A-Z]*)/)
|
||||
} split /::/, $str;
|
||||
}
|
||||
|
||||
sub decode {
|
||||
my ($encoding, $bytes) = @_;
|
||||
return undef unless eval { $bytes = _encoding($encoding)->decode("$bytes", 1); 1 };
|
||||
return $bytes;
|
||||
}
|
||||
|
||||
sub deprecated {
|
||||
local $Carp::CarpLevel = 1;
|
||||
$ENV{MOJO_FATAL_DEPRECATIONS} ? croak @_ : carp @_;
|
||||
}
|
||||
|
||||
sub dumper { Data::Dumper->new([@_])->Indent(1)->Sortkeys(1)->Terse(1)->Useqq(1)->Dump }
|
||||
|
||||
sub encode { _encoding($_[0])->encode("$_[1]", 0) }
|
||||
|
||||
sub extract_usage {
|
||||
my $file = @_ ? "$_[0]" : (caller)[1];
|
||||
|
||||
open my $handle, '>', \my $output;
|
||||
pod2usage -exitval => 'noexit', -input => $file, -output => $handle;
|
||||
$output =~ s/^.*\n|\n$//;
|
||||
$output =~ s/\n$//;
|
||||
|
||||
return unindent($output);
|
||||
}
|
||||
|
||||
sub getopt {
|
||||
my ($array, $opts) = map { ref $_[0] eq 'ARRAY' ? shift : $_ } \@ARGV, [];
|
||||
|
||||
my $save = Getopt::Long::Configure(qw(default no_auto_abbrev no_ignore_case), @$opts);
|
||||
my $result = GetOptionsFromArray $array, @_;
|
||||
Getopt::Long::Configure($save);
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub gunzip {
|
||||
my $compressed = shift;
|
||||
IO::Uncompress::Gunzip::gunzip \$compressed, \my $uncompressed
|
||||
or croak "Couldn't gunzip: $IO::Uncompress::Gunzip::GzipError";
|
||||
return $uncompressed;
|
||||
}
|
||||
|
||||
sub gzip {
|
||||
my $uncompressed = shift;
|
||||
IO::Compress::Gzip::gzip \$uncompressed, \my $compressed or croak "Couldn't gzip: $IO::Compress::Gzip::GzipError";
|
||||
return $compressed;
|
||||
}
|
||||
|
||||
sub html_attr_unescape { _html(shift, 1) }
|
||||
sub html_unescape { _html(shift, 0) }
|
||||
|
||||
sub humanize_bytes {
|
||||
my $size = shift;
|
||||
|
||||
my $prefix = $size < 0 ? '-' : '';
|
||||
|
||||
return "$prefix${size}B" if ($size = abs $size) < 1024;
|
||||
return $prefix . _round($size) . 'KiB' if ($size /= 1024) < 1024;
|
||||
return $prefix . _round($size) . 'MiB' if ($size /= 1024) < 1024;
|
||||
return $prefix . _round($size) . 'GiB' if ($size /= 1024) < 1024;
|
||||
return $prefix . _round($size /= 1024) . 'TiB';
|
||||
}
|
||||
|
||||
sub monkey_patch {
|
||||
my ($class, %patch) = @_;
|
||||
no strict 'refs';
|
||||
no warnings 'redefine';
|
||||
*{"${class}::$_"} = set_subname("${class}::$_", $patch{$_}) for keys %patch;
|
||||
}
|
||||
|
||||
# Direct translation of RFC 3492
|
||||
sub punycode_decode {
|
||||
my $input = shift;
|
||||
use integer;
|
||||
|
||||
my ($n, $i, $bias, @output) = (PC_INITIAL_N, 0, PC_INITIAL_BIAS);
|
||||
|
||||
# Consume all code points before the last delimiter
|
||||
push @output, split(//, $1) if $input =~ s/(.*)\x2d//s;
|
||||
|
||||
while (length $input) {
|
||||
my ($oldi, $w) = ($i, 1);
|
||||
|
||||
# Base to infinity in steps of base
|
||||
for (my $k = PC_BASE; 1; $k += PC_BASE) {
|
||||
my $digit = ord substr $input, 0, 1, '';
|
||||
$digit = $digit < 0x40 ? $digit + (26 - 0x30) : ($digit & 0x1f) - 1;
|
||||
$i += $digit * $w;
|
||||
my $t = $k - $bias;
|
||||
$t = $t < PC_TMIN ? PC_TMIN : $t > PC_TMAX ? PC_TMAX : $t;
|
||||
last if $digit < $t;
|
||||
$w *= PC_BASE - $t;
|
||||
}
|
||||
|
||||
$bias = _adapt($i - $oldi, @output + 1, $oldi == 0);
|
||||
$n += $i / (@output + 1);
|
||||
$i = $i % (@output + 1);
|
||||
splice @output, $i++, 0, chr $n;
|
||||
}
|
||||
|
||||
return join '', @output;
|
||||
}
|
||||
|
||||
# Direct translation of RFC 3492
|
||||
sub punycode_encode {
|
||||
my $output = shift;
|
||||
use integer;
|
||||
|
||||
my ($n, $delta, $bias) = (PC_INITIAL_N, 0, PC_INITIAL_BIAS);
|
||||
|
||||
# Extract basic code points
|
||||
my @input = map {ord} split //, $output;
|
||||
$output =~ s/[^\x00-\x7f]+//gs;
|
||||
my $h = my $basic = length $output;
|
||||
$output .= "\x2d" if $basic > 0;
|
||||
|
||||
for my $m (sort grep { $_ >= PC_INITIAL_N } @input) {
|
||||
next if $m < $n;
|
||||
$delta += ($m - $n) * ($h + 1);
|
||||
$n = $m;
|
||||
|
||||
for my $c (@input) {
|
||||
|
||||
if ($c < $n) { $delta++ }
|
||||
elsif ($c == $n) {
|
||||
my $q = $delta;
|
||||
|
||||
# Base to infinity in steps of base
|
||||
for (my $k = PC_BASE; 1; $k += PC_BASE) {
|
||||
my $t = $k - $bias;
|
||||
$t = $t < PC_TMIN ? PC_TMIN : $t > PC_TMAX ? PC_TMAX : $t;
|
||||
last if $q < $t;
|
||||
my $o = $t + (($q - $t) % (PC_BASE - $t));
|
||||
$output .= chr $o + ($o < 26 ? 0x61 : 0x30 - 26);
|
||||
$q = ($q - $t) / (PC_BASE - $t);
|
||||
}
|
||||
|
||||
$output .= chr $q + ($q < 26 ? 0x61 : 0x30 - 26);
|
||||
$bias = _adapt($delta, $h + 1, $h == $basic);
|
||||
$delta = 0;
|
||||
$h++;
|
||||
}
|
||||
}
|
||||
|
||||
$delta++;
|
||||
$n++;
|
||||
}
|
||||
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub quote {
|
||||
my $str = shift;
|
||||
$str =~ s/(["\\])/\\$1/g;
|
||||
return qq{"$str"};
|
||||
}
|
||||
|
||||
sub scope_guard { Mojo::Util::_Guard->new(cb => shift) }
|
||||
|
||||
sub secure_compare {
|
||||
my ($one, $two) = @_;
|
||||
my $r = length $one != length $two;
|
||||
$two = $one if $r;
|
||||
$r |= ord(substr $one, $_) ^ ord(substr $two, $_) for 0 .. length($one) - 1;
|
||||
return $r == 0;
|
||||
}
|
||||
|
||||
sub slugify {
|
||||
my ($value, $allow_unicode) = @_;
|
||||
|
||||
if ($allow_unicode) {
|
||||
|
||||
# Force unicode semantics by upgrading string
|
||||
utf8::upgrade($value = Unicode::Normalize::NFKC($value));
|
||||
$value =~ s/[^\w\s-]+//g;
|
||||
}
|
||||
else {
|
||||
$value = Unicode::Normalize::NFKD($value);
|
||||
$value =~ s/[^a-zA-Z0-9_\p{PosixSpace}-]+//g;
|
||||
}
|
||||
(my $new = lc trim($value)) =~ s/[-\s]+/-/g;
|
||||
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub split_cookie_header { _header(shift, 1) }
|
||||
sub split_header { _header(shift, 0) }
|
||||
|
||||
sub tablify {
|
||||
my $rows = shift;
|
||||
|
||||
my @spec;
|
||||
for my $row (@$rows) {
|
||||
for my $i (0 .. $#$row) {
|
||||
($row->[$i] //= '') =~ y/\r\n//d;
|
||||
my $len = length $row->[$i];
|
||||
$spec[$i] = $len if $len >= ($spec[$i] // 0);
|
||||
}
|
||||
}
|
||||
|
||||
my @fm = (map({"\%-${_}s"} @spec[0 .. $#spec - 1]), '%s');
|
||||
return join '', map { sprintf join(' ', @fm[0 .. $#$_]) . "\n", @$_ } @$rows;
|
||||
}
|
||||
|
||||
sub term_escape {
|
||||
my $str = shift;
|
||||
$str =~ s/([\x00-\x09\x0b-\x1f\x7f\x80-\x9f])/sprintf '\\x%02x', ord $1/ge;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub trim {
|
||||
my $str = shift;
|
||||
$str =~ s/^\s+//;
|
||||
$str =~ s/\s+$//;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub unindent {
|
||||
my $str = shift;
|
||||
my $min = min map { m/^([ \t]*)/; length $1 || () } split /\n/, $str;
|
||||
$str =~ s/^[ \t]{0,$min}//gm if $min;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub unquote {
|
||||
my $str = shift;
|
||||
return $str unless $str =~ s/^"(.*)"$/$1/g;
|
||||
$str =~ s/\\\\/\\/g;
|
||||
$str =~ s/\\"/"/g;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub url_escape {
|
||||
my ($str, $pattern) = @_;
|
||||
|
||||
if ($pattern) {
|
||||
unless (exists $PATTERN{$pattern}) {
|
||||
(my $quoted = $pattern) =~ s!([/\$\[])!\\$1!g;
|
||||
$PATTERN{$pattern} = eval "sub { \$_[0] =~ s/([$quoted])/sprintf '%%%02X', ord \$1/ge }" or croak $@;
|
||||
}
|
||||
$PATTERN{$pattern}->($str);
|
||||
}
|
||||
else { $str =~ s/([^A-Za-z0-9\-._~])/sprintf '%%%02X', ord $1/ge }
|
||||
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub url_unescape {
|
||||
my $str = shift;
|
||||
$str =~ s/%([0-9a-fA-F]{2})/chr hex $1/ge;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub xml_escape {
|
||||
return $_[0] if ref $_[0] && ref $_[0] eq 'Mojo::ByteStream';
|
||||
my $str = shift // '';
|
||||
$str =~ s/([&<>"'])/$XML{$1}/ge;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub xor_encode {
|
||||
my ($input, $key) = @_;
|
||||
|
||||
# Encode with variable key length
|
||||
my $len = length $key;
|
||||
my $buffer = my $output = '';
|
||||
$output .= $buffer ^ $key while length($buffer = substr($input, 0, $len, '')) == $len;
|
||||
return $output .= $buffer ^ substr($key, 0, length $buffer, '');
|
||||
}
|
||||
|
||||
sub _adapt {
|
||||
my ($delta, $numpoints, $firsttime) = @_;
|
||||
use integer;
|
||||
|
||||
$delta = $firsttime ? $delta / PC_DAMP : $delta / 2;
|
||||
$delta += $delta / $numpoints;
|
||||
my $k = 0;
|
||||
while ($delta > ((PC_BASE - PC_TMIN) * PC_TMAX) / 2) {
|
||||
$delta /= PC_BASE - PC_TMIN;
|
||||
$k += PC_BASE;
|
||||
}
|
||||
|
||||
return $k + (((PC_BASE - PC_TMIN + 1) * $delta) / ($delta + PC_SKEW));
|
||||
}
|
||||
|
||||
sub _encoding { $ENCODING{$_[0]} //= find_encoding($_[0]) // croak "Unknown encoding '$_[0]'" }
|
||||
|
||||
sub _entity {
|
||||
my ($point, $name, $attr) = @_;
|
||||
|
||||
# Code point
|
||||
return chr($point !~ /^x/ ? $point : hex $point) unless defined $name;
|
||||
|
||||
# Named character reference
|
||||
my $rest = my $last = '';
|
||||
while (length $name) {
|
||||
return $ENTITIES{$name} . reverse $rest
|
||||
if exists $ENTITIES{$name} && (!$attr || $name =~ /;$/ || $last !~ /[A-Za-z0-9=]/);
|
||||
$rest .= $last = chop $name;
|
||||
}
|
||||
return '&' . reverse $rest;
|
||||
}
|
||||
|
||||
# Supported on Perl 5.14+
|
||||
sub _global_destruction { defined ${^GLOBAL_PHASE} && ${^GLOBAL_PHASE} eq 'DESTRUCT' }
|
||||
|
||||
sub _header {
|
||||
my ($str, $cookie) = @_;
|
||||
|
||||
my (@tree, @part);
|
||||
while ($str =~ /\G[,;\s]*([^=;, ]+)\s*/gc) {
|
||||
push @part, $1, undef;
|
||||
my $expires = $cookie && @part > 2 && lc $1 eq 'expires';
|
||||
|
||||
# Special "expires" value
|
||||
if ($expires && $str =~ /\G=\s*$EXPIRES_RE/gco) { $part[-1] = $1 }
|
||||
|
||||
# Quoted value
|
||||
elsif ($str =~ /\G=\s*("(?:\\\\|\\"|[^"])*")/gc) { $part[-1] = unquote $1 }
|
||||
|
||||
# Unquoted value
|
||||
elsif ($str =~ /\G=\s*([^;, ]*)/gc) { $part[-1] = $1 }
|
||||
|
||||
# Separator
|
||||
next unless $str =~ /\G[;\s]*,\s*/gc;
|
||||
push @tree, [@part];
|
||||
@part = ();
|
||||
}
|
||||
|
||||
# Take care of final part
|
||||
return [@part ? (@tree, \@part) : @tree];
|
||||
}
|
||||
|
||||
sub _html {
|
||||
my ($str, $attr) = @_;
|
||||
$str =~ s/$ENTITY_RE/_entity($1, $2, $attr)/geo;
|
||||
return $str;
|
||||
}
|
||||
|
||||
sub _options {
|
||||
|
||||
# Hash or name (one)
|
||||
return ref $_[0] eq 'HASH' ? (undef, %{shift()}) : @_ if @_ == 1;
|
||||
|
||||
# Name and values (odd)
|
||||
return shift, @_ if @_ % 2;
|
||||
|
||||
# Name and hash or just values (even)
|
||||
return ref $_[1] eq 'HASH' ? (shift, %{shift()}) : (undef, @_);
|
||||
}
|
||||
|
||||
# This may break in the future, but is worth it for performance
|
||||
sub _readable { !!(IO::Poll::_poll(@_[0, 1], my $m = POLLIN | POLLPRI) > 0) }
|
||||
|
||||
sub _round { $_[0] < 10 ? int($_[0] * 10 + 0.5) / 10 : int($_[0] + 0.5) }
|
||||
|
||||
sub _stash {
|
||||
my ($name, $object) = (shift, shift);
|
||||
|
||||
# Hash
|
||||
return $object->{$name} //= {} unless @_;
|
||||
|
||||
# Get
|
||||
return $object->{$name}{$_[0]} unless @_ > 1 || ref $_[0];
|
||||
|
||||
# Set
|
||||
my $values = ref $_[0] ? $_[0] : {@_};
|
||||
@{$object->{$name}}{keys %$values} = values %$values;
|
||||
|
||||
return $object;
|
||||
}
|
||||
|
||||
sub _teardown {
|
||||
return unless my $class = shift;
|
||||
|
||||
# @ISA has to be cleared first because of circular references
|
||||
no strict 'refs';
|
||||
@{"${class}::ISA"} = ();
|
||||
delete_package $class;
|
||||
}
|
||||
|
||||
package Mojo::Util::_Guard;
|
||||
use Mojo::Base -base;
|
||||
|
||||
sub DESTROY { shift->{cb}() }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::Util - Portable utility functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::Util qw(b64_encode url_escape url_unescape);
|
||||
|
||||
my $str = 'test=23';
|
||||
my $escaped = url_escape $str;
|
||||
say url_unescape $escaped;
|
||||
say b64_encode $escaped, '';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::Util> provides portable utility functions for L<Mojo>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::Util> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 b64_decode
|
||||
|
||||
my $bytes = b64_decode $b64;
|
||||
|
||||
Base64 decode bytes with L<MIME::Base64>.
|
||||
|
||||
=head2 b64_encode
|
||||
|
||||
my $b64 = b64_encode $bytes;
|
||||
my $b64 = b64_encode $bytes, "\n";
|
||||
|
||||
Base64 encode bytes with L<MIME::Base64>, the line ending defaults to a newline.
|
||||
|
||||
=head2 camelize
|
||||
|
||||
my $camelcase = camelize $snakecase;
|
||||
|
||||
Convert C<snake_case> string to C<CamelCase> and replace C<-> with C<::>.
|
||||
|
||||
# "FooBar"
|
||||
camelize 'foo_bar';
|
||||
|
||||
# "FooBar::Baz"
|
||||
camelize 'foo_bar-baz';
|
||||
|
||||
# "FooBar::Baz"
|
||||
camelize 'FooBar::Baz';
|
||||
|
||||
=head2 class_to_file
|
||||
|
||||
my $file = class_to_file 'Foo::Bar';
|
||||
|
||||
Convert a class name to a file.
|
||||
|
||||
# "foo_bar"
|
||||
class_to_file 'Foo::Bar';
|
||||
|
||||
# "foobar"
|
||||
class_to_file 'FOO::Bar';
|
||||
|
||||
# "foo_bar"
|
||||
class_to_file 'FooBar';
|
||||
|
||||
# "foobar"
|
||||
class_to_file 'FOOBar';
|
||||
|
||||
=head2 class_to_path
|
||||
|
||||
my $path = class_to_path 'Foo::Bar';
|
||||
|
||||
Convert class name to path, as used by C<%INC>.
|
||||
|
||||
# "Foo/Bar.pm"
|
||||
class_to_path 'Foo::Bar';
|
||||
|
||||
# "FooBar.pm"
|
||||
class_to_path 'FooBar';
|
||||
|
||||
=head2 decamelize
|
||||
|
||||
my $snakecase = decamelize $camelcase;
|
||||
|
||||
Convert C<CamelCase> string to C<snake_case> and replace C<::> with C<->.
|
||||
|
||||
# "foo_bar"
|
||||
decamelize 'FooBar';
|
||||
|
||||
# "foo_bar-baz"
|
||||
decamelize 'FooBar::Baz';
|
||||
|
||||
# "foo_bar-baz"
|
||||
decamelize 'foo_bar-baz';
|
||||
|
||||
=head2 decode
|
||||
|
||||
my $chars = decode 'UTF-8', $bytes;
|
||||
|
||||
Decode bytes to characters with L<Encode>, or return C<undef> if decoding failed.
|
||||
|
||||
=head2 deprecated
|
||||
|
||||
deprecated 'foo is DEPRECATED in favor of bar';
|
||||
|
||||
Warn about deprecated feature from perspective of caller. You can also set the C<MOJO_FATAL_DEPRECATIONS> environment
|
||||
variable to make them die instead with L<Carp>.
|
||||
|
||||
=head2 dumper
|
||||
|
||||
my $perl = dumper {some => 'data'};
|
||||
|
||||
Dump a Perl data structure with L<Data::Dumper>.
|
||||
|
||||
=head2 encode
|
||||
|
||||
my $bytes = encode 'UTF-8', $chars;
|
||||
|
||||
Encode characters to bytes with L<Encode>.
|
||||
|
||||
=head2 extract_usage
|
||||
|
||||
my $usage = extract_usage;
|
||||
my $usage = extract_usage '/home/sri/foo.pod';
|
||||
|
||||
Extract usage message from the SYNOPSIS section of a file containing POD documentation, defaults to using the file this
|
||||
function was called from.
|
||||
|
||||
# "Usage: APPLICATION test [OPTIONS]\n"
|
||||
extract_usage;
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Usage: APPLICATION test [OPTIONS]
|
||||
|
||||
=cut
|
||||
|
||||
=head2 getopt
|
||||
|
||||
getopt
|
||||
'H|headers=s' => \my @headers,
|
||||
't|timeout=i' => \my $timeout,
|
||||
'v|verbose' => \my $verbose;
|
||||
getopt $array,
|
||||
'H|headers=s' => \my @headers,
|
||||
't|timeout=i' => \my $timeout,
|
||||
'v|verbose' => \my $verbose;
|
||||
getopt $array, ['pass_through'],
|
||||
'H|headers=s' => \my @headers,
|
||||
't|timeout=i' => \my $timeout,
|
||||
'v|verbose' => \my $verbose;
|
||||
|
||||
Extract options from an array reference with L<Getopt::Long>, but without changing its global configuration, defaults
|
||||
to using C<@ARGV>. The configuration options C<no_auto_abbrev> and C<no_ignore_case> are enabled by default.
|
||||
|
||||
# Extract "charset" option
|
||||
getopt ['--charset', 'UTF-8'], 'charset=s' => \my $charset;
|
||||
say $charset;
|
||||
|
||||
=head2 gunzip
|
||||
|
||||
my $uncompressed = gunzip $compressed;
|
||||
|
||||
Uncompress bytes with L<IO::Compress::Gunzip>.
|
||||
|
||||
=head2 gzip
|
||||
|
||||
my $compressed = gzip $uncompressed;
|
||||
|
||||
Compress bytes with L<IO::Compress::Gzip>.
|
||||
|
||||
=head2 hmac_sha1_sum
|
||||
|
||||
my $checksum = hmac_sha1_sum $bytes, 'passw0rd';
|
||||
|
||||
Generate HMAC-SHA1 checksum for bytes with L<Digest::SHA>.
|
||||
|
||||
# "11cedfd5ec11adc0ec234466d8a0f2a83736aa68"
|
||||
hmac_sha1_sum 'foo', 'passw0rd';
|
||||
|
||||
=head2 html_attr_unescape
|
||||
|
||||
my $str = html_attr_unescape $escaped;
|
||||
|
||||
Same as L</"html_unescape">, but handles special rules from the L<HTML Living Standard|https://html.spec.whatwg.org>
|
||||
for HTML attributes.
|
||||
|
||||
# "foo=bar<est=baz"
|
||||
html_attr_unescape 'foo=bar<est=baz';
|
||||
|
||||
# "foo=bar<est=baz"
|
||||
html_attr_unescape 'foo=bar<est=baz';
|
||||
|
||||
=head2 html_unescape
|
||||
|
||||
my $str = html_unescape $escaped;
|
||||
|
||||
Unescape all HTML entities in string.
|
||||
|
||||
# "<div>"
|
||||
html_unescape '<div>';
|
||||
|
||||
=head2 humanize_bytes
|
||||
|
||||
my $str = humanize_bytes 1234;
|
||||
|
||||
Turn number of bytes into a simplified human readable format.
|
||||
|
||||
# "1B"
|
||||
humanize_bytes 1;
|
||||
|
||||
# "7.5GiB"
|
||||
humanize_bytes 8007188480;
|
||||
|
||||
# "13GiB"
|
||||
humanize_bytes 13443399680;
|
||||
|
||||
# "-685MiB"
|
||||
humanize_bytes -717946880;
|
||||
|
||||
=head2 md5_bytes
|
||||
|
||||
my $checksum = md5_bytes $bytes;
|
||||
|
||||
Generate binary MD5 checksum for bytes with L<Digest::MD5>.
|
||||
|
||||
=head2 md5_sum
|
||||
|
||||
my $checksum = md5_sum $bytes;
|
||||
|
||||
Generate MD5 checksum for bytes with L<Digest::MD5>.
|
||||
|
||||
# "acbd18db4cc2f85cedef654fccc4a4d8"
|
||||
md5_sum 'foo';
|
||||
|
||||
=head2 monkey_patch
|
||||
|
||||
monkey_patch $package, foo => sub {...};
|
||||
monkey_patch $package, foo => sub {...}, bar => sub {...};
|
||||
|
||||
Monkey patch functions into package.
|
||||
|
||||
monkey_patch 'MyApp',
|
||||
one => sub { say 'One!' },
|
||||
two => sub { say 'Two!' },
|
||||
three => sub { say 'Three!' };
|
||||
|
||||
=head2 punycode_decode
|
||||
|
||||
my $str = punycode_decode $punycode;
|
||||
|
||||
Punycode decode string as described in L<RFC 3492|https://tools.ietf.org/html/rfc3492>.
|
||||
|
||||
# "bücher"
|
||||
punycode_decode 'bcher-kva';
|
||||
|
||||
=head2 punycode_encode
|
||||
|
||||
my $punycode = punycode_encode $str;
|
||||
|
||||
Punycode encode string as described in L<RFC 3492|https://tools.ietf.org/html/rfc3492>.
|
||||
|
||||
# "bcher-kva"
|
||||
punycode_encode 'bücher';
|
||||
|
||||
=head2 quote
|
||||
|
||||
my $quoted = quote $str;
|
||||
|
||||
Quote string.
|
||||
|
||||
=head2 scope_guard
|
||||
|
||||
my $guard = scope_guard sub {...};
|
||||
|
||||
Create anonymous scope guard object that will execute the passed callback when the object is destroyed.
|
||||
|
||||
# Execute closure at end of scope
|
||||
{
|
||||
my $guard = scope_guard sub { say "Mojo!" };
|
||||
say "Hello";
|
||||
}
|
||||
|
||||
=head2 secure_compare
|
||||
|
||||
my $bool = secure_compare $str1, $str2;
|
||||
|
||||
Constant time comparison algorithm to prevent timing attacks. The secret string should be the second argument, to avoid
|
||||
leaking information about the length of the string.
|
||||
|
||||
=head2 sha1_bytes
|
||||
|
||||
my $checksum = sha1_bytes $bytes;
|
||||
|
||||
Generate binary SHA1 checksum for bytes with L<Digest::SHA>.
|
||||
|
||||
=head2 sha1_sum
|
||||
|
||||
my $checksum = sha1_sum $bytes;
|
||||
|
||||
Generate SHA1 checksum for bytes with L<Digest::SHA>.
|
||||
|
||||
# "0beec7b5ea3f0fdbc95d0dd47f3c5bc275da8a33"
|
||||
sha1_sum 'foo';
|
||||
|
||||
=head2 slugify
|
||||
|
||||
my $slug = slugify $string;
|
||||
my $slug = slugify $string, $bool;
|
||||
|
||||
Returns a URL slug generated from the input string. Non-word characters are removed, the string is trimmed and
|
||||
lowercased, and whitespace characters are replaced by a dash. By default, non-ASCII characters are normalized to ASCII
|
||||
word characters or removed, but if a true value is passed as the second parameter, all word characters will be allowed
|
||||
in the result according to unicode semantics.
|
||||
|
||||
# "joel-is-a-slug"
|
||||
slugify 'Joel is a slug';
|
||||
|
||||
# "this-is-my-resume"
|
||||
slugify 'This is: my - résumé! ☃ ';
|
||||
|
||||
# "this-is-my-résumé"
|
||||
slugify 'This is: my - résumé! ☃ ', 1;
|
||||
|
||||
=head2 split_cookie_header
|
||||
|
||||
my $tree = split_cookie_header 'a=b; expires=Thu, 07 Aug 2008 07:07:59 GMT';
|
||||
|
||||
Same as L</"split_header">, but handles C<expires> values from L<RFC 6265|https://tools.ietf.org/html/rfc6265>.
|
||||
|
||||
=head2 split_header
|
||||
|
||||
my $tree = split_header 'foo="bar baz"; test=123, yada';
|
||||
|
||||
Split HTTP header value into key/value pairs, each comma separated part gets its own array reference, and keys without
|
||||
a value get C<undef> assigned.
|
||||
|
||||
# "one"
|
||||
split_header('one; two="three four", five=six')->[0][0];
|
||||
|
||||
# "two"
|
||||
split_header('one; two="three four", five=six')->[0][2];
|
||||
|
||||
# "three four"
|
||||
split_header('one; two="three four", five=six')->[0][3];
|
||||
|
||||
# "five"
|
||||
split_header('one; two="three four", five=six')->[1][0];
|
||||
|
||||
# "six"
|
||||
split_header('one; two="three four", five=six')->[1][1];
|
||||
|
||||
=head2 steady_time
|
||||
|
||||
my $time = steady_time;
|
||||
|
||||
High resolution time elapsed from an arbitrary fixed point in the past, resilient to time jumps if a monotonic clock is
|
||||
available through L<Time::HiRes>.
|
||||
|
||||
=head2 tablify
|
||||
|
||||
my $table = tablify [['foo', 'bar'], ['baz', 'yada']];
|
||||
|
||||
Row-oriented generator for text tables.
|
||||
|
||||
# "foo bar\nyada yada\nbaz yada\n"
|
||||
tablify [['foo', 'bar'], ['yada', 'yada'], ['baz', 'yada']];
|
||||
|
||||
=head2 term_escape
|
||||
|
||||
my $escaped = term_escape $str;
|
||||
|
||||
Escape all POSIX control characters except for C<\n>.
|
||||
|
||||
# "foo\\x09bar\\x0d\n"
|
||||
term_escape "foo\tbar\r\n";
|
||||
|
||||
=head2 trim
|
||||
|
||||
my $trimmed = trim $str;
|
||||
|
||||
Trim whitespace characters from both ends of string.
|
||||
|
||||
# "foo bar"
|
||||
trim ' foo bar ';
|
||||
|
||||
=head2 unindent
|
||||
|
||||
my $unindented = unindent $str;
|
||||
|
||||
Unindent multi-line string.
|
||||
|
||||
# "foo\nbar\nbaz\n"
|
||||
unindent " foo\n bar\n baz\n";
|
||||
|
||||
=head2 unquote
|
||||
|
||||
my $str = unquote $quoted;
|
||||
|
||||
Unquote string.
|
||||
|
||||
=head2 url_escape
|
||||
|
||||
my $escaped = url_escape $str;
|
||||
my $escaped = url_escape $str, '^A-Za-z0-9\-._~';
|
||||
|
||||
Percent encode unsafe characters in string as described in L<RFC 3986|https://tools.ietf.org/html/rfc3986>, the pattern
|
||||
used defaults to C<^A-Za-z0-9\-._~>.
|
||||
|
||||
# "foo%3Bbar"
|
||||
url_escape 'foo;bar';
|
||||
|
||||
=head2 url_unescape
|
||||
|
||||
my $str = url_unescape $escaped;
|
||||
|
||||
Decode percent encoded characters in string as described in L<RFC 3986|https://tools.ietf.org/html/rfc3986>.
|
||||
|
||||
# "foo;bar"
|
||||
url_unescape 'foo%3Bbar';
|
||||
|
||||
=head2 xml_escape
|
||||
|
||||
my $escaped = xml_escape $str;
|
||||
|
||||
Escape unsafe characters C<&>, C<E<lt>>, C<E<gt>>, C<"> and C<'> in string, but do not escape L<Mojo::ByteStream>
|
||||
objects.
|
||||
|
||||
# "<div>"
|
||||
xml_escape '<div>';
|
||||
|
||||
# "<div>"
|
||||
use Mojo::ByteStream qw(b);
|
||||
xml_escape b('<div>');
|
||||
|
||||
=head2 xor_encode
|
||||
|
||||
my $encoded = xor_encode $str, $key;
|
||||
|
||||
XOR encode string with variable length key.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
277
database/perl/vendor/lib/Mojo/WebSocket.pm
vendored
Normal file
277
database/perl/vendor/lib/Mojo/WebSocket.pm
vendored
Normal file
@@ -0,0 +1,277 @@
|
||||
package Mojo::WebSocket;
|
||||
use Mojo::Base -strict;
|
||||
|
||||
use Config;
|
||||
use Exporter qw(import);
|
||||
use Mojo::Util qw(b64_encode dumper sha1_bytes xor_encode);
|
||||
|
||||
use constant DEBUG => $ENV{MOJO_WEBSOCKET_DEBUG} || 0;
|
||||
|
||||
# Unique value from RFC 6455
|
||||
use constant GUID => '258EAFA5-E914-47DA-95CA-C5AB0DC85B11';
|
||||
|
||||
# Perl with support for quads
|
||||
use constant MODERN => (($Config{use64bitint} // '') eq 'define' || $Config{longsize} >= 8);
|
||||
|
||||
# Opcodes
|
||||
use constant {WS_CONTINUATION => 0x0, WS_TEXT => 0x1, WS_BINARY => 0x2, WS_CLOSE => 0x8, WS_PING => 0x9,
|
||||
WS_PONG => 0xa};
|
||||
|
||||
our @EXPORT_OK = (
|
||||
qw(WS_BINARY WS_CLOSE WS_CONTINUATION WS_PING WS_PONG WS_TEXT build_frame challenge client_handshake parse_frame),
|
||||
qw(server_handshake)
|
||||
);
|
||||
|
||||
sub build_frame {
|
||||
my ($masked, $fin, $rsv1, $rsv2, $rsv3, $op, $payload) = @_;
|
||||
warn "-- Building frame ($fin, $rsv1, $rsv2, $rsv3, $op)\n" if DEBUG;
|
||||
|
||||
# Head
|
||||
my $head = $op + ($fin ? 128 : 0);
|
||||
$head |= 0b01000000 if $rsv1;
|
||||
$head |= 0b00100000 if $rsv2;
|
||||
$head |= 0b00010000 if $rsv3;
|
||||
my $frame = pack 'C', $head;
|
||||
|
||||
# Small payload
|
||||
my $len = length $payload;
|
||||
if ($len < 126) {
|
||||
warn "-- Small payload ($len)\n@{[dumper $payload]}" if DEBUG;
|
||||
$frame .= pack 'C', $masked ? ($len | 128) : $len;
|
||||
}
|
||||
|
||||
# Extended payload (16-bit)
|
||||
elsif ($len < 65536) {
|
||||
warn "-- Extended 16-bit payload ($len)\n@{[dumper $payload]}" if DEBUG;
|
||||
$frame .= pack 'Cn', $masked ? (126 | 128) : 126, $len;
|
||||
}
|
||||
|
||||
# Extended payload (64-bit with 32-bit fallback)
|
||||
else {
|
||||
warn "-- Extended 64-bit payload ($len)\n@{[dumper $payload]}" if DEBUG;
|
||||
$frame .= pack 'C', $masked ? (127 | 128) : 127;
|
||||
$frame .= MODERN ? pack('Q>', $len) : pack('NN', 0, $len & 0xffffffff);
|
||||
}
|
||||
|
||||
# Mask payload
|
||||
if ($masked) {
|
||||
my $mask = pack 'N', int(rand 9 x 7);
|
||||
$payload = $mask . xor_encode($payload, $mask x 128);
|
||||
}
|
||||
|
||||
return $frame . $payload;
|
||||
}
|
||||
|
||||
sub challenge {
|
||||
my $tx = shift;
|
||||
|
||||
# "permessage-deflate" extension
|
||||
my $headers = $tx->res->headers;
|
||||
$tx->compressed(1) if ($headers->sec_websocket_extensions // '') =~ /permessage-deflate/;
|
||||
|
||||
return _challenge($tx->req->headers->sec_websocket_key) eq $headers->sec_websocket_accept;
|
||||
}
|
||||
|
||||
sub client_handshake {
|
||||
my $tx = shift;
|
||||
|
||||
my $headers = $tx->req->headers;
|
||||
$headers->upgrade('websocket') unless $headers->upgrade;
|
||||
$headers->connection('Upgrade') unless $headers->connection;
|
||||
$headers->sec_websocket_version(13) unless $headers->sec_websocket_version;
|
||||
|
||||
# Generate 16 byte WebSocket challenge
|
||||
my $challenge = b64_encode sprintf('%16u', int(rand 9 x 16)), '';
|
||||
$headers->sec_websocket_key($challenge) unless $headers->sec_websocket_key;
|
||||
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub parse_frame {
|
||||
my ($buffer, $max) = @_;
|
||||
|
||||
# Head
|
||||
return undef unless length $$buffer >= 2;
|
||||
my ($first, $second) = unpack 'C2', $$buffer;
|
||||
|
||||
# FIN
|
||||
my $fin = ($first & 0b10000000) == 0b10000000 ? 1 : 0;
|
||||
|
||||
# RSV1-3
|
||||
my $rsv1 = ($first & 0b01000000) == 0b01000000 ? 1 : 0;
|
||||
my $rsv2 = ($first & 0b00100000) == 0b00100000 ? 1 : 0;
|
||||
my $rsv3 = ($first & 0b00010000) == 0b00010000 ? 1 : 0;
|
||||
|
||||
# Opcode
|
||||
my $op = $first & 0b00001111;
|
||||
warn "-- Parsing frame ($fin, $rsv1, $rsv2, $rsv3, $op)\n" if DEBUG;
|
||||
|
||||
# Small payload
|
||||
my ($hlen, $len) = (2, $second & 0b01111111);
|
||||
if ($len < 126) { warn "-- Small payload ($len)\n" if DEBUG }
|
||||
|
||||
# Extended payload (16-bit)
|
||||
elsif ($len == 126) {
|
||||
return undef unless length $$buffer > 4;
|
||||
$hlen = 4;
|
||||
$len = unpack 'x2n', $$buffer;
|
||||
warn "-- Extended 16-bit payload ($len)\n" if DEBUG;
|
||||
}
|
||||
|
||||
# Extended payload (64-bit with 32-bit fallback)
|
||||
elsif ($len == 127) {
|
||||
return undef unless length $$buffer > 10;
|
||||
$hlen = 10;
|
||||
$len = MODERN ? unpack('x2Q>', $$buffer) : unpack('x2x4N', $$buffer);
|
||||
warn "-- Extended 64-bit payload ($len)\n" if DEBUG;
|
||||
}
|
||||
|
||||
# Check message size
|
||||
return 1 if $len > $max;
|
||||
|
||||
# Check if whole packet has arrived
|
||||
$len += 4 if my $masked = $second & 0b10000000;
|
||||
return undef if length $$buffer < ($hlen + $len);
|
||||
substr $$buffer, 0, $hlen, '';
|
||||
|
||||
# Payload
|
||||
my $payload = $len ? substr($$buffer, 0, $len, '') : '';
|
||||
$payload = xor_encode($payload, substr($payload, 0, 4, '') x 128) if $masked;
|
||||
warn dumper $payload if DEBUG;
|
||||
|
||||
return [$fin, $rsv1, $rsv2, $rsv3, $op, $payload];
|
||||
}
|
||||
|
||||
sub server_handshake {
|
||||
my $tx = shift;
|
||||
|
||||
my $headers = $tx->res->headers;
|
||||
$headers->upgrade('websocket')->connection('Upgrade');
|
||||
$headers->sec_websocket_accept(_challenge($tx->req->headers->sec_websocket_key));
|
||||
|
||||
return $tx;
|
||||
}
|
||||
|
||||
sub _challenge { b64_encode(sha1_bytes(($_[0] || '') . GUID), '') }
|
||||
|
||||
1;
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Mojo::WebSocket - The WebSocket protocol
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Mojo::WebSocket qw(WS_TEXT build_frame parse_frame);
|
||||
|
||||
my $bytes = build_frame 0, 1, 0, 0, 0, WS_TEXT, 'Hello World!';
|
||||
my $frame = parse_frame \$bytes, 262144;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Mojo::WebSocket> implements the WebSocket protocol as described in L<RFC 6455|https://tools.ietf.org/html/rfc6455>.
|
||||
Note that 64-bit frames require a Perl with support for quads or they are limited to 32-bit.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
L<Mojo::WebSocket> implements the following functions, which can be imported individually.
|
||||
|
||||
=head2 build_frame
|
||||
|
||||
my $bytes = build_frame $masked, $fin, $rsv1, $rsv2, $rsv3, $op, $payload;
|
||||
|
||||
Build WebSocket frame.
|
||||
|
||||
# Masked binary frame with FIN bit and payload
|
||||
say build_frame 1, 1, 0, 0, 0, WS_BINARY, 'Hello World!';
|
||||
|
||||
# Text frame with payload but without FIN bit
|
||||
say build_frame 0, 0, 0, 0, 0, WS_TEXT, 'Hello ';
|
||||
|
||||
# Continuation frame with FIN bit and payload
|
||||
say build_frame 0, 1, 0, 0, 0, WS_CONTINUATION, 'World!';
|
||||
|
||||
# Close frame with FIN bit and without payload
|
||||
say build_frame 0, 1, 0, 0, 0, WS_CLOSE, '';
|
||||
|
||||
# Ping frame with FIN bit and payload
|
||||
say build_frame 0, 1, 0, 0, 0, WS_PING, 'Test 123';
|
||||
|
||||
# Pong frame with FIN bit and payload
|
||||
say build_frame 0, 1, 0, 0, 0, WS_PONG, 'Test 123';
|
||||
|
||||
=head2 challenge
|
||||
|
||||
my $bool = challenge Mojo::Transaction::WebSocket->new;
|
||||
|
||||
Check WebSocket handshake challenge.
|
||||
|
||||
=head2 client_handshake
|
||||
|
||||
my $tx = client_handshake Mojo::Transaction::HTTP->new;
|
||||
|
||||
Perform WebSocket handshake client-side.
|
||||
|
||||
=head2 parse_frame
|
||||
|
||||
my $frame = parse_frame \$bytes, $limit;
|
||||
|
||||
Parse WebSocket frame.
|
||||
|
||||
# Parse single frame and remove it from buffer
|
||||
my $frame = parse_frame \$buffer, 262144;
|
||||
say "FIN: $frame->[0]";
|
||||
say "RSV1: $frame->[1]";
|
||||
say "RSV2: $frame->[2]";
|
||||
say "RSV3: $frame->[3]";
|
||||
say "Opcode: $frame->[4]";
|
||||
say "Payload: $frame->[5]";
|
||||
|
||||
=head2 server_handshake
|
||||
|
||||
my $tx = server_handshake Mojo::Transaction::HTTP->new;
|
||||
|
||||
Perform WebSocket handshake server-side.
|
||||
|
||||
=head1 CONSTANTS
|
||||
|
||||
L<Mojo::WebSocket> implements the following constants, which can be imported individually.
|
||||
|
||||
=head2 WS_BINARY
|
||||
|
||||
Opcode for C<Binary> frames.
|
||||
|
||||
=head2 WS_CLOSE
|
||||
|
||||
Opcode for C<Close> frames.
|
||||
|
||||
=head2 WS_CONTINUATION
|
||||
|
||||
Opcode for C<Continuation> frames.
|
||||
|
||||
=head2 WS_PING
|
||||
|
||||
Opcode for C<Ping> frames.
|
||||
|
||||
=head2 WS_PONG
|
||||
|
||||
Opcode for C<Pong> frames.
|
||||
|
||||
=head2 WS_TEXT
|
||||
|
||||
Opcode for C<Text> frames.
|
||||
|
||||
=head1 DEBUGGING
|
||||
|
||||
You can set the C<MOJO_WEBSOCKET_DEBUG> environment variable to get some advanced diagnostics information printed to
|
||||
C<STDERR>.
|
||||
|
||||
MOJO_WEBSOCKET_DEBUG=1
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Mojolicious>, L<Mojolicious::Guides>, L<https://mojolicious.org>.
|
||||
|
||||
=cut
|
||||
2231
database/perl/vendor/lib/Mojo/resources/html_entities.txt
vendored
Normal file
2231
database/perl/vendor/lib/Mojo/resources/html_entities.txt
vendored
Normal file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user