#!/usr/bin/perl
#

package Apache::LiveJournal;

use strict;
use Apache::Constants qw(:common REDIRECT HTTP_NOT_MODIFIED HTTP_MOVED_PERMANENTLY
                         M_TRACE M_OPTIONS);
use Apache::File ();
use lib "$ENV{'LJHOME'}/cgi-bin";
use Apache::LiveJournal::PalImg;
use LJ::S2;
use LJ::Blob;
use Apache::LiveJournal::Interface::Blogger;
use Apache::LiveJournal::Interface::AtomAPI;
use Apache::LiveJournal::Interface::S2;
use LJR::GD;

BEGIN {
    $LJ::OPTMOD_ZLIB = eval "use Compress::Zlib (); 1;";
    $LJ::OPTMOD_XMLRPC = eval "use XMLRPC::Transport::HTTP (); 1;";

    require "$ENV{'LJHOME'}/cgi-bin/ljlib.pl";
    require "$ENV{'LJHOME'}/cgi-bin/ljviews.pl";
    require "$ENV{'LJHOME'}/cgi-bin/ljprotocol.pl";
    if (%LJ::FOTOBILDER_IP) {
        use Apache::LiveJournal::Interface::FotoBilder;
    }
}

my %RQ;       # per-request data
my %USERPIC;  # conf related to userpics
my %REDIR;
my $GTop;     # GTop object (created if $LJ::LOG_GTOP is true)

# Mapping of MIME types to image types understood by the blob functions.
my %MimeTypeMap = (
    'image/gif' => 'gif',
    'image/jpeg' => 'jpg',
    'image/png' => 'png',
);
my %MimeTypeMapd6 = (
    'G' => 'gif',
    'J' => 'jpg',
    'P' => 'png',
);

$USERPIC{'cache_dir'} = "$ENV{'LJHOME'}/htdocs/userpics";
$USERPIC{'use_disk_cache'} = -d $USERPIC{'cache_dir'};
$USERPIC{'symlink'} = eval { symlink('',''); 1; };

# redirect data.
foreach my $file ('redirect.dat', 'redirect-local.dat') {
    open (REDIR, "$ENV{'LJHOME'}/cgi-bin/$file") or next;
    while (<REDIR>) {
        next unless (/^(\S+)\s+(\S+)/);
        my ($src, $dest) = ($1, $2);
        $REDIR{$src} = $dest;
    }
    close REDIR;
}

my @req_hosts;  # client IP, and/or all proxies, real or claimed

# init handler (PostReadRequest)
sub handler
{
    my $r = shift;

    if ($LJ::SERVER_TOTALLY_DOWN) {
        $r->handler("perl-script");
        $r->set_handlers(PerlHandler => [ \&totally_down_content ]);
        return OK;
    }

    # only perform this once in case of internal redirects
    if ($r->is_initial_req) {
        $r->push_handlers(PerlCleanupHandler => sub { %RQ = () });
        $r->push_handlers(PerlCleanupHandler => "Apache::LiveJournal::db_logger");
        $r->push_handlers(PerlCleanupHandler => "LJ::end_request");

        if ($LJ::TRUST_X_HEADERS) {
            # if we're behind a lite mod_proxy front-end, we need to trick future handlers
            # into thinking they know the real remote IP address.  problem is, it's complicated
            # by the fact that mod_proxy did nothing, requiring mod_proxy_add_forward, then
            # decided to do X-Forwarded-For, then did X-Forwarded-Host, so we have to deal
            # with all permutations of versions, hence all the ugliness:
            @req_hosts = ($r->connection->remote_ip);
            if (my $forward = $r->header_in('X-Forwarded-For'))
            {
                my (@hosts, %seen);
                foreach (split(/\s*,\s*/, $forward)) {
                    next if $seen{$_}++;
                    push @hosts, $_;
                    push @req_hosts, $_;
                }
                if (@hosts) {
                    my $real = pop @hosts;
                    $r->connection->remote_ip($real);
                }
                $r->header_in('X-Forwarded-For', join(", ", @hosts));
            }

            # and now, deal with getting the right Host header
            if ($_ = $r->header_in('X-Host')) {
                $r->header_in('Host', $_);
            } elsif ($_ = $r->header_in('X-Forwarded-Host')) {
                $r->header_in('Host', $_);
            }
        }

        # reload libraries that might've changed
        if ($LJ::IS_DEV_SERVER) {
            my %to_reload;
            while (my ($file, $mod) = each %LJ::LIB_MOD_TIME) {
                my $cur_mod = (stat($file))[9];
                next if $cur_mod == $mod;
                $to_reload{$file} = 1;
            }
            my @key_del;
            foreach (my ($key, $file) = each %INC) {
                push @key_del, $key if $to_reload{$file};
            }
            delete $INC{$_} foreach @key_del;

            foreach my $file (keys %to_reload) {
                print STDERR "Reloading $file...\n";
                my $good = do $file;
                if ($good) {
                    $LJ::LIB_MOD_TIME{$file} = (stat($file))[9];
                } else {
                    die "Failed to reload module [$file] due to error: $@\n";
                }
            }
        }
    }

    $r->set_handlers(PerlTransHandler => [ \&trans ]);

    return OK;
}

sub redir
{
    my ($r, $url, $code) = @_;
    $r->content_type("text/html");
    $r->header_out(Location => $url);
    return $code || REDIRECT;
}

sub totally_down_content
{
    my $r = shift;
    my $uri = $r->uri;

    if ($uri =~ m!^/interface/flat! || $uri =~ m!^/cgi-bin/log\.cg!) {
        $r->content_type("text/plain");
        $r->send_http_header();
        $r->print("success\nFAIL\nerrmsg\n$LJ::SERVER_DOWN_MESSAGE");
        return OK;
    }

    if ($uri =~ m!^/customview.cgi!) {
        $r->content_type("text/html");
        $r->send_http_header();
        $r->print("<!-- $LJ::SERVER_DOWN_MESSAGE -->");
        return OK;
    }

    # FIXME: ljcom-specific, move to a hook; too lazy now.
    if ($uri =~ m!^/paidaccounts/pp_notify\.bml!) {
        $r->status(SERVER_ERROR);
    }

    $r->content_type("text/html");
    $r->send_http_header();
    $r->print("<h1>$LJ::SERVER_DOWN_SUBJECT</h1>$LJ::SERVER_DOWN_MESSAGE");
    return OK;
}

sub blocked_bot
{
    my $r = shift;

    $r->status_line("403 Denied");
    $r->content_type("text/html");
    $r->send_http_header();
    my $subject = $LJ::BLOCKED_BOT_SUBJECT || "403 Denied";
    my $message = $LJ::BLOCKED_BOT_MESSAGE || "You don't have permission to view this page.";
    $r->print("<h1>$subject</h1>$message");
    return OK;
}

sub trans
{
    my $r = shift;
    return DECLINED if ! $r->is_main || $r->method_number == M_OPTIONS;  # don't deal with subrequests or OPTIONS

    my $uri = $r->uri;
    my $args = $r->args;
    my $args_wq = $args ? "?$args" : "";
    my $host = $r->header_in("Host");
    my $hostport = ($host =~ s/:\d+$//) ? $& : "";

    # disable TRACE (so scripts on non-LJ domains can't invoke
    # a trace to get the LJ cookies in the echo)
    return FORBIDDEN if $r->method_number == M_TRACE;

    # If the configuration says to log statistics and GTop is available, mark
    # values before the request runs so it can be turned into a delta later
    if ( $LJ::LOG_GTOP && $LJ::HAVE_GTOP ) {
        $GTop ||= new GTop;
        $r->pnotes( 'gtop_cpu' => $GTop->cpu );
        $r->pnotes( 'gtop_mem' => $GTop->proc_mem($$) );
    }

    LJ::start_request();
    LJ::procnotify_check();
    S2::set_domain('LJ');

    my $is_ssl = $LJ::IS_SSL = LJ::run_hook("ssl_check", {
        r => $r,
    });

    # handle uniq cookies
    if ($LJ::UNIQ_COOKIES && $r->is_initial_req) {

        # if cookie exists, check for sysban
        my ($uniq, $uniq_time);
        if (Apache->header_in("Cookie") =~ /\bljuniq\s*=\s*([a-zA-Z0-9]{15}):(\d+)/) {
            ($uniq, $uniq_time) = ($1, $2);
            $r->notes("uniq" => $uniq);
            if (LJ::sysban_check('uniq', $uniq) && index($uri, $LJ::BLOCKED_BOT_URI) != 0) {
                $r->handler("perl-script");
                $r->push_handlers(PerlHandler => \&blocked_bot );
                return OK;
            };
        }

        # if no cookie, create one.  if older than a day, revalidate
        my $now = time();
        my $DAY = 3600*24;
        if (! $uniq || $now - $uniq_time > $DAY) {
            $uniq ||= LJ::rand_chars(15);

            # 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=$uniq:$now; " .
                                         "expires=" . LJ::time_to_cookie($now + $DAY*60) . "; " .
                                         ($dom ? "domain=$dom; " : "") . "path=/");
            }
        }
    }

    # only allow certain pages over SSL
    if ($is_ssl) {
        if ($uri =~ m!^/interface/!) {
            # handled later
        } elsif ($LJ::SSLDOCS && $uri !~ m!(\.\.|\%|\.\/)!) {
            my $file = "$LJ::SSLDOCS/$uri";
            unless (-e $file) {
                # no such file.  send them to the main server if it's a GET.
                return $r->method eq 'GET' ? redir($r, "$LJ::SITEROOT$uri$args_wq") : 404;
            }
            if (-d _) { $file .= "/index.bml"; }
            $file =~ s!/{2,}!/!g;
            $r->filename($file);
            $LJ::IMGPREFIX = "/img";
            $LJ::STATPREFIX = "/stc";
            return OK;
        }
        return FORBIDDEN;
    } else {
        $LJ::IMGPREFIX = $LJ::IMGPREFIX_BAK;
        $LJ::STATPREFIX = $LJ::STATPREFIX_BAK;
    }

    # let foo.com still work, but redirect to www.foo.com
    if ($LJ::DOMAIN_WEB && $r->method eq "GET" &&
        $host eq $LJ::DOMAIN && $LJ::DOMAIN_WEB ne $LJ::DOMAIN)
    {
        my $url = "$LJ::SITEROOT$uri";
        $url .= "?" . $args if $args;
        return redir($r, $url);
    }

    # check for sysbans on ip address
    foreach my $ip (@req_hosts) {
        if (LJ::sysban_check('ip', $ip) && index($uri, $LJ::BLOCKED_BOT_URI) != 0) {
            $r->handler("perl-script");
            $r->push_handlers(PerlHandler => \&blocked_bot );
            return OK;
        }
    }
    if (LJ::run_hook("forbid_request", $r) && index($uri, $LJ::BLOCKED_BOT_URI) != 0) {
        $r->handler("perl-script");
        $r->push_handlers(PerlHandler => \&blocked_bot );
        return OK;
    }

    # see if we should setup a minimal scheme based on the initial part of the
    # user-agent string; FIXME: maybe this should do more than just look at the
    # initial letters?
    if (my $ua = $r->header_in('User-Agent')) {
        if (($ua =~ /^([a-z]+)/i) && $LJ::MINIMAL_USERAGENT{$1}) {
            $r->notes('use_minimal_scheme' => 1);
            $r->notes('bml_use_scheme' => $LJ::MINIMAL_BML_SCHEME);
        }
    }

    # now we know that the request is going to succeed, so do some checking if they have a defined
    # referer.  clients and such don't, so ignore them.
    my $referer = $r->header_in("Referer");
    if ($referer && $r->method eq 'POST' && !LJ::check_referer('', $referer)) {
       $r->log_error("REFERER WARNING: POST to $uri from $referer");
    }

    my %GET = $r->args;

    # anti-squatter checking
    if ($LJ::ANTI_SQUATTER && $r->method eq "GET") {
        my $ref = $r->header_in("Referer");
        if ($ref && index($ref, $LJ::SITEROOT) != 0) {
            # FIXME: this doesn't anti-squat user domains yet
            if ($uri !~ m!^/404!) {
                # So hacky!  (see note below)
                $LJ::SQUAT_URL = "http://$host$hostport$uri$args_wq";
            } else {
                # then Apache's 404 handler takes over and we get here
                # FIXME: why??  why doesn't it just work to return OK
                # the first time with the handlers pushed?  nothing
                # else requires this chicanery!
                $r->handler("perl-script");
                $r->push_handlers(PerlHandler => \&anti_squatter);
            }
            return OK;
        }
    }

    my $bml_handler = sub {
        my $filename = shift;
        $r->handler("perl-script");
        $r->notes("bml_filename" => $filename);
#        $r->push_handlers(PerlHandler => \&Apache::BML::handler);
        return OK;
    };

    # is this the embed module host
    my $embed_host = $host;
    $embed_host = $r->header_in("X-Forwarded-Host")
      if $r->header_in("X-Forwarded-Host");
    if ($LJ::EMBED_MODULE_DOMAIN && $embed_host =~ /$LJ::EMBED_MODULE_DOMAIN/) {
        return $bml_handler->("$LJ::HOME/htdocs/tools/embedcontent.bml");
    }

    my $journal_view = sub {
        my $opts = shift;
        $opts ||= {};

        my $orig_user = $opts->{'user'};
        $opts->{'user'} = LJ::canonical_username($opts->{'user'});

        if ($opts->{'mode'} eq "info") {
            return redir($r, "$LJ::SITEROOT/userinfo.bml?user=$opts->{'user'}");
        }

        %RQ = %$opts;

        # redirect communities to /community/<name>
        my $u = LJ::load_user($opts->{'user'});
        if ($u && $u->{'journaltype'} eq "C" &&
            ($opts->{'vhost'} eq "" || $opts->{'vhost'} eq "tilde")) {
            my $newurl = $uri;
            $newurl =~ s!^/(users/|~)\Q$orig_user\E!!;
            $newurl = "$LJ::SITEROOT/community/$opts->{'user'}$newurl$args_wq";
            return redir($r, $newurl);
        }

        # redirect case errors in username
        if ($orig_user ne lc($orig_user)) {
            my $url = LJ::journal_base($opts->{'user'}, $opts->{'vhost'}) .
                "/$opts->{'mode'}$opts->{'pathextra'}$args_wq";
            return redir($r, $url);
        }

        if ($opts->{mode} eq "data" && $opts->{pathextra} =~ m!^/(\w+)(/.*)?!) {
            if (my $handler = LJ::run_hook("data_handler:$1", $RQ{'user'}, $2)) {
                $r->handler("perl-script");
                $r->push_handlers(PerlHandler => $handler);
                return OK;
            }
        }

        $r->handler("perl-script");
        $r->push_handlers(PerlHandler => \&journal_content);
        return OK;
    };

    my $determine_view = sub {
        my ($user, $vhost, $uuri) = @_;
        my $mode = undef;
        my $pe;

        if ($uuri =~ m#^/(\d+)\.html$#) {
            if ($GET{'mode'} eq "reply" || $GET{'replyto'}) {
                $mode = "reply";
            } else {
                $mode = "entry";
            }
        } elsif ($uuri =~ m#^/(\d+)\.htm$#) {
            return redir($r, "http://$host$hostport$uri" . "l");

        } elsif ($uuri =~ m#^/(\d\d\d\d)(?:/(\d\d)(?:/(\d\d))?)?(/?)$#) {
            my ($year, $mon, $day, $slash) = ($1, $2, $3, $4);
            # Year 2038 fix:
            if ($year < 1970 || $year > 2037) { #crash in some rare cases
                return 404;
            }
            unless ($slash) {
                return redir($r, "http://$host$hostport$uri/");
            }

            # the S1 ljviews code looks at $opts->{'pathextra'}, because
            # that's how it used to do it, when the pathextra was /day[/yyyy/mm/dd]
            $pe = $uuri;

            if (defined $day) {
                $mode = "day";
            } elsif (defined $mon) {
                $mode = "month";
            } else {
                $mode = "calendar";
            }

        } elsif ($uuri =~ m!
                 /([a-z\_]+)?           # optional /<viewname>
                 (.*)                   # path extra: /FriendGroup, for example
                 !x && ($1 eq "" || defined $LJ::viewinfo{$1})) {

            ($mode, $pe) = ($1, $2);
            $mode ||= "" unless length $pe;  # if no pathextra, then imply 'lastn'

            # redirect old-style URLs to new versions:
            if ($mode =~ /day|calendar/ && $pe =~ m!^/\d\d\d\d!) {
                my $newuri = $uri;
                $newuri =~ s!$mode/(\d\d\d\d)!$1!;
                return redir($r, "http://$host$hostport$newuri");
            } elsif ($mode eq 'rss') {
                # code 301: moved permanently, update your links.
                return redir($r, LJ::journal_base($user) . "/data/rss$args_wq", 301);
            } elsif ($mode eq 'pics' && $LJ::REDIRECT_ALLOWED{$LJ::FB_DOMAIN}) {
                # redirect to a user's gallery
                my $url = "$LJ::FB_SITEROOT/$user";
                return redir($r, $url);
            }
        } elsif (($vhost eq "users" || $vhost =~ /^other:/) &&
                 $uuri eq "/robots.txt") {
            $mode = "robots_txt";
        }

        return undef unless defined $mode;
        return $journal_view->({'vhost' => $vhost,
                                'mode' => $mode,
                                'args' => $args,
                                'pathextra' => $pe,
                                'user' => $user });
    };

    # flag if we hit a domain that was configured as a "normal" domain
    # which shouldn't be inspected for its domain name.  (for use with
    # Akamai and other CDN networks...)
    my $skip_domain_checks = 0;

    # user domains
    if ($LJ::USER_VHOSTS &&
        $host =~ /^([\w\-]{1,15})\.\Q$LJ::USER_DOMAIN\E$/ &&
        $1 ne "www" &&

        # 1xx: info, 2xx: success, 3xx: redirect, 4xx: client err, 5xx: server err
        # let the main server handle any errors
        $r->status < 400)
    {
        my $user = $1;

        # see if the "user" is really functional code
        my $func = $LJ::SUBDOMAIN_FUNCTION{$user};

        if ($func eq "normal") {
            # site admin wants this domain to be ignored and treated as if it
            # were "www", so set this flag so the custom "OTHER_VHOSTS" check
            # below fails.
            $skip_domain_checks = 1;

        } elsif ($uri =~ m!^/(?:talkscreen|delcomment)\.bml!) {
            # these URLs need to always work for the javascript comment management code
            # (JavaScript can't do cross-domain XMLHttpRequest calls)
            $skip_domain_checks = 1;

        } elsif ($func) {
            my $code = {
                'userpics' => \&userpic_trans,
                'files' => \&files_trans,
            };
            return $code->{$func}->($r) if $code->{$func};
            return 404;  # bogus ljconfig
        } else {
            my $view = $determine_view->($user, "users", $uri);
            return $view if defined $view;
            return 404;
        }
    }

    # custom used-specified domains
    if ($LJ::OTHER_VHOSTS && !$skip_domain_checks &&
        $host ne $LJ::DOMAIN_WEB &&
        $host ne $LJ::DOMAIN && $host =~ /\./ &&
        $host =~ /[^\d\.]/)
    {
        my $dbr = LJ::get_db_reader();
        my $checkhost = lc($host);
        $checkhost =~ s/^www\.//i;
        $checkhost = $dbr->quote($checkhost);
        # FIXME: memcache this?
        my $user = $dbr->selectrow_array(qq{
            SELECT u.user FROM useridmap u, domains d WHERE
            u.userid=d.userid AND d.domain=$checkhost
        });
        return 404 unless $user;

        my $view = $determine_view->($user, "other:$host$hostport", $uri);
        return $view if defined $view;
        return 404;
    }

    # userpic
    return userpic_trans($r) if $uri =~ m!^/userpic/!;

    # comments
    return comments_trans($r) if $uri =~ m!^/comments/!;

    # readable comments
    return numreplies_trans($r) if $uri =~ m!^/numreplies/!;

    # front page journal
    if ($LJ::FRONTPAGE_JOURNAL) {
        my $view = $determine_view->($LJ::FRONTPAGE_JOURNAL, "front", $uri);
        return $view if defined $view;
    }

    # normal (non-domain) journal view
    if (! $LJ::ONLY_USER_VHOSTS &&
        $uri =~ m!
        ^/(users\/|community\/|\~)  # users/community/tilde
        ([^/]*)                     # potential username
        (.*)?                       # rest
        !x)
    {
        my ($part1, $user, $rest) = ($1, $2, $3);

        # get what the username should be
        my $cuser = LJ::canonical_username($user);
        return DECLINED unless length($cuser);

        my $srest = $rest || '/';

        # redirect to canonical username and/or add slash if needed
        return redir($r, "http://$host$hostport/$part1$cuser$srest$args_wq")
            if $cuser ne $user or not $rest;

        my $vhost = { 'users/' => '', 'community/' => 'community',
                      '~' => 'tilde' }->{$part1};

        my $view = $determine_view->($user, $vhost, $rest);
        return $view if defined $view;
    }

    # protocol support
    if ($uri =~ m!^/(?:interface/(\w+))|cgi-bin/log\.cgi!) {
        my $int = $1 || "flat";
        $r->handler("perl-script");
        if ($int eq "fotobilder") {
            return 403 unless $LJ::FOTOBILDER_IP{$r->connection->remote_ip};
            $r->push_handlers(PerlHandler => \&Apache::LiveJournal::Interface::FotoBilder::handler);
            return OK;
        }
        if ($int =~ /^flat|xmlrpc|blogger|atom(?:api)?$/) {
            $RQ{'interface'} = $int;
            $RQ{'is_ssl'} = $is_ssl;
            $r->push_handlers(PerlHandler => \&interface_content);
            return OK;
        }
        if ($int eq "s2") {
            $r->push_handlers(PerlHandler => \&Apache::LiveJournal::Interface::S2::handler);
            return OK;
        }
        return 404;
    }

    # customview
    if ($uri =~ m!^/customview\.cgi!) {
        $r->handler("perl-script");
        $r->push_handlers(PerlHandler => \&customview_content);
        return OK;
    }

    if ($uri =~ m!^/palimg/!) {
        $r->handler("perl-script");
        $r->push_handlers(PerlHandler => \&Apache::LiveJournal::PalImg::handler);
        return OK;
    }

    # redirected resources
    if ($REDIR{$uri}) {
        my $new = $REDIR{$uri};
        if ($r->args) {
            $new .= ($new =~ /\?/ ? "&" : "?");
            $new .= $r->args;
        }
        return redir($r, $new, HTTP_MOVED_PERMANENTLY);
    }

    # confirm
    if ($uri =~ m!^/confirm/(\w+\.\w+)!) {
        return redir($r, "$LJ::SITEROOT/register.bml?$1");
    }

    # approve
    if ($uri =~ m!^/approve/(\w+\.\w+)!) {
        return redir($r, "$LJ::SITEROOT/approve.bml?$1");
    }

    return FORBIDDEN if $uri =~ m!^/userpics! || $uri =~ m!^/comments! || $uri =~ m!^/numreplies!;
    return DECLINED;
}

sub numreplies_trans {
    my $r = shift;

    #readable comments url:  /numreplies/ljr_todo/35616
    return NOT_FOUND unless $r->uri =~ m!^/(?:numreplies/)?(.*)/(\d+)$!;
    my ($user, $ditemid) = ($1, $2);

    # Load the user object and make sure talk is viewable
    my $u = LJ::load_user($user);
    return NOT_FOUND unless $u && $u->{'statusvis'} !~ /[XS]/;

    my $itemid = $ditemid>>8;
    my $row = LJ::get_log2_row($u, $itemid);
    return NOT_FOUND unless $row;

    my $new = "$LJ::SITEROOT/comments/$itemid/$u->{userid}";
    return redir($r, $new, HTTP_MOVED_PERMANENTLY);
}

sub comments_trans {
    my $r = shift;
    
    return NOT_FOUND unless $r->uri =~ m!^/(?:comments/)?(\d+)/(\d+)$!;
    my ($itemid, $userid) = ($1, $2);

    $RQ{'itemid'} = $itemid;
    $RQ{'itemid-userid'} = $userid;

    $r->notes("codepath" => "img.comments");
    $r->handler("perl-script");
    $r->push_handlers(PerlHandler => \&comments_content);

    return OK;
}

sub comments_content {
    my $r = shift;

    my $itemid = $RQ{'itemid'};
    my $userid = $RQ{'itemid-userid'}+0;

    my $lastmod;
    my $mime = "image/png";
    my $size;
    my $now = time();
    # nginx use memcache directly, so avoid calculation - 60s is OK.
    my $expires = 60;

    my $send_headers = sub {

        $r->content_type($mime);
        $r->header_out("Cache-Control", "max-age=$expires, must-revalidate, no-transform");
        $r->header_out("Last-Modified", LJ::time_to_http($lastmod));
        $r->header_out("Expires", LJ::time_to_http($now + $expires));
        $r->header_out("Content-length", $size+0);
        $r->send_http_header();
    };
    
    # Load the user object and pic and make sure the picture is viewable
    my $u = LJ::load_userid($userid);
    return NOT_FOUND unless $u && $u->{'statusvis'} !~ /[XS]/;
    
    my $row = LJ::get_log2_row($u, $itemid);
    $lastmod = LJ::mysqldate_to_time($row->{'logtime'}, 0) if $row && $row->{'logtime'};
    
    my $count = LJ::Talk::get_replycount($u, $itemid);
    
    my $dbr = LJ::get_db_reader();
    my ($font, $color, $ljr_es_lastmod) = $dbr->selectrow_array(
      "SELECT font_name, font_color, UNIX_TIMESTAMP(update_time) FROM ljr_export_settings WHERE user=?",
      undef, $u->{'user'});
    
    $font = "gdLargeFont" unless $font;
    $color = "blue" unless $color;
    
    if ($ljr_es_lastmod) {
      $lastmod = $ljr_es_lastmod unless $lastmod;
    }
    $lastmod = $now - 3600 * 24 * 31 unless $lastmod; # month
    
    my $img = LJR::GD::generate_number($count, $font, $color, "   ");
    my $data = $img->png;
    $size = length($data);
    $send_headers->();
    LJ::MemCache::set($r->uri, $data); #used by nginx! (NB!) $size < $MEMCACHE_COMPRESS_THRESHOLD. cleared in replycount_do()
    $r->print($data) unless $r->header_only;
    return OK;
}

sub userpic_trans
{
    my $r = shift;
    return 404 unless $r->uri =~ m!^/(?:userpic/)?(\d+)/(\d+)$!;
    my ($picid, $userid) = ($1, $2);

    $r->notes("codepath" => "img.userpic");

    # we can safely do this without checking since we never re-use
    # picture IDs and don't let the contents get modified
    return HTTP_NOT_MODIFIED if $r->header_in('If-Modified-Since');

    $RQ{'picid'} = $picid;
    $RQ{'pic-userid'} = $userid;

    if ($USERPIC{'use_disk_cache'}) {
        my @dirs_make;
        my $file;

        if ($picid =~ /^\d*(\d\d)(\d\d\d)$/) {
            push @dirs_make, ("$USERPIC{'cache_dir'}/$2",
                              "$USERPIC{'cache_dir'}/$2/$1");
            $file = "$USERPIC{'cache_dir'}/$2/$1/$picid-$userid";
        } else {
            my $mod = sprintf("%03d", $picid % 1000);
            push @dirs_make, "$USERPIC{'cache_dir'}/$mod";
            $file = "$USERPIC{'cache_dir'}/$mod/p$picid-$userid";
        }

        foreach (@dirs_make) {
            next if -d $_;
            mkdir $_, 0777;
        }

        # set both, so we can compared later if they're the same,
        # and thus know if directories were created (if not,
        # apache will give us a pathinfo)
        $RQ{'userpicfile'} = $file;
        $r->filename($file);
    }

    $r->handler("perl-script");
    $r->push_handlers(PerlHandler => \&userpic_content);
    return OK;
}

sub userpic_content
{
    my $r = shift;
    my $file = $r->filename;

    my $picid = $RQ{'picid'};
    my $userid = $RQ{'pic-userid'}+0;

    # will we try to use disk cache?
    my $disk_cache = $USERPIC{'use_disk_cache'} &&
        $file eq $RQ{'userpicfile'};

    my ($data, $lastmod);
    my $need_cache;

    my $mime = "image/jpeg";
    my $set_mime = sub {
        my $data = shift;
        if ($data =~ /^GIF/) { $mime = "image/gif"; }
        elsif ($data =~ /^\x89PNG/) { $mime = "image/png"; }
    };
    my $size;

    my $send_headers = sub {
        $r->content_type($mime);
        $r->header_out("Content-length", $size+0);
        $r->header_out("Cache-Control", "no-transform");
        $r->header_out("Last-Modified", LJ::time_to_http($lastmod));
        $r->send_http_header();
    };

    # Load the user object and pic and make sure the picture is viewable
    my $u = LJ::load_userid($userid);
    return NOT_FOUND unless $u && $u->{'statusvis'} !~ /[XS]/;

    my %upics;
    LJ::load_userpics(\%upics, [ $u, $picid ]);
    my $pic = $upics{$picid} or return NOT_FOUND;
    return NOT_FOUND if $pic->{'userid'} != $userid || $pic->{state} eq 'X';

    # Read the mimetype from the pichash if dversion 7
    $mime = { 'G' => 'image/gif',
              'J' => 'image/jpeg',
              'P' => 'image/png', }->{$pic->{fmt}};

    ### Handle reproxyable requests

    # For dversion 7+ and mogilefs userpics, follow this path
    if ($pic->{location} eq 'M' ) {  # 'M' for mogilefs
        my $key = $u->mogfs_userpic_key( $picid );

        if ( !$LJ::REPROXY_DISABLE{userpics} &&
             $r->header_in('X-Proxy-Capabilities') &&
             $r->header_in('X-Proxy-Capabilities') =~ m{\breproxy-file\b}i )
        {
            my $memkey = [$picid, "mogp.up.$picid"];

            my $zone = $r->header_in('X-MogileFS-Explicit-Zone') || undef;
            $memkey->[1] .= ".$zone" if $zone;
            
            my $paths = LJ::MemCache::get($memkey);
            unless ($paths) {
                my @paths = LJ::mogclient()->get_paths( $key, { noverify => 1, zone => $zone });
                $paths = \@paths;
                LJ::MemCache::add($memkey, $paths, 3600) if @paths;
            }

            # reproxy url
            if ($paths->[0] =~ m/^http:/) {
                $r->header_out('X-REPROXY-URL', join(' ', @$paths));
            }

            # reproxy file
            else {
                $r->header_out('X-REPROXY-FILE', $paths->[0]);
            }

            $send_headers->();
        }

        else {
            my $data = LJ::mogclient()->get_file_data( $key );
            return NOT_FOUND unless $data;
            $size = length $$data;
            $send_headers->();
            $r->print( $$data ) unless $r->header_only;
        }

        return OK;
    }

    # dversion < 7 reproxy file path
    if ( !$LJ::REPROXY_DISABLE{userpics} &&
         exists $LJ::PERLBAL_ROOT{userpics} &&
         $r->header_in('X-Proxy-Capabilities') &&
         $r->header_in('X-Proxy-Capabilities') =~ m{\breproxy-file\b}i )
    {
        my (
            $root,
            $fmt,
            $path,
           );

        # Get the blobroot and load the pic hash
        $root = $LJ::PERLBAL_ROOT{userpics};

        # sometimes we don't want to reproxy userpics
        unless ($LJ::USERPIC_REPROXY_DISABLE{$u->{clusterid}}) {
            # Now ask the blob lib for the path to send to the reproxy
            $fmt = ($u->{'dversion'} > 6) ? $MimeTypeMapd6{ $pic->{fmt} } : $MimeTypeMap{ $pic->{contenttype} };
            $path = LJ::Blob::get_rel_path( $root, $u, "userpic", $fmt, $picid );

            $r->header_out( 'X-REPROXY-FILE', $path );
            $send_headers->();

            return OK;
        }
    }

    # try to get it from disk if in disk-cache mode
    if ($disk_cache) {
        if (-s $r->finfo) {
            $lastmod = (stat _)[9];
            $size = -s _;
            my $fh = Apache::File->new($file);
            my $magic;
            read($fh, $magic, 4);
            $set_mime->($magic);
            $send_headers->();
            $r->print($magic);
            $r->send_fd($fh);
            $fh->close();
            return OK;
        } else {
            $need_cache = 1;
        }
    }

    # else, get it from db.
    unless ($data) {
        $lastmod = $pic->{'picdate'};

        if ($LJ::USERPIC_BLOBSERVER) {
            my $fmt = ($u->{'dversion'} > 6) ? $MimeTypeMapd6{ $pic->{fmt} } : $MimeTypeMap{ $pic->{contenttype} };
            $data = LJ::Blob::get($u, "userpic", $fmt, $picid);
        }

        unless ($data) {
            my $dbb = LJ::get_cluster_reader($u);
            return SERVER_ERROR unless $dbb;
            $data = $dbb->selectrow_array("SELECT imagedata FROM userpicblob2 WHERE ".
                                          "userid=$pic->{'userid'} AND picid=$picid");
        }
    }

    return NOT_FOUND unless $data;

    if ($need_cache) {
        # make $realfile /userpic-userid, and $file /userpic
        my $realfile = $file;
        unless ($file =~ s/-\d+$//) {
            $realfile .= "-$pic->{'userid'}";
        }

        # delete short file on Unix if it exists
        unlink $file if $USERPIC{'symlink'} && -f $file;

        # write real file.
        open (F, ">$realfile"); print F $data; close F;

        # make symlink, or duplicate file (if on Windows)
        my $symtarget = $realfile;  $symtarget =~ s!.+/!!;
        unless (eval { symlink($symtarget, $file) }) {
            open (F, ">$file"); print F $data; close F;
        }
    }

    $set_mime->($data);
    $size = length($data);
    $send_headers->();
    $r->print($data) unless $r->header_only;
    return OK;
}

sub files_trans
{
    my $r = shift;
    return 404 unless $r->uri =~ m!^/(\w{1,15})/(\w+)(/\S+)!;
    my ($user, $domain, $rest) = ($1, $2, $3);

    if (my $handler = LJ::run_hook("files_handler:$domain", $user, $rest)) {
        $r->notes("codepath" => "files.$domain");
        $r->handler("perl-script");
        $r->push_handlers(PerlHandler => $handler);
        return OK;
    }
    return 404;
}

sub journal_content
{
    my $r = shift;
    my $uri = $r->uri;

    my %GET = $r->args;

    if ($RQ{'mode'} eq "robots_txt")
    {
        my $u = LJ::load_user($RQ{'user'});
        LJ::load_user_props($u, "opt_blockrobots");
        $r->content_type("text/plain");
        $r->send_http_header();
        $r->print("User-Agent: *\n");
        if ($u->{'opt_blockrobots'}) {
            $r->print("Disallow: /\n");
        }
        return OK;
    }

    # handle HTTP digest authentication
    if ($GET{'auth'} eq 'digest' ||
        $r->header_in("Authorization") =~ /^Digest/) {
        my $res = LJ::auth_digest($r);
        unless ($res) {
            $r->content_type("text/html");
            $r->send_http_header();
            $r->print("<b>Digest authentication failed.</b>");
            return OK;
        }
    }

    my $criterr = 0;
    my $remote = LJ::get_remote({ criterr => \$criterr });

    # check for faked cookies here, since this is pretty central.
    if ($criterr) {
        $r->status_line("500 Invalid Cookies"); # client error, in fact
        $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';
            Apache->request->err_headers_out->add('Set-Cookie' => $cookiestr);
        }

        $r->send_http_header();
        $r->print("Invalid cookies.  Try <a href='$LJ::SITEROOT/logout.bml'>logging out</a> and then logging back in.\n");
        $r->print("<!-- xxxxxxxxxxxxxxxxxxxxxxxx -->\n") for (0..100);
        return OK;
    }

    # LJ::make_journal() will set this flag if the user's
    # style system is unable to handle the requested
    # view (S1 can't do EntryPage or MonthPage), in which
    # case it's our job to invoke the legacy BML page.
    my $handle_with_bml = 0;

    my %headers = ();
    my $opts = {
        'r' => $r,
        'headers' => \%headers,
        'args' => $RQ{'args'},
        'getargs' => \%GET,
        'vhost' => $RQ{'vhost'},
        'pathextra' => $RQ{'pathextra'},
        'handle_with_bml_ref' => \$handle_with_bml,
    };

    my $user = $RQ{'user'};
    my $html = LJ::make_journal($user, $RQ{'mode'}, $remote, $opts);

    return HTTP_NOT_MODIFIED if $opts->{'notmodified'};
    return redir($r, $opts->{'redir'}) if $opts->{'redir'};
    return $opts->{'handler_return'} if defined $opts->{'handler_return'};

    # if LJ::make_journal() indicated it can't handle the request:
    if ($handle_with_bml) {
        my $args = $r->args;
        my $args_wq = $args ? "?$args" : "";

        # can't show BML on user domains... redirect them
        if ($RQ{'vhost'} eq "users" && ($RQ{'mode'} eq "entry" ||
                                        $RQ{'mode'} eq "reply" ||
                                        $RQ{'mode'} eq "month"))
        {
            my $u = LJ::load_user($RQ{'user'});
            my $base = "$LJ::SITEROOT/users/$RQ{'user'}";
            $base = "$LJ::SITEROOT/community/$RQ{'user'}" if $u && $u->{'journaltype'} eq "C";
            return redir($r, "$base$uri$args_wq");
        }

        if ($RQ{'mode'} eq "entry" || $RQ{'mode'} eq "reply") {
            my $filename = $RQ{'mode'} eq "entry" ?
                "$LJ::HOME/htdocs/talkread.bml" :
                "$LJ::HOME/htdocs/talkpost.bml";
            $r->notes("_journal" => $RQ{'user'});
            $r->notes("bml_filename" => $filename);
            return Apache::BML::handler($r);
        }

        if ($RQ{'mode'} eq "month") {
            my $filename = "$LJ::HOME/htdocs/view/index.bml";
            $r->notes("_journal" => $RQ{'user'});
            $r->notes("bml_filename" => $filename);
            return Apache::BML::handler($r);
        }
    }

    my $status = $opts->{'status'} || "200 OK";
    $opts->{'contenttype'} ||= $opts->{'contenttype'} = "text/html";
    if ($opts->{'contenttype'} =~ m!^text/! &&
        $LJ::UNICODE && $opts->{'contenttype'} !~ /charset=/) {
        $opts->{'contenttype'} .= "; charset=utf-8";
    }

    # Set to 1 if the code should generate junk to help IE
    # display a more meaningful error message.
    my $generate_iejunk = 0;

    if ($opts->{'badargs'})
    {
        # No special information to give to the user, so just let
        # Apache handle the 404
        return 404;
    }
    elsif ($opts->{'baduser'})
    {
        $status = "404 Unknown User";
        $html = "<h1>Unknown User</h1><p>There is no user <b>$user</b> at $LJ::SITENAME.</p>";
        $generate_iejunk = 1;
    }
    elsif ($opts->{'badfriendgroup'})
    {
        # give a real 404 to the journal owner
        if ($remote && $remote->{'user'} eq $user) {
            $status = "404 Friend group does not exist";
            $html = "<h1>Not Found</h1>" .
                    "<p>The friend group you are trying to access does not exist.</p>";

        # otherwise be vague with a 403
        } else {
            # send back a 403 and don't reveal if the group existed or not
            $status = "403 Friend group does not exist, or is not public";
            $html = "<h1>Denied</h1>" .
                    "<p>Sorry, the friend group you are trying to access does not exist " .
                    "or is not public.</p>\n";

            $html .= "<p>You're not logged in.  If you're the owner of this journal, " .
                     "<a href='$LJ::SITEROOT/login.bml'>log in</a> and try again.</p>\n"
                         unless $remote;
        }

        $generate_iejunk = 1;

    } elsif ($opts->{'suspendeduser'}) {
        $status = "403 User suspended";
        $html = "<h1>Suspended User</h1>" .
                "<p>The content at this URL is from a suspended user.</p>";

        $generate_iejunk = 1;
    }

    unless ($html) {
        $status = "400 Bad Template";
        $html = "<h1>Error</h1><p>User <b>$user</b> has messed up their journal template definition.</p>";
        $generate_iejunk = 1;
    }

    $r->status_line($status);
    foreach my $hname (keys %headers) {
        if (ref($headers{$hname}) && ref($headers{$hname}) eq "ARRAY") {
            foreach (@{$headers{$hname}}) {
                $r->header_out($hname, $_);
            }
        } else {
            $r->header_out($hname, $headers{$hname});
        }
    }

    $r->content_type($opts->{'contenttype'});
    $r->header_out("Cache-Control", "private, proxy-revalidate") unless $opts->{'cachecontrol'};
    $r->header_out("Cache-Control", $opts->{'cachecontrol'}) if $opts->{'cachecontrol'};

    $html .= ("<!-- xxxxxxxxxxxxxxxxxxxxxxxxxxxx -->\n" x 100) if $generate_iejunk;

    unless ($generate_iejunk) {
        my $etag;
        $etag = Digest::MD5::md5_hex(pack('C*', unpack('C*', $html)));
        $etag = '"' . $etag . '"';
        $r->header_out("ETag", $etag);
    }

    my $length = length($html);
    $r->header_out("Content-length", $length);
    $r->send_http_header();
    $r->print($html) unless $r->header_only;

    return OK;
}

sub customview_content
{
    my $r = shift;

    my %FORM = $r->args;

    my $charset = "utf-8";

    if ($LJ::UNICODE && $FORM{'charset'}) {
        $charset = $FORM{'charset'};
        if ($charset ne "utf-8" && ! Unicode::MapUTF8::utf8_supported_charset($charset)) {
            $r->content_type("text/html");
            $r->send_http_header();
            $r->print("<b>Error:</b> requested charset not supported.");
            return OK;
        }
    }

    my $ctype = "text/html";
    if ($FORM{'type'} eq "xml") {
        $ctype = "text/xml";
    }

    if ($LJ::UNICODE) {
        $ctype .= "; charset=$charset";
    }

    $r->content_type($ctype);

    my $user = $FORM{'username'} || $FORM{'user'};
    my $styleid = $FORM{'styleid'} + 0;
    my $nooverride = $FORM{'nooverride'} ? 1 : 0;

    my $remote;
    if ($FORM{'checkcookies'}) {
        $remote = LJ::get_remote();
    }

    my $opts =   { "nocache" => $FORM{'nocache'},
                   "vhost" => "customview",
                   "nooverride" => $nooverride,
                   "styleid" => $styleid,
                   "saycharset" => $charset,
                   "args" => scalar $r->args,
                   "getargs" => \%FORM,
                   "r" => $r,
               };
	       
    my $data = (LJ::make_journal($user, "", $remote, $opts)
          || "<b>[$LJ::SITENAME: Bad username, styleid, or style definition]</b>");

    return HTTP_NOT_MODIFIED if $opts->{'notmodified'};

    if ($FORM{'enc'} eq "js") {
        $data =~ s/\\/\\\\/g;
        $data =~ s/\"/\\\"/g;
        $data =~ s/\n/\\n/g;
        $data =~ s/\r//g;
        $data = "document.write(\"$data\")";
    }

    if ($LJ::UNICODE && $charset ne 'utf-8') {
        $data = Unicode::MapUTF8::from_utf8({-string=>$data, -charset=>$charset});
    }

    $r->header_out("Cache-Control", "must-revalidate");
    $r->header_out("Content-Length", length($data));
    $r->send_http_header();
    $r->print($data) unless $r->header_only;
    return OK;
}

sub interface_content
{
    my $r = shift;
    my $args = $r->args;

    if ($RQ{'interface'} eq "xmlrpc") {
        return 404 unless $LJ::OPTMOD_XMLRPC;
        my $server = XMLRPC::Transport::HTTP::Apache
            -> on_action(sub { die "Access denied\n" if $_[2] =~ /:|\'/ })
            -> dispatch_to('LJ::XMLRPC')
            -> handle($r);
        return OK;
    }

    if ($RQ{'interface'} eq "blogger") {
        return 404 unless $LJ::OPTMOD_XMLRPC;
    my $pkg = "Apache::LiveJournal::Interface::Blogger";
        my $server = XMLRPC::Transport::HTTP::Apache
            -> on_action(sub { die "Access denied\n" if $_[2] =~ /:|\'/ })
            -> dispatch_with({ 'blogger' => $pkg })
            -> dispatch_to($pkg)
            -> handle($r);
        return OK;
    }

    if ($RQ{'interface'} =~ /atom(?:api)?/) {
        # the interface package will set up all headers and
        # print everything
        Apache::LiveJournal::Interface::AtomAPI::handle($r);
        return OK;
    }

    if ($RQ{'interface'} ne "flat") {
        $r->content_type("text/plain");
        $r->send_http_header;
        $r->print("Unknown interface.");
        return OK;
    }

    $r->content_type("text/plain");

    my %out = ();
    my %FORM = ();
    my $content;
    $r->read($content, $r->header_in("Content-Length"));
    LJ::decode_url_string($content, \%FORM);

    # the protocol needs the remote IP in just one place, where tracking is done.
    $ENV{'_REMOTE_IP'} = $r->connection()->remote_ip();
    LJ::do_request(\%FORM, \%out);

    if ($FORM{'responseenc'} eq "urlenc") {
        $r->send_http_header;
        foreach (sort keys %out) {
            $r->print(LJ::eurl($_) . "=" . LJ::eurl($out{$_}) . "&");
        }
        return OK;
    }

    my $length = 0;
    foreach (sort keys %out) {
        $length += length($_)+1;
        $length += length($out{$_})+1;
    }

    $r->header_out("Content-length", $length);
    $r->send_http_header;
    foreach (sort keys %out) {
        my $key = $_;
        my $val = $out{$_};
        $key =~ y/\r\n//d;
        $val =~ y/\r\n//d;
        $r->print($key, "\n", $val, "\n");
        if ($key ne $_ || $val ne $out{$_}) {
            print STDERR "Stripped spurious newline in $FORM{mode} protocol request for $FORM{user}: $_ => $out{$_}\n";
        }
    }

    return OK;
}

sub db_logger
{
    my $r = shift;
    my $rl = $r->last;

    $r->pnotes('did_lj_logging' => 1);

    my $uri = $r->uri;
    my $ctype = $rl->content_type;

    return if $ctype =~ m!^image/! and $LJ::DONT_LOG_IMAGES;
    return if $uri =~ m!^/(img|userpic)/! and $LJ::DONT_LOG_IMAGES;
    return if $uri =~ m!^/(comments)/! and $LJ::DONT_LOG_IMAGES;

    my $dbl = LJ::get_dbh("logs");
    my @dinsertd_socks;

    my $now = time;
    my @now = localtime($now);

    foreach my $hostport (@LJ::DINSERTD_HOSTS) {
        next if $LJ::CACHE_DINSERTD_DEAD{$hostport} > $now - 15;

        my $sock =
            $LJ::CACHE_DINSERTD_SOCK{$hostport} ||=
            IO::Socket::INET->new(PeerAddr => $hostport,
                                  Proto    => 'tcp',
                                  Timeout  => 1,
                                  );

        if ($sock) {
            delete $LJ::CACHE_DINSERTD_DEAD{$hostport};
            push @dinsertd_socks, [ $hostport, $sock ];
        } else {
            delete $LJ::CACHE_DINSERTD_SOCK{$hostport};
            $LJ::CACHE_DINSERTD_DEAD{$hostport} = $now;
        }
    }

    # why go on if we have nowhere to log to?
    return unless $dbl || @dinsertd_socks;

    $ctype =~ s/;.*//;  # strip charset

    # Send out DBI profiling information
    if ( $LJ::DB_LOG_HOST && $LJ::HAVE_DBI_PROFILE ) {
        my ( $host, $dbh );

        while ( ($host,$dbh) = each %LJ::DB_REPORT_HANDLES ) {
            $host =~ s{^(.*?);.*}{$1};

            # For testing: append a random character to simulate different
            # connections.
            if ( $LJ::IS_DEV_SERVER ) {
                $host .= "_" . substr( "abcdefghijklmnopqrstuvwxyz", int rand(26), 1 );
            }

            # From DBI::Profile:
            #   Profile data is stored at the `leaves' of the tree as references
            #   to an array of numeric values. For example:
            #   [
            #     106,                    # count
            #     0.0312958955764771,     # total duration
            #     0.000490069389343262,   # first duration
            #     0.000176072120666504,   # shortest duration
            #     0.00140702724456787,    # longest duration
            #     1023115819.83019,       # time of first event
            #     1023115819.86576,       # time of last event
            #   ]

            # The leaves are stored as values in the hash keyed by statement
            # because LJ::get_dbirole_dbh() sets the profile to
            # "2/DBI::Profile". The 2 part is the DBI::Profile magic number
            # which means split the times by statement.
            my $data = $dbh->{Profile}{Data};

            # Make little arrayrefs out of the statement and longest
            # running-time for this handle so they can be sorted. Then sort them
            # by running-time so the longest-running one can be send to the
            # stats collector.
            my @times =
                sort { $a->[0] <=> $b->[0] }
                map  {[ $data->{$_}[4], $_ ]} keys %$data;

            # ( host, class, time, notes )
            LJ::blocking_report( $host, 'db', @{$times[0]} );
        }
    }

    my $table = sprintf("access%04d%02d%02d%02d", $now[5]+1900,
                        $now[4]+1, $now[3], $now[2]);

    unless ($LJ::CACHED_LOG_CREATE{"$table"}++) {
        my $sql = "(".
                 "whn TIMESTAMP(14) NOT NULL,".
                 "INDEX(whn),".
                 "server VARCHAR(30),".
                 "addr VARCHAR(15) NOT NULL,".
                 "ljuser VARCHAR(15),".
                 "journalid INT UNSIGNED,". # userid of what's being looked at
                 "codepath VARCHAR(80),".  # protocol.getevents / s[12].friends / bml.update / bml.friends.index
                 "anonsess INT UNSIGNED,".
                 "langpref VARCHAR(5),".
                 "uniq VARCHAR(15),".
                 "method VARCHAR(10) NOT NULL,".
                 "uri VARCHAR(255) NOT NULL,".
                 "args VARCHAR(255),".
                 "status SMALLINT UNSIGNED NOT NULL,".
                 "ctype VARCHAR(30),".
                 "bytes MEDIUMINT UNSIGNED NOT NULL,".
                 "browser VARCHAR(100),".
                 "clientver VARCHAR(100),".
                 "secs TINYINT UNSIGNED,".
                 "ref VARCHAR(200),".
                 "pid SMALLINT UNSIGNED,".
                 "cpu_user FLOAT UNSIGNED,".
                 "cpu_sys FLOAT UNSIGNED,".
                 "cpu_total FLOAT UNSIGNED,".
                 "mem_vsize INT,".
                 "mem_share INT,".
                 "mem_rss INT,".
                 "mem_unshared INT) DELAY_KEY_WRITE = 1";

        if ($dbl) {
            $dbl->do("CREATE TABLE IF NOT EXISTS $table $sql");
            $r->log_error("error creating log table ($table), perhaps due to old MySQL not supporting delayed key writes?  Error is: " .
                          $dbl->errstr) if $dbl->err;
        }

        foreach my $rec (@dinsertd_socks) {
            my $sock = $rec->[1];
            my $url = LJ::eurl("CREATE TABLE IF NOT EXISTS [tablename] $sql");
            print $sock "SET_NOTE lj_create_table $url\r\n";
            my $res = <$sock>;
        }
    }

    my $var = {
        'whn' => sprintf("%04d%02d%02d%02d%02d%02d", $now[5]+1900, $now[4]+1, @now[3, 2, 1, 0]),
        'server' => $LJ::SERVER_NAME,
        'addr' => $r->connection->remote_ip,
        'ljuser' => $rl->notes('ljuser'),
        'journalid' => $rl->notes('journalid'),
        'codepath' => $rl->notes('codepath'),
        'anonsess' => $rl->notes('anonsess'),
        'langpref' => $rl->notes('langpref'),
        'clientver' => $rl->notes('clientver'),
        'uniq' => $r->notes('uniq'),
        'method' => $r->method,
        'uri' => $uri,
        'args' => scalar $r->args,
        'status' => $rl->status,
        'ctype' => $ctype,
        'bytes' => $rl->bytes_sent,
        'browser' => $r->header_in("User-Agent"),
        'secs' => $now - $r->request_time(),
        'ref' => $r->header_in("Referer"),
    };

    # If the configuration says to log statistics and GTop is available, then
    # add those data to the log
    # The GTop object is only created once per child:
    #   Benchmark: timing 10000 iterations of Cached GTop, New Every Time...
    #   Cached GTop: 2.06161 wallclock secs ( 1.06 usr +  0.97 sys =  2.03 CPU) @ 4926.11/s (n=10000)
    #   New Every Time: 2.17439 wallclock secs ( 1.18 usr +  0.94 sys =  2.12 CPU) @ 4716.98/s (n=10000)
  STATS: {
        if ( $LJ::LOG_GTOP && $LJ::HAVE_GTOP ) {
            $GTop ||= new GTop or last STATS;

            my $startcpu = $r->pnotes( 'gtop_cpu' ) or last STATS;
            my $endcpu = $GTop->cpu                 or last STATS;
            my $startmem = $r->pnotes( 'gtop_mem' ) or last STATS;
            my $endmem = $GTop->proc_mem( $$ )      or last STATS;
            my $cpufreq = $endcpu->frequency        or last STATS;

            # Map the GTop values into the corresponding fields in a slice
            @$var{qw{pid cpu_user cpu_sys cpu_total mem_vsize mem_share mem_rss mem_unshared}} = (
                $$,
                ($endcpu->user - $startcpu->user) / $cpufreq,
                ($endcpu->sys - $startcpu->sys) / $cpufreq,
                ($endcpu->total - $startcpu->total) / $cpufreq,
                $endmem->vsize - $startmem->vsize,
                $endmem->share - $startmem->share,
                $endmem->rss - $startmem->rss,
                $endmem->size - $endmem->share,
               );
        }
    }

    if ($dbl) {
        my $delayed = $LJ::IMMEDIATE_LOGGING ? "" : "DELAYED";
        $dbl->do("INSERT $delayed INTO $table (" . join(',', keys %$var) . ") ".
                 "VALUES (" . join(',', map { $dbl->quote($var->{$_}) } keys %$var) . ")");

        $dbl->disconnect if $LJ::DISCONNECT_DB_LOG;
    }

    if (@dinsertd_socks) {
        $var->{_table} = $table;
        my $string = "INSERT " . Storable::nfreeze($var) . "\r\n";
        my $len = "\x01" . substr(pack("N", length($string) - 2), 1, 3);
        $string = $len . $string;

        foreach my $rec (@dinsertd_socks) {
            my $sock = $rec->[1];
            print $sock $string;
            my $rin;
            my $res;
            vec($rin, fileno($sock), 1) = 1;
            $res = <$sock> if select($rin, undef, undef, 0.3);
            delete $LJ::CACHE_DINSERTD_SOCK{$rec->[0]} unless $res =~ /^OK\b/;
        }
    }


    # Now clear the profiling data for each handle we're profiling at the last
    # possible second to avoid the next request's data being skewed by
    # requests that happen above.
    if ( $LJ::DB_LOG_HOST && $LJ::HAVE_DBI_PROFILE ) {
        for my $dbh ( values %LJ::DB_REPORT_HANDLES ) {
            # DBI::Profile-recommended way of resetting profile data
            $dbh->{Profile}{Data} = undef;
        }
        %LJ::DB_REPORT_HANDLES = ();
    }
}


sub anti_squatter
{
    my $r = shift;
    $r->push_handlers(PerlHandler => sub {
        my $r = shift;
        $r->content_type("text/html");
        $r->send_http_header();
        $r->print("<html><head><title>Dev Server Warning</title>",
                  "<style> body { border: 20px solid red; padding: 30px; margin: 0; font-family: sans-serif; } ",
                  "h1 { color: #500000; }",
                  "</style></head>",
                  "<body><h1>Warning</h1><p>This server is for development and testing only.  ",
                  "Accounts are subject to frequent deletion.  Don't use this machine for anything important.</p>",
                  "<form method='post' action='/misc/ack-devserver.bml' style='margin-top: 1em'>",
                  LJ::html_hidden("dest", "$LJ::SQUAT_URL"),
                  LJ::html_submit(undef, "Acknowledged"),
                  "</form></body></html>");
        return OK;
    });

}

package LJ::Protocol;

sub xmlrpc_method {
    my $method = shift;
    shift;   # get rid of package name that dispatcher includes.
    my $req = shift;

    if (@_) {
        # don't allow extra arguments
        die SOAP::Fault
            ->faultstring(LJ::Protocol::error_message(202))
            ->faultcode(202);
    }
    my $error = 0;
    if (ref $req eq "HASH") {
        foreach my $key ('subject', 'event') {
            # get rid of the UTF8 flag in scalars
            $req->{$key} = pack('C*', unpack('C*', $req->{$key}))
                if $req->{$key};
        }
    }
    my $res = LJ::Protocol::do_request($method, $req, \$error);
    if ($error) {
        die SOAP::Fault
            ->faultstring(LJ::Protocol::error_message($error))
            ->faultcode(substr($error, 0, 3));
    }
    return $res;
}

package LJ::XMLRPC;

use vars qw($AUTOLOAD);

sub AUTOLOAD {
    my $method = $AUTOLOAD;
    $method =~ s/^.*:://;
    LJ::Protocol::xmlrpc_method($method, @_);
}

1;