view release on metacpan or  search on metacpan

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

        push( @temp, $c->name );
        push( @temp, $c->value );
        $io->print( join( "\t", @temp ), "\n" );
    });
    $io->close;
    return( $self );
}

# For backward compatibility with HTTP::Cookies
sub scan { return( shift->do( @_ ) ); }

# NOTE: the secret key to be used to decrypt or encrypt the cookie jar file
sub secret { return( shift->_set_get_scalar( 'secret', @_ ) ); }

sub set
{
    my $self = shift( @_ );
    my $c    = shift( @_ );
    my $opts = $self->_get_args_as_hash( @_ );
    return( $self->error( "No cookie name was provided to set." ) ) if( !$c->name->length );
    return( $self->error( "Cookie value should be an object." ) ) if( !Scalar::Util::blessed( $c ) );
    return( $self->error( "Cookie object does not have any as_string method." ) ) if( !$c->can( 'as_string' ) );
    $opts->{response} //= '';
    my $r = $self->request;
    if( $r )
    {
        $r->err_headers_out->add( 'Set-Cookie', $c->as_string );
    }
    elsif( $opts->{response} && $self->_is_object( $opts->{response} ) && $opts->{response}->can( 'header' ) )
    {
        $opts->{response}->header( 'Set-Cookie' => $c->as_string );
    }
    else
    {
        return( "Set-Cookie: " . $c->as_string );
    }
    return( $self );
}

# NOTE: cookie jar file type, e.g.: json, lwp or netscape
sub type { return( shift->_set_get_scalar( 'type', @_ ) ); }

sub _cookies { return( shift->_set_get_array_as_object( '_cookies', @_ ) ); }

sub _domain_match
{
    my $self   = shift( @_ );
    my $host   = lc( shift( @_ ) // '' );
    my $domain = lc( shift( @_ ) // '' );
    return(1) if( $host eq $domain );
    return(1) if( $host =~ /\.\Q$domain\E$/ );
    return(0);
}

sub _encrypt_objects
{
    my $self = shift( @_ );
    my( $key, $algo, $iv ) = @_;
    return( $self->error( "Key provided is empty!" ) ) if( !defined( $key ) || !CORE::length( "$key" ) );
    return( $self->error( "No algorithm was provided to encrypt cookie value. You can choose any <NAME> for which there exists Crypt::Cipher::<NAME>" ) ) if( !defined( $algo ) || !CORE::length( "$algo" ) );
    $self->_load_class( 'Crypt::Mode::CBC', { version => CRYPTX_VERSION } ) || return( $self->pass_error );
    $self->_load_class( 'Bytes::Random::Secure' ) || return( $self->pass_error );
    # try-catch
    local $@;
    my $crypt = eval
    {
        Crypt::Mode::CBC->new( "$algo" );
    };
    if( $@ )
    {
        return( $self->error( "Error getting the encryption objects for algorithm \"$algo\": $@" ) );
    }
    $crypt or return( $self->error( "Unable to create a Crypt::Mode::CBC object." ) );

    my $class = "Crypt::Cipher::${algo}";
    $self->_load_class( $class ) || return( $self->pass_error );
    
    my( $key_len, $block_len );
    eval
    {
        $key_len = $class->keysize;
        $block_len = $class->blocksize;
    };
    if( $@ )
    {
        return( $self->error( "Error getting the encryption key and block size for algorithm \"$algo\": $@" ) );
    }
    return( $self->error( "The size of the key provided (", CORE::length( $key ), ") does not match the minimum key size required for this algorithm \"$algo\" (${key_len})." ) ) if( CORE::length( $key ) < $key_len );
    # Generate an "IV", i.e. Initialisation Vector based on the required block size
    if( defined( $iv ) && CORE::length( "$iv" ) )
    {
        if( CORE::length( $iv ) != $block_len )
        {
            return( $self->error( "The Initialisation Vector provided for cookie encryption has a length (", CORE::length( $iv ), ") which does not match the algorithm ($algo) size requirement ($block_len). Please refer to the Cookie::Jar package doc...
        }
    }
    else
    {
        $iv = eval
        {
            Bytes::Random::Secure::random_bytes( $block_len );
        };
        if( $@ )
        {
            return( $self->error( "Error trying to get $block_len secure random bytes: $@" ) );
        }
        # Save it for decryption
        $self->_initialisation_vector( $iv );
    }
    my $key_pack = pack( 'H' x $key_len, $key );
    my $iv_pack  = pack( 'H' x $block_len, $iv );
    return({ 'crypt' => $crypt, key => $key_pack, iv => $iv_pack });
}

sub _index { return( shift->_set_get_hash_as_mix_object( '_index', @_ ) ); }

# For cookies file encryption
sub _initialisation_vector { return( shift->_set_get_scalar_as_object( '_initialisation_vector', @_ ) ); }

sub _normalize_path  # so that plain string compare can be used
{
    my $self = shift( @_ );
    my $str  = shift( @_ );
    my $x;
    $str =~ s{
        %([0-9a-fA-F][0-9a-fA-F])
    }
    {
        $x = uc( $1 );
        $x eq '2F' || $x eq '25' ? "%$x" : pack( 'C', hex( $x ) );
    }egx;
    $str =~ s/([\0-\x20\x7f-\xff])/sprintf( '%%%02X', ord( $1 ) )/eg;
    return( $str );