stat\( results from the CPAN

Cookie

    }
    my $ref = $self->_cookies;
    my $idx = $self->_index;
    $this->name or return( $self->error( "No cookie name was set in this cookie." ) );
    my $key = $self->key( $this ) || return( $self->pass_error );
    $ref->push( $this );
    $idx->{ $key } = [] if( !CORE::exists( $idx->{ $key } ) );
    push( @{$idx->{ $key }}, $this );
    return( $this );
}

sub add_cookie_header { return( shift->add_request_header( @_ ) ); }

sub add_request_header
{
    my $self = shift( @_ );
    my $req  = shift( @_ ) || return( $self->error( "No request object was provided." ) );
    return( $self->error( "Request object provided is not an object." ) ) if( !Scalar::Util::blessed( $req ) );
    return( $self->error( "Request object provided does not support the uri or header methods." ) ) if( !$req->can( 'uri' ) || !$req->can( 'header' ) );
    my $uri = $req->uri || return( $self->error( "No uri set in the request object." ) );
    my $scheme = $uri->scheme;
    unless( $scheme =~ /^https?\z/ )
    {
        return( '' );
    }
    my( $host, $port, $path );
    if( $host = $req->header( 'Host' ) )
    {
        $host =~ s/:(\d+)$//;
        $host = lc( $host );
        $port = $1;
    }
    else
    {
        $host = lc( $uri->host );
    }
    my $is_secure = ( $scheme eq 'https' ? 1 : 0 );
    # URI::URL method
    if( $uri->can( 'epath' ) )
    {
        $path = $uri->epath;
    }
    else
    {
        # URI::_generic method
        $path = $uri->path;
    }
    $path = '/' unless( CORE::length( $path ) );
    $port = $uri->port if( !defined( $port ) || !CORE::length( $port ) );
    # my $now = time();
    my $now = DateTime->now;
    $path = $self->_normalize_path( $path ) if( CORE::index( $path, '%' ) != -1 );
    my $root;
    if( $self->_is_ip( $host ) )
    {
        $root = $host;
    }
    else
    {
        my $dom = Cookie::Domain->new || return( $self->pass_error( Cookie::Domain->error ) );
        my $res = $dom->stat( $host );
        return( $self->pass_error( $dom->error ) ) if( !defined( $res ) );
        if( !CORE::length( $res ) || ( $res && !$res->domain->length ) )
        {
            return( $self->error( "No root domain found for host \"$host\"." ) );
        }
        $root = $res->domain;
    }
    # rfc6265, section 5.4
    # "Either:
    # The cookie's host-only-flag is true and the canonicalized request-host is identical to the cookie's domain.
    # Or:
    # The cookie's host-only-flag is false and the canonicalized request-host domain-matches the cookie's domain."
    # Meaning, $host is, for example, www.example.or.jp and cookie domain was not set and defaulted to example.or.jp, then it matches; or
    # cookie domain was explicitly set to www.example.or.jp and matches www.example.or.jp
    # <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4>
    # cookie values for the "Cookie" header
    my @values = ();
    my @ok_cookies = ();
    # Get all cookies for the canonicalised request-host and its sub domains, then we check each one found according to rfc6265 algorithm as stated above
    my $cookies = $self->get_by_domain( $root, with_subdomain => 1 );
    # Ref: rfc6265, section 5.4
    # <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4>
    foreach my $c ( @$cookies )
    {
        unless( ( $c->host_only  && $root eq $c->domain ) ||
                ( !$c->host_only && $self->_domain_match( $host, $c->domain ) ) )
        {
            next;
        }
        if( index( $path, $c->path ) != 0 )
        {
            next;
        }
        elsif( !$is_secure && $c->secure )
        {
            next;
        }
        # elsif( $c->expires && $c->expires->epoch < $now )
        elsif( $c->expires && $c->expires < $now )
        {
            next;
        }
        elsif( $c->port && $c->port != $port )
        {
            next;
        }
        push( @ok_cookies, $c );
    }
    
    # sort cookies by path and by creation date.
    # Ref: rfc6265, section 5.4.2:
    # "Cookies with longer paths are listed before cookies with shorter paths."
    # "Among cookies that have equal-length path fields, cookies with earlier creation-times are listed before cookies with later creation-times."
    # <https://datatracker.ietf.org/doc/html/rfc6265#section-5.4>
    # The OR here actually means AND, since the <=> comparison returns false when 2 elements are equal
    # So when 2 path are the same, we differentiate them by their creation date
    foreach my $c ( sort{ $b->path->length <=> $a->path->length || $a->created_on <=> $b->created_on } @ok_cookies )
    {
        push( @values, $c->as_string({ is_request => 1 }) );
        # rfc6265, section 5.4.3

lib/Cookie/Jar.pm view on Meta::CPAN

# From http client point of view
sub extract
{
    my $self = shift( @_ );
    my $resp = shift( @_ ) || return( $self->error( "No response object was provided." ) );
    return( $self->error( "Response object provided is not an object." ) ) if( !Scalar::Util::blessed( $resp ) );
    my $uri;
    if( $self->_is_a( $resp, 'HTTP::Response' ) )
    {
        my $req = $resp->request;
        return( $self->error( "No HTTP::Request object is set in this HTTP::Response." ) ) if( !$resp->request );
        $uri = $resp->request->uri;
    }
    elsif( $resp->can( 'uri' ) && $resp->can( 'header' ) )
    {
        $uri = $resp->uri;
    }
    else
    {
        return( $self->error( "Response object provided does not support the uri or scheme methods and is not a class or subclass of HTTP::Response either." ) );
    }
    my $all = Module::Generic::HeaderValue->new_from_multi( [$resp->header( 'Set-Cookie' )], debug => $self->debug, decode => 1 ) ||
        return( $self->pass_error( Module::Generic::HeaderValue->error ) );
    return( $resp ) unless( $all->length );
    $uri || return( $self->error( "No uri set in the response object." ) );
    my( $host, $port, $path );
    if( $host = $resp->header( 'Host' ) ||
        ( $resp->request && ( $host = $resp->request->header( 'Host' ) ) ) )
    {
        if( $host =~ s/:(\d+)$// )
        {
            $port = $1;
        }
        $host = lc( $host );
    }
    else
    {
        $host = lc( $uri->host );
    }
    
    # URI::URL method
    if( $uri->can( 'epath' ) )
    {
        $path = $uri->epath;
    }
    else
    {
        # URI::_generic method
        $path = $uri->path;
    }
    $path = '/' unless( CORE::length( $path ) );
    $port = $uri->port if( !defined( $port ) || !CORE::length( $port ) );
    my $root;
    if( $self->_is_ip( $host ) )
    {
        $root = $host;
    }
    else
    {
        my $dom = Cookie::Domain->new || return( $self->pass_error( Cookie::Domain->error ) );
        my $res = $dom->stat( $host );
        if( !defined( $res ) )
        {
            return( $self->pass_error( $dom->error ) );
        }
        # Possibly empty
        $root = $res ? $res->domain : '';
    }
    
    foreach my $o ( @$all )
    {
        my( $name, $value ) = $o->value->list;
        my $c = Cookie->new( name => $name, value => $value ) || 
            return( $self->pass_error( Cookie->error ) );
        if( CORE::length( $o->param( 'expires' ) ) )
        {
            my $dt = $self->_parse_timestamp( $o->param( 'expire' ) );
            if( $dt )
            {
                $c->expires( $dt );
            }
            else
            {
                $c->expires( $o->param( 'expires' ) );
            }
        }
        elsif( CORE::length( $o->param( 'max-age' ) ) )
        {
            $c->max_age( $o->param( 'max-age' ) );
        }
        
        if( $o->param( 'domain' ) )
        {
            # rfc6265, section 5.2.3:
            # "If the first character of the attribute-value string is %x2E ("."): Let cookie-domain be the attribute-value without the leading %x2E (".") character."
            # Ref: <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.3>
            my $c_dom = $o->param( 'domain' );
            # Remove leading dot as per rfc specifications
            $c_dom =~ s/^\.//g;
            # "Convert the cookie-domain to lower case."
            $c_dom = lc( $c_dom );
            # Check the domain name is legitimate, i.e. sent from a host that has authority
            # "The user agent will reject cookies unless the Domain attribute specifies a scope for the cookie that would include the origin server.  For example, the user agent will accept a cookie with a Domain attribute of "example.com" or of "foo...
            # <https://tools.ietf.org/html/rfc6265#section-4.1.2.3>
            if( CORE::length( $c_dom ) >= CORE::length( $root ) && 
                ( $c_dom eq $host || $host =~ /\.$c_dom$/ ) )
            {
                $c->domain( $c_dom );
            }
            else
            {
                next;
            }
        }
        # "If omitted, defaults to the host of the current document URL, not including subdomains."
        # <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Set-Cookie>
        else
        {
            if( $root )
            {
                $c->domain( $root );

lib/Cookie/Jar.pm view on Meta::CPAN

        else
        {
            my $frag = $self->new_array( [split( /\//, $path )] );
            # Not perfect
            if( $path eq '/' || substr( $path, -1, 1 ) eq '/' )
            {
                $c->path( $path );
            }
            else
            {
                $frag->pop;
                $c->path( $frag->join( '/' )->scalar );
            }
        }
        $c->port( $port ) if( defined( $port ) );
        $c->http_only(1) if( $o->param( 'httponly' ) );
        $c->secure(1) if( $o->param( 'secure' ) );
        $c->same_site(1) if( $o->param( 'samesite' ) );
        
        my @old = $self->get({ name => $c->name, host => $c->domain, path => $c->path });
        if( scalar( @old ) )
        {
            $c->created_on( $old[0]->created_on ) if( $old[0]->created_on );
            # $self->replace( $c );
            for( @old )
            {
                my $arr;
                $arr = $self->delete( $_ ) || do
                {
                    # Error trying to remove cookie
                };
            }
        }
        $self->message( 3, "Adding cookie name '", $c->name, "'." ) if( $COOKIES_DEBUG );        
        $self->add( $c ) || return( $self->pass_error );
    }
    return( $self );
}

sub extract_cookies { return( shift->extract( @_ ) ); }

sub extract_one
{
    my $self = shift( @_ );
    my $str = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    $opts->{path} //= '/';
    return( $self->error( "No cookie data was provided." ) ) if( !length( "$str" ) );
    
    my( $host, $root );
    if( defined( $opts->{host} ) && CORE::length( $opts->{host} ) )
    {
        $host = $opts->{host};
        if( $self->_is_ip( $host ) )
        {
            $root = $host;
        }
        else
        {
            my $dom = Cookie::Domain->new || return( $self->pass_error( Cookie::Domain->error ) );
            my $res = $dom->stat( $host );
            if( !defined( $res ) )
            {
                return( $self->pass_error( $dom->error ) );
            }
            # Possibly empty
            $root = $res ? $res->domain : '';
        }
    }

    my $o = Module::Generic::HeaderValue->new_from_header( "$str" ) ||
        return( $self->pass_error( Module::Generic::HeaderValue->error ) );
    my( $name, $value ) = $o->value->list;
    my $c = Cookie->new( name => $name, value => $value ) || 
        return( $self->pass_error( Cookie->error ) );
    if( CORE::length( $o->param( 'expires' ) ) )
    {
        my $dt = $self->_parse_timestamp( $o->param( 'expire' ) );
        if( $dt )
        {
            $c->expires( $dt );
        }
        else
        {
            $c->expires( $o->param( 'expires' ) );
        }
    }
    elsif( CORE::length( $o->param( 'max-age' ) ) )
    {
        $c->max_age( $o->param( 'max-age' ) );
    }
    
    if( $o->param( 'domain' ) )
    {
        # rfc6265, section 5.2.3:
        # "If the first character of the attribute-value string is %x2E ("."): Let cookie-domain be the attribute-value without the leading %x2E (".") character."
        # Ref: <https://datatracker.ietf.org/doc/html/rfc6265#section-5.2.3>
        my $c_dom = $o->param( 'domain' );
        # Remove leading dot as per rfc specifications
        $c_dom =~ s/^\.//g;
        # "Convert the cookie-domain to lower case."
        $c_dom = lc( $c_dom );
        $c->domain( $c_dom );
    }
    # "If omitted, defaults to the host of the current document URL, not including subdomains."
    # <https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Set-Cookie>
    else
    {
        if( $root )
        {
            $c->domain( $root );
            $c->implicit(1);
        }
        else
        {
        }
    }
    
    # rfc6265: "If the server omits the Path attribute, the user agent will use the "directory" of the request-uri's path component as the default value."
    if( defined( $o->param( 'path' ) ) && CORE::length( $o->param( 'path' ) ) )
    {

( run in 1.766 second using v1.01-cache-2.11-cpan-5b529ec07f3 )