Initial Commit

database/perl/vendor/lib/Mojo/UserAgent/CookieJar.pm

@@ -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