mark: A photo of Mark kneeling on top of the Taal Volcano in the Philippines. It was a long hike. (Default)
Mark Smith ([staff profile] mark) wrote in [site community profile] changelog2010-04-21 08:48 am

[dw-free] Add cookie support to DW::Request

[commit: http://hg.dwscoalition.org/dw-free/rev/4964f14bf7ad]

http://bugs.dwscoalition.org/show_bug.cgi?id=2446

Add cookie support to DW::Request, this moves them out of the purview of
BML.

Patch by [personal profile] exor674.

Files modified:
  • bin/checkconfig.pl
  • cgi-bin/Apache/LiveJournal.pm
  • cgi-bin/DW/Request.pm
  • cgi-bin/DW/Request/Apache2.pm
  • cgi-bin/DW/Request/Base.pm
  • cgi-bin/DW/Request/Standard.pm
  • cgi-bin/DW/Template/Filters.pm
  • cgi-bin/LJ/Lang.pm
  • cgi-bin/LJ/PageStats.pm
  • cgi-bin/LJ/Session.pm
  • cgi-bin/LJ/Setting/SiteScheme.pm
  • cgi-bin/LJ/UniqCookie.pm
  • cgi-bin/LJ/User.pm
  • cgi-bin/LJ/Widget/Feeds.pm
  • cgi-bin/LJ/Widget/PopularInterests.pm
  • htdocs/login.bml
--------------------------------------------------------------------------------
diff -r a6bc338ff907 -r 4964f14bf7ad bin/checkconfig.pl
--- a/bin/checkconfig.pl	Wed Apr 21 08:07:33 2010 +0000
+++ b/bin/checkconfig.pl	Wed Apr 21 08:48:41 2010 +0000
@@ -83,6 +83,7 @@ my %modules = (
                "Compress::Zlib" => { 'deb' => 'libcompress-zlib-perl', },
                "Net::DNS" => { 'deb' => 'libnet-dns-perl', },
                "Template" => { 'deb' => 'libtemplate-perl', },
+               "CGI" => { deb => 'libcgi-pm-perl', },
                "Net::OpenID::Server" => {
                    opt => 'Required for OpenID server support.'
                },
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/Apache/LiveJournal.pm
--- a/cgi-bin/Apache/LiveJournal.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/Apache/LiveJournal.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -658,7 +658,7 @@ sub trans
         }
 
         if ($uuri eq "/__setdomsess") {
-            return redir($r, LJ::Session->setdomsess_handler($r));
+            return redir( $r, LJ::Session->setdomsess_handler );
         }
 
         if ($uuri =~ m#^/calendar(.*)#) {
@@ -1324,13 +1324,16 @@ sub journal_content
     if ($criterr) {
         $r->status_line("500 Invalid Cookies");
         $r->content_type("text/html");
+
         # reset all cookies
-        foreach my $dom (@LJ::COOKIE_DOMAIN_RESET) {
-            my $cookiestr = 'ljsession=';
-            $cookiestr .= '; expires=' . LJ::time_to_cookie(1);
-            $cookiestr .= $dom ? "; domain=$dom" : '';
-            $cookiestr .= '; path=/; HttpOnly';
-            BML::get_request()->err_headers_out->add('Set-Cookie' => $cookiestr);
+        foreach my $dom ( @LJ::COOKIE_DOMAIN_RESET ) {
+            DW::Request->get->add_cookie(
+                name     => 'ljsession',
+                expires  => LJ::time_to_cookie(1),
+                domain   => $dom ? $dom : undef,
+                path     => '/',
+                httponly => 1
+            );
         }
 
         $r->print("Invalid cookies.  Try <a href='$LJ::SITEROOT/logout.bml'>logging out</a> and then logging back in.\n");
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/DW/Request.pm
--- a/cgi-bin/DW/Request.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/DW/Request.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -82,6 +82,11 @@ sub reset {
 
 These methods work on any DW::Request subclass.
 
+=head2 C<< $r->add_cookie( %args ) >>
+
+Sends this cookie to the browser.  %args should be the same arguments passed to CGI::Cookie->new, except without the
+initial hyphens CGI::Cookie asks you to use.  We don't use those.
+
 =head2 C<< $r->call_bml( $filename ) >>
 
     return $r->call_bml( $filename );
@@ -93,8 +98,8 @@ Must be called as above, with the result
 
     return $r->call_response_handler( \&handler );
 
-This will ensure the sub gets called at some point soon, don't expect it to be called instantly, but also don't expect this to be return immediately either.
-Must be called as above, with the result being directly returned.
+This will ensure the sub gets called at some point soon, don't expect it to be called instantly, but also don't expect
+this to be return immediately either.  Must be called as above, with the result being directly returned.
 
 =head2 C<< $r->content >>
 
@@ -104,6 +109,22 @@ This cannot be used with $r->post_args.
 =head2 C<< $r->content_type( [$content_type] ) >>
 
 Get or set the content type.
+
+=head2 C<< $r->cookie( $name ) >>
+
+Returns value(s) of cookie.
+
+=head2 C<< $r->delete_cookie( %args ) >>
+
+%args should be the same arguments passed to CGI::Cookie->new.
+
+=head2 C<< $r->err_header_out( $header[, $value] ) >>
+
+Sets or gets an response header that is also included on the error pages.
+
+=head2 C<< $r->err_header_out_add( $header, $value ) >>
+
+Adds another instance of a header for headers that allow multiple instances that is also included on the error pages.
 
 =head2 C<< $r->get_args >>
 
@@ -120,6 +141,10 @@ Sets or gets an request header.
 =head2 C<< $r->header_out( $header[, $value] ) >>
 
 Sets or gets an response header.
+
+=head2 C<< $r->header_out_add( $header, $value ) >>
+
+Adds another instance of a header for headers that allow multiple instances.
 
 =head2 C<< $r->meets_conditions >>
 
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/DW/Request/Apache2.pm
--- a/cgi-bin/DW/Request/Apache2.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/DW/Request/Apache2.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -16,8 +16,10 @@
 #
 
 package DW::Request::Apache2;
+use strict;
+use DW::Request::Base;
+use base 'DW::Request::Base';
 
-use strict;
 use Apache2::Const -compile => qw/ :common REDIRECT HTTP_NOT_MODIFIED /;
 use Apache2::Log ();
 use Apache2::Request;
@@ -41,6 +43,7 @@ sub new {
 sub new {
     my DW::Request::Apache2 $self = $_[0];
     $self = fields::new( $self ) unless ref $self;
+    $self->SUPER::new;
 
     # setup object
     $self->{r}         = $_[1];
@@ -160,6 +163,28 @@ sub header_out {
     }
 }
 
+# appends a value to a header
+sub header_out_add {
+    my DW::Request::Apache2 $self = $_[0];
+    return $self->{r}->headers_out->add( $_[1] , $_[2] );
+}
+
+# searches for a given header and returns the value, or sets it
+sub err_header_out {
+    my DW::Request::Apache2 $self = $_[0];
+    if ( scalar( @_ ) == 2 ) {
+        return $self->{r}->err_headers_out->{$_[1]};
+    } else {
+        return $self->{r}->err_headers_out->{$_[1]} = $_[2];
+    }
+}
+
+# appends a value to a header
+sub err_header_out_add {
+    my DW::Request::Apache2 $self = $_[0];
+    return $self->{r}->err_headers_out->add( $_[1] , $_[2] );
+}
+
 # returns the ip address of the connected person
 sub get_remote_ip {
     my DW::Request::Apache2 $self = $_[0];
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/DW/Request/Base.pm
--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/cgi-bin/DW/Request/Base.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -0,0 +1,71 @@
+#!/usr/bin/perl
+#
+# DW::Request::Base
+#
+# Methods that are the same over most or all DW::Request modules
+#
+# Authors:
+#      Andrea Nall <anall@andreanall.com>
+#
+# Copyright (c) 2010 by Dreamwidth Studios, LLC.
+#
+# This program is free software; you may redistribute it and/or modify it under
+# the same terms as Perl itself.  For a copy of the license, please reference
+# 'perldoc perlartistic' or 'perldoc perlgpl'.
+#
+
+package DW::Request::Base;
+
+use strict;
+use Carp qw/ confess cluck /;
+use CGI::Cookie;
+
+use fields (
+            'cookies_in',
+        );
+
+sub new {
+    my $self = $_[0];
+    confess "This is a base class, you can't use it directly."
+        unless ref $self;
+
+    $self->{cookies_in} = undef;
+}
+
+sub cookie {
+    my DW::Request::Base $self = $_[0];
+
+    $self->{cookies_in} ||= { CGI::Cookie->parse( $self->header_in( 'Cookie' ) ) };
+    return unless exists $self->{cookies_in}->{$_[1]};
+    return $self->{cookies_in}->{$_[1]}->value;
+}
+
+sub add_cookie {
+    my DW::Request::Base $self = shift;
+    my %args = ( @_ );
+
+    confess "Must provide name" unless $args{name};
+    confess "Must provide value (try delete_cookie if you really mean this)" unless exists $args{value};
+
+    $args{domain} ||= ".$LJ::DOMAIN";
+
+    # extraneous parenthesis inside map {} needed to force BLOCK mode map
+    my $cookie = CGI::Cookie->new( map { ( "-$_" => $args{$_} ) } keys %args );
+    $self->err_header_out_add( 'Set-Cookie' => $cookie );
+    return $cookie;
+}
+
+sub delete_cookie {
+    my DW::Request::Base $self = shift;
+    my %args = ( @_ );
+
+    confess "Must provide name" unless $args{name};
+
+    $args{value}    = '';
+    $args{expires}  = "-1d";
+    $args{domain} ||= ".$LJ::DOMAIN";
+
+    return $self->add_cookie( %args );
+}
+
+1;
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/DW/Request/Standard.pm
--- a/cgi-bin/DW/Request/Standard.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/DW/Request/Standard.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -17,8 +17,10 @@
 #
 
 package DW::Request::Standard;
+use strict;
+use DW::Request::Base;
+use base 'DW::Request::Base';
 
-use strict;
 use Carp qw/ confess cluck /;
 use HTTP::Request;
 use HTTP::Response;
@@ -45,6 +47,7 @@ sub new {
 sub new {
     my DW::Request::Standard $self = $_[0];
     $self = fields::new( $self ) unless ref $self;
+    $self->SUPER::new;
 
     # setup object
     $self->{req}         = $_[1];
@@ -54,7 +57,7 @@ sub new {
     $self->{uri}         = $self->{req}->uri;
     $self->{notes}       = {};
     $self->{pnotes}      = {};
-    
+
     # now stick ourselves as the primary request ...
     unless ( $DW::Request::cur_req ) {
         $DW::Request::determined = 1;
@@ -178,9 +181,16 @@ sub header_out {
     }
 }
 
+# appends a value to a header
+sub header_out_add {
+    my DW::Request::Standard $self = $_[0];
+    return $self->{res}->push_header( $_[1] , $_[2] );
+}
+
 # this may not be precisely correct?  maybe we need to maintain our
 # own set of headers that are separate for errors... FIXME: investigate
 *err_header_out = \&header_out;
+*err_header_out_add = \&header_out_add;
 
 # returns the ip address of the connected person
 sub get_remote_ip {
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/DW/Template/Filters.pm
--- a/cgi-bin/DW/Template/Filters.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/DW/Template/Filters.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -73,7 +73,7 @@ sub _decide_language {
 
     # next is their cookie preference
     #FIXME: COOKIE!
-    #if ($BML::COOKIEIE{'langpref'} =~ m!^(\w{2,10})/(\d+)$!) {
+    #if ( $r->cookie('langpref') =~ m!^(\w{2,10})/(\d+)$! ) {
     #    if (exists $env->{"Langs-$1"}) {
     #        # FIXME: Probably should actually do this!!!
     #        # make sure the document says it was changed at least as new as when
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/Lang.pm
--- a/cgi-bin/LJ/Lang.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/Lang.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -733,22 +733,26 @@ sub set_lang {
 
     my $l = LJ::Lang::get_lang($lang);
     my $remote = LJ::get_remote();
+    my $r = DW::Request->get;
 
     # default cookie value to set
     my $cval = $l->{lncode} . "/" . time();
 
     # if logged in, change userprop and make cookie expiration
     # the same as their login expiration
+    my $expires = undef;
     if ($remote) {
         $remote->set_prop("browselang", $l->{lncode});
 
-        if ($remote->{_session}->{exptype} eq 'long') {
-            $cval = [ $cval, $remote->{_session}->{timeexpire} ];
-        }
+        $expires = $remote->{_session}->{timeexpire} if $remote->{_session}->{exptype} eq 'long';
     }
 
     # set cookie
-    $BML::COOKIE{langpref} = $cval;
+    $r->add_cookie(
+        name    => 'langpref',
+        value   => $cval,
+        expires => $expires,
+    );
 
     # set language through BML so it will apply immediately
     BML::set_language($l->{lncode});
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/PageStats.pm
--- a/cgi-bin/LJ/PageStats.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/PageStats.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -83,14 +83,14 @@ sub should_render {
     my $ctx = $self->get_context;
     return 0 unless ($ctx && $ctx =~ /^(app|journal)$/);
 
-    my $r = $self->get_request or return 0;
+    my $r = DW::Request->get or return 0;
 
     # Make sure we don't exclude tracking from this page or path
     return 0 if grep { $r->uri =~ /$_/ } @{ $LJ::PAGESTATS_EXCLUDE{'uripath'} };
-    return 0 if grep { $r->notes('codepath') eq $_ } @{ $LJ::PAGESTATS_EXCLUDE{'codepath'} };
+    return 0 if grep { $r->note( 'codepath' ) eq $_ } @{ $LJ::PAGESTATS_EXCLUDE{'codepath'} };
 
     # See if their ljuniq cookie has the PageStats flag
-    if ($BML::COOKIE{'ljuniq'} =~ /[a-zA-Z0-9]{15}:\d+:pgstats([01])/) {
+    if ( $r->cookie( 'ljuniq' ) =~ /[a-zA-Z0-9]{15}:\d+:pgstats([01])/ ) {
         return 0 unless $1; # Don't serve PageStats if it is "pgstats:0"
     } else {
         return 0; # They don't have it set this request, but will for the next one
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/Session.pm
--- a/cgi-bin/LJ/Session.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/Session.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -483,22 +483,22 @@ sub session_from_cookies {
     my $class = shift;
     my %getopts = @_;
 
-    # must be in web context
-    return undef unless eval { BML::get_request(); };
+    my $r = DW::Request->get;
+    return undef unless $r;
 
     my $sessobj;
 
     my $domain_cookie = LJ::Session->domain_cookie;
     if ($domain_cookie) {
         # journal domain
-        $sessobj = LJ::Session->session_from_domain_cookie(\%getopts, @{ $BML::COOKIE{"$domain_cookie\[\]"} || [] });
+        $sessobj = LJ::Session->session_from_domain_cookie(\%getopts, $r->cookie( $domain_cookie ) );
     } else {
         # this is the master cookie at "www.livejournal.com" or "livejournal.com";
-        my @cookies = @{ $BML::COOKIE{'ljmastersession[]'} || [] };
+        my @cookies = $r->cookie( 'ljmastersession' );
         # but support old clients who are just sending an "ljsession" cookie which they got
         # from ljprotocol's "generatesession" mode.
         unless (@cookies) {
-            @cookies = @{ $BML::COOKIE{'ljsession[]'} || [] };
+            @cookies = $r->cookie( 'ljsession' );
             $getopts{old_cookie} = 1;
         }
         $sessobj = LJ::Session->session_from_master_cookie(\%getopts, @cookies);
@@ -513,8 +513,10 @@ sub session_from_domain_cookie {
     my $class = shift;
     my $opts = ref $_[0] ? shift() : {};
 
+    my $r = DW::Request->get;
+
     # the logged-in cookie
-    my $li_cook = $BML::COOKIE{'ljloggedin'};
+    my $li_cook = $r->cookie( 'ljloggedin' );
     return undef unless $li_cook;
 
     my $no_session = sub {
@@ -552,6 +554,8 @@ sub session_from_master_cookie {
     my @cookies = grep { $_ } @_;
     return undef unless @cookies;
 
+    my $r = DW::Request->get;
+
     my $errs       = delete $opts->{errlist} || [];
     my $tried_fast = delete $opts->{tried_fast} || do { my $foo; \$foo; };
     my $ignore_ip  = delete $opts->{ignore_ip} ? 1 : 0;
@@ -565,7 +569,7 @@ sub session_from_master_cookie {
     # our return value
     my $sess;
 
-    my $li_cook = $BML::COOKIE{'ljloggedin'};
+    my $li_cook = $r->cookie( 'ljloggedin' );
 
   COOKIE:
     foreach my $sessdata (@cookies) {
@@ -716,19 +720,18 @@ sub session_length {
 
 # given an Apache $r object, returns the URL to go to after setting the domain cookie
 sub setdomsess_handler {
-    my ($class, $r) = @_;
+    my ($class) = @_;
 
-    # FIXME: ModPerl 2.0: best way to do this?  has to be a better way of handling incoming
-    # requests so that we don't have to parse input at all these stages...
-    Apache::BML::parse_inputs( $r );
-    my %get = %{ BML::get_GET() || {} };
+    my $r = DW::Request->get;
 
-    my $dest    = $get{'dest'};
-    my $domcook = $get{'k'};
-    my $cookie  = $get{'v'};
+    my $get = $r->get_args;
+
+    my $dest    = $get->{'dest'};
+    my $domcook = $get->{'k'};
+    my $cookie  = $get->{'v'};
 
     return "$LJ::SITEROOT" unless valid_destination($dest);
-    return $dest unless valid_domain_cookie($domcook, $cookie, $BML::COOKIE{'ljloggedin'});
+    return $dest unless valid_domain_cookie( $domcook, $cookie, $r->cookie( 'ljloggedin' ) );
 
     my $path = '/'; # By default cookie path is root
 
@@ -805,7 +808,7 @@ sub set_cookie {
 sub set_cookie {
     my ($key, $value, %opts) = @_;
 
-    my $r = eval { BML::get_request() };
+    my $r = DW::Request->get;
     return unless $r;
 
     my $http_only = delete $opts{http_only};
@@ -816,8 +819,8 @@ sub set_cookie {
     croak("Invalid cookie options: " . join(", ", keys %opts)) if %opts;
 
     # Mac IE 5 can't handle HttpOnly, so filter it out
-    if ($http_only && ! $LJ::DEBUG{'no_mac_ie_httponly'}) {
-        my $ua = $r->headers_in->{'User-Agent'};
+    if ($http_only && ! $LJ::DEBUG{no_mac_ie_httponly}) {
+        my $ua = $r->header_in( 'User-Agent' );
         $http_only = 0 if $ua =~ /MSIE.+Mac_/;
     }
 
@@ -830,24 +833,26 @@ sub set_cookie {
         $expires = 5 if $delete;
     }
 
-    my $cookiestr = $key . '=' . $value;
-    $cookiestr .= '; expires=' . LJ::time_to_cookie($expires) if $expires;
-    $cookiestr .= '; domain=' . $domain if $domain;
-    $cookiestr .= '; path=' . $path if $path;
-    $cookiestr .= '; HttpOnly' if $http_only;
-
-    $r->err_headers_out->add('Set-Cookie' => $cookiestr);
+    $r->add_cookie(
+        name     => $key,
+        value    => $value,
+        expires  => $expires ? LJ::time_to_cookie($expires) : undef,
+        domain   => $domain || undef,
+        path     => $path || undef,
+        httponly => $http_only ? 1 : 0,
+    );
 
     # Backwards compatability for older browsers
     my @labels = split(/\./, $domain);
-    if ($domain && scalar @labels == 2 && ! $LJ::DEBUG{'no_extra_dot_cookie'}) {
-        my $cookiestr = $key . '=' . $value;
-        $cookiestr .= '; expires=' . LJ::time_to_cookie($expires) if $expires;
-        $cookiestr .= '; domain=.' . $domain;
-        $cookiestr .= '; path=' . $path if $path;
-        $cookiestr .= '; HttpOnly' if $http_only;
-
-        $r->err_headers_out->add('Set-Cookie' => $cookiestr);
+    if ($domain && scalar @labels == 2 && ! $LJ::DEBUG{no_extra_dot_cookie}) {
+        $r->add_cookie(
+            name     => $key,
+            value    => $value,
+            expires  => $expires ? LJ::time_to_cookie($expires) : undef,
+            domain   => $domain,
+            path     => $path || undef,
+            httponly => $http_only ? 1 : 0,
+        );
     }
 }
 
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/Setting/SiteScheme.pm
--- a/cgi-bin/LJ/Setting/SiteScheme.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/Setting/SiteScheme.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -38,11 +38,13 @@ sub option {
     my ($class, $u, $errs, $args, %opts) = @_;
     my $key = $class->pkgkey;
 
+    my $r = DW::Request->get;
+
     my @bml_schemes = LJ::site_schemes();
     return "" unless @bml_schemes;
 
     my $show_hidden = $opts{getargs}->{view} && $opts{getargs}->{view} eq "schemes";
-    my $sitescheme = $class->get_arg($args, "sitescheme") || BML::get_scheme() || $BML::COOKIE{BMLschemepref} || $bml_schemes[0]->{scheme};
+    my $sitescheme = $class->get_arg( $args, "sitescheme" ) || BML::get_scheme() || $r->cookie( 'BMLschemepref' ) || $bml_schemes[0]->{scheme};
 
     my $ret;
     foreach my $scheme (@bml_schemes) {
@@ -91,6 +93,8 @@ sub save {
     my ($class, $u, $args) = @_;
     $class->error_check($u, $args);
 
+    my $r = DW::Request->get;
+
     my $val = my $cval = $class->get_arg($args, "sitescheme");
     return 1 unless $val;
     my @bml_schemes = LJ::site_schemes();
@@ -98,20 +102,24 @@ sub save {
     # don't set cookie for default scheme
     if ($val eq $bml_schemes[0]->{scheme} && !$LJ::SAVE_SCHEME_EXPLICITLY) {
         $cval = "";
-        delete $BML::COOKIE{BMLschemepref};
+        $r->delete_cookie( name => 'BMLschemepref' );
     }
 
+    my $expires = undef;
     if ($u) {
         # set a userprop to remember their schemepref
         $u->set_prop( schemepref => $val );
 
         # cookie expires when session expires
-        $cval = [ $val, $u->{_session}->{timeexpire} ]
+        $expires = $u->{_session}->{timeexpire}
             if $u->{_session}->{exptype} eq "long";
     }
 
-    # set cookie
-    $BML::COOKIE{BMLschemepref} = $cval if $cval;
+    $r->add_cookie(
+        name    => 'BMLschemepref',
+        value   => $cval,
+        expires => $expires,
+    ) if $cval;
     BML::set_scheme($val);
 
     return 1;
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/UniqCookie.pm
--- a/cgi-bin/LJ/UniqCookie.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/UniqCookie.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -392,7 +392,7 @@ sub ensure_cookie_value {
     my $class = shift;
     return unless LJ::is_web_context();
 
-    my $r = BML::get_request();
+    my $r = DW::Request->get;
     return unless $r;
     
     my ($uniq, $uniq_time, $uniq_extra) = $class->parts_from_cookie;
@@ -437,10 +437,13 @@ sub ensure_cookie_value {
     # set uniq cookies for all cookie_domains
     my @domains = ref $LJ::COOKIE_DOMAIN ? @$LJ::COOKIE_DOMAIN : ($LJ::COOKIE_DOMAIN);
     foreach my $dom (@domains) {
-        $r->err_headers_out->add("Set-Cookie" =>
-                                 "ljuniq=$new_cookie_value; " .
-                                 "expires=" . LJ::time_to_cookie($now + 86400*60) . "; " .
-                                 ($dom ? "domain=$dom; " : "") . "path=/");
+        $r->add_cookie(
+            name    => 'ljuniq',
+            value   => $new_cookie_value,
+            expires => '+60d',
+            domain  => $dom || undef,
+            path    => '/'
+        );
     }
 
     return;
@@ -468,14 +471,9 @@ sub parts_from_cookie {
     my $class = shift;
     return unless LJ::is_web_context();
 
-    my $r = BML::get_request();
-    my $cookieval = $r->headers_in->{"Cookie"};
+    my $r = DW::Request->get;
 
-    if ($cookieval =~ /\bljuniq\s*=\s*([a-zA-Z0-9]{15}):(\d+)([^;]+)/) {
-        return wantarray() ? ($1, $2, $3) : $1;
-    }
-
-    return;
+    return $class->parts_from_value( $r->cookie( 'ljuniq' ) );
 }
 
 # returns: (uniq_val, uniq_time, uniq_extra)
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/User.pm
--- a/cgi-bin/LJ/User.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/User.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -1124,10 +1124,14 @@ sub sessions {
 
 sub _logout_common {
     my $u = shift;
+    my $r = DW::Request->get;
     LJ::Session->clear_master_cookie;
-    LJ::User->set_remote(undef);
-    delete $BML::COOKIE{'BMLschemepref'};
-    eval { BML::set_scheme(undef); };
+    LJ::User->set_remote( undef );
+    $r->delete_cookie(
+        name    => 'BMLschemepref',
+        domain  => ".$LJ::DOMAIN",
+    );
+    eval { BML::set_scheme( undef ); };
 }
 
 
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/Widget/Feeds.pm
--- a/cgi-bin/LJ/Widget/Feeds.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/Widget/Feeds.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -23,9 +23,9 @@ sub render_body {
     my $class = shift;
     my %opts = @_;
 
+    my $r = DW::Request->get;
     my $remote = LJ::get_remote();
     my $get = $class->get_args;
-    my $cart = $get->{'cart'} || $BML::COOKIE{cart};
     my $body;
     $body .= "<h2 class='solid-neutral'>" . $class->ml('widget.feeds.title') . "</h2>";
     $body .= "<a href='$LJ::SITEROOT/syn/list' class='more-link'>" .
diff -r a6bc338ff907 -r 4964f14bf7ad cgi-bin/LJ/Widget/PopularInterests.pm
--- a/cgi-bin/LJ/Widget/PopularInterests.pm	Wed Apr 21 08:07:33 2010 +0000
+++ b/cgi-bin/LJ/Widget/PopularInterests.pm	Wed Apr 21 08:48:41 2010 +0000
@@ -26,7 +26,6 @@ sub render_body {
 
     my $remote = LJ::get_remote();
     my $get = $class->get_args;
-    my $cart = $get->{'cart'} || $BML::COOKIE{cart};
     my $body;
 
     my $rows = LJ::Stats::get_popular_interests();
diff -r a6bc338ff907 -r 4964f14bf7ad htdocs/login.bml
--- a/htdocs/login.bml	Wed Apr 21 08:07:33 2010 +0000
+++ b/htdocs/login.bml	Wed Apr 21 08:48:41 2010 +0000
@@ -235,13 +235,14 @@ _c?>
     };
     my $logout_remote = sub {
         $remote->kill_session if $remote;
-        foreach (qw(langpref BMLschemepref)) {
-            delete $COOKIE{$_} if $COOKIE{$_};
+        my $r = DW::Request->get;
+        foreach ( qw(langpref BMLschemepref) ) {
+            $r->delete_cookie( name => $_ ) if $r->cookie( $_ );
         }
-        $remote      = undef;
+        $remote  = undef;
         $cursess = undef;
-        LJ::set_remote(undef);
-        LJ::Hooks::run_hooks("post_logout");
+        LJ::set_remote( undef );
+        LJ::Hooks::run_hooks( "post_logout" );
     };
 
     if (LJ::did_post()) {
--------------------------------------------------------------------------------
yvi: Kaylee half-smiling, looking very pretty (Default)

[personal profile] yvi 2010-04-21 09:00 am (UTC)(link)
*supports the further slaying of BML*