#!/usr/bin/perl
#
#
# lib: DBI::, Digest::MD5, URI::URL
# lib: cgi-bin/ljconfig.pl, cgi-bin/ljlang.pl, cgi-bin/ljpoll.pl
# lib: cgi-bin/cleanhtml.pl
# link: htdocs/paidaccounts/index.bml, htdocs/users, htdocs/view/index.bml
# hook: canonicalize_url, name_caps, name_caps_short, post_create
# hook: validate_get_remote
#
package LJ;
use strict;
use Carp;
use lib "$ENV{'LJHOME'}/cgi-bin";
use DBI;
use DBI::Role;
use DBIx::StateKeeper;
use Digest::MD5 ();
use Digest::SHA1 ();
use HTTP::Date ();
use LJ::MemCache;
use LJ::User;
use Time::Local ();
use Storable ();
use Compress::Zlib ();
use IO::Socket::INET qw{};
use Unicode::MapUTF8;
use LJ::Entry;
do "$ENV{'LJHOME'}/cgi-bin/ljr_readconf.pl";
do "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
do "$ENV{'LJHOME'}/cgi-bin/ljdefaults.pl";
sub END { LJ::end_request(); }
# tables on user databases (ljlib-local should define @LJ::USE_TABLES_LOCAL)
# this is here and no longer in bin/upgrading/update-db-{general|local}.pl
# so other tools (in particular, the inter-cluster user mover) can verify
# that it knows how to move all types of data before it will proceed.
@LJ::USER_TABLES = ("userbio", "cmdbuffer", "dudata",
"log2", "logtext2", "logprop2", "logsec2",
"talk2", "talkprop2", "talktext2", "talkleft",
"userpicblob2", "events",
"ratelog", "loginstall", "sessions", "sessions_data",
"s1usercache", "modlog", "modblob",
"userproplite2", "links", "s1overrides", "s1style",
"s1stylecache", "userblob", "userpropblob",
"clustertrack2", "captcha_session", "reluser2",
"tempanonips", "inviterecv", "invitesent",
"memorable2", "memkeyword2", "userkeywords",
"friendgroup2", "userpicmap2", "userpic2",
"s2stylelayers2", "s2compiled2", "userlog",
"logtags", "logtagsrecent", "logkwsum",
"recentactions", "usertags", "pendcomments",
"embedcontent", "embedcontent_preview",
);
# keep track of what db locks we have out
%LJ::LOCK_OUT = (); # {global|user} => caller_with_lock
require "$ENV{'LJHOME'}/cgi-bin/ljlib-local.pl"
if -e "$ENV{'LJHOME'}/cgi-bin/ljlib-local.pl";
require "taglib.pl";
require "ljtextutil.pl";
# if this is a dev server, alias LJ::D to Data::Dumper::Dumper
if ($LJ::IS_DEV_SERVER) {
eval "use Data::Dumper ();";
*LJ::D = \&Data::Dumper::Dumper;
}
$LJ::DBIRole = new DBI::Role {
'timeout' => $LJ::DB_TIMEOUT,
'sources' => \%LJ::DBINFO,
'default_db' => "livejournal",
'time_check' => 60,
'time_report' => \&dbtime_callback,
};
LJ::MemCache::init();
# $LJ::PROTOCOL_VER is the version of the client-server protocol
# used uniformly by server code which uses the protocol.
$LJ::PROTOCOL_VER = ($LJ::UNICODE ? "1" : "0");
# user.dversion values:
# 0: unclustered (unsupported)
# 1: clustered, not pics (unsupported)
# 2: clustered
# 3: weekuserusage populated (Note: this table's now gone)
# 4: userproplite2 clustered, and cldversion on userproplist table
# 5: overrides clustered, and style clustered
# 6: clustered memories, friend groups, and keywords (for memories)
# 7: clustered userpics, keyword limiting, and comment support
$LJ::MAX_DVERSION = 7;
# constants
use constant ENDOFTIME => 2147483647;
$LJ::EndOfTime = 2147483647; # for string interpolation
# width constants. BMAX_ constants are restrictions on byte width (of utf-8 text),
# CMAX_ on character width (character means byte unless $LJ::UNICODE,
# in which case it means a UTF-8 character).
use constant BMAX_SUBJECT => 255; # *_SUBJECT for journal events, not comments
use constant CMAX_SUBJECT => 255;
use constant BMAX_COMMENT => 29000;
use constant CMAX_COMMENT => 14300;
use constant BMAX_MEMORY => 150;
use constant CMAX_MEMORY => 80;
use constant BMAX_NAME => 100;
use constant CMAX_NAME => 50;
use constant BMAX_KEYWORD => 80;
use constant CMAX_KEYWORD => 40;
use constant BMAX_PROP => 255; # logprop[2]/talkprop[2]/userproplite (not userprop)
use constant CMAX_PROP => 255;
use constant BMAX_GRPNAME => 60;
use constant CMAX_GRPNAME => 30;
use constant BMAX_GRPNAME2 => 90; # introduced in dversion6, when we widened the groupname column
use constant CMAX_GRPNAME2 => 40; # but we have to keep the old GRPNAME around while dversion5 exists
use constant BMAX_EVENT => 80000; #item text, in utf-8
use constant CMAX_EVENT => 40000; #item text, in chars
use constant BMAX_INTEREST => 100;
use constant CMAX_INTEREST => 50;
use constant BMAX_UPIC_COMMENT => 255;
use constant CMAX_UPIC_COMMENT => 120;
# declare views (calls into ljviews.pl)
@LJ::views = qw(lastn friends calendar day);
%LJ::viewinfo = (
"lastn" => {
"creator" => \&LJ::S1::create_view_lastn,
"des" => "Most Recent Events",
},
"calendar" => {
"creator" => \&LJ::S1::create_view_calendar,
"des" => "Calendar",
},
"day" => {
"creator" => \&LJ::S1::create_view_day,
"des" => "Day View",
},
"friends" => {
"creator" => \&LJ::S1::create_view_friends,
"des" => "Friends View",
"owner_props" => ["opt_usesharedpic", "friendspagetitle"],
},
"friendsfriends" => {
"creator" => \&LJ::S1::create_view_friends,
"des" => "Friends of Friends View",
"styleof" => "friends",
},
"data" => {
"creator" => \&LJ::Feed::create_view,
"des" => "Data View (RSS, etc.)",
"owner_props" => ["opt_whatemailshow", "no_mail_alias"],
},
"rss" => { # this is now provided by the "data" view.
"des" => "RSS View (XML)",
},
"res" => {
"des" => "S2-specific resources (stylesheet)",
},
"pics" => {
"des" => "FotoBilder pics (root gallery)",
},
"info" => {
# just a redirect to userinfo.bml for now.
# in S2, will be a real view.
"des" => "Profile Page",
},
"tag" => {
"creator" => \&LJ::S1::create_view_lastn,
"des" => "Filtered Most Recent Events",
},
);
## we want to set this right away, so when we get a HUP signal later
## and our signal handler sets it to true, perl doesn't need to malloc,
## since malloc may not be thread-safe and we could core dump.
## see LJ::clear_caches and LJ::handle_caches
$LJ::CLEAR_CACHES = 0;
# DB Reporting UDP socket object
$LJ::ReportSock = undef;
# DB Reporting handle collection. ( host => $dbh )
%LJ::DB_REPORT_HANDLES = ();
## if this library is used in a BML page, we don't want to destroy BML's
## HUP signal handler.
if ($SIG{'HUP'}) {
my $oldsig = $SIG{'HUP'};
$SIG{'HUP'} = sub {
&{$oldsig};
LJ::clear_caches();
};
} else {
$SIG{'HUP'} = \&LJ::clear_caches;
}
# given two db roles, returns true only if the two roles are for sure
# served by different database servers. this is useful for, say,
# the moveusercluster script: you wouldn't want to select something
# from one db, copy it into another, and then delete it from the
# source if they were both the same machine.
#
# name: LJ::use_diff_db
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub use_diff_db {
$LJ::DBIRole->use_diff_db(@_);
}
sub get_blob_domainid
{
my $name = shift;
my $id = {
"userpic" => 1,
"phonepost" => 2,
"captcha_audio" => 3,
"captcha_image" => 4,
"fotobilder" => 5,
}->{$name};
# FIXME: add hook support, so sites can't define their own
# general code gets priority on numbers, say, 1-200, so verify
# hook returns a number 201-255
return $id if $id;
die "Unknown blob domain: $name";
}
sub locker {
return $LJ::LOCKER_OBJ if $LJ::LOCKER_OBJ;
eval "use DDLockClient ();";
die "Couldn't load locker client: $@" if $@;
return $LJ::LOCKER_OBJ =
new DDLockClient (
servers => [ @LJ::LOCK_SERVERS ],
lockdir => $LJ::LOCKDIR || "$LJ::HOME/locks",
);
}
sub mogclient {
return $LJ::MogileFS if $LJ::MogileFS;
if (%LJ::MOGILEFS_CONFIG && $LJ::MOGILEFS_CONFIG{hosts}) {
eval "use MogileFS;";
die "Couldn't load MogileFS: $@" if $@;
$LJ::MogileFS = new MogileFS (
domain => $LJ::MOGILEFS_CONFIG{domain},
root => $LJ::MOGILEFS_CONFIG{root},
hosts => $LJ::MOGILEFS_CONFIG{hosts},
)
or die "Could not initialize MogileFS";
# set preferred ip list if we have one
$LJ::MogileFS->set_pref_ip(\%LJ::MOGILEFS_PREF_IP)
if %LJ::MOGILEFS_PREF_IP;
}
return $LJ::MogileFS;
}
#
# name: LJ::get_dbh
# class: db
# des: Given one or more roles, returns a database handle.
# info:
# args:
# des-:
# returns:
#
sub get_dbh {
my $opts = ref $_[0] eq "HASH" ? shift : {};
# supported options:
# 'raw': don't return a DBIx::StateKeeper object
unless (exists $opts->{'max_repl_lag'}) {
# for slave or clusterslave roles, don't allow lag
if ($_[0] =~ /slave$/) {
$opts->{'max_repl_lag'} = $LJ::MAX_REPL_LAG || 100_000;
}
}
if ($LJ::DEBUG{'get_dbh'} && $_[0] ne "logs") {
my $errmsg = "get_dbh(@_) at \n";
my $i = 0;
while (my ($p, $f, $l) = caller($i++)) {
next if $i > 3;
$errmsg .= " $p, $f, $l\n";
}
warn $errmsg;
}
my $mapping;
ROLE:
foreach my $role (@_) {
# let site admin turn off global master write access during
# maintenance
return undef if $LJ::DISABLE_MASTER && $role eq "master";
if (($mapping = $LJ::WRAPPED_DB_ROLE{$role}) && ! $opts->{raw}) {
if (my $keeper = $LJ::REQ_DBIX_KEEPER{$role}) {
return $keeper->set_database() ? $keeper : undef;
}
my ($canl_role, $dbname) = @$mapping;
my $tracker;
# DBIx::StateTracker::new will die if it can't connect to the database,
# so it's wrapper in an eval
eval {
$tracker =
$LJ::REQ_DBIX_TRACKER{$canl_role} ||=
DBIx::StateTracker->new(sub { LJ::get_dbirole_dbh({unshared=>1},
$canl_role) });
};
if ($tracker) {
my $keeper = DBIx::StateKeeper->new($tracker, $dbname);
$LJ::REQ_DBIX_KEEPER{$role} = $keeper;
return $keeper->set_database() ? $keeper : undef;
}
next ROLE;
}
my $db = LJ::get_dbirole_dbh($opts, $role);
return $db if $db;
}
return undef;
}
#
# name: LJ::get_dbirole_dbh
# class: db
# des: Internal function for get_dbh(). Uses the DBIRole to fetch a dbh, with
# hooks into db stats-generation if that's turned on.
# info:
# args: opts, role
# des-opts: A hashref of options.
# des-role: The database role.
# returns: A dbh.
#
sub get_dbirole_dbh {
my $dbh = $LJ::DBIRole->get_dbh( @_ ) or return undef;
if ( $LJ::DB_LOG_HOST && $LJ::HAVE_DBI_PROFILE ) {
$LJ::DB_REPORT_HANDLES{ $dbh->{Name} } = $dbh;
# :TODO: Explain magic number
$dbh->{Profile} ||= "2/DBI::Profile";
# And turn off useless (to us) on_destroy() reports, too.
undef $DBI::Profile::ON_DESTROY_DUMP;
}
return $dbh;
}
#
# name: LJ::get_lock
# des: get a mysql lock on a given key/dbrole combination
# returns: undef if called improperly, true on success, die() on failure
# args: db, dbrole, lockname, wait_time?
# des-dbrole: the role this lock should be gotten on, either 'global' or 'user'
# des-lockname: the name to be used for this lock
# des-wait_time: an optional timeout argument, defaults to 10 seconds
#
sub get_lock
{
my ($db, $dbrole, $lockname, $wait_time) = @_;
return undef unless $db && $lockname;
return undef unless $dbrole eq 'global' || $dbrole eq 'user';
my $curr_sub = (caller 1)[3]; # caller of current sub
# die if somebody already has a lock
die "LOCK ERROR: $curr_sub; can't get lock from: $LJ::LOCK_OUT{$dbrole}\n"
if exists $LJ::LOCK_OUT{$dbrole};
# get a lock from mysql
$wait_time ||= 10;
$db->do("SELECT GET_LOCK(?,?)", undef, $lockname, $wait_time)
or return undef;
# successfully got a lock
$LJ::LOCK_OUT{$dbrole} = $curr_sub;
return 1;
}
#
# name: LJ::may_lock
# des: see if we COULD get a mysql lock on a given key/dbrole combination,
# but don't actually get it.
# returns: undef if called improperly, true on success, die() on failure
# args: db, dbrole
# des-dbrole: the role this lock should be gotten on, either 'global' or 'user'
#
sub may_lock
{
my ($db, $dbrole) = @_;
return undef unless $db && ($dbrole eq 'global' || $dbrole eq 'user');
# die if somebody already has a lock
if ($LJ::LOCK_OUT{$dbrole}) {
my $curr_sub = (caller 1)[3]; # caller of current sub
die "LOCK ERROR: $curr_sub; can't get lock from $LJ::LOCK_OUT{$dbrole}\n";
}
# see if a lock is already out
return undef if exists $LJ::LOCK_OUT{$dbrole};
return 1;
}
#
# name: LJ::release_lock
# des: release a mysql lock on a given key/dbrole combination
# returns: undef if called improperly, true on success, die() on failure
# args: db, dbrole, lockname
# des-dbrole: the role this lock should be gotten on, either 'global' or 'user'
# des-lockname: the name to be used for this lock
#
sub release_lock
{
my ($db, $dbrole, $lockname) = @_;
return undef unless $db && $lockname;
return undef unless $dbrole eq 'global' || $dbrole eq 'user';
# get a lock from mysql
$db->do("SELECT RELEASE_LOCK(?)", undef, $lockname);
delete $LJ::LOCK_OUT{$dbrole};
return 1;
}
#
# name: LJ::get_newids
# des: Lookup an old global ID and see what journal it belongs to and its new ID.
# info: Interface to [dbtable[oldids]] table (URL compatability)
# returns: Undef if non-existent or unconverted, or arrayref of [$userid, $newid].
# args: area, oldid
# des-area: The "area" of the id. Legal values are "L" (log), to lookup an old itemid,
# or "T" (talk) to lookup an old talkid.
# des-oldid: The old globally-unique id of the item.
#
sub get_newids
{
my $sth;
my $db = LJ::get_dbh("oldids") || LJ::get_db_reader();
return $db->selectrow_arrayref("SELECT userid, newid FROM oldids ".
"WHERE area=? AND oldid=?", undef,
$_[0], $_[1]);
}
sub get_groupmask
{
# TAG:FR:ljlib:get_groupmask
my ($journal, $remote) = @_;
return 0 unless $journal && $remote;
my $jid = LJ::want_userid($journal);
my $fid = LJ::want_userid($remote);
return 0 unless $jid && $fid;
my $memkey = [$jid,"frgmask:$jid:$fid"];
my $mask = LJ::MemCache::get($memkey);
unless (defined $mask) {
my $dbr = LJ::get_db_reader();
die "No database reader available" unless $dbr;
$mask = $dbr->selectrow_array("SELECT groupmask FROM friends ".
"WHERE userid=? AND friendid=?",
undef, $jid, $fid);
LJ::MemCache::set($memkey, $mask+0);
}
return $mask+0; # force it to a numeric scalar
}
#
# name: LJ::get_timeupdate_multi
# des: Get the last time a list of users updated
# args: opt?, uids
# des-opt: optional hashref, currently can contain 'memcache_only' and 'max_age'
# to only retrieve data from memcache
# des-uids: list of userids to load timeupdates for
# returns: hashref; uid => unix timeupdate
#
# --not used any more, see below
#
sub get_timeupdate_multi {
my ($opt, @uids) = @_;
# allow optional opt hashref as first argument
unless (ref $opt eq 'HASH') {
push @uids, $opt;
$opt = {};
}
return {} unless @uids;
my $oldest = $opt->{'max_age'} ? (time() - $opt->{'max_age'}) : 0;
# L.P.: MemCache::get_multi() is not good for 10^4 entries (ljr_fif).
# need_bind of a large size also not a good idea.
my @memkeys = map { [$_, "tu:$_"] } @uids;
my $mem = LJ::MemCache::get_multi(@memkeys) || {};
my @need;
my %timeupdate; # uid => timeupdate
foreach (@uids) {
if ($mem->{"tu:$_"}) {
my $ttt = unpack("N", $mem->{"tu:$_"});
$timeupdate{$_} = $ttt if $ttt > $oldest;
} else {
push @need, $_;
}
}
# if everything was in memcache, return now
return \%timeupdate if $opt->{'memcache_only'} || ! @need;
# fill in holes from the database. safe to use the reader because we
# only do an add to memcache, whereas postevent does a set, overwriting
# any potentially old data
my $dbr = LJ::get_db_reader();
my $need_bind = join(",", map { "?" } @need);
my $sth = $dbr->prepare("SELECT userid, UNIX_TIMESTAMP(timeupdate) " .
"FROM userusage WHERE userid IN ($need_bind)");
$sth->execute(@need);
while (my ($uid, $tu) = $sth->fetchrow_array) {
$timeupdate{$uid} = $tu if $tu > $oldest;
# set memcache for this row
LJ::MemCache::add([$uid, "tu:$uid"], pack("N", $tu));
}
return \%timeupdate;
}
# Simplified and optimized version of LJ::get_timeupdate_multi
# args: period in seconds, userids hashref
# returns: hashref
# uid => unix timeupdate
#
sub get_timeupdate_multi_fast {
my ($max_age, $hint) = @_;
unless ($max_age) {
return LJ::get_timeupdate_multi(keys %$hint); #fallfack :(
}
my $store_max_age = $LJ::MAX_FRIENDS_VIEW_AGE || 3600*24*56; # 8 weeks default
my $cut_age = $max_age ? time() - $max_age : time() - $store_max_age;
my %timeupdate;
my $updates = LJ::MemCache::get("blob:timeupdate");
if ($updates && @$updates > 1 && $updates->[0] == @$updates) {
my $i = 1; my $imax = @$updates -1;
while ($i < $imax) {
my ($uid, $tu) = ($updates->[$i++], $updates->[$i++]);
$timeupdate{$uid} = $tu if $tu > $cut_age && (!$hint || exists $hint->{$uid});
}
return \%timeupdate;
}
$updates = [0];
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT userid, UNIX_TIMESTAMP(timeupdate) FROM userusage " .
"WHERE timeupdate > DATE_SUB(NOW(), INTERVAL $store_max_age SECOND)");
$sth->execute();
while (my ($uid, $tu) = $sth->fetchrow_array) {
push @$updates, ($uid, $tu);
$timeupdate{$uid} = $tu if $tu > $cut_age && (!$hint || exists $hint->{$uid});
}
$updates->[0] = @$updates;
LJ::MemCache::set("blob:timeupdate", $updates, 60); # 1 minute
return \%timeupdate;
}
#
# name: LJ::get_friend_items
# des: Return friend items for a given user, filter, and period.
# args: dbarg?, opts
# des-opts: Hashref of options:
# - u
# - remote
# - itemshow
# - skip
# - dayskip (!)
# - filter (opt) defaults to all
# - friends (opt) friends rows loaded via LJ::get_friends()
# - friends_u (opt) u objects of all friends loaded
# - dateformat: either "S2" for S2 code, or anything else for S1
# - common_filter: set true if this is the default view
# - friendsoffriends: load friends of friends, not just friends
# - showtypes: /[PYC]/
# returns: Array of item hashrefs containing the same elements
#
sub get_friend_items
{
&nodb;
my $opts = shift;
my $u = $opts->{'u'};
my $userid = $u->{'userid'};
return () if $LJ::FORCE_EMPTY_FRIENDS{$userid};
my $remote = $opts->{'remote'};
my $remoteid = $remote ? $remote->{'userid'} : 0;
my $itemshow = $opts->{'itemshow'}+0;
my $skip = $opts->{'skip'}+0;
my $getitems = $itemshow + $skip;
my $filter = $opts->{'filter'}+0;
my $max_age = $LJ::MAX_FRIENDS_VIEW_AGE || 3600*24*56; # 8 weeks default
my $timeskip = 3600*24*($opts->{'dayskip'}+0);
# sanity check:
$skip = 0 if $skip < 0;
#use Time::HiRes qw(gettimeofday tv_interval);
#my $t0 = [gettimeofday];
#my @elapsed;
#push @elapsed, (tv_interval ($t0));
#print STDERR "@elapsed \n";
my $debug = 0; my @stat = ();
my $fif_optimized = ! $opts->{'friendsoffriends'} &&
(($LJ::LJR_FIF && LJ::get_userid($LJ::LJR_FIF) == $userid) ||
($LJ::LJR_SYN && LJ::get_userid($LJ::LJR_SYN) == $userid));
# given a hash of friends rows, strip out rows with invalid journals (twit)
my $twit_friends = sub {
my $friends = shift;
# delete objects based on twit_list
my $list = get_twit_list($remoteid);
foreach my $twit (@$list) {
delete $friends->{$twit} if exists $friends->{$twit};
}
};
# given a hash of friends rows, strip out rows with invalid journaltype
my $filter_journaltypes = sub {
my ($friends, $friends_u, $valid_types) = @_;
return unless $friends && $friends_u;
push (@stat, scalar keys %$friends) if $debug;
# delete objects based on twit_list
$twit_friends->($friends);
# load u objects for all the given
LJ::load_userids_multiple([ map { $_, \$friends_u->{$_} } keys %$friends ]);
# delete u objects based on 'showtypes' and 'statusvis'
$valid_types ||= uc($opts->{'showtypes'});
foreach my $fid (keys %$friends_u) {
my $fu = $friends_u->{$fid};
if ($fu->{'statusvis'} ne "V" || #check_twit($remoteid, $fid) ||
$valid_types && index(uc($valid_types), $fu->{journaltype}) == -1)
{
delete $friends_u->{$fid};
delete $friends->{$fid};
}
}
push (@stat, scalar keys %$friends) if $debug;
# all args passed by reference
return;
};
my @friends_buffer = ();
######################################
# normal friends mode (journals for /friends page)
my $fill_friends_buffer = sub
{
# get all friends for this user and groupmask
my $friends = LJ::get_friends($userid, $filter) || {};
push (@stat, scalar keys %$friends) if $debug;
# get update times for friendids, strip out too old
my $timeupdate = LJ::get_timeupdate_multi_fast($max_age, $friends) || {};
# strip out invalid friend journals
my %friends_u;
$filter_journaltypes->($timeupdate, \%friends_u);
# now push a properly formatted @friends_buffer row
foreach my $fid (keys %friends_u) {
push @friends_buffer, [ $fid, $timeupdate->{$fid}, $friends->{$fid}, $friends_u{$fid} ];
}
};
######################################
# normal friends mode for ljr_fif (optimized ljr_fif/friends page)
$fill_friends_buffer = sub
{
$max_age = 3600*24*5 if $skip < 101 && $timeskip ==0;
# get recently changed ids
my $timeupdate = LJ::get_timeupdate_multi_fast($max_age);
push (@stat, scalar keys %$timeupdate) if $debug;
# get all friends for this user and groupmask, within %$timeupdate entries
my $friends = LJ::get_friends($userid, $filter, undef, undef, $timeupdate) || {};
# strip out invalid friend journals
my %friends_u;
$filter_journaltypes->($friends, \%friends_u);
# now push a properly formatted @friends_buffer row
foreach my $fid (keys %friends_u) {
push @friends_buffer, [ $fid, $timeupdate->{$fid}, $friends->{$fid}, $friends_u{$fid} ];
}
} if $fif_optimized;
#################################################
# memcached friends of friends mode (journals for /friendsfriends page)
$fill_friends_buffer = sub
{
# get journal's friends
my $friends = LJ::get_friends($userid, $filter) || {};
# strip out invalid friend journaltypes
my %friends_u;
$filter_journaltypes->($friends, \%friends_u, "P");
# get friends of friends
my $ffriends = LJ::get_friends_multi($friends, $filter) || {}; # hash arg!
# exclude self, if happen
delete $ffriends->{$userid} if exists $ffriends->{$userid};
# get update times for friendsfriends, strip out too old
my $ff_tu = LJ::get_timeupdate_multi_fast($max_age, $ffriends);
# strip out invalid friendsfriends journaltypes
my %ffriends_u;
$filter_journaltypes->($ff_tu, \%ffriends_u);
# build friends buffer
foreach my $ffid (keys %ffriends_u) {
# since this is ff mode, we'll force colors to ffffff on 000000
$ffriends->{$ffid}->{'fgcolor'} = "#000000";
$ffriends->{$ffid}->{'bgcolor'} = "#ffffff";
push @friends_buffer, [ $ffid, $ff_tu->{$ffid}, $ffriends->{$ffid}, $ffriends_u{$ffid} ];
}
} if $opts->{'friendsoffriends'} && @LJ::MEMCACHE_SERVERS;
##############################################
# old friends of friends mode (journals for /friendsfriends page)
# - use this when there are no memcache servers
$fill_friends_buffer = sub
{
# load all user's friends of friends
# TAG:FR:ljlib:old_friendsfriends_getitems
my %f;
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare(qq{
SELECT f.friendid, f.groupmask, UNIX_TIMESTAMP(uu.timeupdate),
u.journaltype FROM friends f, userusage uu, user u
WHERE f.userid=? AND f.friendid=uu.userid AND u.userid=f.friendid AND u.journaltype='P'
});
$sth->execute($userid);
while (my ($id, $mask, $time, $jt) = $sth->fetchrow_array) {
next if $id == $userid; # don't follow user's own friends
$f{$id} = { 'userid' => $id, 'timeupdate' => $time, 'jt' => $jt,
'relevant' => ($filter && !($mask & $filter)) ? 0 : 1 , };
}
# load some friends of friends (most 20 queries)
my $fct = 0;
foreach my $fid (sort { $f{$b}->{'timeupdate'} <=> $f{$a}->{'timeupdate'} } keys %f)
{
next unless $f{$fid}->{'jt'} eq "P" && $f{$fid}->{'relevant'};
last if ++$fct > 20;
my $extra;
if ($opts->{'showtypes'}) {
my @in;
if ($opts->{'showtypes'} =~ /P/) { push @in, "'P'"; }
if ($opts->{'showtypes'} =~ /Y/) { push @in, "'Y'"; }
if ($opts->{'showtypes'} =~ /C/) { push @in, "'C','S','N'"; }
$extra = "AND u.journaltype IN (".join (',', @in).")" if @in;
}
# TAG:FR:ljlib:old_friendsfriends_getitems2
my $sth = $dbr->prepare(qq{
SELECT u.*, UNIX_TIMESTAMP(uu.timeupdate) AS timeupdate
FROM friends f, userusage uu, user u WHERE f.userid=? AND
f.friendid=uu.userid AND f.friendid=u.userid AND u.statusvis='V' $extra
AND uu.timeupdate > DATE_SUB(NOW(), INTERVAL 14 DAY) LIMIT 100
});
$sth->execute($fid);
while (my $u = $sth->fetchrow_hashref) {
my $uid = $u->{'userid'};
next if $f{$uid} || $uid == $userid; # we don't wanna see our friends
next if check_twit($remoteid, $uid);
# timeupdate
my $time = $u->{'timeupdate'};
delete $u->{'timeupdate'}; # not a proper $u column??
push @friends_buffer, [ $uid, $time, {}, $u ];
}
}
} if $opts->{'friendsoffriends'} && ! @LJ::MEMCACHE_SERVERS;
######################################
$fill_friends_buffer->();
## sort is suboptimal for $#friends_buffer >> $getitems, but $#friends_buffer < 500 in fact
@friends_buffer = sort { $b->[1] <=> $a->[1] } @friends_buffer; #latest first
my $s4 = 0;
my $get_next_friend = sub {
my ($mintime) = @_;
return undef unless @friends_buffer && $friends_buffer[0]->[1] >= $mintime;
$s4++;
return shift @friends_buffer;
};
my $lastmax = $LJ::EndOfTime - time() + $max_age;
my $lastmin = $LJ::EndOfTime - time() + $timeskip; # 0 if $timeskip == 0 ??
my @items = (); # what we'll return
my $itemsleft = $getitems; # even though we got a bunch, potentially, they could be old
my $fr;
while ($itemsleft && ($fr = $get_next_friend->( $LJ::EndOfTime - $lastmax )))
{
# load the next recent updating friend's recent items
my $friendid = $fr->[0];
$opts->{'friends'}->{$friendid} = $fr->[2]; # friends row
$opts->{'friends_u'}->{$friendid} = $fr->[3]; # friend u object
my $newitems = LJ::get_log2_recent_user({
'clusterid' => $fr->[3]->{'clusterid'},
'userid' => $friendid,
'remote' => $remote,
'itemshow' => $itemsleft,
'notafter' => $lastmax, # reverse time!
'notbefore' => $lastmin,
'timeupdate' => $fr->[1],
});
next unless @$newitems;
$itemsleft--; # we'll need at least one less for the next friend
# sort all the total items by rlogtime (recent at beginning).
# if there's an in-second tie, the "newer" post is determined by
# the higher jitemid, which means nothing if the posts are in the same
# journal, but means everything if they are (which happens almost never
# for a human, but all the time for RSS feeds, once we remove the
# synsucker's 1-second delay between postevents)
#
# while we can merge sorted arrays (@newitems already sorted rlogtime),
# doing append and sort performs faster and less error-prone
#
push @items, @$newitems;
if (@items >= $getitems)
{
@items = sort {$a->[0] <=> $b->[0] || # rlogtime
$b->[1] <=> $a->[1]} @items; # jitemid
@items = splice(@items, 0, $getitems);
$lastmax = $items[-1]->[0]; # rlogtime
# stop looping if we know the next friend's newest entry
# is older than the oldest one we've already loaded.
}
}
@items = sort {$a->[0] <=> $b->[0] || # rlogtime
$b->[1] <=> $a->[1]} @items; # jitemid
@items = splice(@items, 0, $getitems) if @items > $getitems;
print STDERR "debug get_friend_items(): userid $userid -> $stat[0] $stat[1] $stat[2](twit $remoteid) $stat[3](statusvis); used $s4, getitems $getitems\n" if $debug;
# remove skipped ones
splice(@items, 0, $skip) if $skip;
my @friend_items = (); # what we'll return, in hashref format
# convert and fill
foreach (@items) {
### fields really used by the caller: qw(ownerid posterid itemid security alldatepart), 'anum'.
#
my $item = {};
# $_ = [$rlogtime, $jitemid, $posterid, $eventtime, $anum, $ditemid, $security, $journalid]
@$item{'rlogtime', 'itemid', 'posterid', 'alldatepart', 'anum', 'ditemid', 'security', 'ownerid'} = @$_;
# renamed: jitemid->itemid, eventtime->alldatepart, userid=journalid->ownerid)
push @friend_items, $item;
#set owner
$opts->{'owners'}->{$item->{'ownerid'}} = 1;
# date conversion
if ($opts->{'dateformat'} eq "S2") {
$item->{'alldatepart'} = LJ::alldatepart_s2(LJ::mysql_time($item->{'alldatepart'}, 1)); #was: eventtime
} else {
$item->{'alldatepart'} = LJ::alldatepart_s1(LJ::mysql_time($item->{'alldatepart'}, 1)); #was: eventtime
}
}
LJ::fill_items_with_text_props(\@friend_items, $opts->{'friends_u'}, {'multiowner' => 1});
#LJ::MemCache::add([$userid, "Test1:$userid"], \@friend_items, 300) if ($remoteid && $userid == 4);
return @friend_items;
}
#
# name: LJ::get_recent_items
# class:
# des: Returns journal entries for a given account.
# info:
# args: dbarg, opts
# des-opts: Hashref of options with keys:
# -- u: $u object
# -- err: scalar ref to return error code/msg in
# -- remote: remote user's $u
# -- tags: arrayref of tag strings to return entries with
# -- clustersource: if value 'slave', uses replicated databases
# -- order: if 'logtime', sorts by logtime, not eventtime
# -- friendsview: if true, sorts by logtime, not eventtime
# -- notafter: upper bound inclusive for rlogtime/revttime (depending on sort mode),
# defaults to no limit
# -- itemshow: items to show
# -- skip: items to skip
# -- dayskip (!)
# -- viewall: if set, no security is used.
# -- dateformat: if "S2", uses S2's 'alldatepart' format.
#
# returns: array of hashrefs containing keys:
# -- itemid (the jitemid)
# -- posterid
# -- security
# -- alldatepart (in S1 or S2 fmt, depending on 'dateformat' req key)
# -- ownerid (if in 'friendsview' mode)
# -- rlogtime (if in 'friendsview' mode)
# -- text (array)
# -- props (hash)
#
sub get_recent_items
{
&nodb;
my $opts = shift;
my $sth;
my @items = (); # what we'll return
my $err = $opts->{'err'};
my $userid = $opts->{'u'}->{'userid'};
my $remote = $opts->{'remote'};
my $remoteid = $remote ? $remote->{'userid'} : 0;
my $clusterid = $opts->{'u'}->{'clusterid'};
my @sources = ("cluster$clusterid");
if (my $ab = $LJ::CLUSTER_PAIR_ACTIVE{$clusterid}) {
@sources = ("cluster${clusterid}${ab}");
}
unshift @sources, ("cluster${clusterid}lite", "cluster${clusterid}slave")
if $opts->{'clustersource'} eq "slave";
my $logdb = LJ::get_dbh(@sources);
my $sort_key = "revttime";
# community/friend views need to post by log time, not event time
$sort_key = "rlogtime" if ($opts->{'order'} eq "logtime" ||
$opts->{'friendsview'});
# 'notafter':
# the friends view doesn't want to load things that it knows it
# won't be able to use. if this argument is zero or undefined,
# then we'll load everything less than or equal to 1 second from
# the end of time. we don't include the last end of time second
# because that's what backdated entries are set to. (so for one
# second at the end of time we'll have a flashback of all those
# backdated entries... but then the world explodes and everybody
# with 32 bit time_t structs dies)
my $notafter = $opts->{'notafter'} + 0 || $LJ::EndOfTime - 1;
my $timewhere = " $sort_key <= $notafter ";
my $skip = $opts->{'skip'}+0;
my $itemshow = $opts->{'itemshow'}+0;
#sanity check:
my $max_hints = $LJ::MAX_HINTS_LASTN; # temporary
if ($itemshow > $max_hints) { $itemshow = $max_hints; }
my $maxskip = $max_hints - $itemshow;
if ($skip < 0) { $skip = 0; }
if ($skip > $maxskip) { $skip = $maxskip; }
my $t = 3600*24*($opts->{'dayskip'}+0);
if ($t) {
$timewhere .= "AND $sort_key > ($LJ::EndOfTime - UNIX_TIMESTAMP()) + $t ";
}
my $mask = 0;
if ($remote &&
($remote->{'journaltype'} eq "P" || $remote->{'journaltype'} eq "I") &&
$remoteid != $userid) {
$mask = LJ::get_groupmask($userid, $remoteid);
}
# decide what level of security the remote user can see
my $secwhere = "";
if ($userid == $remoteid || $opts->{'viewall'}) {
# no extra where restrictions... user can see all their own stuff
# alternatively, if 'viewall' opt flag is set, security is off.
} elsif ($mask) {
# can see public or things with them in the mask
$secwhere = "AND (security='public' OR (security='usemask' AND allowmask & $mask != 0)) ";
} else {
# not a friend? only see public.
$secwhere = "AND security='public' ";
}
# because LJ::get_friend_items needs rlogtime for sorting.
my $extra_sql;
if ($opts->{'friendsview'}) {
$extra_sql .= "journalid AS 'ownerid', rlogtime, ";
}
# if we need to get by tag, get an itemid list now
my $jitemidwhere;
if ($opts->{tags}) {
# from keyword to tag
$opts->{tagids} = [];
my $tags = LJ::Tags::get_usertags($opts->{'u'}, { remote => $remote });
my %kwref = ( map { $tags->{$_}->{name} => $_ } keys %{$tags || {}} );
foreach (@{$opts->{tags}}) {
push @{$opts->{tagids}}, $kwref{$_} if $kwref{$_};
}
unless (scalar @{$opts->{tagids}}) { return (); }
# select jitemids uniquely
my $in = join(',', map { $_+0 } @{$opts->{tagids}});
my $jitemids = $logdb->selectcol_arrayref(qq{
SELECT DISTINCT jitemid FROM logtags WHERE journalid = ? AND kwid IN ($in)
}, undef, $userid);
die $logdb->errstr if $logdb->err;
# set $jitemidwhere iff we have jitemids
if (@$jitemids) {
$jitemidwhere = " AND jitemid IN (" .
join(',', map { $_+0 } @$jitemids) .
")";
} else {
# no items, so show no entries
return ();
}
}
my $sql;
my $dateformat = "%a %W %b %M %y %Y %c %m %e %d %D %p %i %l %h %k %H";
if ($opts->{'dateformat'} eq "S2") {
$dateformat = "%Y %m %d %H %i %s %w"; # yyyy mm dd hh mm ss day_of_week
}
$sql = qq{
SELECT jitemid AS 'itemid', posterid, security, $extra_sql
DATE_FORMAT(eventtime, "$dateformat") AS 'alldatepart', anum
FROM log2 USE INDEX ($sort_key)
WHERE journalid=$userid AND $timewhere $secwhere $jitemidwhere
ORDER BY $sort_key
LIMIT $skip,$itemshow
};
unless ($logdb) {
$$err = "nodb" if ref $err eq "SCALAR";
return ();
}
$sth = $logdb->prepare($sql);
$sth->execute;
if ($logdb->err) { die $logdb->errstr; }
# keep track of the last alldatepart, and a per-minute buffer -- ??? zachem eto ???
my $last_time;
my @buf;
my $flush = sub {
return unless @buf;
push @items, sort { $b->{itemid} <=> $a->{itemid} } @buf;
@buf = ();
};
while (my $li = $sth->fetchrow_hashref) {
$flush->() if $li->{alldatepart} ne $last_time;
push @buf, $li;
$last_time = $li->{alldatepart};
}
$flush->();
LJ::fill_items_with_text_props(\@items, $opts->{'u'});
#LJ::MemCache::add([$userid, "Test:$userid"], \@items, 300) if ($remoteid && $userid == 4);
return @items;
}
#
# name: LJ::register_authaction
# des: Registers a secret to have the user validate.
# info: Some things, like requiring a user to validate their email address, require
# making up a secret, mailing it to the user, then requiring them to give it
# back (usually in a URL you make for them) to prove they got it. This
# function creates a secret, attaching what it's for and an optional argument.
# Background maintenance jobs keep track of cleaning up old unvalidated secrets.
# args: dbarg?, userid, action, arg?
# des-userid: Userid of user to register authaction for.
# des-action: Action type to register. Max chars: 50.
# des-arg: Optional argument to attach to the action. Max chars: 255.
# returns: 0 if there was an error. Otherwise, a hashref
# containing keys 'aaid' (the authaction ID) and the 'authcode',
# a 15 character string of random characters from
# [func[LJ::make_auth_code]].
#
sub register_authaction
{
&nodb;
my $dbh = LJ::get_db_writer();
my $userid = shift; $userid += 0;
my $action = $dbh->quote(shift);
my $arg1 = $dbh->quote(shift);
# make the authcode
my $authcode = LJ::make_auth_code(15);
my $qauthcode = $dbh->quote($authcode);
$dbh->do("INSERT INTO authactions (aaid, userid, datecreate, authcode, action, arg1) ".
"VALUES (NULL, $userid, NOW(), $qauthcode, $action, $arg1)");
return 0 if $dbh->err;
return { 'aaid' => $dbh->{'mysql_insertid'},
'authcode' => $authcode,
};
}
#
# class: logging
# name: LJ::statushistory_add
# des: Adds a row to a user's statushistory
# info: See the [dbtable[statushistory]] table.
# returns: boolean; 1 on success, 0 on failure
# args: dbarg?, userid, adminid, shtype, notes?
# des-userid: The user being acted on.
# des-adminid: The site admin doing the action.
# des-shtype: The status history type code.
# des-notes: Optional notes associated with this action.
#
sub statushistory_add
{
&nodb;
my $dbh = LJ::get_db_writer();
my $userid = shift;
$userid = LJ::want_userid($userid) + 0;
my $actid = shift;
my $qshtype = $dbh->quote(shift);
my $qnotes = $dbh->quote(shift);
$dbh->do("INSERT INTO statushistory (userid, adminid, shtype, notes) ".
"VALUES ($userid, $actid, $qshtype, $qnotes)");
return $dbh->err ? 0 : 1;
}
#
# name: LJ::make_link
# des: Takes a group of key=value pairs to append to a url
# returns: The finished url
# args: url, vars
# des-url: A string with the URL to append to. The URL
# shouldn't have a question mark in it.
# des-vars: A hashref of the key=value pairs to append with.
#
sub make_link
{
my $url = shift;
my $vars = shift;
my $append = "?";
foreach (keys %$vars) {
next if ($vars->{$_} eq "");
$url .= "${append}${_}=$vars->{$_}";
$append = "&";
}
return $url;
}
#
# class: time
# name: LJ::ago_text
# des: Converts integer seconds to English time span
# info: Turns a number of seconds into the largest possible unit of
# time. "2 weeks", "4 days", or "20 hours".
# returns: A string with the number of largest units found
# args: secondsold
# des-secondsold: The number of seconds from now something was made.
#
sub ago_text
{
my $secondsold = shift;
return "Never." unless defined $secondsold;
my $num;
my $unit;
if ($secondsold > 60*60*24*7) {
$num = int($secondsold / (60*60*24*7));
$unit = "week";
} elsif ($secondsold > 60*60*24) {
$num = int($secondsold / (60*60*24));
$unit = "day";
} elsif ($secondsold > 60*60) {
$num = int($secondsold / (60*60));
$unit = "hour";
} elsif ($secondsold > 60) {
$num = int($secondsold / (60));
$unit = "minute";
} else {
$num = $secondsold;
$unit = "second";
}
return "$num $unit" . ($num==1?"":"s") . " ago";
}
#
# name: LJ::get_authas_user
# des: Given a username, will return a user object if remote is an admin for the
# username. Otherwise returns undef
# returns: user object if authenticated, otherwise undef.
# args: user
# des-opts: Username of user to attempt to auth as.
#
sub get_authas_user {
my $user = shift;
return undef unless $user;
# get a remote
my $remote = LJ::get_remote();
return undef unless $remote;
# remote is already what they want?
return $remote if $remote->{'user'} eq $user;
# load user and authenticate
my $u = LJ::load_user($user);
return undef unless $u;
return undef unless $u->{clusterid};
# does $u have admin access?
return undef unless LJ::can_manage($remote, $u);
# passed all checks, return $u
return $u;
}
#
# name: LJ::shared_member_request
# des: Registers an authaction to add a user to a
# shared journal and sends an approval email
# returns: Hashref; output of LJ::register_authaction()
# includes datecreate of old row if no new row was created
# args: ju, u, attr?
# des-ju: Shared journal user object
# des-u: User object to add to shared journal
#
sub shared_member_request {
my ($ju, $u) = @_;
return undef unless ref $ju && ref $u;
my $dbh = LJ::get_db_writer();
# check for duplicates
my $oldaa = $dbh->selectrow_hashref("SELECT aaid, authcode, datecreate FROM authactions " .
"WHERE userid=? AND action='shared_invite' AND used='N' " .
"AND NOW() < datecreate + INTERVAL 1 HOUR " .
"ORDER BY 1 DESC LIMIT 1",
undef, $ju->{'userid'});
return $oldaa if $oldaa;
# insert authactions row
my $aa = LJ::register_authaction($ju->{'userid'}, 'shared_invite', "targetid=$u->{'userid'}");
return undef unless $aa;
# if there are older duplicates, invalidate any existing unused authactions of this type
$dbh->do("UPDATE authactions SET used='Y' WHERE userid=? AND aaid<>? " .
"AND action='shared_invite' AND used='N'",
undef, $ju->{'userid'}, $aa->{'aaid'});
my $body = "The maintainer of the $ju->{'user'} shared journal has requested that " .
"you be given posting access.\n\n" .
"If you do not wish to be added to this journal, just ignore this email. " .
"However, if you would like to accept posting rights to $ju->{'user'}, click " .
"the link below to authorize this action.\n\n" .
" $LJ::SITEROOT/approve/$aa->{'aaid'}.$aa->{'authcode'}\n\n" .
"Regards\n$LJ::SITENAME Team\n";
LJ::send_mail({
'to' => $u->{'email'},
'from' => $LJ::ADMIN_EMAIL,
'fromname' => $LJ::SITENAME,
'charset' => 'utf-8',
'subject' => "Community Membership: $ju->{'name'}",
'body' => $body
});
return $aa;
}
#
# name: LJ::is_valid_authaction
# des: Validates a shared secret (authid/authcode pair)
# info: See [func[LJ::register_authaction]].
# returns: Hashref of authaction row from database.
# args: dbarg?, aaid, auth
# des-aaid: Integer; the authaction ID.
# des-auth: String; the auth string. (random chars the client already got)
#
sub is_valid_authaction
{
&nodb;
# we use the master db to avoid races where authactions could be
# used multiple times
my $dbh = LJ::get_db_writer();
my ($aaid, $auth) = @_;
return $dbh->selectrow_hashref("SELECT * FROM authactions WHERE aaid=? AND authcode=?",
undef, $aaid, $auth);
}
#
# name: LJ::mark_authaction_used
# des: Marks an authaction as being used.
# args: aaid
# des-aaid: Either an authaction hashref or the id of the authaction to mark used.
# returns: 1 on success, undef on error.
#
sub mark_authaction_used
{
my $aaid = ref $_[0] ? $_[0]->{aaid}+0 : $_[0]+0
or return undef;
my $dbh = LJ::get_db_writer()
or return undef;
$dbh->do("UPDATE authactions SET used='Y' WHERE aaid = ?", undef, $aaid);
return undef if $dbh->err;
return 1;
}
#
# name: LJ::get_mood_picture
# des: Loads a mood icon hashref given a themeid and moodid.
# args: themeid, moodid, ref
# des-themeid: Integer; mood themeid.
# des-moodid: Integer; mood id.
# des-ref: Hashref to load mood icon data into.
# returns: Boolean; 1 on success, 0 otherwise.
#
sub get_mood_picture
{
my ($themeid, $moodid, $ref) = @_;
my $moods_encountered;
LJ::load_mood_theme($themeid) unless $LJ::CACHE_MOOD_THEME{$themeid};
LJ::load_moods() unless $LJ::CACHED_MOODS;
do
{
if ($LJ::CACHE_MOOD_THEME{$themeid} &&
$LJ::CACHE_MOOD_THEME{$themeid}->{$moodid}) {
%{$ref} = %{$LJ::CACHE_MOOD_THEME{$themeid}->{$moodid}};
if ($ref->{'pic'} =~ m!^/!) {
$ref->{'pic'} =~ s!^/img!!;
$ref->{'pic'} = $LJ::IMGPREFIX . $ref->{'pic'};
}
$ref->{'moodid'} = $moodid;
return 1;
} else {
if ($moods_encountered->{$moodid}) {
$moodid = 0;
}
else {
$moods_encountered->{$moodid} = 1;
$moodid = (defined $LJ::CACHE_MOODS{$moodid} ?
$LJ::CACHE_MOODS{$moodid}->{'parent'} : 0);
}
}
}
while ($moodid);
return 0;
}
# mood id to name (or undef)
sub mood_name
{
my ($moodid) = @_;
LJ::load_moods() unless $LJ::CACHED_MOODS;
my $m = $LJ::CACHE_MOODS{$moodid};
return $m ? $m->{'name'} : undef;
}
# mood name to id (or undef)
sub mood_id
{
my ($mood) = @_;
return undef unless $mood;
LJ::load_moods() unless $LJ::CACHED_MOODS;
foreach my $m (values %LJ::CACHE_MOODS) {
return $m->{'id'} if $mood eq $m->{'name'};
}
return undef;
}
sub get_moods
{
LJ::load_moods() unless $LJ::CACHED_MOODS;
return \%LJ::CACHE_MOODS;
}
#
# class: time
# name: LJ::http_to_time
# des: Converts HTTP date to Unix time.
# info: Wrapper around HTTP::Date::str2time.
# See also [func[LJ::time_to_http]].
# args: string
# des-string: HTTP Date. See RFC 2616 for format.
# returns: integer; Unix time.
#
sub http_to_time {
my $string = shift;
return HTTP::Date::str2time($string);
}
sub mysqldate_to_time {
my ($string, $gmt) = @_;
return undef unless $string =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(?: (\d\d):(\d\d)(?::(\d\d))?)?$/;
my ($y, $mon, $d, $h, $min, $s) = ($1, $2, $3, $4, $5, $6);
my $calc = sub {
$gmt ?
Time::Local::timegm($s, $min, $h, $d, $mon-1, $y) :
Time::Local::timelocal($s, $min, $h, $d, $mon-1, $y);
#Error converting 2106-02-07 06:28:16: Day too big - 49710 > 24853
#Cannot handle date (16, 28, 06, 07, 1, 2106) at /home/lj-admin/lj/cgi-bin/ljlib.pl line 1419
};
my $ret;
## try to do it. it'll die if the day is bogus
#$ret = eval { $calc->(); };
#return $ret unless $@;
# Year 2038 fix:
$y = 2037 if $y > 2037;
$y = 1970 if $y < 1970;
# then fix the day up, if so.
my $max_day = LJ::days_in_month($mon, $y);
$d = $max_day if $d > $max_day;
$ret = eval { $calc->(); };
return $ret unless $@;
print STDERR "Error converting $string: " . $@;
return 0;
}
#
# class: time
# name: LJ::time_to_http
# des: Converts a Unix time to an HTTP date.
# info: Wrapper around HTTP::Date::time2str to make an
# HTTP date (RFC 1123 format) See also [func[LJ::http_to_time]].
# args: time
# des-time: Integer; Unix time.
# returns: String; RFC 1123 date.
#
sub time_to_http {
my $time = shift;
return HTTP::Date::time2str($time);
}
#
# name: LJ::time_to_cookie
# des: Converts unix time to format expected in a Set-Cookie header
# args: time
# des-time: unix time
# returns: string; Date/Time in format expected by cookie.
#
sub time_to_cookie {
my $time = shift;
$time = time() unless defined $time;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
$year+=1900;
my @day = qw{Sunday Monday Tuesday Wednesday Thursday Friday Saturday};
my @month = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
return sprintf("$day[$wday], %02d-$month[$mon]-%04d %02d:%02d:%02d GMT",
$mday, $year, $hour, $min, $sec);
}
# http://www.w3.org/TR/NOTE-datetime
# http://www.w3.org/TR/xmlschema-2/#dateTime
sub time_to_w3c {
my ($time, $ofs) = @_;
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($time);
$mon++;
$year += 1900;
$ofs =~ s/([\-+]\d\d)(\d\d)/$1:$2/;
$ofs = 'Z' if $ofs =~ /0000$/;
return sprintf("%04d-%02d-%02dT%02d:%02d:%02d$ofs",
$year, $mon, $mday,
$hour, $min, $sec);
}
#
# name: LJ::get_urls
# des: Returns a list of all referenced URLs from a string
# args: text
# des-text: Text to extra URLs from
# returns: list of URLs
#
sub get_urls
{
return ($_[0] =~ m!http://[^\s\"\'\<\>]+!g);
}
#
# name: LJ::record_meme
# des: Records a URL reference from a journal entry to the meme table.
# args: dbarg?, url, posterid, itemid, journalid?
# des-url: URL to log
# des-posterid: Userid of person posting
# des-itemid: Itemid URL appears in. This is the display itemid,
# which is the jitemid*256+anum from the [dbtable[log2]] table.
# des-journalid: Optional, journal id of item, if item is clustered. Otherwise
# this should be zero or undef.
#
sub record_meme
{
my ($url, $posterid, $itemid, $jid) = @_;
return if $LJ::DISABLED{'meme'};
$url =~ s!/$!!; # strip / at end
LJ::run_hooks("canonicalize_url", \$url);
# canonicalize_url hook might just erase it, so
# we don't want to record it.
return unless $url;
my $dbh = LJ::get_db_writer();
$dbh->do("REPLACE INTO meme (url, posterid, journalid, itemid) " .
"VALUES (?, ?, ?, ?)", undef, $url, $posterid, $jid, $itemid);
}
#
# name: LJ::name_caps
# des: Given a user's capability class bit mask, returns a
# site-specific string representing the capability class name.
# args: caps
# des-caps: 16 bit capability bitmask
#
sub name_caps
{
return undef unless LJ::are_hooks("name_caps");
my $caps = shift;
return LJ::run_hook("name_caps", $caps);
}
#
# name: LJ::name_caps_short
# des: Given a user's capability class bit mask, returns a
# site-specific short string code.
# args: caps
# des-caps: 16 bit capability bitmask
#
sub name_caps_short
{
return undef unless LJ::are_hooks("name_caps_short");
my $caps = shift;
return LJ::run_hook("name_caps_short", $caps);
}
#
# name: LJ::get_cap
# des: Given a user object or capability class bit mask and a capability/limit name,
# returns the maximum value allowed for given user or class, considering
# all the limits in each class the user is a part of.
# args: u_cap, capname
# des-u_cap: 16 bit capability bitmask or a user object from which the
# bitmask could be obtained
# des-capname: the name of a limit, defined in doc/capabilities.txt
#
sub get_cap
{
my $caps = shift; # capability bitmask (16 bits), or user object
my $cname = shift; # capability limit name
my $u = ref $caps ? $caps : undef;
if (! defined $caps) { $caps = 0; }
elsif ($u) { $caps = $u->{'caps'}; }
my $max = undef;
# allow a way for admins to force-set the read-only cap
# to lower writes on a cluster.
if ($cname eq "readonly" && $u &&
($LJ::READONLY_CLUSTER{$u->{clusterid}} ||
$LJ::READONLY_CLUSTER_ADVISORY{$u->{clusterid}} &&
! LJ::get_cap($u, "avoid_readonly"))) {
# HACK for desperate moments. in when_needed mode, see if
# database is locky first
my $cid = $u->{clusterid};
if ($LJ::READONLY_CLUSTER_ADVISORY{$cid} eq "when_needed") {
my $now = time();
return 1 if $LJ::LOCKY_CACHE{$cid} > $now - 15;
my $dbcm = LJ::get_cluster_master($u->{clusterid});
return 1 unless $dbcm;
my $sth = $dbcm->prepare("SHOW PROCESSLIST");
$sth->execute;
return 1 if $dbcm->err;
my $busy = 0;
my $too_busy = $LJ::WHEN_NEEDED_THRES || 300;
while (my $r = $sth->fetchrow_hashref) {
$busy++ if $r->{Command} ne "Sleep";
}
if ($busy > $too_busy) {
$LJ::LOCKY_CACHE{$cid} = $now;
return 1;
}
} else {
return 1;
}
}
# underage/coppa check etc
if ($cname eq "underage" && $u &&
($LJ::UNDERAGE_BIT &&
$caps & 1 << $LJ::UNDERAGE_BIT)) {
return 1;
}
# is there a hook for this cap name?
if (LJ::are_hooks("check_cap_$cname")) {
die "Hook 'check_cap_$cname' requires full user object"
unless defined $u;
my $val = LJ::run_hook("check_cap_$cname", $u);
return $val if defined $val;
# otherwise fall back to standard means
}
# otherwise check via other means
foreach my $bit (keys %LJ::CAP) {
next unless ($caps & (1 << $bit));
my $v = $LJ::CAP{$bit}->{$cname};
next unless (defined $v);
next if (defined $max && $max > $v);
$max = $v;
}
return defined $max ? $max : $LJ::CAP_DEF{$cname};
}
#
# name: LJ::get_cap_min
# des: Just like [func[LJ::get_cap]], but returns the minimum value.
# Although it might not make sense at first, some things are
# better when they're low, like the minimum amount of time
# a user might have to wait between getting updates or being
# allowed to refresh a page.
# args: u_cap, capname
# des-u_cap: 16 bit capability bitmask or a user object from which the
# bitmask could be obtained
# des-capname: the name of a limit, defined in doc/capabilities.txt
#
sub get_cap_min
{
my $caps = shift; # capability bitmask (16 bits), or user object
my $cname = shift; # capability name
if (! defined $caps) { $caps = 0; }
elsif (isu($caps)) { $caps = $caps->{'caps'}; }
my $min = undef;
foreach my $bit (keys %LJ::CAP) {
next unless ($caps & (1 << $bit));
my $v = $LJ::CAP{$bit}->{$cname};
next unless (defined $v);
next if (defined $min && $min < $v);
$min = $v;
}
return defined $min ? $min : $LJ::CAP_DEF{$cname};
}
#
# name: LJ::are_hooks
# des: Returns true if the site has one or more hooks installed for
# the given hookname.
# args: hookname
#
sub are_hooks
{
my $hookname = shift;
return defined $LJ::HOOKS{$hookname};
}
#
# name: LJ::clear_hooks
# des: Removes all hooks.
#
sub clear_hooks
{
%LJ::HOOKS = ();
}
#
# name: LJ::run_hooks
# des: Runs all the site-specific hooks of the given name.
# returns: list of arrayrefs, one for each hook ran, their
# contents being their own return values.
# args: hookname, args*
# des-args: Arguments to be passed to hook.
#
sub run_hooks
{
my ($hookname, @args) = @_;
my @ret;
foreach my $hook (@{$LJ::HOOKS{$hookname} || []}) {
push @ret, [ $hook->(@args) ];
}
return @ret;
}
#
# name: LJ::run_hook
# des: Runs single site-specific hook of the given name.
# returns: return value from hook
# args: hookname, args*
# des-args: Arguments to be passed to hook.
#
sub run_hook
{
my ($hookname, @args) = @_;
return undef unless @{$LJ::HOOKS{$hookname} || []};
return $LJ::HOOKS{$hookname}->[0]->(@args);
return undef;
}
#
# name: LJ::register_hook
# des: Installs a site-specific hook.
# info: Installing multiple hooks per hookname is valid.
# They're run later in the order they're registered.
# args: hookname, subref
# des-subref: Subroutine reference to run later.
#
sub register_hook
{
my $hookname = shift;
my $subref = shift;
push @{$LJ::HOOKS{$hookname}}, $subref;
}
#
# name: LJ::register_setter
# des: Installs code to run for the "set" command in the console.
# info: Setters can be general or site-specific.
# args: key, subref
# des-key: Key to set.
# des-subref: Subroutine reference to run later.
#
sub register_setter
{
my $key = shift;
my $subref = shift;
$LJ::SETTER{$key} = $subref;
}
register_setter('synlevel', sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^(title|summary|full)$/) {
$$err = "Illegal value. Must be 'title', 'summary', or 'full'";
return 0;
}
LJ::set_userprop($u, 'opt_synlevel', $value);
return 1;
});
register_setter("newpost_minsecurity", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^(public|friends|private)$/) {
$$err = "Illegal value. Must be 'public', 'friends', or 'private'";
return 0;
}
# Don't let commmunities be private
if ($u->{'journaltype'} eq "C" && $value eq "private") {
$$err = "newpost_minsecurity cannot be private for communities";
return 0;
}
$value = "" if $value eq "public";
LJ::set_userprop($u, "newpost_minsecurity", $value);
return 1;
});
register_setter("stylesys", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^[sS]?(1|2)$/) {
$$err = "Illegal value. Must be S1 or S2.";
return 0;
}
$value = $1 + 0;
LJ::set_userprop($u, "stylesys", $value);
return 1;
});
register_setter("maximagesize", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ m/^(\d+)[x,|](\d+)$/) {
$$err = "Illegal value. Must be width,height.";
return 0;
}
$value = "$1|$2";
LJ::set_userprop($u, "opt_imagelinks", $value);
return 1;
});
register_setter("opt_ljcut_disable_lastn", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^(0|1)$/) {
$$err = "Illegal value. Must be '0' or '1'";
return 0;
}
LJ:set_userprop($u, "opt_ljcut_disable_lastn", $value);
return 1;
});
register_setter("opt_ljcut_disable_friends", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^(0|1)$/) {
$$err = "Illegal value. Must be '0' or '1'";
return 0;
}
LJ:set_userprop($u, "opt_ljcut_disable_friends", $value);
return 1;
});
register_setter("disable_quickreply", sub {
my ($dba, $u, $remote, $key, $value, $err) = @_;
unless ($value =~ /^(0|1)$/) {
$$err = "Illegal value. Must be '0' or '1'";
return 0;
}
LJ:set_userprop($u, "opt_no_quickreply", $value);
return 1;
});
#
# name: LJ::make_auth_code
# des: Makes a random string of characters of a given length.
# returns: string of random characters, from an alphabet of 30
# letters & numbers which aren't easily confused.
# args: length
# des-length: length of auth code to return
#
sub make_auth_code
{
my $length = shift;
my $digits = "abcdefghjkmnpqrstvwxyz23456789";
my $auth;
for (1..$length) { $auth .= substr($digits, int(rand(30)), 1); }
return $auth;
}
#
# name: LJ::acid_encode
# des: Given a decimal number, returns base 30 encoding
# using an alphabet of letters & numbers that are
# not easily mistaken for each other.
# returns: Base 30 encoding, alwyas 7 characters long.
# args: number
# des-number: Number to encode in base 30.
#
sub acid_encode
{
my $num = shift;
my $acid = "";
my $digits = "abcdefghjkmnpqrstvwxyz23456789";
while ($num) {
my $dig = $num % 30;
$acid = substr($digits, $dig, 1) . $acid;
$num = ($num - $dig) / 30;
}
return ("a"x(7-length($acid)) . $acid);
}
#
# name: LJ::acid_decode
# des: Given an acid encoding from [func[LJ::acid_encode]],
# returns the original decimal number.
# returns: Integer.
# args: acid
# des-acid: base 30 number from [func[LJ::acid_encode]].
#
sub acid_decode
{
my $acid = shift;
$acid = lc($acid);
my %val;
my $digits = "abcdefghjkmnpqrstvwxyz23456789";
for (0..30) { $val{substr($digits,$_,1)} = $_; }
my $num = 0;
my $place = 0;
while ($acid) {
return 0 unless ($acid =~ s/[$digits]$//o);
$num += $val{$&} * (30 ** $place++);
}
return $num;
}
#
# name: LJ::acct_code_generate
# des: Creates invitation code(s) from an optional userid
# for use by anybody.
# returns: Code generated (if quantity 1),
# number of codes generated (if quantity>1),
# or undef on failure.
# args: dbarg?, userid?, quantity?
# des-userid: Userid to make the invitation code from,
# else the code will be from userid 0 (system)
# des-quantity: Number of codes to generate (default 1)
#
sub acct_code_generate
{
&nodb;
my $userid = int(shift);
my $quantity = shift || 1;
my $dbh = LJ::get_db_writer();
my @authcodes = map {LJ::make_auth_code(5)} 1..$quantity;
my @values = map {"(NULL, $userid, 0, '$_')"} @authcodes;
my $sql = "INSERT INTO acctcode (acid, userid, rcptid, auth) "
. "VALUES " . join(",", @values);
my $num_rows = $dbh->do($sql) or return undef;
if ($quantity == 1) {
my $acid = $dbh->{'mysql_insertid'} or return undef;
return acct_code_encode($acid, $authcodes[0]);
} else {
return $num_rows;
}
}
#
# name: LJ::acct_code_encode
# des: Given an account ID integer and a 5 digit auth code, returns
# a 12 digit account code.
# returns: 12 digit account code.
# args: acid, auth
# des-acid: account ID, a 4 byte unsigned integer
# des-auth: 5 random characters from base 30 alphabet.
#
sub acct_code_encode
{
my $acid = shift;
my $auth = shift;
return lc($auth) . acid_encode($acid);
}
#
# name: LJ::acct_code_decode
# des: Breaks an account code down into its two parts
# returns: list of (account ID, auth code)
# args: code
# des-code: 12 digit account code
#
sub acct_code_decode
{
my $code = shift;
return (acid_decode(substr($code, 5, 7)), lc(substr($code, 0, 5)));
}
#
# name: LJ::acct_code_check
# des: Checks the validity of a given account code
# returns: boolean; 0 on failure, 1 on validity. sets $$err on failure.
# args: dbarg?, code, err?, userid?
# des-code: account code to check
# des-err: optional scalar ref to put error message into on failure
# des-userid: optional userid which is allowed in the rcptid field,
# to allow for htdocs/create.bml case when people double
# click the submit button.
#
sub acct_code_check
{
&nodb;
my $code = shift;
my $err = shift; # optional; scalar ref
my $userid = shift; # optional; acceptable userid (double-click proof)
my $dbh = LJ::get_db_writer();
unless (length($code) == 12) {
$$err = "Malformed code; not 12 characters.";
return 0;
}
my ($acid, $auth) = acct_code_decode($code);
my $ac = $dbh->selectrow_hashref("SELECT userid, rcptid, auth ".
"FROM acctcode WHERE acid=?",
undef, $acid);
unless ($ac && $ac->{'auth'} eq $auth) {
$$err = "Invalid account code.";
return 0;
}
if ($ac->{'rcptid'} && $ac->{'rcptid'} != $userid) {
$$err = "This code has already been used: $code";
return 0;
}
# is the journal this code came from suspended?
my $u = LJ::load_userid($ac->{'userid'});
if ($u && $u->{'statusvis'} eq "S") {
$$err = "Code belongs to a suspended account.";
return 0;
}
return 1;
}
#
# name: LJ::load_mood_theme
# des: Loads and caches a mood theme, or returns immediately if already loaded.
# args: dbarg?, themeid
# des-themeid: the mood theme ID to load
#
sub load_mood_theme
{
&nodb;
my $themeid = shift;
return if $LJ::CACHE_MOOD_THEME{$themeid};
return unless $themeid;
# check memcache
my $memkey = [$themeid, "moodthemedata:$themeid"];
return if $LJ::CACHE_MOOD_THEME{$themeid} = LJ::MemCache::get($memkey) and
%{$LJ::CACHE_MOOD_THEME{$themeid} || {}};
# fall back to db
my $dbh = LJ::get_db_writer()
or return 0;
$LJ::CACHE_MOOD_THEME{$themeid} = {};
my $sth = $dbh->prepare("SELECT moodid, picurl, width, height FROM moodthemedata WHERE moodthemeid=?");
$sth->execute($themeid);
return 0 if $dbh->err;
while (my ($id, $pic, $w, $h) = $sth->fetchrow_array) {
$LJ::CACHE_MOOD_THEME{$themeid}->{$id} = { 'pic' => $pic, 'w' => $w, 'h' => $h };
}
# set in memcache
LJ::MemCache::set($memkey, $LJ::CACHE_MOOD_THEME{$themeid})
if %{$LJ::CACHE_MOOD_THEME{$themeid} || {}};
return 1;
}
#
# name: LJ::load_props
# des: Loads and caches one or more of the various *proplist tables:
# logproplist, talkproplist, and userproplist, which describe
# the various meta-data that can be stored on log (journal) items,
# comments, and users, respectively.
# args: dbarg?, table*
# des-table: a list of tables' proplists to load. can be one of
# "log", "talk", "user", or "rate"
#
sub load_props
{
my $dbarg = ref $_[0] ? shift : undef;
my @tables = @_;
my $dbr;
my %keyname = qw(log propid
talk tpropid
user upropid
rate rlid
);
foreach my $t (@tables) {
next unless defined $keyname{$t};
next if defined $LJ::CACHE_PROP{$t};
my $tablename = $t eq "rate" ? "ratelist" : "${t}proplist";
$dbr ||= LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT * FROM $tablename");
$sth->execute;
while (my $p = $sth->fetchrow_hashref) {
$p->{'id'} = $p->{$keyname{$t}};
$LJ::CACHE_PROP{$t}->{$p->{'name'}} = $p;
$LJ::CACHE_PROPID{$t}->{$p->{'id'}} = $p;
}
}
}
#
# name: LJ::get_prop
# des: This is used to retrieve
# a hashref of a row from the given tablename's proplist table.
# One difference from getting it straight from the database is
# that the 'id' key is always present, as a copy of the real
# proplist unique id for that table.
# args: table, name
# returns: hashref of proplist row from db
# des-table: the tables to get a proplist hashref from. can be one of
# "log", "talk", or "user".
# des-name: the name of the prop to get the hashref of.
#
sub get_prop
{
my $table = shift;
my $name = shift;
unless (defined $LJ::CACHE_PROP{$table}) {
LJ::load_props($table);
return undef unless $LJ::CACHE_PROP{$table};
}
return $LJ::CACHE_PROP{$table}->{$name};
}
#
# name: LJ::load_codes
# des: Populates hashrefs with lookup data from the database or from memory,
# if already loaded in the past. Examples of such lookup data include
# state codes, country codes, color name/value mappings, etc.
# args: dbarg?, whatwhere
# des-whatwhere: a hashref with keys being the code types you want to load
# and their associated values being hashrefs to where you
# want that data to be populated.
#
sub load_codes
{
&nodb;
my $req = shift;
my $dbr = LJ::get_db_reader();
foreach my $type (keys %{$req})
{
my $memkey = "load_codes:$type";
unless ($LJ::CACHE_CODES{$type} ||= LJ::MemCache::get($memkey))
{
$LJ::CACHE_CODES{$type} = [];
my $sth = $dbr->prepare("SELECT code, item, sortorder FROM codes WHERE type=?");
$sth->execute($type);
while (my ($code, $item, $sortorder) = $sth->fetchrow_array)
{
push @{$LJ::CACHE_CODES{$type}}, [ $code, $item, $sortorder ];
}
@{$LJ::CACHE_CODES{$type}} =
sort { $a->[2] <=> $b->[2] } @{$LJ::CACHE_CODES{$type}};
LJ::MemCache::set($memkey, $LJ::CACHE_CODES{$type}, 60*15);
}
foreach my $it (@{$LJ::CACHE_CODES{$type}})
{
if (ref $req->{$type} eq "HASH") {
$req->{$type}->{$it->[0]} = $it->[1];
} elsif (ref $req->{$type} eq "ARRAY") {
push @{$req->{$type}}, { 'code' => $it->[0], 'item' => $it->[1] };
}
}
}
}
#
# name: LJ::debug
# des: When $LJ::DEBUG is set, logs the given message to
# the Apache error log. Or, if $LJ::DEBUG is 2, then
# prints to STDOUT.
# returns: 1 if logging disabled, 0 on failure to open log, 1 otherwise
# args: message
# des-message: Message to log.
#
sub debug
{
return 1 unless ($LJ::DEBUG);
if ($LJ::DEBUG == 2) {
print $_[0], "\n";
return 1;
}
my $r = Apache->request;
return 0 unless $r;
$r->log_error($_[0]);
return 1;
}
#
# name: LJ::auth_okay
# des: Validates a user's password. The "clear" or "md5" argument
# must be present, and either the "actual" argument (the correct
# password) must be set, or the first argument must be a user
# object ($u) with the 'password' key set. Note that this is
# the preferred way to validate a password (as opposed to doing
# it by hand) since this function will use a pluggable authenticator
# if one is defined, so LiveJournal installations can be based
# off an LDAP server, for example.
# returns: boolean; 1 if authentication succeeded, 0 on failure
# args: u, clear, md5, actual?, ip_banned?
# des-clear: Clear text password the client is sending. (need this or md5)
# des-md5: MD5 of the password the client is sending. (need this or clear).
# If this value instead of clear, clear can be anything, as md5
# validation will take precedence.
# des-actual: The actual password for the user. Ignored if a pluggable
# authenticator is being used. Required unless the first
# argument is a user object instead of a username scalar.
# des-ip_banned: Optional scalar ref which this function will set to true
# if IP address of remote user is banned.
#
sub auth_okay
{
my $u = shift;
my $clear = shift;
my $md5 = shift;
my $actual = shift;
my $ip_banned = shift;
return 0 unless isu($u);
$actual ||= $u->{'password'};
my $user = $u->{'user'};
# set the IP banned flag, if it was provided.
my $fake_scalar;
my $ref = ref $ip_banned ? $ip_banned : \$fake_scalar;
if (LJ::login_ip_banned($u)) {
$$ref = 1;
return 0;
} else {
$$ref = 0;
}
my $bad_login = sub {
LJ::handle_bad_login($u);
return 0;
};
# setup this auth checker for LDAP
if ($LJ::LDAP_HOST && ! $LJ::AUTH_CHECK) {
require LJ::LDAP;
$LJ::AUTH_CHECK = sub {
my ($user, $try, $type) = @_;
die unless $type eq "clear";
return LJ::LDAP::is_good_ldap($user, $try);
};
}
## custom authorization:
if (ref $LJ::AUTH_CHECK eq "CODE") {
my $type = $md5 ? "md5" : "clear";
my $try = $md5 || $clear;
my $good = $LJ::AUTH_CHECK->($user, $try, $type);
return $good || $bad_login->();
}
## LJ default authorization:
return 0 unless $actual;
return 1 if ($md5 && lc($md5) eq LJ::hash_password($actual));
return 1 if ($clear eq $actual);
return $bad_login->();
}
# Implement Digest authentication per RFC2617
# called with Apache's request oject
# modifies outgoing header fields appropriately and returns
# 1/0 according to whether auth succeeded. If succeeded, also
# calls LJ::set_remote() to set up internal LJ auth.
# this routine should be called whenever it's clear the client
# wants/the server demands digest auth, and if it returns 1,
# things proceed as usual; if it returns 0, the caller should
# $r->send_http_header(), output an auth error message in HTTP
# data and return to apache.
# Note: Authentication-Info: not sent (optional and nobody supports
# it anyway). Instead, server nonces are reused within their timeout
# limits and nonce counts are used to prevent replay attacks.
sub auth_digest {
my ($r) = @_;
my $decline = sub {
my $stale = shift;
my $nonce = LJ::challenge_generate(180); # 3 mins timeout
my $authline = "Digest realm=\"lj\", nonce=\"$nonce\", algorithm=MD5, qop=\"auth\"";
$authline .= ", stale=\"true\"" if $stale;
$r->header_out("WWW-Authenticate", $authline);
$r->status_line("401 Authentication required");
return 0;
};
unless ($r->header_in("Authorization")) {
return $decline->(0);
}
my $header = $r->header_in("Authorization");
# parse it
# TODO: could there be "," or " " inside attribute values, requiring
# trickier parsing?
my @vals = split(/[, \s]/, $header);
my $authname = shift @vals;
my %attrs;
foreach (@vals) {
if (/^(\S*?)=(\S*)$/) {
my ($attr, $value) = ($1,$2);
if ($value =~ m/^\"([^\"]*)\"$/) {
$value = $1;
}
$attrs{$attr} = $value;
}
}
# sanity checks
unless ($authname eq 'Digest' && $attrs{'qop'} eq 'auth' &&
$attrs{'realm'} eq 'lj' && $attrs{'algorithm'} eq 'MD5') {
return $decline->(0);
}
my %opts;
LJ::challenge_check($attrs{'nonce'}, \%opts);
return $decline->(0) unless $opts{'valid'};
# if the nonce expired, force a new one
return $decline->(1) if $opts{'expired'};
# check the nonce count
# be lenient, allowing for error of magnitude 1 (Mozilla has a bug,
# it repeats nc=00000001 twice...)
# in case the count is off, force a new nonce; if a client's
# nonce count implementation is broken and it doesn't send nc= or
# always sends 1, this'll at least work due to leniency above
my $ncount = hex($attrs{'nc'});
unless (abs($opts{'count'} - $ncount) <= 1) {
return $decline->(1);
}
# the username
my $user = LJ::canonical_username($attrs{'username'});
my $u = LJ::load_user($user);
return $decline->(0) unless $u;
# don't allow empty passwords
return $decline->(0) unless $u->{'password'};
# recalculate the hash and compare to response
my $a1src="$u->{'user'}:lj:$u->{'password'}";
my $a1 = Digest::MD5::md5_hex($a1src);
my $a2src = $r->method . ":$attrs{'uri'}";
my $a2 = Digest::MD5::md5_hex($a2src);
my $hashsrc = "$a1:$attrs{'nonce'}:$attrs{'nc'}:$attrs{'cnonce'}:$attrs{'qop'}:$a2";
my $hash = Digest::MD5::md5_hex($hashsrc);
return $decline->(0)
unless $hash eq $attrs{'response'};
# set the remote
LJ::set_remote($u);
return $u;
}
# Create a challenge token for secure logins
sub challenge_generate
{
my ($goodfor, $attr) = @_;
$goodfor ||= 60;
$attr ||= LJ::rand_chars(20);
my ($stime, $secret) = LJ::get_secret();
# challenge version, secret time, secret age, time in secs token is good for, random chars.
my $s_age = time() - $stime;
my $chalbare = "c0:$stime:$s_age:$goodfor:$attr";
my $chalsig = Digest::MD5::md5_hex($chalbare . $secret);
my $chal = "$chalbare:$chalsig";
return $chal;
}
# Return challenge info.
# This could grow later - for now just return the rand chars used.
sub get_challenge_attributes
{
return (split /:/, shift)[4];
}
# Validate a challenge string previously supplied by challenge_generate
# return 1 "good" 0 "bad", plus sets keys in $opts:
# 'valid'=1/0 whether the string itself was valid
# 'expired'=1/0 whether the challenge expired, provided it's valid
# 'count'=N number of times we've seen this challenge, including this one,
# provided it's valid and not expired
# $opts also supports in parameters:
# 'dont_check_count' => if true, won't return a count field
# the return value is 1 if 'valid' and not 'expired' and 'count'==1
sub challenge_check {
my ($chal, $opts) = @_;
my ($valid, $expired, $count) = (1, 0, 0);
my ($c_ver, $stime, $s_age, $goodfor, $rand, $chalsig) = split /:/, $chal;
my $secret = LJ::get_secret($stime);
my $chalbare = "$c_ver:$stime:$s_age:$goodfor:$rand";
# Validate token
$valid = 0
unless $secret && $c_ver eq 'c0'; # wrong version
$valid = 0
unless Digest::MD5::md5_hex($chalbare . $secret) eq $chalsig;
$expired = 1
unless (not $valid) or time() - ($stime + $s_age) < $goodfor;
# Check for token dups
if ($valid && !$expired && !$opts->{dont_check_count}) {
if (@LJ::MEMCACHE_SERVERS) {
$count = LJ::MemCache::incr("chaltoken:$chal", 1);
unless ($count) {
LJ::MemCache::add("chaltoken:$chal", 1, $goodfor);
$count = 1;
}
} else {
my $dbh = LJ::get_db_writer();
my $rv = $dbh->do("SELECT GET_LOCK(?,5)", undef, $chal);
if ($rv) {
$count = $dbh->selectrow_array("SELECT count FROM challenges WHERE challenge=?",
undef, $chal);
if ($count) {
$dbh->do("UPDATE challenges SET count=count+1 WHERE challenge=?",
undef, $chal);
$count++;
} else {
$dbh->do("INSERT INTO challenges SET ctime=?, challenge=?, count=1",
undef, $stime + $s_age, $chal);
$count = 1;
}
}
$dbh->do("SELECT RELEASE_LOCK(?)", undef, $chal);
}
# if we couldn't get the count (means we couldn't store either)
# , consider it invalid
$valid = 0 unless $count;
}
if ($opts) {
$opts->{'expired'} = $expired;
$opts->{'valid'} = $valid;
$opts->{'count'} = $count;
}
return ($valid && !$expired && ($count==1 || $opts->{dont_check_count}));
}
# Validate login/talk md5 responses.
# Return 1 on valid, 0 on invalid.
sub challenge_check_login
{
my ($u, $chal, $res, $banned, $opts) = @_;
return 0 unless $u;
my $pass = $u->{'password'};
return 0 if $pass eq "";
# set the IP banned flag, if it was provided.
my $fake_scalar;
my $ref = ref $banned ? $banned : \$fake_scalar;
if (LJ::login_ip_banned($u)) {
$$ref = 1;
return 0;
} else {
$$ref = 0;
}
# check the challenge string validity
return 0 unless LJ::challenge_check($chal, $opts);
# Validate password
my $hashed = Digest::MD5::md5_hex($chal . Digest::MD5::md5_hex($pass));
if ($hashed eq $res) {
return 1;
} else {
LJ::handle_bad_login($u);
return 0;
}
}
#
# name: LJ::is_friend
# des: Checks to see if a user is a friend of another user.
# returns: boolean; 1 if user B is a friend of user A or if A == B
# args: usera, userb
# des-usera: Source user hashref or userid.
# des-userb: Destination user hashref or userid. (can be undef)
#
sub is_friend
{
&nodb;
my ($ua, $ub) = @_[0, 1];
$ua = LJ::want_userid($ua);
$ub = LJ::want_userid($ub);
return 0 unless $ua && $ub;
return 1 if $ua == $ub;
# get group mask from the first argument to the second argument and
# see if first bit is set. if it is, they're a friend. get_groupmask
# is memcached and used often, so it's likely to be available quickly.
return LJ::get_groupmask(@_[0, 1]) & 1;
}
#
# name: LJ::is_banned
# des: Checks to see if a user is banned from a journal.
# returns: boolean; 1 iff "user" is banned from "journal"
# args: user, journal
# des-user: User hashref or userid.
# des-journal: Journal hashref or userid.
#
sub is_banned
{
&nodb;
# get user and journal ids
my $uid = LJ::want_userid(shift);
my $jid = LJ::want_userid(shift);
return 1 unless $uid && $jid;
# for speed: common case is non-community posting and replies
# in own journal. avoid db hit.
return 0 if ($uid == $jid);
# edge from journal -> user
return LJ::check_rel($jid, $uid, 'B');
}
#
# name: LJ::get_remote_noauth
# des: returns who the remote user says they are, but doesn't check
# their login token. disadvantage: insecure, only use when
# you're not doing anything critical. advantage: faster.
# returns: hashref containing only key 'user', not 'userid' like
# [func[LJ::get_remote]].
#
sub get_remote_noauth
{
my $sess = $BML::COOKIE{'ljsession'};
return { 'user' => $1 } if $sess =~ /^ws:(\w+):/;
return undef;
}
#
# name: LJ::clear_caches
# des: This function is called from a HUP signal handler and is intentionally
# very very simple (1 line) so we don't core dump on a system without
# reentrant libraries. It just sets a flag to clear the caches at the
# beginning of the next request (see [func[LJ::handle_caches]]).
# There should be no need to ever call this function directly.
#
sub clear_caches
{
$LJ::CLEAR_CACHES = 1;
}
#
# name: LJ::handle_caches
# des: clears caches if the CLEAR_CACHES flag is set from an earlier
# HUP signal that called [func[LJ::clear_caches]], otherwise
# does nothing.
# returns: true (always) so you can use it in a conjunction of
# statements in a while loop around the application like:
# while (LJ::handle_caches() && FCGI::accept())
#
sub handle_caches
{
return 1 unless $LJ::CLEAR_CACHES;
$LJ::CLEAR_CACHES = 0;
do "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
do "$ENV{'LJHOME'}/cgi-bin/ljdefaults.pl";
$LJ::DBIRole->flush_cache();
%LJ::CACHE_PROP = ();
%LJ::CACHE_STYLE = ();
$LJ::CACHED_MOODS = 0;
$LJ::CACHED_MOOD_MAX = 0;
%LJ::CACHE_MOODS = ();
%LJ::CACHE_MOOD_THEME = ();
%LJ::CACHE_USERID = ();
%LJ::CACHE_USERNAME = ();
%LJ::CACHE_CODES = ();
%LJ::CACHE_USERPROP = (); # {$prop}->{ 'upropid' => ... , 'indexed' => 0|1 };
%LJ::CACHE_ENCODINGS = ();
return 1;
}
#
# name: LJ::start_request
# des: Before a new web request is obtained, this should be called to
# determine if process should die or keep working, clean caches,
# reload config files, etc.
# returns: 1 if a new request is to be processed, 0 if process should die.
#
sub start_request
{
handle_caches();
# TODO: check process growth size
# clear per-request caches
LJ::unset_remote(); # clear cached remote
$LJ::ACTIVE_CRUMB = ''; # clear active crumb
%LJ::CACHE_USERPIC = (); # picid -> hashref
%LJ::CACHE_USERPIC_INFO = (); # uid -> { ... }
%LJ::REQ_CACHE_USER_NAME = (); # users by name
%LJ::REQ_CACHE_USER_ID = (); # users by id
%LJ::REQ_CACHE_REL = (); # relations from LJ::check_rel()
%LJ::REQ_CACHE_DIRTY = (); # caches calls to LJ::mark_dirty()
%LJ::S1::REQ_CACHE_STYLEMAP = (); # styleid -> uid mappings
%LJ::REQ_DBIX_TRACKER = (); # canonical dbrole -> DBIx::StateTracker
%LJ::REQ_DBIX_KEEPER = (); # dbrole -> DBIx::StateKeeper
%LJ::REQ_HEAD_HAS = (); # avoid code duplication for js
# we use this to fake out get_remote's perception of what
# the client's remote IP is, when we transfer cookies between
# authentication domains. see the FotoBilder interface.
$LJ::_XFER_REMOTE_IP = undef;
# clear the handle request cache (like normal cache, but verified already for
# this request to be ->ping'able).
$LJ::DBIRole->clear_req_cache();
# need to suck db weights down on every request (we check
# the serial number of last db weight change on every request
# to validate master db connection, instead of selecting
# the connection ID... just as fast, but with a point!)
$LJ::DBIRole->trigger_weight_reload();
# reset BML's cookies
eval { BML::reset_cookies() };
# check the modtime of ljconfig.pl and reload if necessary
# only do a stat every 10 seconds and then only reload
# if the file has changed
my $now = time();
if ($now - $LJ::CACHE_CONFIG_MODTIME_LASTCHECK > 10) {
my $modtime = (stat("$ENV{'LJHOME'}/cgi-bin/ljconfig.pl"))[9];
if ($modtime > $LJ::CACHE_CONFIG_MODTIME) {
# reload config and update cached modtime
$LJ::CACHE_CONFIG_MODTIME = $modtime;
eval {
do "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
do "$ENV{'LJHOME'}/cgi-bin/ljdefaults.pl";
# reload MogileFS config
if (LJ::mogclient()) {
LJ::mogclient()->reload
( domain => $LJ::MOGILEFS_CONFIG{domain},
root => $LJ::MOGILEFS_CONFIG{root},
hosts => $LJ::MOGILEFS_CONFIG{hosts}, );
LJ::mogclient()->set_pref_ip(\%LJ::MOGILEFS_PREF_IP)
if %LJ::MOGILEFS_PREF_IP;
}
};
$LJ::IMGPREFIX_BAK = $LJ::IMGPREFIX;
$LJ::STATPREFIX_BAK = $LJ::STATPREFIX;
$LJ::LOCKER_OBJ = undef;
$LJ::DBIRole->set_sources(\%LJ::DBINFO);
LJ::MemCache::reload_conf();
if ($modtime > $now - 60) {
# show to stderr current reloads. won't show
# reloads happening from new apache children
# forking off the parent who got the inital config loaded
# hours/days ago and then the "updated" config which is
# a different hours/days ago.
#
# only print when we're in web-context
print STDERR "ljconfig.pl reloaded\n"
if eval { Apache->request };
}
}
$LJ::CACHE_CONFIG_MODTIME_LASTCHECK = $now;
}
return 1;
}
#
# name: LJ::end_request
# des: Clears cached DB handles/trackers/keepers (if $LJ::DISCONNECT_DBS is
# true) and disconnects MemCache handles (if $LJ::DISCONNECT_MEMCACHE is
# true).
#
sub end_request
{
LJ::flush_cleanup_handlers();
LJ::disconnect_dbs() if $LJ::DISCONNECT_DBS;
LJ::MemCache::disconnect_all() if $LJ::DISCONNECT_MEMCACHE;
}
#
# name: LJ::flush_cleanup_handlers
# des: Runs all cleanup handlers registered in @LJ::CLEANUP_HANDLERS
#
sub flush_cleanup_handlers {
while (my $ref = shift @LJ::CLEANUP_HANDLERS) {
next unless ref $ref eq 'CODE';
$ref->();
}
}
#
# name: LJ::disconnect_dbs
# des: Clear cached DB handles and trackers/keepers to partitioned DBs.
#
sub disconnect_dbs {
# clear cached handles
$LJ::DBIRole->disconnect_all( { except => [qw(logs)] });
# and cached trackers/keepers to partitioned dbs
while (my ($role, $tk) = each %LJ::REQ_DBIX_TRACKER) {
$tk->disconnect if $tk;
}
%LJ::REQ_DBIX_TRACKER = ();
%LJ::REQ_DBIX_KEEPER = ();
}
#
# name: LJ::load_userpics
# des: Loads a bunch of userpic at once.
# args: dbarg?, upics, idlist
# des-upics: hashref to load pictures into, keys being the picids
# des-idlist: [$u, $picid] or [[$u, $picid], [$u, $picid], +] objects
# also supports depreciated old method of an array ref of picids
#
sub load_userpics
{
&nodb;
my ($upics, $idlist) = @_;
return undef unless ref $idlist eq 'ARRAY' && $idlist->[0];
# deal with the old calling convention, just an array ref of picids eg. [7, 4, 6, 2]
if (! ref $idlist->[0] && $idlist->[0]) { # assume we have an old style caller
my $in = join(',', map { $_+0 } @$idlist);
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT userid, picid, width, height " .
"FROM userpic WHERE picid IN ($in)");
$sth->execute;
while ($_ = $sth->fetchrow_hashref) {
my $id = $_->{'picid'};
undef $_->{'picid'};
$upics->{$id} = $_;
}
return;
}
# $idlist needs to be an arrayref of arrayrefs,
# HOWEVER, there's a special case where it can be
# an arrayref of 2 items: $u (which is really an arrayref)
# as well due to 'fields' and picid which is an integer.
#
# [$u, $picid] needs to map to [[$u, $picid]] while allowing
# [[$u1, $picid1], [$u2, $picid2], [etc...]] to work.
if (scalar @$idlist == 2 && ! ref $idlist->[1]) {
$idlist = [ $idlist ];
}
my @load_list;
foreach my $row (@{$idlist})
{
my ($u, $id) = @$row;
next unless ref $u;
if ($LJ::CACHE_USERPIC{$id}) {
$upics->{$id} = $LJ::CACHE_USERPIC{$id};
} elsif ($id+0) {
push @load_list, [$u, $id+0];
}
}
return unless @load_list;
if (@LJ::MEMCACHE_SERVERS) {
my @mem_keys = map { [$_->[1],"userpic.$_->[1]"] } @load_list;
my $mem = LJ::MemCache::get_multi(@mem_keys) || {};
while (my ($k, $v) = each %$mem) {
next unless $v && $k =~ /(\d+)/;
my $id = $1;
$upics->{$id} = LJ::MemCache::array_to_hash("userpic", $v);
}
@load_list = grep { ! $upics->{$_->[1]} } @load_list;
return unless @load_list;
}
my %db_load;
my @load_list_d6;
foreach my $row (@load_list) {
# ignore users on clusterid 0
next unless $row->[0]->{clusterid};
if ($row->[0]->{'dversion'} > 6) {
push @{$db_load{$row->[0]->{'clusterid'}}}, $row;
} else {
push @load_list_d6, $row;
}
}
foreach my $cid (keys %db_load) {
my $dbcr = LJ::get_cluster_def_reader($cid);
unless ($dbcr) {
print STDERR "Error: LJ::load_userpics unable to get handle; cid = $cid\n";
next;
}
my (@bindings, @data);
foreach my $row (@{$db_load{$cid}}) {
push @bindings, "(userid=? AND picid=?)";
push @data, ($row->[0]->{userid}, $row->[1]);
}
next unless @data && @bindings;
my $sth = $dbcr->prepare("SELECT userid, picid, width, height, fmt, state, ".
" UNIX_TIMESTAMP(picdate) AS 'picdate', location, flags ".
"FROM userpic2 WHERE " . join(' OR ', @bindings));
$sth->execute(@data);
while (my $ur = $sth->fetchrow_hashref) {
my $id = delete $ur->{'picid'};
$upics->{$id} = $ur;
# force into numeric context so they'll be smaller in memcache:
foreach my $k (qw(userid width height flags picdate)) {
$ur->{$k} += 0;
}
$ur->{location} = uc(substr($ur->{location}, 0, 1));
$LJ::CACHE_USERPIC{$id} = $ur;
LJ::MemCache::set([$id,"userpic.$id"], LJ::MemCache::hash_to_array("userpic", $ur));
}
}
# following path is only for old style d6 userpics... don't load any if we don't
# have any to load
return unless @load_list_d6;
my $dbr = LJ::get_db_writer();
my $picid_in = join(',', map { $_->[1] } @load_list_d6);
my $sth = $dbr->prepare("SELECT userid, picid, width, height, contenttype, state, ".
" UNIX_TIMESTAMP(picdate) AS 'picdate' ".
"FROM userpic WHERE picid IN ($picid_in)");
$sth->execute;
while (my $ur = $sth->fetchrow_hashref) {
my $id = delete $ur->{'picid'};
$upics->{$id} = $ur;
# force into numeric context so they'll be smaller in memcache:
foreach my $k (qw(userid width height picdate)) {
$ur->{$k} += 0;
}
$ur->{location} = "?";
$ur->{flags} = undef;
$ur->{fmt} = {
'image/gif' => 'G',
'image/jpeg' => 'J',
'image/png' => 'P',
}->{delete $ur->{contenttype}};
$LJ::CACHE_USERPIC{$id} = $ur;
LJ::MemCache::set([$id,"userpic.$id"], LJ::MemCache::hash_to_array("userpic", $ur));
}
}
#
# name: LJ::expunge_userpic
# des: Expunges a userpic so that the system will no longer deliver this userpic. If
# your site has off-site caching or something similar, you can also define a hook
# "expunge_userpic" which will be called with a picid and userid when a pic is
# expunged.
# args: u, picid
# des-picid: Id of the picture to expunge.
# des-u: User object
# returns: undef on error, or the userid of the picture owner on success.
#
sub expunge_userpic {
# take in a picid and expunge it from the system so that it can no longer be used
my ($u, $picid) = @_;
$picid += 0;
return undef unless $picid && ref $u;
# get the pic information
my $state;
if ($u->{'dversion'} > 6) {
my $dbcm = LJ::get_cluster_master($u);
return undef unless $dbcm && $u->writer;
$state = $dbcm->selectrow_array('SELECT state FROM userpic2 WHERE userid = ? AND picid = ?',
undef, $u->{'userid'}, $picid);
return $u->{'userid'} if $state eq 'X'; # already expunged
# else now mark it
$u->do("UPDATE userpic2 SET state='X' WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
return LJ::error($dbcm) if $dbcm->err;
$u->do("DELETE FROM userpicmap2 WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
} else {
my $dbr = LJ::get_db_reader();
return undef unless $dbr;
$state = $dbr->selectrow_array('SELECT state FROM userpic WHERE picid = ?',
undef, $picid);
return $u->{'userid'} if $state eq 'X'; # already expunged
# else now mark it
my $dbh = LJ::get_db_writer();
return undef unless $dbh;
$dbh->do("UPDATE userpic SET state='X' WHERE picid = ?", undef, $picid);
return LJ::error($dbh) if $dbh->err;
$dbh->do("DELETE FROM userpicmap WHERE userid = ? AND picid = ?", undef, $u->{'userid'}, $picid);
}
# now clear the user's memcache picture info
LJ::MemCache::delete([$u->{'userid'}, "upicinf:$u->{'userid'}"]);
# call the hook and get out of here
my $rval = LJ::run_hook('expunge_userpic', $picid, $u->{'userid'});
return ($u->{'userid'}, $rval);
}
#
# name: LJ::activate_userpics
# des: Sets/unsets userpics as inactive based on account caps
# args: uuserid
# returns: nothing
#
sub activate_userpics
{
# this behavior is optional, but enabled by default
return 1 if $LJ::ALLOW_PICS_OVER_QUOTA;
my $u = shift;
return undef unless LJ::isu($u);
# if a userid was given, get a real $u object
$u = LJ::load_userid($u, "force") unless isu($u);
# should have a $u object now
return undef unless isu($u);
# can't get a cluster read for expunged users since they are clusterid 0,
# so just return 1 to the caller from here and act like everything went fine
return 1 if $u->{'statusvis'} eq 'X';
my $userid = $u->{'userid'};
# active / inactive lists
my @active = ();
my @inactive = ();
my $allow = LJ::get_cap($u, "userpics");
# get a database handle for reading/writing
my $dbh = LJ::get_db_writer();
my $dbcr = LJ::get_cluster_def_reader($u);
# select all userpics and build active / inactive lists
my $sth;
if ($u->{'dversion'} > 6) {
return undef unless $dbcr;
$sth = $dbcr->prepare("SELECT picid, state FROM userpic2 WHERE userid=?");
} else {
return undef unless $dbh;
$sth = $dbh->prepare("SELECT picid, state FROM userpic WHERE userid=?");
}
$sth->execute($userid);
while (my ($picid, $state) = $sth->fetchrow_array) {
next if $state eq 'X'; # expunged, means userpic has been removed from site by admins
if ($state eq 'I') {
push @inactive, $picid;
} else {
push @active, $picid;
}
}
# inactivate previously activated userpics
if (@active > $allow) {
my $to_ban = @active - $allow;
# find first jitemid greater than time 2 months ago using rlogtime index
# ($LJ::EndOfTime - UnixTime)
my $jitemid = $dbcr->selectrow_array("SELECT jitemid FROM log2 USE INDEX (rlogtime) " .
"WHERE journalid=? AND rlogtime > ? LIMIT 1",
undef, $userid, $LJ::EndOfTime - time() + 86400*60);
# query all pickws in logprop2 with jitemid > that value
my %count_kw = ();
my $propid = LJ::get_prop("log", "picture_keyword")->{'id'};
my $sth = $dbcr->prepare("SELECT value, COUNT(*) FROM logprop2 " .
"WHERE journalid=? AND jitemid > ? AND propid=?" .
"GROUP BY value");
$sth->execute($userid, $jitemid, $propid);
while (my ($value, $ct) = $sth->fetchrow_array) {
# keyword => count
$count_kw{$value} = $ct;
}
my $keywords_in = join(",", map { $dbh->quote($_) } keys %count_kw);
# map pickws to picids for freq hash below
my %count_picid = ();
if ($keywords_in) {
my $sth;
if ($u->{'dversion'} > 6) {
$sth = $dbcr->prepare("SELECT k.keyword, m.picid FROM userkeywords k, userpicmap2 m ".
"WHERE k.keyword IN ($keywords_in) AND k.kwid=m.kwid AND k.userid=m.userid " .
"AND k.userid=?");
} else {
$sth = $dbh->prepare("SELECT k.keyword, m.picid FROM keywords k, userpicmap m " .
"WHERE k.keyword IN ($keywords_in) AND k.kwid=m.kwid " .
"AND m.userid=?");
}
$sth->execute($userid);
while (my ($keyword, $picid) = $sth->fetchrow_array) {
# keyword => picid
$count_picid{$picid} += $count_kw{$keyword};
}
}
# we're only going to ban the least used, excluding the user's default
my @ban = (grep { $_ != $u->{'defaultpicid'} }
sort { $count_picid{$a} <=> $count_picid{$b} } @active);
@ban = splice(@ban, 0, $to_ban) if @ban > $to_ban;
my $ban_in = join(",", map { $dbh->quote($_) } @ban);
if ($u->{'dversion'} > 6) {
$u->do("UPDATE userpic2 SET state='I' WHERE userid=? AND picid IN ($ban_in)",
undef, $userid) if $ban_in;
} else {
$dbh->do("UPDATE userpic SET state='I' WHERE userid=? AND picid IN ($ban_in)",
undef, $userid) if $ban_in;
}
}
# activate previously inactivated userpics
if (@inactive && @active < $allow) {
my $to_activate = $allow - @active;
$to_activate = @inactive if $to_activate > @inactive;
# take the $to_activate newest (highest numbered) pictures
# to reactivated
@inactive = sort @inactive;
my @activate_picids = splice(@inactive, -$to_activate);
my $activate_in = join(",", map { $dbh->quote($_) } @activate_picids);
if ($activate_in) {
if ($u->{'dversion'} > 6) {
$u->do("UPDATE userpic2 SET state='N' WHERE userid=? AND picid IN ($activate_in)",
undef, $userid);
} else {
$dbh->do("UPDATE userpic SET state='N' WHERE userid=? AND picid IN ($activate_in)",
undef, $userid);
}
}
}
# delete userpic info object from memcache
LJ::MemCache::delete([$userid, "upicinf:$userid"]);
return 1;
}
#
# name: LJ::get_userpic_info
# des: Given a user gets their user picture info
# args: uuid, opts (optional)
# des-u: user object or userid
# des-opts: hash of options, 'load_comments'
# returns: hash of userpicture information
# for efficiency, we store the userpic structures
# in memcache in a packed format.
#
# memory format:
# [
# version number of format,
# userid,
# "packed string", which expands to an array of {width=>..., ...}
# "packed string", which expands to { 'kw1' => id, 'kw2' => id, ...}
# ]
#
sub get_userpic_info
{
my ($uuid, $opts) = @_;
return undef unless $uuid;
my $userid = LJ::want_userid($uuid);
my $u = LJ::want_user($uuid); # This should almost always be in memory already
return undef unless $u && $u->{clusterid};
# in the cache, cool, well unless it doesn't have comments or urls
# and we need them
if (my $cachedata = $LJ::CACHE_USERPIC_INFO{$userid}) {
my $good = 1;
if ($u->{'dversion'} > 6) {
$good = 0 if $opts->{'load_comments'} && ! $cachedata->{'_has_comments'};
$good = 0 if $opts->{'load_urls'} && ! $cachedata->{'_has_urls'};
}
return $cachedata if $good;
}
my $VERSION_PICINFO = 3;
my $memkey = [$u->{'userid'},"upicinf:$u->{'userid'}"];
my ($info, $minfo);
if ($minfo = LJ::MemCache::get($memkey)) {
# the pre-versioned memcache data was a two-element hash.
# since then, we use an array and include a version number.
if (ref $minfo eq 'HASH' ||
$minfo->[0] != $VERSION_PICINFO) {
# old data in the cache. delete.
LJ::MemCache::delete($memkey);
} else {
my (undef, $picstr, $kwstr) = @$minfo;
$info = {
'pic' => {},
'kw' => {},
};
while (length $picstr >= 7) {
my $pic = { userid => $u->{'userid'} };
($pic->{picid},
$pic->{width}, $pic->{height},
$pic->{state}) = unpack "NCCA", substr($picstr, 0, 7, '');
$info->{pic}->{$pic->{picid}} = $pic;
}
my ($pos, $nulpos);
$pos = $nulpos = 0;
while (($nulpos = index($kwstr, "\0", $pos)) > 0) {
my $kw = substr($kwstr, $pos, $nulpos-$pos);
my $id = unpack("N", substr($kwstr, $nulpos+1, 4));
$pos = $nulpos + 5; # skip NUL + 4 bytes.
$info->{kw}->{$kw} = $info->{pic}->{$id} if $info;
}
}
if ($u->{'dversion'} > 6) {
# Load picture comments
if ($opts->{'load_comments'}) {
my $commemkey = [$u->{'userid'}, "upiccom:$u->{'userid'}"];
my $comminfo = LJ::MemCache::get($commemkey);
if ($comminfo) {
my ($pos, $nulpos);
$pos = $nulpos = 0;
while (($nulpos = index($comminfo, "\0", $pos)) > 0) {
my $comment = substr($comminfo, $pos, $nulpos-$pos);
my $id = unpack("N", substr($comminfo, $nulpos+1, 4));
$pos = $nulpos + 5; # skip NUL + 4 bytes.
$info->{'pic'}->{$id}->{'comment'} = $comment;
}
$info->{'_has_comments'} = 1;
} else { # Requested to load comments, but they aren't in memcache
# so force a db load
undef $info;
}
}
# Load picture urls
if ($opts->{'load_urls'} && $info) {
my $urlmemkey = [$u->{'userid'}, "upicurl:$u->{'userid'}"];
my $urlinfo = LJ::MemCache::get($urlmemkey);
if ($urlinfo) {
my ($pos, $nulpos);
$pos = $nulpos = 0;
while (($nulpos = index($urlinfo, "\0", $pos)) > 0) {
my $url = substr($urlinfo, $pos, $nulpos-$pos);
my $id = unpack("N", substr($urlinfo, $nulpos+1, 4));
$pos = $nulpos + 5; # skip NUL + 4 bytes.
$info->{'pic'}->{$id}->{'url'} = $url;
}
$info->{'_has_urls'} = 1;
} else { # Requested to load urls, but they aren't in memcache
# so force a db load
undef $info;
}
}
}
}
my %minfocom; # need this in this scope
my %minfourl;
unless ($info) {
$info = {
'pic' => {},
'kw' => {},
};
my ($picstr, $kwstr);
my $sth;
my $dbcr = LJ::get_cluster_def_reader($u);
my $db = @LJ::MEMCACHE_SERVERS ? LJ::get_db_writer() : LJ::get_db_reader();
return undef unless $dbcr && $db;
if ($u->{'dversion'} > 6) {
$sth = $dbcr->prepare("SELECT picid, width, height, state, userid, comment, url ".
"FROM userpic2 WHERE userid=?");
} else {
$sth = $db->prepare("SELECT picid, width, height, state, userid ".
"FROM userpic WHERE userid=?");
}
$sth->execute($u->{'userid'});
my @pics;
while (my $pic = $sth->fetchrow_hashref) {
next if $pic->{state} eq 'X'; # no expunged pics in list
push @pics, $pic;
$info->{'pic'}->{$pic->{'picid'}} = $pic;
$minfocom{int($pic->{picid})} = $pic->{comment} if $u->{'dversion'} > 6
&& $opts->{'load_comments'} && $pic->{'comment'};
$minfourl{int($pic->{'picid'})} = $pic->{'url'} if $u->{'dversion'} > 6
&& $opts->{'load_urls'} && $pic->{'url'};
}
$picstr = join('', map { pack("NCCA", $_->{picid},
$_->{width}, $_->{height}, $_->{state}) } @pics);
if ($u->{'dversion'} > 6) {
$sth = $dbcr->prepare("SELECT k.keyword, m.picid FROM userpicmap2 m, userkeywords k ".
"WHERE k.userid=? AND m.kwid=k.kwid AND m.userid=k.userid");
} else {
$sth = $db->prepare("SELECT k.keyword, m.picid FROM userpicmap m, keywords k ".
"WHERE m.userid=? AND m.kwid=k.kwid");
}
$sth->execute($u->{'userid'});
my %minfokw;
while (my ($kw, $id) = $sth->fetchrow_array) {
next unless $info->{'pic'}->{$id};
next if $kw =~ /[\n\r\0]/; # used to be a bug that allowed these to get in.
$info->{'kw'}->{$kw} = $info->{'pic'}->{$id};
$minfokw{$kw} = int($id);
}
$kwstr = join('', map { pack("Z*N", $_, $minfokw{$_}) } keys %minfokw);
$memkey = [$u->{'userid'},"upicinf:$u->{'userid'}"];
$minfo = [ $VERSION_PICINFO, $picstr, $kwstr ];
LJ::MemCache::set($memkey, $minfo);
if ($u->{'dversion'} > 6) {
if ($opts->{'load_comments'}) {
$info->{'comment'} = \%minfocom;
my $commentstr = join('', map { pack("Z*N", $minfocom{$_}, $_) } keys %minfocom);
my $memkey = [$u->{'userid'}, "upiccom:$u->{'userid'}"];
LJ::MemCache::set($memkey, $commentstr);
$info->{'_has_comments'} = 1;
}
if ($opts->{'load_urls'}) {
my $urlstr = join('', map { pack("Z*N", $minfourl{$_}, $_) } keys %minfourl);
my $memkey = [$u->{'userid'}, "upicurl:$u->{'userid'}"];
LJ::MemCache::set($memkey, $urlstr);
$info->{'_has_urls'} = 1;
}
}
}
$LJ::CACHE_USERPIC_INFO{$u->{'userid'}} = $info;
return $info;
}
#
# name: LJ::get_pic_from_keyword
# des: Given a userid and keyword, returns the pic row hashref
# args: u, keyword
# des-keyword: The keyword of the userpic to fetch
# returns: hashref of pic row found
#
sub get_pic_from_keyword
{
my ($u, $kw) = @_;
my $info = LJ::get_userpic_info($u);
return undef unless $info;
return $info->{'kw'}{$kw};
}
sub get_picid_from_keyword
{
my ($u, $kw, $default) = @_;
$default ||= (ref $u ? $u->{'defaultpicid'} : 0);
return $default unless $kw;
my $info = LJ::get_userpic_info($u);
return $default unless $info;
my $pr = $info->{'kw'}{$kw};
return $pr ? $pr->{'picid'} : $default;
}
#
# name: LJ::server_down_html
# des: Returns an HTML server down message.
# returns: A string with a server down message in HTML.
#
sub server_down_html
{
return "$LJ::SERVER_DOWN_SUBJECT
$LJ::SERVER_DOWN_MESSAGE";
}
sub get_db_reader {
return LJ::get_dbh("slave", "master");
}
sub get_db_writer {
return LJ::get_dbh("master");
}
#
# name: LJ::get_cluster_reader
# class: db
# des: Returns a cluster slave for a user, or cluster master if no slaves exist.
# args: uarg
# des-uarg: Either a userid scalar or a user object.
# returns: DB handle. Or undef if all dbs are unavailable.
#
sub get_cluster_reader
{
my $arg = shift;
my $id = isu($arg) ? $arg->{'clusterid'} : $arg;
my @roles = ("cluster${id}slave", "cluster${id}");
if (my $ab = $LJ::CLUSTER_PAIR_ACTIVE{$id}) {
$ab = lc($ab);
# master-master cluster
@roles = ("cluster${id}${ab}") if $ab eq "a" || $ab eq "b";
}
return LJ::get_dbh(@roles);
}
#
# name: LJ::get_cluster_def_reader
# class: db
# des: Returns a definitive cluster reader for a given user, used
# when the caller wants the master handle, but will only
# use it to read.
# args: uarg
# des-uarg: Either a clusterid scalar or a user object.
# returns: DB handle. Or undef if definitive reader is unavailable.
#
sub get_cluster_def_reader
{
my @dbh_opts = scalar(@_) == 2 ? (shift @_) : ();
my $arg = shift;
my $id = isu($arg) ? $arg->{'clusterid'} : $arg;
return LJ::get_cluster_reader(@dbh_opts, $id) if
$LJ::DEF_READER_ACTUALLY_SLAVE{$id};
return LJ::get_dbh(@dbh_opts, LJ::master_role($id));
}
#
# name: LJ::get_cluster_master
# class: db
# des: Returns a cluster master for a given user, used when the caller
# might use it to do a write (insert/delete/update/etc...)
# args: uarg
# des-uarg: Either a clusterid scalar or a user object.
# returns: DB handle. Or undef if master is unavailable.
#
sub get_cluster_master
{
my @dbh_opts = scalar(@_) == 2 ? (shift @_) : ();
my $arg = shift;
my $id = isu($arg) ? $arg->{'clusterid'} : $arg;
return undef if $LJ::READONLY_CLUSTER{$id};
return LJ::get_dbh(@dbh_opts, LJ::master_role($id));
}
# returns the DBI::Role role name of a cluster master given a clusterid
sub master_role {
my $id = shift;
my $role = "cluster${id}";
if (my $ab = $LJ::CLUSTER_PAIR_ACTIVE{$id}) {
$ab = lc($ab);
# master-master cluster
$role = "cluster${id}${ab}" if $ab eq "a" || $ab eq "b";
}
return $role;
}
#
# name: LJ::make_graphviz_dot_file
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub make_graphviz_dot_file
{
&nodb;
my $user = shift;
# the code below is inefficient. let sites disable it.
return if $LJ::DISABLED{'graphviz_dot'};
my $dbr = LJ::get_db_reader();
my $quser = $dbr->quote($user);
my $sth;
my $ret;
my $u = LJ::load_user($user);
return unless $u;
$ret .= "digraph G {\n";
$ret .= " node [URL=\"$LJ::SITEROOT/userinfo.bml?user=\\N\"]\n";
$ret .= " node [fontsize=10, color=lightgray, style=filled]\n";
$ret .= " \"$user\" [color=yellow, style=filled]\n";
# TAG:FR:ljlib:make_graphviz_dot_file1
my @friends = ();
$sth = $dbr->prepare("SELECT friendid FROM friends WHERE userid=$u->{'userid'} AND userid<>friendid");
$sth->execute;
while ($_ = $sth->fetchrow_hashref) {
push @friends, $_->{'friendid'};
}
# TAG:FR:ljlib:make_graphviz_dot_file2
my $friendsin = join(", ", map { $dbr->quote($_); } ($u->{'userid'}, @friends));
my $sql = "SELECT uu.user, uf.user AS 'friend' FROM friends f, user uu, user uf WHERE f.userid=uu.userid AND f.friendid=uf.userid AND f.userid<>f.friendid AND uu.statusvis='V' AND uf.statusvis='V' AND (f.friendid=$u->{'userid'} OR (f.userid IN ($friendsin) AND f.friendid IN ($friendsin)))";
$sth = $dbr->prepare($sql);
$sth->execute;
while ($_ = $sth->fetchrow_hashref) {
$ret .= " \"$_->{'user'}\"->\"$_->{'friend'}\"\n";
}
$ret .= "}\n";
return $ret;
}
#
# name: LJ::make_remote
# des: Returns a minimal user structure ($remote-like) from
# a username and userid.
# args: user, userid
# des-user: Username.
# des-userid: User ID.
# returns: hashref with 'user' and 'userid' keys, or undef if
# either argument was bogus (so caller can pass
# untrusted input)
#
sub make_remote
{
my $user = LJ::canonical_username(shift);
my $userid = shift;
if ($user && $userid && $userid =~ /^\d+$/) {
return { 'user' => $user,
'userid' => $userid, };
}
return undef;
}
#
# name: LJ::get_cluster_description
# des: Get descriptive text for a cluster id.
# args: clusterid, bold?
# des-clusterid: id of cluster to get description of
# des-bold: 1 == bold cluster name and subcluster id, else don't
# returns: string representing the cluster description
#
sub get_cluster_description {
my ($cid, $dobold) = @_;
$cid += 0;
my $text = LJ::run_hook('cluster_description', $cid, $dobold ? 1 : 0);
return $text if $text;
# default behavior just returns clusterid
return $cid;
}
#
# name: LJ::load_moods
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub load_moods
{
return if $LJ::CACHED_MOODS;
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT moodid, mood, parentmood FROM moods");
$sth->execute;
while (my ($id, $mood, $parent) = $sth->fetchrow_array) {
$LJ::CACHE_MOODS{$id} = { 'name' => $mood, 'parent' => $parent, 'id' => $id };
if ($id > $LJ::CACHED_MOOD_MAX) { $LJ::CACHED_MOOD_MAX = $id; }
}
$LJ::CACHED_MOODS = 1;
}
#
# name: LJ::do_to_cluster
# des: Given a subref, this function will pick a random cluster and run the subref,
# passing it the cluster id. If the subref returns a 1, this function will exit
# with a 1. Else, the function will call the subref again, with the next cluster.
# args: subref
# des-subref: Reference to a sub to call; @_ = (clusterid)
# returns: 1 if the subref returned a 1 at some point, undef if it didn't ever return
# success and we tried every cluster.
#
sub do_to_cluster {
my $subref = shift;
# start at some random point and iterate through the clusters one by one until
# $subref returns a true value
my $size = @LJ::CLUSTERS;
my $start = int(rand() * $size);
my $rval = undef;
my $tries = $size > 15 ? 15 : $size;
foreach (1..$tries) {
# select at random
my $idx = $start++ % $size;
# get subref value
$rval = $subref->($LJ::CLUSTERS[$idx]);
last if $rval;
}
# return last rval
return $rval;
}
#
# name: LJ::cmd_buffer_add
# des: Schedules some command to be run sometime in the future which would
# be too slow to do syncronously with the web request. An example
# is deleting a journal entry, which requires recursing through a lot
# of tables and deleting all the appropriate stuff.
# args: db, journalid, cmd, hargs
# des-db: Global db handle to run command on, or user clusterid if cluster
# des-journalid: Journal id command affects. This is indexed in the
# [dbtable[cmdbuffer]] table so that all of a user's queued
# actions can be run before that user is potentially moved
# between clusters.
# des-cmd: Text of the command name. 30 chars max.
# des-hargs: Hashref of command arguments.
#
sub cmd_buffer_add
{
my ($db, $journalid, $cmd, $args) = @_;
return 0 unless $cmd;
my $cid = ref $db ? 0 : $db+0;
$db = $cid ? LJ::get_cluster_master($cid) : $db;
my $ab = $LJ::CLUSTER_PAIR_ACTIVE{$cid};
return 0 unless $db;
my $arg_str = "";
if (ref $args eq 'HASH') {
foreach (sort keys %$args) {
$arg_str .= LJ::eurl($_) . "=" . LJ::eurl($args->{$_}) . "&";
}
chop $arg_str;
} else {
$arg_str = $args || "";
}
my $rv;
if ($ab && ($ab eq 'a' || $ab eq 'b')) {
# get a lock
my $locked = $db->selectrow_array("SELECT GET_LOCK('cmd-buffer-$cid',10)");
return 0 unless $locked; # 10 second timeout elapsed
# a or b -- a goes odd, b goes even!
my $max = $db->selectrow_array('SELECT MAX(cbid) FROM cmdbuffer');
$max += $ab eq 'a' ? ($max & 1 ? 2 : 1) : ($max & 1 ? 1 : 2);
# insert command
$db->do('INSERT INTO cmdbuffer (cbid, journalid, instime, cmd, args) ' .
'VALUES (?, ?, NOW(), ?, ?)', undef,
$max, $journalid, $cmd, $arg_str);
$rv = $db->err ? 0 : 1;
# release lock
$db->selectrow_array("SELECT RELEASE_LOCK('cmd-buffer-$cid')");
} else {
# old method
$db->do("INSERT INTO cmdbuffer (journalid, cmd, instime, args) ".
"VALUES (?, ?, NOW(), ?)", undef,
$journalid, $cmd, $arg_str);
$rv = $db->err ? 0 : 1;
}
return $rv;
}
#
# name: LJ::mysql_time
# des:
# class: time
# info:
# args:
# des-:
# returns:
#
sub mysql_time
{
my ($time, $gmt) = @_;
$time ||= time();
my @ltime = $gmt ? gmtime($time) : localtime($time);
return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
$ltime[5]+1900,
$ltime[4]+1,
$ltime[3],
$ltime[2],
$ltime[1],
$ltime[0]);
}
# gets date in MySQL format, produces s2dateformat
# s1 dateformat is:
# "%a %W %b %M %y %Y %c %m %e %d %D %p %i %l %h %k %H"
# sample string:
# Tue Tuesday Sep September 03 2003 9 09 30 30 30th AM 22 9 09 9 09
# Thu Thursday Oct October 03 2003 10 10 2 02 2nd AM 33 9 09 9 09
sub alldatepart_s1
{
my $time = shift;
my ($sec,$min,$hour,$mday,$mon,$year,$wday) =
gmtime(LJ::mysqldate_to_time($time, 1));
my $ret = "";
$ret .= LJ::Lang::day_short($wday+1) . " " .
LJ::Lang::day_long($wday+1) . " " .
LJ::Lang::month_short($mon+1) . " " .
LJ::Lang::month_long($mon+1) . " " .
sprintf("%02d %04d %d %02d %d %02d %d%s ",
$year % 100, $year + 1900, $mon+1, $mon+1,
$mday, $mday, $mday, LJ::Lang::day_ord($mday));
$ret .= $hour < 12 ? "AM " : "PM ";
$ret .= sprintf("%02d %d %02d %d %02d", $min,
($hour+11)%12 + 1,
($hour+ 11)%12 +1,
$hour,
$hour);
return $ret;
}
# gets date in MySQL format, produces s2dateformat
# s2 dateformat is: yyyy mm dd hh mm ss day_of_week
sub alldatepart_s2
{
my $time = shift;
my ($sec,$min,$hour,$mday,$mon,$year,$wday) =
gmtime(LJ::mysqldate_to_time($time, 1));
return
sprintf("%04d %02d %02d %02d %02d %02d %01d",
$year+1900,
$mon+1,
$mday,
$hour,
$min,
$sec,
$wday);
}
#
# name: LJ::get_keyword_id
# class:
# des: Get the id for a keyword.
# args: uuid?, keyword, autovivify?
# des-uuid: User object or userid to use. Pass this only if you want to use the userkeywords
# clustered table! If you do not pass user information, the keywords table on the global
# will be used.
# des-keyword: A string keyword to get the id of.
# returns: Returns a kwid into keywords or userkeywords, depending on if you passed a user or
# not. If the keyword doesn't exist, it is automatically created for you.
# des-autovivify: If present and 1, automatically create keyword. If present and 0, do not
# automatically create the keyword. If not present, default behavior is the old style --
# yes, do automatically create the keyword.
#
sub get_keyword_id
{
&nodb;
# see if we got a user? if so we use userkeywords on a cluster
my $u;
if (@_ >= 2) {
$u = LJ::want_user(shift);
return undef unless $u;
}
my ($kw, $autovivify) = @_;
$autovivify = 1 unless defined $autovivify;
# setup the keyword for use
unless ($kw =~ /\S/) { return 0; }
$kw = LJ::text_trim($kw, LJ::BMAX_KEYWORD, LJ::CMAX_KEYWORD);
# get the keyword and insert it if necessary
my $kwid;
if ($u && $u->{dversion} > 5) {
# new style userkeywords -- but only if the user has the right dversion
$kwid = $u->selectrow_array('SELECT kwid FROM userkeywords WHERE userid = ? AND keyword = ?',
undef, $u->{userid}, $kw);
$kwid = 0 unless defined($kwid);
if ($autovivify && ! $kwid) {
# create a new keyword
$kwid = LJ::alloc_user_counter($u, 'K');
return undef unless $kwid;
# attempt to insert the keyword
my $rv = $u->do("INSERT IGNORE INTO userkeywords (userid, kwid, keyword) VALUES (?, ?, ?)",
undef, $u->{userid}, $kwid, $kw) + 0;
return undef if $u->err;
# at this point, if $rv is 0, the keyword is already there so try again
unless ($rv) {
$kwid = $u->selectrow_array('SELECT kwid FROM userkeywords WHERE userid = ? AND keyword = ?',
undef, $u->{userid}, $kw) + 0;
}
}
} else {
# old style global
my $dbh = LJ::get_db_writer();
my $qkw = $dbh->quote($kw);
# Making this a $dbr could cause problems due to the insertion of
# data based on the results of this query. Leave as a $dbh.
$kwid = $dbh->selectrow_array("SELECT kwid FROM keywords WHERE keyword=$qkw");
if ($autovivify && ! $kwid) {
$dbh->do("INSERT INTO keywords (kwid, keyword) VALUES (NULL, $qkw)");
$kwid = $dbh->{'mysql_insertid'};
}
}
return $kwid;
}
#
# name: LJ::delete_user
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub delete_user
{
# TODO: Is this function even being called?
# It doesn't look like it does anything useful
my $dbh = shift;
my $user = shift;
my $quser = $dbh->quote($user);
my $sth;
$sth = $dbh->prepare("SELECT user, userid FROM useridmap WHERE user=$quser");
my $u = $sth->fetchrow_hashref;
unless ($u) { return; }
### so many issues.
}
#
# name: LJ::hash_password
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub hash_password
{
return Digest::MD5::md5_hex($_[0]);
}
#
# name: LJ::can_use_journal
# class:
# des:
# info:
# args:
# des-:
# returns:
#
sub can_use_journal
{
&nodb;
my ($posterid, $reqownername, $res) = @_;
## find the journal owner's info
my $uowner = LJ::load_user($reqownername);
unless ($uowner) {
$res->{'errmsg'} = "Journal \"$reqownername\" does not exist.";
return 0;
}
my $ownerid = $uowner->{'userid'};
# the 'ownerid' necessity came first, way back when. but then
# with clusters, everything needed to know more, like the
# journal's dversion and clusterid, so now it also returns the
# user row.
$res->{'ownerid'} = $ownerid;
$res->{'u_owner'} = $uowner;
## check if user has access
return 1 if LJ::check_rel($ownerid, $posterid, 'P');
# let's check if this community is allowing post access to non-members
LJ::load_user_props($uowner, "nonmember_posting");
if ($uowner->{'nonmember_posting'}) {
my $dbr = LJ::get_db_reader() or die "nodb";
my $postlevel = $dbr->selectrow_array("SELECT postlevel FROM ".
"community WHERE userid=$ownerid");
return 1 if $postlevel eq 'members';
}
# is the poster an admin for this community?
return 1 if LJ::can_manage($posterid, $uowner);
$res->{'errmsg'} = "You do not have access to post to this journal.";
return 0;
}
#
# name: LJ::days_in_month
# class: time
# des: Figures out the number of days in a month.
# args: month, year?
# des-month: Month
# des-year: Year. Necessary for February. If undefined or zero, function
# will return 29.
# returns: Number of days in that month in that year.
#
sub days_in_month
{
my ($month, $year) = @_;
if ($month == 2)
{
return 29 unless $year; # assume largest
if ($year % 4 == 0)
{
# years divisible by 400 are leap years
return 29 if ($year % 400 == 0);
# if they're divisible by 100, they aren't.
return 28 if ($year % 100 == 0);
# otherwise, if divisible by 4, they are.
return 29;
}
}
return ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$month-1]);
}
sub day_of_week
{
my ($year, $month, $day) = @_;
my $time = Time::Local::timelocal(0,0,0,$day,$month-1,$year);
return (localtime($time))[6];
}
#
# name: LJ::blocking_report
# des: Log a report on the total amount of time used in a slow operation to a
# remote host via UDP.
# args: host, time, notes, type
# des-host: The DB host the operation used.
# des-type: The type of service the operation was talking to (e.g., 'database',
# 'memcache', etc.)
# des-time: The amount of time (in floating-point seconds) the operation took.
# des-notes: A short description of the operation.
#
sub blocking_report {
my ( $host, $type, $time, $notes ) = @_;
if ( $LJ::DB_LOG_HOST ) {
unless ( $LJ::ReportSock ) {
my ( $host, $port ) = split /:/, $LJ::DB_LOG_HOST, 2;
return unless $host && $port;
$LJ::ReportSock = new IO::Socket::INET (
PeerPort => $port,
Proto => 'udp',
PeerAddr => $host
) or return;
}
my $msg = join( "\x3", $host, $type, $time, $notes );
$LJ::ReportSock->send( $msg );
}
}
#
# name: LJ::color_fromdb
# des: Takes a value of unknown type from the db and returns an #rrggbb string.
# args: color
# des-color: either a 24-bit decimal number, or an #rrggbb string.
# returns: scalar; #rrggbb string, or undef if unknown input format
#
sub color_fromdb
{
my $c = shift;
return $c if $c =~ /^\#[0-9a-f]{6,6}$/i;
return sprintf("\#%06x", $c) if $c =~ /^\d+$/;
return undef;
}
#
# name: LJ::color_todb
# des: Takes an #rrggbb value and returns a 24-bit decimal number.
# args: color
# des-color: scalar; an #rrggbb string.
# returns: undef if bogus color, else scalar; 24-bit decimal number, can be up to 8 chars wide as a string.
#
sub color_todb
{
my $c = shift;
return undef unless $c =~ /^\#[0-9a-f]{6,6}$/i;
return hex(substr($c, 1, 6));
}
#
# name: LJ::event_register
# des: Logs a subscribable event, if anybody's subscribed to it.
# args: dbarg?, dbc, etype, ejid, eiarg, duserid, diarg
# des-dbc: Cluster master of event
# des-type: One character event type.
# des-ejid: Journalid event occurred in.
# des-eiarg: 4 byte numeric argument
# des-duserid: Event doer's userid
# des-diarg: Event's 4 byte numeric argument
# returns: boolean; 1 on success; 0 on fail.
#
sub event_register
{
&nodb;
my ($dbc, $etype, $ejid, $eiarg, $duserid, $diarg) = @_;
my $dbr = LJ::get_db_reader();
# see if any subscribers first of all (reads cheap; writes slow)
return 0 unless $dbr;
my $qetype = $dbr->quote($etype);
my $qejid = $ejid+0;
my $qeiarg = $eiarg+0;
my $qduserid = $duserid+0;
my $qdiarg = $diarg+0;
my $has_sub = $dbr->selectrow_array("SELECT userid FROM subs WHERE etype=$qetype AND ".
"ejournalid=$qejid AND eiarg=$qeiarg LIMIT 1");
return 1 unless $has_sub;
# so we're going to need to log this event
return 0 unless $dbc;
$dbc->do("INSERT INTO events (evtime, etype, ejournalid, eiarg, duserid, diarg) ".
"VALUES (NOW(), $qetype, $qejid, $qeiarg, $qduserid, $qdiarg)");
return $dbc->err ? 0 : 1;
}
#
# name: LJ::procnotify_add
# des: Sends a message to all other processes on all clusters.
# info: You'll probably never use this yourself.
# args: cmd, args?
# des-cmd: Command name. Currently recognized: "DBI::Role::reload" and "rename_user"
# des-args: Hashref with key/value arguments for the given command. See
# relevant parts of [func[LJ::procnotify_callback]] for required args for different commands.
# returns: new serial number on success; 0 on fail.
#
sub procnotify_add
{
&nodb;
my ($cmd, $argref) = @_;
my $dbh = LJ::get_db_writer();
return 0 unless $dbh;
my $args = join('&', map { LJ::eurl($_) . "=" . LJ::eurl($argref->{$_}) }
sort keys %$argref);
$dbh->do("INSERT INTO procnotify (cmd, args) VALUES (?,?)",
undef, $cmd, $args);
return 0 if $dbh->err;
return $dbh->{'mysql_insertid'};
}
#
# name: LJ::procnotify_callback
# des: Call back function process notifications.
# info: You'll probably never use this yourself.
# args: cmd, argstring
# des-cmd: Command name.
# des-argstring: String of arguments.
# returns: new serial number on success; 0 on fail.
#
sub procnotify_callback
{
my ($cmd, $argstring) = @_;
my $arg = {};
LJ::decode_url_string($argstring, $arg);
if ($cmd eq "rename_user") {
# this looks backwards, but the cache hash names are just odd:
delete $LJ::CACHE_USERNAME{$arg->{'userid'}};
delete $LJ::CACHE_USERID{$arg->{'user'}};
return;
}
# ip bans
if ($cmd eq "ban_ip") {
$LJ::IP_BANNED{$arg->{'ip'}} = $arg->{'exptime'};
return;
}
if ($cmd eq "unban_ip") {
delete $LJ::IP_BANNED{$arg->{'ip'}};
return;
}
# uniq key bans
if ($cmd eq "ban_uniq") {
$LJ::UNIQ_BANNED{$arg->{'uniq'}} = $arg->{'exptime'};
return;
}
if ($cmd eq "unban_uniq") {
delete $LJ::UNIQ_BANNED{$arg->{'uniq'}};
return;
}
}
sub procnotify_check
{
my $now = time;
return if $LJ::CACHE_PROCNOTIFY_CHECK + 30 > $now;
$LJ::CACHE_PROCNOTIFY_CHECK = $now;
my $dbr = LJ::get_db_reader();
if (!$dbr) {
warn("procnotify_check: can't get database reader");
return;
}
my $max = $dbr->selectrow_array("SELECT MAX(nid) FROM procnotify");
return unless defined $max;
my $old = $LJ::CACHE_PROCNOTIFY_MAX;
if (defined $old && $max > $old) {
my $sth = $dbr->prepare("SELECT cmd, args FROM procnotify ".
"WHERE nid > ? AND nid <= $max ORDER BY nid");
$sth->execute($old);
while (my ($cmd, $args) = $sth->fetchrow_array) {
LJ::procnotify_callback($cmd, $args);
}
}
$LJ::CACHE_PROCNOTIFY_MAX = $max;
}
sub dbtime_callback {
my ($dsn, $dbtime, $time) = @_;
my $diff = abs($dbtime - $time);
if ($diff > 2) {
$dsn =~ /host=([^:\;\|]*)/;
my $db = $1;
print STDERR "Clock skew of $diff seconds between web($LJ::SERVER_NAME) and db($db)\n";
}
}
# We're not always running under mod_perl... sometimes scripts (syndication sucker)
# call paths which end up thinking they need the remote IP, but don't.
sub get_remote_ip
{
my $ip;
eval {
$ip = Apache->request->connection->remote_ip;
my $ip2 = Apache->request->header_in("X-Forwarded-For");
$ip = LJ::get_real_remote_ip($ip, $ip2);
};
return $ip || $ENV{'FAKE_IP'};
}
sub md5_struct
{
my ($st, $md5) = @_;
$md5 ||= Digest::MD5->new;
unless (ref $st) {
# later Digest::MD5s die while trying to
# get at the bytes of an invalid utf-8 string.
# this really shouldn't come up, but when it
# does, we clear the utf8 flag on the string and retry.
# see http://zilla.livejournal.org/show_bug.cgi?id=851
eval { $md5->add($st); };
if ($@) {
$st = pack('C*', unpack('C*', $st));
$md5->add($st);
}
return $md5;
}
if (ref $st eq "HASH") {
foreach (sort keys %$st) {
md5_struct($_, $md5);
md5_struct($st->{$_}, $md5);
}
return $md5;
}
if (ref $st eq "ARRAY") {
foreach (@$st) {
md5_struct($_, $md5);
}
return $md5;
}
}
sub rand_chars
{
my $length = shift;
my $chal = "";
my $digits = "abcdefghijklmnopqrstuvwzyzABCDEFGHIJKLMNOPQRSTUVWZYZ0123456789";
for (1..$length) {
$chal .= substr($digits, int(rand(62)), 1);
}
return $chal;
}
# ($time, $secret) = LJ::get_secret(); # will generate
# $secret = LJ::get_secret($time); # won't generate
# ($time, $secret) = LJ::get_secret($time); # will generate (in wantarray)
sub get_secret
{
my $time = int($_[0]);
return undef if $_[0] && ! $time;
my $want_new = ! $time || wantarray;
if (! $time) {
$time = time();
$time -= $time % 3600; # one hour granularity
}
my $memkey = "secret:$time";
my $secret = LJ::MemCache::get($memkey);
return $want_new ? ($time, $secret) : $secret if $secret;
my $dbh = LJ::get_db_writer();
return undef unless $dbh;
$secret = $dbh->selectrow_array("SELECT secret FROM secrets ".
"WHERE stime=?", undef, $time);
if ($secret) {
LJ::MemCache::set($memkey, $secret) if $secret;
return $want_new ? ($time, $secret) : $secret;
}
# return if they specified an explicit time they wanted.
# (calling with no args means generate a new one if secret
# doesn't exist)
return undef unless $want_new;
# don't generate new times that don't fall in our granularity
return undef if $time % 3600;
$secret = LJ::rand_chars(32);
$dbh->do("INSERT IGNORE INTO secrets SET stime=?, secret=?",
undef, $time, $secret);
# check for races:
$secret = get_secret($time);
return ($time, $secret);
}
#
# name: LJ::get_reluser_id
# des: for reluser2, numbers 1 - 31999 are reserved for livejournal stuff, whereas
# numbers 32000-65535 are used for local sites. if you wish to add your
# own hooks to this, you should define a hook "get_reluser_id" in ljlib-local.pl
# no reluser2 types can be a single character, those are reserved for the
# reluser table so we don't have namespace problems.
# args: type
# des-type: the name of the type you're trying to access, e.g. "hide_comm_assoc"
# returns: id of type, 0 means it's not a reluser2 type
#
sub get_reluser_id {
my $type = shift;
return 0 if length $type == 1; # must be more than a single character
my $val =
{
'hide_comm_assoc' => 1,
}->{$type}+0;
return $val if $val;
return 0 unless $type =~ /^local-/;
return LJ::run_hook('get_reluser_id', $type)+0;
}
#
# name: LJ::load_rel_user
# des: Load user relationship information. Loads all relationships of type 'type' in
# which user 'userid' participates on the left side (is the source of the
# relationship).
# args: db?, userid, type
# arg-userid: userid or a user hash to load relationship information for.
# arg-type: type of the relationship
# returns: reference to an array of userids
#
sub load_rel_user
{
my $db = isdb($_[0]) ? shift : undef;
my ($userid, $type) = @_;
return undef unless $type and $userid;
my $u = LJ::want_user($userid);
$userid = LJ::want_userid($userid);
my $typeid = LJ::get_reluser_id($type)+0;
if ($typeid) {
# clustered reluser2 table
$db = LJ::get_cluster_reader($u);
return $db->selectcol_arrayref("SELECT targetid FROM reluser2 WHERE userid=? AND type=?",
undef, $userid, $typeid);
} else {
# non-clustered reluser global table
$db ||= LJ::get_db_reader();
return $db->selectcol_arrayref("SELECT targetid FROM reluser WHERE userid=? AND type=?",
undef, $userid, $type);
}
}
#
# name: LJ::load_rel_target
# des: Load user relationship information. Loads all relationships of type 'type' in
# which user 'targetid' participates on the right side (is the target of the
# relationship).
# args: db?, targetid, type
# arg-targetid: userid or a user hash to load relationship information for.
# arg-type: type of the relationship
# returns: reference to an array of userids
#
sub load_rel_target
{
my $db = isdb($_[0]) ? shift : undef;
my ($targetid, $type) = @_;
return undef unless $type and $targetid;
my $u = LJ::want_user($targetid);
$targetid = LJ::want_userid($targetid);
my $typeid = LJ::get_reluser_id($type)+0;
if ($typeid) {
# clustered reluser2 table
$db = LJ::get_cluster_reader($u);
return $db->selectcol_arrayref("SELECT userid FROM reluser2 WHERE targetid=? AND type=?",
undef, $targetid, $typeid);
} else {
# non-clustered reluser global table
$db ||= LJ::get_db_reader();
return $db->selectcol_arrayref("SELECT userid FROM reluser WHERE targetid=? AND type=?",
undef, $targetid, $type);
}
}
#
# name: LJ::_get_rel_memcache
# des: Helper function: returns memcached value for a given (userid, targetid, type) triple, if valid
# args: userid, targetid, type
# arg-userid: source userid, nonzero
# arg-targetid: target userid, nonzero
# arg-type: type (reluser) or typeid (rel2) of the relationship
# returns: undef on failure, 0 or 1 depending on edge existence
#
sub _get_rel_memcache {
return undef unless @LJ::MEMCACHE_SERVERS;
return undef if $LJ::DISABLED{memcache_reluser};
my ($userid, $targetid, $type) = @_;
return undef unless $userid && $targetid && defined $type;
# memcache keys
my $relkey = [$userid, "rel:$userid:$targetid:$type"]; # rel $uid->$targetid edge
my $modukey = [$userid, "relmodu:$userid:$type" ]; # rel modtime for uid
my $modtkey = [$targetid, "relmodt:$targetid:$type" ]; # rel modtime for targetid
# do a get_multi since $relkey and $modukey are both hashed on $userid
my $memc = LJ::MemCache::get_multi($relkey, $modukey);
return undef unless $memc && ref $memc eq 'HASH';
# [{0|1}, modtime]
my $rel = $memc->{$relkey->[1]};
return undef unless $rel && ref $rel eq 'ARRAY';
# check rel modtime for $userid
my $relmodu = $memc->{$modukey->[1]};
return undef if ! $relmodu || $relmodu > $rel->[1];
# check rel modtime for $targetid
my $relmodt = LJ::MemCache::get($modtkey);
return undef if ! $relmodt || $relmodt > $rel->[1];
# return memcache value if it's up-to-date
return $rel->[0] ? 1 : 0;
}
#
# name: LJ::_set_rel_memcache
# des: Helper function: sets memcache values for a given (userid, targetid, type) triple
# args: userid, targetid, type
# arg-userid: source userid, nonzero
# arg-targetid: target userid, nonzero
# arg-type: type (reluser) or typeid (rel2) of the relationship
# returns: 1 on success, undef on failure
#
sub _set_rel_memcache {
return 1 unless @LJ::MEMCACHE_SERVERS;
my ($userid, $targetid, $type, $val) = @_;
return undef unless $userid && $targetid && defined $type;
$val = $val ? 1 : 0;
# memcache keys
my $relkey = [$userid, "rel:$userid:$targetid:$type"]; # rel $uid->$targetid edge
my $modukey = [$userid, "relmodu:$userid:$type" ]; # rel modtime for uid
my $modtkey = [$targetid, "relmodt:$targetid:$type" ]; # rel modtime for targetid
my $now = time();
my $exp = $now + 3600*6; # 6 hour
LJ::MemCache::set($relkey, [$val, $now], $exp);
LJ::MemCache::set($modukey, $now, $exp);
LJ::MemCache::set($modtkey, $now, $exp);
return 1;
}
#
# name: LJ::check_rel
# des: Checks whether two users are in a specified relationship to each other.
# args: db?, userid, targetid, type
# arg-userid: source userid, nonzero; may also be a user hash.
# arg-targetid: target userid, nonzero; may also be a user hash.
# arg-type: type of the relationship
# returns: 1 if the relationship exists, 0 otherwise
#
sub check_rel
{
my $db = isdb($_[0]) ? shift : undef;
my ($userid, $targetid, $type) = @_;
return undef unless $type && $userid && $targetid;
my $u = LJ::want_user($userid);
$userid = LJ::want_userid($userid);
$targetid = LJ::want_userid($targetid);
my $typeid = LJ::get_reluser_id($type)+0;
my $eff_type = $typeid || $type;
my $key = "$userid-$targetid-$eff_type";
return $LJ::REQ_CACHE_REL{$key} if defined $LJ::REQ_CACHE_REL{$key};
# did we get something from memcache?
my $memval = LJ::_get_rel_memcache($userid, $targetid, $eff_type);
return $memval if defined $memval;
# are we working on reluser or reluser2?
my $table;
if ($typeid) {
# clustered reluser2 table
$db = LJ::get_cluster_reader($u);
$table = "reluser2";
} else {
# non-clustered reluser table
$db ||= LJ::get_db_reader();
$table = "reluser";
}
# get data from db, force result to be {0|1}
my $dbval = $db->selectrow_array("SELECT COUNT(*) FROM $table ".
"WHERE userid=? AND targetid=? AND type=? ",
undef, $userid, $targetid, $eff_type)
? 1 : 0;
# set in memcache
LJ::_set_rel_memcache($userid, $targetid, $eff_type, $dbval);
# return and set request cache
return $LJ::REQ_CACHE_REL{$key} = $dbval;
}
#
# name: LJ::set_rel
# des: Sets relationship information for two users.
# args: dbs?, userid, targetid, type
# arg-userid: source userid, or a user hash
# arg-targetid: target userid, or a user hash
# arg-type: type of the relationship
# returns: 1 if set succeeded, otherwise undef
#
sub set_rel
{
&nodb;
my ($userid, $targetid, $type) = @_;
return undef unless $type and $userid and $targetid;
my $u = LJ::want_user($userid);
$userid = LJ::want_userid($userid);
$targetid = LJ::want_userid($targetid);
my $typeid = LJ::get_reluser_id($type)+0;
my $eff_type = $typeid || $type;
# working on reluser or reluser2?
my ($db, $table);
if ($typeid) {
# clustered reluser2 table
$db = LJ::get_cluster_master($u);
$table = "reluser2";
} else {
# non-clustered reluser global table
$db = LJ::get_db_writer();
$table = "reluser";
}
return undef unless $db;
# set in database
$db->do("REPLACE INTO $table (userid, targetid, type) VALUES (?, ?, ?)",
undef, $userid, $targetid, $eff_type);
return undef if $db->err;
# set in memcache
LJ::_set_rel_memcache($userid, $targetid, $eff_type, 1);
return 1;
}
#
# name: LJ::set_rel_multi
# des: Sets relationship edges for lists of user tuples.
# args: @edges
# arg-edges: array of arrayrefs of edges to set: [userid, targetid, type]
# Where:
# userid: source userid, or a user hash
# targetid: target userid, or a user hash
# type: type of the relationship
# returns: 1 if all sets succeeded, otherwise undef
#
sub set_rel_multi {
return _mod_rel_multi({ mode => 'set', edges => \@_ });
}
#
# name: LJ::clear_rel_multi
# des: Clear relationship edges for lists of user tuples.
# args: @edges
# arg-edges: array of arrayrefs of edges to clear: [userid, targetid, type]
# Where:
# userid: source userid, or a user hash
# targetid: target userid, or a user hash
# type: type of the relationship
# returns: 1 if all clears succeeded, otherwise undef
#
sub clear_rel_multi {
return _mod_rel_multi({ mode => 'clear', edges => \@_ });
}
#
# name: LJ::_mod_rel_multi
# des: Sets/Clears relationship edges for lists of user tuples.
# args: $opts
# arg-opts: keys: mode => {clear|set}
# edges => array of arrayrefs of edges to set: [userid, targetid, type]
# Where:
# userid: source userid, or a user hash
# targetid: target userid, or a user hash
# type: type of the relationship
# returns: 1 if all updates succeeded, otherwise undef
#
sub _mod_rel_multi
{
my $opts = shift;
return undef unless @{$opts->{edges}};
my $mode = $opts->{mode} eq 'clear' ? 'clear' : 'set';
my $memval = $mode eq 'set' ? 1 : 0;
my @reluser = (); # [userid, targetid, type]
my @reluser2 = ();
foreach my $edge (@{$opts->{edges}}) {
my ($userid, $targetid, $type) = @$edge;
$userid = LJ::want_userid($userid);
$targetid = LJ::want_userid($targetid);
next unless $type && $userid && $targetid;
my $typeid = LJ::get_reluser_id($type)+0;
my $eff_type = $typeid || $type;
# working on reluser or reluser2?
push @{$typeid ? \@reluser2 : \@reluser}, [$userid, $targetid, $eff_type];
}
# now group reluser2 edges by clusterid
my %reluser2 = (); # cid => [userid, targetid, type]
my $users = LJ::load_userids(map { $_->[0] } @reluser2);
foreach (@reluser2) {
my $cid = $users->{$_->[0]}->{clusterid} or next;
push @{$reluser2{$cid}}, $_;
}
@reluser2 = ();
# try to get all required cluster masters before we start doing database updates
my %cache_dbcm = ();
foreach my $cid (keys %reluser2) {
next unless @{$reluser2{$cid}};
# return undef immediately if we won't be able to do all the updates
$cache_dbcm{$cid} = LJ::get_cluster_master($cid)
or return undef;
}
# if any error occurs with a cluster, we'll skip over that cluster and continue
# trying to process others since we've likely already done some amount of db
# updates already, but we'll return undef to signify that everything did not
# go smoothly
my $ret = 1;
# do clustered reluser2 updates
foreach my $cid (keys %cache_dbcm) {
# array of arrayrefs: [userid, targetid, type]
my @edges = @{$reluser2{$cid}};
# set in database, then in memcache. keep the two atomic per clusterid
my $dbcm = $cache_dbcm{$cid};
my @vals = map { @$_ } @edges;
if ($mode eq 'set') {
my $bind = join(",", map { "(?,?,?)" } @edges);
$dbcm->do("REPLACE INTO reluser2 (userid, targetid, type) VALUES $bind",
undef, @vals);
}
if ($mode eq 'clear') {
my $where = join(" OR ", map { "(userid=? AND targetid=? AND type=?)" } @edges);
$dbcm->do("DELETE FROM reluser2 WHERE $where", undef, @vals);
}
# don't update memcache if db update failed for this cluster
if ($dbcm->err) {
$ret = undef;
next;
}
# updates to this cluster succeeded, set memcache
LJ::_set_rel_memcache(@$_, $memval) foreach @edges;
}
# do global reluser updates
if (@reluser) {
# nothing to do after this block but return, so we can
# immediately return undef from here if there's a problem
my $dbh = LJ::get_db_writer()
or return undef;
my @vals = map { @$_ } @reluser;
if ($mode eq 'set') {
my $bind = join(",", map { "(?,?,?)" } @reluser);
$dbh->do("REPLACE INTO reluser (userid, targetid, type) VALUES $bind",
undef, @vals);
}
if ($mode eq 'clear') {
my $where = join(" OR ", map { "userid=? AND targetid=? AND type=?" } @reluser);
$dbh->do("DELETE FROM reluser WHERE $where", undef, @vals);
}
# don't update memcache if db update failed for this cluster
return undef if $dbh->err;
# $_ = [userid, targetid, type] for each iteration
LJ::_set_rel_memcache(@$_, $memval) foreach @reluser;
}
return $ret;
}
#
# name: LJ::clear_rel
# des: Deletes a relationship between two users or all relationships of a particular type
# for one user, on either side of the relationship. One of userid,targetid -- bit not
# both -- may be '*'. In that case, if, say, userid is '*', then all relationship
# edges with target equal to targetid and of the specified type are deleted.
# If both userid and targetid are numbers, just one edge is deleted.
# args: dbs?, userid, targetid, type
# arg-userid: source userid, or a user hash, or '*'
# arg-targetid: target userid, or a user hash, or '*'
# arg-type: type of the relationship
# returns: 1 if clear succeeded, otherwise undef
#
sub clear_rel
{
&nodb;
my ($userid, $targetid, $type) = @_;
return undef if $userid eq '*' and $targetid eq '*';
my $u = LJ::want_user($userid);
$userid = LJ::want_userid($userid) unless $userid eq '*';
$targetid = LJ::want_userid($targetid) unless $targetid eq '*';
return undef unless $type && $userid && $targetid;
my $typeid = LJ::get_reluser_id($type)+0;
if ($typeid) {
# clustered reluser2 table
return undef unless $u->writer;
$u->do("DELETE FROM reluser2 WHERE " . ($userid ne '*' ? "userid=$userid AND " : "") .
($targetid ne '*' ? "targetid=$targetid AND " : "") . "type=$typeid");
return undef if $u->err;
} else {
# non-clustered global reluser table
my $dbh = LJ::get_db_writer()
or return undef;
my $qtype = $dbh->quote($type);
$dbh->do("DELETE FROM reluser WHERE " . ($userid ne '*' ? "userid=$userid AND " : "") .
($targetid ne '*' ? "targetid=$targetid AND " : "") . "type=$qtype");
return undef if $dbh->err;
}
# if one of userid or targetid are '*', then we need to note the modtime
# of the reluser edge from the specified id (the one that's not '*')
# so that subsequent gets on rel:userid:targetid:type will know to ignore
# what they got from memcache
my $eff_type = $typeid || $type;
if ($userid eq '*') {
LJ::MemCache::set([$targetid, "relmodt:$targetid:$eff_type"], time());
} elsif ($targetid eq '*') {
LJ::MemCache::set([$userid, "relmodu:$userid:$eff_type"], time());
# if neither userid nor targetid are '*', then just call _set_rel_memcache
# to update the rel:userid:targetid:type memcache key as well as the
# userid and targetid modtime keys
} else {
LJ::_set_rel_memcache($userid, $targetid, $eff_type, 0);
}
return 1;
}
# $dom: 'S' == style, 'P' == userpic, 'A' == stock support answer
# 'C' == captcha, 'E' == external user
sub alloc_global_counter
{
my ($dom, $recurse) = @_;
return undef unless $dom =~ /^[SPCEA]$/;
my $dbh = LJ::get_db_writer();
return undef unless $dbh;
my $newmax;
my $uid = 0; # userid is not needed, we just use '0'
my $rs = $dbh->do("UPDATE counter SET max=LAST_INSERT_ID(max+1) WHERE journalid=? AND area=?",
undef, $uid, $dom);
if ($rs > 0) {
$newmax = $dbh->selectrow_array("SELECT LAST_INSERT_ID()");
return $newmax;
}
return undef if $recurse;
# no prior counter rows - initialize one.
if ($dom eq "S") {
$newmax = $dbh->selectrow_array("SELECT MAX(styleid) FROM s1stylemap");
} elsif ($dom eq "P") {
$newmax = $dbh->selectrow_array("SELECT MAX(picid) FROM userpic");
} elsif ($dom eq "C") {
$newmax = $dbh->selectrow_array("SELECT MAX(capid) FROM captchas");
} elsif ($dom eq "E") {
# if there is no extuser counter row, start making extuser names at
# 'ext_1' - ( the 0 here is incremented after the recurse )
$newmax = 0;
} elsif ($dom eq "A") {
$newmax = $dbh->selectrow_array("SELECT MAX(ansid) FROM support_answers");
} else {
die "No alloc_global_counter initalizer for domain '$dom'";
}
$newmax += 0;
$dbh->do("INSERT IGNORE INTO counter (journalid, area, max) VALUES (?,?,?)",
undef, $uid, $dom, $newmax) or return undef;
return LJ::alloc_global_counter($dom, 1);
}
sub note_recent_action {
my ($cid, $action) = @_;
# accept a user object
$cid = ref $cid ? $cid->{clusterid}+0 : $cid+0;
return undef unless $cid;
my $flag = { post => 'P' }->{$action};
if (! $flag && LJ::are_hooks("recent_action_flags")) {
$flag = LJ::run_hook("recent_action_flags", $action);
die "Invalid flag received from hook: $flag"
unless $flag =~ /^_\w$/; # must be prefixed with '_'
}
# should have a flag by now
return undef unless $flag;
my $dbcm = LJ::get_cluster_master($cid)
or return undef;
# append to recentactions table
$dbcm->do("INSERT INTO recentactions VALUES (?)", undef, $flag);
return undef if $dbcm->err;
return 1;
}
sub is_web_context {
return $ENV{MOD_PERL} ? 1 : 0;
}
# given a unix time, returns;
# ($week, $ubefore)
# week: week number (week 0 is first 3 days of unix time)
# ubefore: seconds before the next sunday, divided by 10
sub weekuu_parts {
my $time = shift;
$time -= 86400*3; # time from the sunday after unixtime 0
my $WEEKSEC = 86400*7;
my $week = int(($time+$WEEKSEC) / $WEEKSEC);
my $uafter = int(($time % $WEEKSEC) / 10);
my $ubefore = int(60480 - ($time % $WEEKSEC) / 10);
return ($week, $uafter, $ubefore);
}
sub weekuu_before_to_time
{
my ($week, $ubefore) = @_;
my $WEEKSEC = 86400*7;
my $time = $week * $WEEKSEC + 86400*3;
$time -= 10 * $ubefore;
return $time;
}
sub weekuu_after_to_time
{
my ($week, $uafter) = @_;
my $WEEKSEC = 86400*7;
my $time = ($week-1) * $WEEKSEC + 86400*3;
$time += 10 * $uafter;
return $time;
}
sub is_open_proxy
{
my $ip = shift;
eval { $ip ||= Apache->request; };
return 0 unless $ip;
if (ref $ip) { $ip = $ip->connection->remote_ip; }
my $dbr = LJ::get_db_reader();
my $stat = $dbr->selectrow_hashref("SELECT status, asof FROM openproxy WHERE addr=?",
undef, $ip);
# only cache 'clear' hosts for a day; 'proxy' for two days
$stat = undef if $stat && $stat->{'status'} eq "clear" && $stat->{'asof'} > 0 && $stat->{'asof'} < time()-86400;
$stat = undef if $stat && $stat->{'status'} eq "proxy" && $stat->{'asof'} < time()-2*86400;
# open proxies are considered open forever, unless cleaned by another site-local mechanism
return 1 if $stat && $stat->{'status'} eq "proxy";
# allow things to be cached clear for a day before re-checking
return 0 if $stat && $stat->{'status'} eq "clear";
# no RBL defined?
return 0 unless @LJ::RBL_LIST;
my $src = undef;
my $rev = join('.', reverse split(/\./, $ip));
foreach my $rbl (@LJ::RBL_LIST) {
my @res = gethostbyname("$rev.$rbl");
if ($res[4]) {
$src = $rbl;
last;
}
}
my $dbh = LJ::get_db_writer();
if ($src) {
$dbh->do("REPLACE INTO openproxy (addr, status, asof, src) VALUES (?,?,?,?)", undef,
$ip, "proxy", time(), $src);
return 1;
} else {
$dbh->do("INSERT IGNORE INTO openproxy (addr, status, asof, src) VALUES (?,?,?,?)", undef,
$ip, "clear", time(), $src);
return 0;
}
}
# loads an include file, given the bare name of the file.
# ($filename)
# returns the text of the file. if the file is specified in %LJ::FILEEDIT_VIA_DB
# then it is loaded from memcache/DB, else it falls back to disk.
sub load_include {
my $file = shift;
return unless $file && $file =~ /^[a-zA-Z0-9-_\.]{1,255}$/;
# okay, edit from where?
if ($LJ::FILEEDIT_VIA_DB || $LJ::FILEEDIT_VIA_DB{$file}) {
# we handle, so first if memcache...
my $val = LJ::MemCache::get("includefile:$file");
return $val if $val;
# straight database hit
my $dbh = LJ::get_db_writer();
$val = $dbh->selectrow_array("SELECT inctext FROM includetext ".
"WHERE incname=?", undef, $file);
LJ::MemCache::set("includefile:$file", $val, time() + 3600);
return $val;
}
# hit it up from the file, if it exists
my $filename = "$ENV{'LJHOME'}/htdocs/inc/$file";
return unless -e $filename;
# get it and return it
my $val;
open (INCFILE, $filename)
or return "Could not open include file: $file.";
{ local $/ = undef; $val = ; }
close INCFILE;
return $val;
}
#
# name: LJ::bit_breakdown
# des: Breaks down a bitmask into an array of bits enabled.
# args: mask
# des-mask: The number to break down.
# returns: A list of bits enabled. E.g., 3 returns (0, 2) indicating that bits 0 and 2 (numbering
# from the right) are currently on.
#
sub bit_breakdown {
my $mask = shift()+0;
# check each bit 0..31 and return only ones that are defined
return grep { defined }
map { $mask & (1<<$_) ? $_ : undef } 0..31;
}
sub last_error_code
{
return $LJ::last_error;
}
sub last_error
{
my $err = {
'utf8' => "Encoding isn't valid UTF-8",
'db' => "Database error",
'comm_not_found' => "Community not found",
'comm_not_comm' => "Account not a community",
'comm_not_member' => "User not a member of community",
'comm_invite_limit' => "Outstanding invitation limit reached",
'comm_user_has_banned' => "Unable to invite; user has banned community",
};
my $des = $err->{$LJ::last_error};
if ($LJ::last_error eq "db" && $LJ::db_error) {
$des .= ": $LJ::db_error";
}
return $des || $LJ::last_error;
}
sub error
{
my $err = shift;
if (isdb($err)) {
$LJ::db_error = $err->errstr;
$err = "db";
} elsif ($err eq "db") {
$LJ::db_error = "";
}
$LJ::last_error = $err;
return undef;
}
# to be called as &nodb; (so this function sees caller's @_)
sub nodb {
shift @_ if
ref $_[0] eq "LJ::DBSet" || ref $_[0] eq "DBI::db" ||
ref $_[0] eq "DBIx::StateKeeper" || ref $_[0] eq "Apache::DBI::db";
}
sub isdb { return ref $_[0] && (ref $_[0] eq "DBI::db" ||
ref $_[0] eq "DBIx::StateKeeper" ||
ref $_[0] eq "Apache::DBI::db"); }
sub no_utf8_flag {
return pack('U*', unpack('C*', $_[0]));
}
sub conf_test {
my ($conf, @args) = @_;
return 0 unless $conf;
return $conf->(@args) if ref $conf eq "CODE";
return $conf;
}
use vars qw($AUTOLOAD);
sub AUTOLOAD {
if ($AUTOLOAD eq "LJ::send_mail") {
require "$ENV{'LJHOME'}/cgi-bin/ljmail.pl";
goto &$AUTOLOAD;
}
croak "Undefined subroutine: $AUTOLOAD";
}
# LJ::S1::get_public_styles lives here in ljlib.pl so that
# cron jobs can call LJ::load_user_props without including
# ljviews.pl
package LJ::S1;
sub get_public_styles {
my $opts = shift;
# Try memcache if no extra options are requested
my $memkey = "s1pubstyc";
my $pubstyc = {};
unless ($opts) {
my $pubstyc = LJ::MemCache::get($memkey);
return $pubstyc if $pubstyc;
}
# not cached, build from db
my $sysid = LJ::get_userid("system");
# all cols *except* formatdata, which is big and unnecessary for most uses.
# it'll be loaded by LJ::S1::get_style
my $cols = "styleid, styledes, type, is_public, is_embedded, ".
"is_colorfree, opt_cache, has_ads, lastupdate";
$cols .= ", formatdata" if $opts->{'formatdata'};
# first try new table
my $dbh = LJ::get_db_writer();
my $sth = $dbh->prepare("SELECT userid, $cols FROM s1style WHERE userid=? AND is_public='Y'");
$sth->execute($sysid);
$pubstyc->{$_->{'styleid'}} = $_ while $_ = $sth->fetchrow_hashref;
# fall back to old table
unless (%$pubstyc) {
$sth = $dbh->prepare("SELECT user, $cols FROM style WHERE user='system' AND is_public='Y'");
$sth->execute();
$pubstyc->{$_->{'styleid'}} = $_ while $_ = $sth->fetchrow_hashref;
}
return undef unless %$pubstyc;
# set in memcache
unless ($opts) {
my $expire = time() + 60*30; # 30 minutes
LJ::MemCache::set($memkey, $pubstyc, $expire);
}
return $pubstyc;
}
# this package also doesn't belong in ljlib.pl, and should probably be
# moved back to ljemailgateway.pl soon, but the web code needed this,
# as well as the mailgated code, so putting it in weblib.pl doesn't
# work, and making modperl-subs.pl include ljemailgateway.pl was
# problematic during the woody-sarge transition (still happening), so
# for now it's here in ljlib.
package LJ::Emailpost;
# Retreives an allowed email addr list for a given user object.
# Returns a hashref with addresses / flags.
# Used for ljemailgateway and manage/emailpost.bml
sub get_allowed_senders {
my $u = shift;
my (%addr, @address);
LJ::load_user_props($u, 'emailpost_allowfrom');
@address = split(/\s*,\s*/, $u->{emailpost_allowfrom});
return undef unless scalar(@address) > 0;
my %flag_english = ( 'E' => 'get_errors' );
foreach my $add (@address) {
my $flags;
$flags = $1 if $add =~ s/\((.+)\)$//;
$addr{$add} = {};
if ($flags) {
$addr{$add}->{$flag_english{$_}} = 1 foreach split(//, $flags);
}
}
return \%addr;
}
# Inserts email addresses into the database.
# Adds flags if needed.
# Used in manage/emailpost.bml
sub set_allowed_senders {
my ($u, $addr) = @_;
my %flag_letters = ( 'get_errors' => 'E' );
my @addresses;
foreach (keys %$addr) {
my $email = $_;
my $flags = $addr->{$_};
if (%$flags) {
$email .= '(';
foreach my $flag (keys %$flags) {
$email .= $flag_letters{$flag};
}
$email .= ')';
}
push(@addresses, $email);
}
close T;
LJ::set_userprop($u, "emailpost_allowfrom", join(", ", @addresses));
}
1;