root/trunk/cgi-bin/ljlib.pl @ 982

Revision 982, 168.4 KB (checked in by bradfitz, 11 years ago)

allow alternative utf-8 checker, or fall back to slow perl one.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
Line 
1#!/usr/bin/perl
2#
3# <LJDEP>
4# lib: DBI::, Digest::MD5, URI::URL
5# lib: cgi-bin/ljconfig.pl, cgi-bin/ljlang.pl, cgi-bin/ljpoll.pl
6# lib: cgi-bin/cleanhtml.pl
7# link: htdocs/paidaccounts/index.bml, htdocs/users, htdocs/view/index.bml
8# hook: canonicalize_url, name_caps, name_caps_short, post_create
9# hook: validate_get_remote
10# </LJDEP>
11
12use strict;
13use DBI;
14use Digest::MD5 qw(md5_hex);
15use Text::Wrap;
16use MIME::Lite;
17use HTTP::Date qw();
18use IO::Socket;
19use Unicode::MapUTF8;
20
21require "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
22require "$ENV{'LJHOME'}/cgi-bin/ljlang.pl";
23require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
24require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
25
26# $LJ::PROTOCOL_VER is the version of the client-server protocol
27# used uniformly by server code which uses the protocol.
28$LJ::PROTOCOL_VER = ($LJ::UNICODE ? "1" : "0");
29
30# constants
31$LJ::EndOfTime = 2147483647;
32
33# width constants. BMAX_ constants are restrictions on byte width,
34# CMAX_ on character width (character means byte unless $LJ::UNICODE,
35# in which case it means a UTF-8 character).
36
37$LJ::BMAX_SUBJECT = 255;   # *_SUBJECT for journal events, not comments
38$LJ::CMAX_SUBJECT = 100;
39$LJ::BMAX_COMMENT = 9000;
40$LJ::CMAX_COMMENT = 4300;
41$LJ::BMAX_MEMORY  = 150;
42$LJ::CMAX_MEMORY  = 80;
43$LJ::BMAX_NAME    = 100;
44$LJ::CMAX_NAME    = 50;
45$LJ::BMAX_KEYWORD = 80;
46$LJ::CMAX_KEYWORD = 40;
47$LJ::BMAX_PROP    = 255;   # logprop[2]/talkprop[2]/userproplite (not userprop)
48$LJ::CMAX_PROP    = 100;
49$LJ::BMAX_GRPNAME = 60;
50$LJ::CMAX_GRPNAME = 30;
51$LJ::BMAX_EVENT   = 65535;
52$LJ::CMAX_EVENT   = 65535;
53
54# declare views (calls into ljviews.pl)
55@LJ::views = qw(lastn friends calendar day);
56%LJ::viewinfo = (
57                 "lastn" => {
58                     "creator" => \&create_view_lastn,
59                     "des" => "Most Recent Events",
60                 },
61                 "calendar" => {
62                     "creator" => \&create_view_calendar,
63                     "des" => "Calendar",
64                 },
65                 "day" => {
66                     "creator" => \&create_view_day,
67                     "des" => "Day View",
68                 },
69                 "friends" => {
70                     "creator" => \&create_view_friends,
71                     "des" => "Friends View",
72                 },
73                 "rss" => {
74                     "creator" => \&create_view_rss,
75                     "des" => "RSS View (XML)",
76                     "nostyle" => 1,
77                 },
78                 "info" => {
79                     # just a redirect to userinfo.bml for now.
80                     # in S2, will be a real view.
81                     "des" => "Profile Page",
82                 }
83                 );
84
85## we want to set this right away, so when we get a HUP signal later
86## and our signal handler sets it to true, perl doesn't need to malloc,
87## since malloc may not be thread-safe and we could core dump.
88## see LJ::clear_caches and LJ::handle_caches
89$LJ::CLEAR_CACHES = 0;
90
91## if this library is used in a BML page, we don't want to destroy BML's
92## HUP signal handler.
93if ($SIG{'HUP'}) {
94    my $oldsig = $SIG{'HUP'};
95    $SIG{'HUP'} = sub {
96        &{$oldsig};
97        LJ::clear_caches();
98    };
99} else {
100    $SIG{'HUP'} = \&LJ::clear_caches;
101}
102
103
104package LJ;
105
106# <LJFUNC>
107# name: LJ::get_newids
108# des: Lookup an old global ID and see what journal it belongs to and its new ID.
109# info: Interface to [dbtable[oldids]] table (URL compatability)
110# returns: Undef if non-existent or unconverted, or arrayref of [$userid, $newid].
111# args: area, oldid
112# des-area: The "area" of the id.  Legal values are "L" (log), to lookup an old itemid,
113#           or "T" (talk) to lookup an old talkid.
114# des-oldid: The old globally-unique id of the item.
115# </LJFUNC>
116sub get_newids
117{
118    my $dbarg = shift;
119    my $dbs = LJ::make_dbs_from_arg($dbarg);
120    my $dbh = $dbs->{'dbh'};
121    my $dbr = $dbs->{'reader'};
122    my $sth;
123
124    my $area = $dbh->quote(shift);
125    my $oldid = $dbh->quote(shift);
126    my $db = LJ::get_dbh("oldids") || $dbr;
127    return $db->selectrow_arrayref("SELECT userid, newid FROM oldids ".
128                                   "WHERE area=$area AND oldid=$oldid");
129}
130
131# <LJFUNC>
132# class: db
133# name: LJ::dbs_selectrow_array
134# des: Like DBI's selectrow_array, but working on a $dbs preferring the slave.
135# info: Given a dbset and a query, will try to query the slave first.
136#       Falls back to master if not in slave yet.  See also
137#       [func[LJ::dbs_selectrow_hashref]].
138# returns: In scalar context, the first column selected.  In list context,
139#          the entire row.
140# args: dbs, query
141# des-query: The select query to run.
142# </LJFUNC>
143sub dbs_selectrow_array
144{
145    my $dbs = shift;
146    my $query = shift;
147
148    my @dbl = ($dbs->{'dbh'});
149    if ($dbs->{'has_slave'}) { unshift @dbl, $dbs->{'dbr'}; }
150    foreach my $db (@dbl) {
151        my $ans = $db->selectrow_arrayref($query);
152        return wantarray() ? @$ans : $ans->[0] if defined $ans;
153    }
154    return undef;
155}
156
157# <LJFUNC>
158# class: db
159# name: LJ::dbs_selectrow_hashref
160# des: Like DBI's selectrow_hashref, but working on a $dbs preferring the slave.
161# info: Given a dbset and a query, will try to query the slave first.
162#       Falls back to master if not in slave yet.  See also
163#       [func[LJ::dbs_selectrow_array]].
164# returns: Hashref, or undef if no row found in either slave or master.
165# args: dbs, query
166# des-query: The select query to run.
167# </LJFUNC>
168sub dbs_selectrow_hashref
169{
170    my $dbs = shift;
171    my $query = shift;
172
173    my @dbl = ($dbs->{'dbh'});
174    if ($dbs->{'has_slave'}) { unshift @dbl, $dbs->{'dbr'}; }
175    foreach my $db (@dbl) {
176        my $ans = $db->selectrow_hashref($query);
177        return $ans if defined $ans;
178    }
179    return undef;
180}
181
182# <LJFUNC>
183# name: LJ::get_friend_items
184# des:
185# info:
186# args:
187# des-:
188# returns:
189# </LJFUNC>
190sub get_friend_items
191{
192    my $dbarg = shift;
193    my $opts = shift;
194
195    my $dbs = LJ::make_dbs_from_arg($dbarg);
196    my $dbh = $dbs->{'dbh'};
197    my $dbr = $dbs->{'reader'};
198    my $sth;
199
200    my $userid = $opts->{'userid'}+0;
201
202    # 'remote' opt takes precendence, then 'remoteid'
203    my $remote = $opts->{'remote'};
204    LJ::load_remote($dbs, $remote);
205    my $remoteid = $remote ? $remote->{'userid'} : 0;
206    if ($remoteid == 0 && $opts->{'remoteid'}) {
207        $remoteid = $opts->{'remoteid'} + 0;
208        $remote = LJ::load_userid($dbs, $remoteid);
209    }
210
211    my @items = ();
212    my $itemshow = $opts->{'itemshow'}+0;
213    my $skip = $opts->{'skip'}+0;
214    my $getitems = $itemshow + $skip;
215
216    my $owners_ref = (ref $opts->{'owners'} eq "HASH") ? $opts->{'owners'} : {};
217    my $filter = $opts->{'filter'}+0;
218
219    # sanity check:
220    $skip = 0 if ($skip < 0);
221
222    # what do your friends think of remote viewer?  what security level?
223    # but only if the remote viewer is a person, not a community/shared journal.
224    my $gmask_from = {};
225    if ($remote && $remote->{'journaltype'} eq "P") {
226        $sth = $dbr->prepare("SELECT ff.userid, ff.groupmask FROM friends fu, friends ff WHERE fu.userid=$userid AND fu.friendid=ff.userid AND ff.friendid=$remoteid");
227        $sth->execute;
228        while (my ($friendid, $mask) = $sth->fetchrow_array) {
229            $gmask_from->{$friendid} = $mask;
230        }
231        $sth->finish;
232    }
233
234    my $filtersql;
235    if ($filter) {
236        if ($remoteid == $userid) {
237            $filtersql = "AND f.groupmask & $filter";
238        }
239    }
240
241    my @friends_buffer = ();
242    my $total_loaded = 0;
243    my $buffer_unit = int($getitems * 1.5);  # load a bit more first to avoid 2nd load
244
245    my $get_next_friend = sub
246    {
247        # return one if we already have some loaded.
248        if (@friends_buffer) {
249            return $friends_buffer[0];
250        }
251
252        # load another batch if we just started or
253        # if we just finished a batch.
254        if ($total_loaded % $buffer_unit == 0)
255        {
256            my $sth = $dbr->prepare("SELECT u.userid, $LJ::EndOfTime-UNIX_TIMESTAMP(uu.timeupdate), u.clusterid FROM friends f, userusage uu, user u WHERE f.userid=$userid AND f.friendid=uu.userid AND f.friendid=u.userid $filtersql AND u.statusvis='V' AND uu.timeupdate IS NOT NULL ORDER BY 2 LIMIT $total_loaded, $buffer_unit");
257            $sth->execute;
258
259            while (my ($userid, $update, $clusterid) = $sth->fetchrow_array) {
260                push @friends_buffer, [ $userid, $update, $clusterid ];
261                $total_loaded++;
262            }
263
264            # return one if we just found some fine, else we're all
265            # out and there's nobody else to load.
266            if (@friends_buffer) {
267                return $friends_buffer[0];
268            } else {
269                return undef;
270            }
271        }
272
273        # otherwise we must've run out.
274        return undef;
275    };
276
277    my $loop = 1;
278    my $max_age = $LJ::MAX_FRIENDS_VIEW_AGE || 3600*24*14;  # 2 week default.
279    my $lastmax = $LJ::EndOfTime - time() + $max_age;
280    my $itemsleft = $getitems;
281    my $fr;
282
283    while ($loop && ($fr = $get_next_friend->()))
284    {
285        shift @friends_buffer;
286
287        # load the next recent updating friend's recent items
288        my $friendid = $fr->[0];
289
290        my @newitems = LJ::get_recent_items($dbs, {
291            'clustersource' => 'slave',  # no effect for cluster 0
292            'clusterid' => $fr->[2],
293            'userid' => $friendid,
294            'remote' => $remote,
295            'itemshow' => $itemsleft,
296            'skip' => 0,
297            'gmask_from' => $gmask_from,
298            'friendsview' => 1,
299            'notafter' => $lastmax,
300        });
301
302        # stamp each with clusterid if from cluster, so ljviews and other
303        # callers will know which items are old (no/0 clusterid) and which
304        # are new
305        if ($fr->[2]) {
306            foreach (@newitems) { $_->{'clusterid'} = $fr->[2]; }
307        }
308
309        if (@newitems)
310        {
311            push @items, @newitems;
312
313            $opts->{'owners'}->{$friendid} = 1;
314
315            $itemsleft--; # we'll need at least one less for the next friend
316
317            # sort all the total items by rlogtime (recent at beginning)
318            @items = sort { $a->{'rlogtime'} <=> $b->{'rlogtime'} } @items;
319
320            # cut the list down to what we need.
321            @items = splice(@items, 0, $getitems) if (@items > $getitems);
322        }
323
324        if (@items == $getitems)
325        {
326            $lastmax = $items[-1]->{'rlogtime'};
327
328            # stop looping if we know the next friend's newest entry
329            # is greater (older) than the oldest one we've already
330            # loaded.
331            my $nextfr = $get_next_friend->();
332            $loop = 0 if ($nextfr && $nextfr->[1] > $lastmax);
333        }
334    }
335
336    # remove skipped ones
337    splice(@items, 0, $skip) if $skip;
338
339    # TODO: KILL! this knows nothing about clusters.
340    # return the itemids for them if they wanted them
341    if (ref $opts->{'itemids'} eq "ARRAY") {
342        @{$opts->{'itemids'}} = map { $_->{'itemid'} } @items;
343    }
344
345    # return the itemids grouped by clusters, if callers wants it.
346    if (ref $opts->{'idsbycluster'} eq "HASH") {
347        foreach (@items) {
348            if ($_->{'clusterid'}) {
349                push @{$opts->{'idsbycluster'}->{$_->{'clusterid'}}},
350                [ $_->{'ownerid'}, $_->{'itemid'} ];
351            } else {
352                push @{$opts->{'idsbycluster'}->{'0'}}, $_->{'itemid'};
353            }
354        }
355    }
356
357    return @items;
358}
359
360# <LJFUNC>
361# name: LJ::get_recent_items
362# class:
363# des:
364# info:
365# args:
366# des-:
367# returns:
368# </LJFUNC>
369sub get_recent_items
370{
371    my $dbarg = shift;
372    my $opts = shift;
373
374    my $dbs = LJ::make_dbs_from_arg($dbarg);
375    my $dbh = $dbs->{'dbh'};
376    my $dbr = $dbs->{'reader'};
377    my $sth;
378
379    my @items = ();             # what we'll return
380
381    my $userid = $opts->{'userid'}+0;
382
383    # 'remote' opt takes precendence, then 'remoteid'
384    my $remote = $opts->{'remote'};
385    LJ::load_remote($dbs, $remote);
386    my $remoteid = $remote ? $remote->{'userid'} : 0;
387    if ($remoteid == 0 && $opts->{'remoteid'}) {
388        $remoteid = $opts->{'remoteid'} + 0;
389        $remote = LJ::load_userid($dbs, $remoteid);
390    }
391
392    my $max_hints = $LJ::MAX_HINTS_LASTN;  # temporary
393    my $sort_key = "revttime";
394
395    my $clusterid = $opts->{'clusterid'}+0;
396    my $logdb = $dbr;
397
398    if ($clusterid) {
399        my $source = $opts->{'clustersource'} eq "slave" ? "slave" : "";
400        $logdb = LJ::get_dbh("cluster${clusterid}$source",
401                             "cluster$clusterid");  # might have no slave
402    }
403
404    # community/friend views need to post by log time, not event time
405    $sort_key = "rlogtime" if ($opts->{'order'} eq "logtime" ||
406                               $opts->{'friendsview'});
407
408    # 'notafter':
409    #   the friends view doesn't want to load things that it knows it
410    #   won't be able to use.  if this argument is zero or undefined,
411    #   then we'll load everything less than or equal to 1 second from
412    #   the end of time.  we don't include the last end of time second
413    #   because that's what backdated entries are set to.  (so for one
414    #   second at the end of time we'll have a flashback of all those
415    #   backdated entries... but then the world explodes and everybody
416    #   with 32 bit time_t structs dies)
417    my $notafter = $opts->{'notafter'} + 0 || $LJ::EndOfTime - 1;
418
419    my $skip = $opts->{'skip'}+0;
420    my $itemshow = $opts->{'itemshow'}+0;
421    if ($itemshow > $max_hints) { $itemshow = $max_hints; }
422    my $maxskip = $max_hints - $itemshow;
423    if ($skip < 0) { $skip = 0; }
424    if ($skip > $maxskip) { $skip = $maxskip; }
425    my $itemload = $itemshow + $skip;
426
427    # get_friend_items will give us this data structure all at once so
428    # we don't have to load each friendof mask one by one, but for
429    # a single lastn view, it's okay to just do it once.
430    my $gmask_from = $opts->{'gmask_from'};
431    unless (ref $gmask_from eq "HASH") {
432        $gmask_from = {};
433        if ($remote && $remote->{'journaltype'} eq "P") {
434            ## then we need to load the group mask for this friend
435            $sth = $dbr->prepare("SELECT groupmask FROM friends WHERE userid=$userid ".
436                                 "AND friendid=$remoteid");
437            $sth->execute;
438            my ($mask) = $sth->fetchrow_array;
439            $gmask_from->{$userid} = $mask;
440        }
441    }
442
443    # what mask can the remote user see?
444    my $mask = $gmask_from->{$userid} + 0;
445
446    # decide what level of security the remote user can see
447    my $secwhere = "";
448    if ($userid == $remoteid || $opts->{'viewall'}) {
449        # no extra where restrictions... user can see all their own stuff
450        # alternatively, if 'viewall' opt flag is set, security is off.
451    } elsif ($mask) {
452        # can see public or things with them in the mask
453        $secwhere = "AND (security='public' OR (security='usemask' AND allowmask & $mask != 0))";
454    } else {
455        # not a friend?  only see public.
456        $secwhere = "AND security='public' ";
457    }
458
459    # because LJ::get_friend_items needs rlogtime for sorting.
460    my $extra_sql;
461    if ($opts->{'friendsview'}) {
462        if ($clusterid) {
463            $extra_sql .= "journalid AS 'ownerid', rlogtime, ";
464        } else {
465            $extra_sql .= "ownerid, rlogtime, ";
466        }
467    }
468
469    my $sql;
470
471    if ($clusterid) {
472        $sql = ("SELECT jitemid AS 'itemid', posterid, security, replycount, $extra_sql ".
473                "DATE_FORMAT(eventtime, \"%a %W %b %M %y %Y %c %m %e %d %D %p %i ".
474                "%l %h %k %H\") AS 'alldatepart', anum ".
475                "FROM log2 WHERE journalid=$userid AND $sort_key <= $notafter $secwhere ".
476                "ORDER BY journalid, $sort_key ".
477                "LIMIT $skip,$itemshow");
478    } else {
479        # old tables ("cluster 0")
480        $sql = ("SELECT itemid, posterid, security, replycount, $extra_sql ".
481                "DATE_FORMAT(eventtime, \"%a %W %b %M %y %Y %c %m %e %d %D %p %i ".
482                "%l %h %k %H\") AS 'alldatepart' ".
483                "FROM log WHERE ownerid=$userid AND $sort_key <= $notafter $secwhere ".
484                "ORDER BY ownerid, $sort_key ".
485                "LIMIT $skip,$itemshow");
486    }
487
488    $sth = $logdb->prepare($sql);
489    $sth->execute;
490    if ($logdb->err) { die $logdb->errstr; }
491    while (my $li = $sth->fetchrow_hashref) {
492        push @items, $li;
493        push @{$opts->{'itemids'}}, $li->{'itemid'};
494    }
495    return @items;
496}
497
498# <LJFUNC>
499# name: LJ::set_userprop
500# des: Sets/deletes a userprop by name for a user.
501# info: This adds or deletes from the
502#       [dbtable[userprop]]/[dbtable[userproplite]] tables.  One
503#       crappy thing about this interface is that it doesn't allow
504#       a batch of userprops to be updated at once, which is the
505#       common thing to do.
506# args: dbarg, userid, propname, value
507# des-userid: The userid of the user.
508# des-propname: The name of the property.
509# des-value: The value to set to the property.  If undefined or the
510#            empty string, then property is deleted.
511# </LJFUNC>
512sub set_userprop
513{
514    my ($dbarg, $userid, $propname, $value) = @_;
515    my $dbs = LJ::make_dbs_from_arg($dbarg);
516    my $dbh = $dbs->{'dbh'};
517
518    my $p;
519
520    if ($LJ::CACHE_USERPROP{$propname}) {
521        $p = $LJ::CACHE_USERPROP{$propname};
522    } else {
523        my $qpropname = $dbh->quote($propname);
524        $userid += 0;
525        my $propid;
526        my $sth;
527
528        $sth = $dbh->prepare("SELECT upropid, indexed FROM userproplist WHERE name=$qpropname");
529        $sth->execute;
530        $p = $sth->fetchrow_hashref;
531        return unless ($p);
532        $LJ::CACHE_USERPROP{$propname} = $p;
533    }
534
535    my $table = $p->{'indexed'} ? "userprop" : "userproplite";
536    if (defined $value && $value ne "") {
537        $value = $dbh->quote($value);
538        $dbh->do("REPLACE INTO $table (userid, upropid, value) ".
539                 "VALUES ($userid, $p->{'upropid'}, $value)");
540    } else {
541        $dbh->do("DELETE FROM $table WHERE userid=$userid AND upropid=$p->{'upropid'}");
542    }
543}
544
545# <LJFUNC>
546# name: LJ::register_authaction
547# des: Registers a secret to have the user validate.
548# info: Some things, like requiring a user to validate their email address, require
549#       making up a secret, mailing it to the user, then requiring them to give it
550#       back (usually in a URL you make for them) to prove they got it.  This
551#       function creates a secret, attaching what it's for and an optional argument.
552#       Background maintenance jobs keep track of cleaning up old unvalidated secrets.
553# args: dbarg, userid, action, arg?
554# des-userid: Userid of user to register authaction for.
555# des-action: Action type to register.   Max chars: 50.
556# des-arg: Optional argument to attach to the action.  Max chars: 255.
557# returns: 0 if there was an error.  Otherwise, a hashref
558#          containing keys 'aaid' (the authaction ID) and the 'authcode',
559#          a 15 character string of random characters from
560#          [func[LJ::make_auth_code]].
561# </LJFUNC>
562sub register_authaction
563{
564    my $dbarg = shift;
565    my $dbs = LJ::make_dbs_from_arg($dbarg);
566    my $dbh = $dbs->{'dbh'};
567
568    my $userid = shift;  $userid += 0;
569    my $action = $dbh->quote(shift);
570    my $arg1 = $dbh->quote(shift);
571
572    # make the authcode
573    my $authcode = LJ::make_auth_code(15);
574    my $qauthcode = $dbh->quote($authcode);
575
576    $dbh->do("INSERT INTO authactions (aaid, userid, datecreate, authcode, action, arg1) ".
577             "VALUES (NULL, $userid, NOW(), $qauthcode, $action, $arg1)");
578
579    return 0 if $dbh->err;
580    return { 'aaid' => $dbh->{'mysql_insertid'},
581             'authcode' => $authcode,
582         };
583}
584
585# <LJFUNC>
586# class: logging
587# name: LJ::send_statserv
588# des: Sends UDP packet of info to the statistics server.
589# returns: Nothing.
590# args: cachename, ip, type, url?
591# des-cachename: The name to cache this client under. This is can be the
592#                logged in username, the value of a guest cookie, or
593#                simply "ip" to indicate a cookie-less client.
594# des-ip: The dotted quad representing the client's IP address.
595# des-type: What type of client this is. "user", "guest" or "ip".
596# des-url: An optional URL of what the client hit.
597# </LJFUNC>
598sub send_statserv
599{
600    my $user = shift;
601    my $ip = shift;
602    my $type = shift;
603    my $url = shift || "";
604
605    return unless ($LJ::STATSERV);
606    # If we don't already have a socket defined, do the startup work.
607    unless ($LJ::UDP_SOCKET) {
608        my $sock = IO::Socket::INET->new(Proto => 'udp')
609                   or print STDERR "Can't create socket: $!\n";
610        my $ipaddr = IO::Socket::inet_aton($LJ::STATSERV);
611        my $portaddr = IO::Socket::sockaddr_in($LJ::STATSERV_PORT, $ipaddr);
612        $LJ::UDP_SOCKET = $sock;
613        $LJ::UDP_STATSERV = $portaddr;
614    }
615
616    # If we end up with a weird cachename, declare hatred for the
617    # IP it came from.
618    unless ($user =~ m/\w+/) { $user = "ip"; $type = "ip"; }
619    unless (length($user) < 50) { $user = "ip"; $type = "ip"; }
620
621    my $msg = "cmd: $user : $ip : $type";
622    if ($url) { $msg .= " : $url"; }
623
624    # This really needs to sound some kind of alarm. If a user can
625    # figure out how to execute this code, they can attack the site
626    # freely.
627    if (length($msg) > 450) {
628        print STDERR "statserv message $msg is too long!\n";
629    }
630
631    $LJ::UDP_SOCKET->send($msg, 0, $LJ::UDP_STATSERV)
632                     or print STDERR "Can't send to statserv: $!\n";
633
634}
635
636# <LJFUNC>
637# class: web
638# name: LJ::make_cookie
639# des: Prepares cookie header lines.
640# returns: An array of cookie lines.
641# args: name, value, expires, path?, domain?
642# des-name: The name of the cookie.
643# des-value: The value to set the cookie to.
644# des-expires: The time (in seconds) when the cookie is supposed to expire.
645#              Set this to 0 to expire when the browser closes. Set it to
646#              undef to delete the cookie.
647# des-path: The directory path to bind the cookie to.
648# des-domain: The domain (or domains) to bind the cookie to.
649# </LJFUNC>
650sub make_cookie
651{
652    my ($name, $value, $expires, $path, $domain) = @_;
653    my $cookie = "";
654    my @cookies = ();
655
656    # let the domain argument be an array ref, so callers can set
657    # cookies in both .foo.com and foo.com, for some broken old browsers.
658    if ($domain && ref $domain eq "ARRAY") {
659        foreach (@$domain) {
660            push(@cookies, LJ::make_cookie($name, $value, $expires, $path, $_));
661        }
662        return;
663    }
664
665    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($expires);
666    $year+=1900;
667
668    my @day = qw{Sunday Monday Tuesday Wednesday Thursday Friday Saturday};
669    my @month = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
670
671    $cookie = sprintf "%s=%s", LJ::eurl($name), LJ::eurl($value);
672
673    # this logic is confusing potentially
674    unless (defined $expires && $expires==0) {
675        $cookie .= sprintf "; expires=$day[$wday], %02d-$month[$mon]-%04d %02d:%02d:%02d GMT",
676                $mday, $year, $hour, $min, $sec;
677    }
678
679    $cookie .= "; path=$path" if $path;
680    $cookie .= "; domain=$domain" if $domain;
681    push(@cookies, $cookie);
682    return @cookies;
683}
684
685
686# <LJFUNC>
687# class: logging
688# name: LJ::statushistory_add
689# des: Adds a row to a user's statushistory
690# info: See the [dbtable[statushistory]] table.
691# returns: boolean; 1 on success, 0 on failure
692# args: dbarg, userid, adminid, shtype, notes?
693# des-userid: The user getting acted on.
694# des-adminid: The site admin doing the action.
695# des-shtype: The status history type code.
696# des-notes: Optional notes associated with this action.
697# </LJFUNC>
698sub statushistory_add
699{
700    my $dbarg = shift;
701    my $dbs = LJ::make_dbs_from_arg($dbarg);
702    my $dbh = $dbs->{'dbh'};
703
704    my $userid = shift;  $userid += 0;
705    my $actid  = shift;  $actid  += 0;
706
707    my $qshtype = $dbh->quote(shift);
708    my $qnotes  = $dbh->quote(shift);
709
710    $dbh->do("INSERT INTO statushistory (userid, adminid, shtype, notes) ".
711             "VALUES ($userid, $actid, $qshtype, $qnotes)");
712    return $dbh->err ? 0 : 1;
713}
714
715# <LJFUNC>
716# name: LJ::make_link
717# des: Takes a group of key=value pairs to append to a url
718# returns: The finished url
719# args: url, vars
720# des-url: A string with the URL to append to.  The URL
721#          shouldn't have a question mark in it.
722# des-vars: A hashref of the key=value pairs to append with.
723# </LJFUNC>
724sub make_link
725{
726    my $url = shift;
727    my $vars = shift;
728    my $append = "?";
729    foreach (keys %$vars) {
730        next if ($vars->{$_} eq "");
731        $url .= "${append}${_}=$vars->{$_}";
732        $append = "&";
733    }
734    return $url;
735}
736
737# <LJFUNC>
738# class: time
739# name: LJ::ago_text
740# des: Converts integer seconds to English time span
741# info: Turns a number of seconds into the largest possible unit of
742#       time. "2 weeks", "4 days", or "20 hours".
743# returns: A string with the number of largest units found
744# args: secondsold
745# des-secondsold: The number of seconds from now something was made.
746# </LJFUNC>
747sub ago_text
748{
749    my $secondsold = shift;
750    return "Never." unless ($secondsold);
751    my $num;
752    my $unit;
753    if ($secondsold > 60*60*24*7) {
754        $num = int($secondsold / (60*60*24*7));
755        $unit = "week";
756    } elsif ($secondsold > 60*60*24) {
757        $num = int($secondsold / (60*60*24));
758        $unit = "day";
759    } elsif ($secondsold > 60*60) {
760        $num = int($secondsold / (60*60));
761        $unit = "hour";
762    } elsif ($secondsold > 60) {
763        $num = int($secondsold / (60));
764        $unit = "minute";
765    } else {
766        $num = $secondsold;
767        $unit = "second";
768    }
769    return "$num $unit" . ($num==1?"":"s") . " ago";
770}
771
772# <LJFUNC>
773# class: component
774# name: LJ::auth_fields
775# des: Makes a login form.
776# info: Returns a form for either submitting username/password to a script or
777#       entering a new username/password.
778# returns: The built form
779# args: form, opts?
780# des-form: The hash of form information, which is used to determine whether to
781#           get the current login info and display a concise form, or to display
782#           a login form.
783# des-opts: hashref containing 'user' key to force (finds/makes the hpassword)
784# </LJFUNC>
785sub auth_fields
786{
787    my $form = shift;
788    my $opts = shift;
789
790    my $remote = LJ::get_remote_noauth();
791    my $ret = "";
792    if ((!$form->{'altlogin'} && $remote) || $opts->{'user'})
793    {
794        my $hpass;
795        my $luser = $opts->{'user'} || $remote->{'user'};
796        if ($opts->{'user'}) {
797            $hpass = $form->{'hpassword'} || LJ::hash_password($form->{'password'});
798        } elsif ($remote && $BMLClient::COOKIE{"ljhpass"} =~ /^$luser:(.+)/) {
799            $hpass = $1;
800        }
801
802        my $alturl = $ENV{'REQUEST_URI'};
803        $alturl .= ($alturl =~ /\?/) ? "&amp;" : "?";
804        $alturl .= "altlogin=1";
805
806        $ret .= "<tr align='left'><td colspan='2' align='left'>You are currently logged in as <b>$luser</b>.";
807        $ret .= "<br />If this is not you, <a href='$alturl'>click here</a>.\n"
808            unless $opts->{'noalt'};
809        $ret .= "<input type='hidden' name='user' value='$luser'>\n";
810        $ret .= "<input type='hidden' name='hpassword' value='$hpass'><br />&nbsp;\n";
811        $ret .= "</td></tr>\n";
812    } else {
813        $ret .= "<tr align='left'><td>Username:</td><td align='left'><input type='text' name='user' size='15' maxlength='15' value='";
814        my $user = $form->{'user'};
815        unless ($user || $ENV{'QUERY_STRING'} =~ /=/) { $user=$ENV{'QUERY_STRING'}; }
816        $ret .= BMLUtil::escapeall($user) unless ($form->{'altlogin'});
817        $ret .= "' /></td></tr>\n";
818        $ret .= "<tr><td>Password:</td><td align='left'>\n";
819        my $epass = LJ::ehtml($form->{'password'});
820        $ret .= "<input type='password' name='password' size='15' maxlength='30' value='$epass' />";
821        $ret .= "</td></tr>\n";
822    }
823    return $ret;
824}
825
826# <LJFUNC>
827# class: component
828# name: LJ::auth_fields_2
829# des: Makes a login form.
830# info: Like [func[LJ::auth_fields]], with a lot more functionality.  Creates the
831#       HTML for a login box if user not logged in. Creates a drop-down
832#       selection box of possible journals to switch to if user is logged in.
833# returns: The resultant HTML form box.
834# args: form, opts
835# des-form: Form results from the previous page.
836# des-opts: Journal/password options for changing the login box.
837# </LJFUNC>
838sub auth_fields_2
839{
840    my $dbs = shift;
841    my $form = shift;
842    my $opts = shift;
843    my $remote = LJ::get_remote($dbs);
844    my $ret = "";
845
846    # text box mode
847    if ($form->{'authas'} eq "(other)" || $form->{'altlogin'} ||
848        $form->{'user'} || ! $remote)
849    {
850        $ret .= "<tr><td align='right'><u>U</u>sername:</td><td align='left'><input type=\"text\" name='user' size='15' maxlength='15' accesskey='u' value=\"";
851        my $user = $form->{'user'};
852        unless ($user || $ENV{'QUERY_STRING'} =~ /=/) { $user=$ENV{'QUERY_STRING'}; }
853        $ret .= BMLUtil::escapeall($user) unless ($form->{'altlogin'});
854        $ret .= "\" /></td></tr>\n";
855        $ret .= "<tr><td align='right'><u>P</u>assword:</td><td align='left'>\n";
856        $ret .= "<input type='password' name='password' size='15' maxlength='30' accesskey='p' value=\"" .
857            LJ::ehtml($opts->{'password'}) . "\" />";
858        $ret .= "</td></tr>\n";
859        return $ret;
860    }
861
862    # logged in mode
863    $ret .= "<tr><td align='right'><u>U</u>sername:</td><td align='left'>";
864
865    my $alturl = LJ::self_link($form, { 'altlogin' => 1 });
866    my @shared = ($remote->{'user'});
867
868    my $sopts = {};
869    $sopts->{'notshared'} = 1 unless $opts->{'shared'};
870    $sopts->{'getother'} = $opts->{'getother'};
871
872    $ret .= LJ::make_shared_select($dbs, $remote, $form, $sopts);
873
874    if ($sopts->{'getother'}) {
875        my $alturl = LJ::self_link($form, { 'altlogin' => 1 });
876        $ret .= "&nbsp;(<a href='$alturl'>Other</a>)";
877    }
878
879    $ret .= "</td></tr>\n";
880    return $ret;
881}
882
883# <LJFUNC>
884# class: component
885# name: LJ::make_shared_select
886# des: Creates a list of shared journals a user has access to
887#      for insertion into a drop-down menu.
888# returns: The HTML for the options menu.
889# args: u, form, opts
890# des-form: The form hash from the previous page.
891# des-opts: A hash of options to change the types of selections shown.
892# </LJFUNC>
893sub make_shared_select
894{
895    my ($dbs, $u, $form, $opts) = @_;
896
897    my %u2k;
898    $u2k{$u->{'user'}} = "(remote)";
899
900    my @choices = ("(remote)", $u->{'user'});
901    unless ($opts->{'notshared'}) {
902        foreach (LJ::get_shared_journals($dbs, $u)) {
903            push @choices, $_, $_;
904            $u2k{$_} = $_;
905        }
906    }
907    unless ($opts->{'getother'}) {
908        push @choices, "(other)", "Other...";
909    }
910
911    if (@choices > 2) {
912        my $sel;
913        if ($form->{'user'}) {
914            $sel = $u2k{$form->{'user'}} || "(other)";
915        } else {
916            $sel = $form->{'authas'};
917        }
918        return LJ::html_select({
919            'name' => 'authas',
920            'raw' => "accesskey='u'",
921            'selected' => $sel,
922        }, @choices);
923    } else {
924        return "<b>$u->{'user'}</b>";
925    }
926}
927
928# <LJFUNC>
929# name: LJ::get_shared_journals
930# des: Gets an array of shared journals a user has access to.
931# returns: An array of shared journals.
932# args: dbs, u
933# </LJFUNC>
934sub get_shared_journals
935{
936    my $dbs = shift;
937    my $u = shift;
938    LJ::load_user_privs($dbs, $u, "sharedjournal");
939    return sort keys %{$u->{'_priv'}->{'sharedjournal'}};
940}
941
942# <LJFUNC>
943# name: LJ::get_effective_user
944# des: Given a set of input, will return the effective user to process as.
945# info: Is passed a reference to a form hash, a remote hash reference, a
946#       reference to an error variable, and a reference to a user hash to
947#       possibly fill. Given the form input, it will authenticate and return
948#       the user (logged in user, a community, other user) that the remote
949#       user requested to do an action with.
950# returns: The user to process as.
951# args: dbs, opts
952# des-opts: A hash of options to pass.
953# </LJFUNC>
954sub get_effective_user
955{
956    my $dbs = shift;
957    my $opts = shift;
958    my $f = $opts->{'form'};
959    my $refu = $opts->{'out_u'};
960    my $referr = $opts->{'out_err'};
961    my $remote = $opts->{'remote'};
962
963    $$referr = "";
964
965    # presence of 'altlogin' means user is probably logged in but
966    # wants to act as somebody else, so ignore their cookie and just
967    # fail right away, which'll cause the form to be loaded where they
968    # can enter manually a username.
969    if ($f->{'altlogin'}) { return ""; }
970
971    # this means the same, and is used by LJ::make_shared_select:
972    if ($f->{'authas'} eq "(other)") { return ""; }
973
974    # an explicit 'user' argument overrides the remote setting.  if
975    # the password is correct, the user they requested is the
976    # effective one, else we have no effective yet.
977    if ($f->{'user'}) {
978        my $u = LJ::load_user($dbs, $f->{'user'});
979        unless ($u) {
980            $$referr = "Invalid user.";
981            return;
982        }
983
984        # if password present, check it.
985        if ($f->{'password'} || $f->{'hpassword'}) {
986            if (LJ::auth_okay($u, $f->{'password'}, $f->{'hpassword'}, $u->{'password'})) {
987                $$refu = $u;
988                return $f->{'user'};
989            } else {
990                $$referr = "Invalid password.";
991                return;
992            }
993        }
994
995        # otherwise don't check it and return nothing (to prevent the
996        # remote setting from taking place... this forces the
997        # user/password boxes to appear)
998        return;
999    }
1000
1001    # not logged in?
1002    return unless $remote;
1003
1004    # logged in. use self identity unless they're requesting to act as
1005    # a community.
1006    return $remote->{'user'}
1007    unless ($f->{'authas'} && $f->{'authas'} ne "(remote)");
1008
1009    # if they have the privs, let them be that community
1010    return $f->{'authas'}
1011    if (LJ::check_priv($dbs, $remote, "sharedjournal", $f->{'authas'}));
1012
1013    # else, complain.
1014    $$referr = "Invalid privileges to act as requested community.";
1015    return;
1016}
1017
1018# <LJFUNC>
1019# class: web
1020# name: LJ::self_link
1021# des: Takes the URI of the current page, and adds the current form data
1022#      to the url, then adds any additional data to the url.
1023# returns: scalar; the full url
1024# args: form, newvars
1025# des-form: A hashref of the form information from the page.
1026# des-newvars: A hashref of information to add/override to the link.
1027# </LJFUNC>
1028sub self_link
1029{
1030    my $form = shift;
1031    my $newvars = shift;
1032    my $link = $ENV{'REQUEST_URI'};
1033    $link =~ s/\?.+//;
1034    $link .= "?";
1035    foreach (keys %$newvars) {
1036        if (! exists $form->{$_}) { $form->{$_} = ""; }
1037    }
1038    foreach (sort keys %$form) {
1039        if (defined $newvars->{$_} && ! $newvars->{$_}) { next; }
1040        my $val = $newvars->{$_} || $form->{$_};
1041        next unless $val;
1042        $link .= LJ::eurl($_) . "=" . LJ::eurl($val) . "&";
1043    }
1044    chop $link;
1045    return $link;
1046}
1047
1048# <LJFUNC>
1049# class: web
1050# name: LJ::get_query_string
1051# des: Returns the query string, which can be in a number of spots
1052#      depending on the webserver & configuration, sadly.
1053# returns: String; query string.
1054# </LJFUNC>
1055sub get_query_string
1056{
1057    my $q = $ENV{'QUERY_STRING'} || $ENV{'REDIRECT_QUERY_STRING'};
1058    if ($q eq "" && $ENV{'REQUEST_URI'} =~ /\?(.+)/) {
1059        $q = $1;
1060    }
1061    return $q;
1062}
1063
1064# <LJFUNC>
1065# class: web
1066# name: LJ::get_form_data
1067# des: Loads a hashref with form data from a GET or POST request.
1068# args: hashref, type?
1069# des-hashref: Hashref to populate with form data.
1070# des-type: If "GET", will ignore POST data.
1071# </LJFUNC>
1072sub get_form_data
1073{
1074    my $hashref = shift;
1075    my $type = shift;
1076    my $buffer;
1077
1078    if ($ENV{'REQUEST_METHOD'} eq 'POST' && $type ne "GET") {
1079        read(STDIN, $buffer, $ENV{'CONTENT_LENGTH'});
1080    } else {
1081        $buffer = $ENV{'QUERY_STRING'} || $ENV{'REDIRECT_QUERY_STRING'};
1082        if ($buffer eq "" && $ENV{'REQUEST_URI'} =~ /\?(.+)/) {
1083            $buffer = $1;
1084        }
1085    }
1086
1087    # Split the name-value pairs
1088    LJ::decode_url_string($buffer, $hashref);
1089}
1090
1091# <LJFUNC>
1092# name: LJ::is_valid_authaction
1093# des: Validates a shared secret (authid/authcode pair)
1094# info: See [func[LJ::register_authaction]].
1095# returns: Hashref of authaction row from database.
1096# args: dbarg, aaid, auth
1097# des-aaid: Integer; the authaction ID.
1098# des-auth: String; the auth string. (random chars the client already got)
1099# </LJFUNC>
1100sub is_valid_authaction
1101{
1102    my $dbarg = shift;
1103    my $dbs = LJ::make_dbs_from_arg($dbarg);
1104    my $dbh = $dbs->{'dbh'};
1105
1106    # TODO: make this use slave if available (low usage/priority)
1107    my ($aaid, $auth) = map { $dbh->quote($_) } @_;
1108    my $sth = $dbh->prepare("SELECT aaid, userid, datecreate, authcode, action, arg1 FROM authactions WHERE aaid=$aaid AND authcode=$auth");
1109    $sth->execute;
1110    return $sth->fetchrow_hashref;
1111}
1112
1113# <LJFUNC>
1114# class: s1
1115# name: LJ::fill_var_props
1116# args: vars, key, hashref
1117# des: S1 utility function to interpolate %%variables%% in a variable.  If
1118#      a modifier is given like %%foo:var%%, then [func[LJ::fvp_transform]]
1119#      is called.
1120# des-vars: hashref with keys being S1 vars
1121# des-key: the variable in the vars hashref we're expanding
1122# des-hashref: hashref of values that could interpolate.
1123# returns: Expanded string.
1124# </LJFUNC>
1125sub fill_var_props
1126{
1127    my ($vars, $key, $hashref) = @_;
1128    my $data = $vars->{$key};
1129    $data =~ s/%%(?:([\w:]+:))?(\S+?)%%/$1 ? LJ::fvp_transform(lc($1), $vars, $hashref, $2) : $hashref->{$2}/eg;
1130    return $data;
1131}
1132
1133# <LJFUNC>
1134# class: s1
1135# name: LJ::fvp_transform
1136# des: Called from [func[LJ::fill_var_props]] to do trasformations.
1137# args: transform, vars, hashref, attr
1138# des-transform: The transformation type.
1139# des-vars: hashref with keys being S1 vars
1140# des-hashref: hashref of values that could interpolate. (see
1141#              [func[LJ::fill_var_props]])
1142# des-attr: the attribute name that's being interpolated.
1143# returns: Transformed interpolated variable.
1144# </LJFUNC>
1145sub fvp_transform
1146{
1147    my ($transform, $vars, $hashref, $attr) = @_;
1148    my $ret = $hashref->{$attr};
1149    while ($transform =~ s/(\w+):$//) {
1150        my $trans = $1;
1151        if ($trans eq "ue") {
1152            $ret = LJ::eurl($ret);
1153        }
1154        elsif ($trans eq "xe") {
1155            $ret = LJ::exml($ret);
1156        }
1157        elsif ($trans eq "lc") {
1158            $ret = lc($ret);
1159        }
1160        elsif ($trans eq "uc") {
1161            $ret = uc($ret);
1162        }
1163        elsif ($trans eq "color") {
1164            $ret = $vars->{"color-$attr"};
1165        }
1166        elsif ($trans eq "cons") {
1167            if ($attr eq "siteroot") { return $LJ::SITEROOT; }
1168            if ($attr eq "sitename") { return $LJ::SITENAME; }
1169            if ($attr eq "img") { return $LJ::IMGPREFIX; }
1170        }
1171    }
1172    return $ret;
1173}
1174
1175# <LJFUNC>
1176# name: LJ::get_mood_picture
1177# des: Loads a mood icon hashref given a themeid and moodid.
1178# args: themeid, moodid, ref
1179# des-themeid: Integer; mood themeid.
1180# des-moodid: Integer; mood id.
1181# des-ref: Hashref to load mood icon data into.
1182# returns: Boolean; 1 on success, 0 otherwise.
1183# </LJFUNC>
1184sub get_mood_picture
1185{
1186    my ($themeid, $moodid, $ref) = @_;
1187    do
1188    {
1189        if ($LJ::CACHE_MOOD_THEME{$themeid}->{$moodid}) {
1190            %{$ref} = %{$LJ::CACHE_MOOD_THEME{$themeid}->{$moodid}};
1191            if ($ref->{'pic'} =~ m!^/!) {
1192                $ref->{'pic'} =~ s!^/img!!;
1193                $ref->{'pic'} = $LJ::IMGPREFIX . $ref->{'pic'};
1194            }
1195            $ref->{'moodid'} = $moodid;
1196            return 1;
1197        } else {
1198            $moodid = $LJ::CACHE_MOODS{$moodid}->{'parent'};
1199        }
1200    }
1201    while ($moodid);
1202    return 0;
1203}
1204
1205
1206# <LJFUNC>
1207# class: s1
1208# name: LJ::prepare_currents
1209# des: do all the current music/mood/weather/whatever stuff.  only used by ljviews.pl.
1210# args: dbarg, args
1211# des-args: hashref with keys: 'props' (a hashref with itemid keys), 'vars' hashref with
1212#           keys being S1 variables.
1213# </LJFUNC>
1214sub prepare_currents
1215{
1216    my $dbarg = shift;
1217    my $args = shift;
1218
1219    my $dbs = LJ::make_dbs_from_arg($dbarg);
1220    my $datakey = $args->{'datakey'} || $args->{'itemid'}; # new || old
1221
1222    my %currents = ();
1223    my $val;
1224    if ($val = $args->{'props'}->{$datakey}->{'current_music'}) {
1225        $currents{'Music'} = $val;
1226    }
1227    if ($val = $args->{'props'}->{$datakey}->{'current_mood'}) {
1228        $currents{'Mood'} = $val;
1229    }
1230    if ($val = $args->{'props'}->{$datakey}->{'current_moodid'}) {
1231        my $theme = $args->{'user'}->{'moodthemeid'};
1232        LJ::load_mood_theme($dbs, $theme);
1233        my %pic;
1234        if (LJ::get_mood_picture($theme, $val, \%pic)) {
1235            $currents{'Mood'} = "<img src=\"$pic{'pic'}\" align='absmiddle' width='$pic{'w'}' ".
1236                "height='$pic{'h'}' vspace='1'> $LJ::CACHE_MOODS{$val}->{'name'}";
1237        } else {
1238            $currents{'Mood'} = $LJ::CACHE_MOODS{$val}->{'name'};
1239        }
1240    }
1241    if (%currents) {
1242        if ($args->{'vars'}->{$args->{'prefix'}.'_CURRENTS'})
1243        {
1244            ### PREFIX_CURRENTS is defined, so use the correct style vars
1245
1246            my $fvp = { 'currents' => "" };
1247            foreach (sort keys %currents) {
1248                $fvp->{'currents'} .= LJ::fill_var_props($args->{'vars'}, $args->{'prefix'}.'_CURRENT', {
1249                    'what' => $_,
1250                    'value' => $currents{$_},
1251                });
1252            }
1253            $args->{'event'}->{'currents'} =
1254                LJ::fill_var_props($args->{'vars'}, $args->{'prefix'}.'_CURRENTS', $fvp);
1255        } else
1256        {
1257            ### PREFIX_CURRENTS is not defined, so just add to %%events%%
1258            $args->{'event'}->{'event'} .= "<br />&nbsp;";
1259            foreach (sort keys %currents) {
1260                $args->{'event'}->{'event'} .= "<br /><b>Current $_</b>: " . $currents{$_} . "\n";
1261            }
1262        }
1263    }
1264}
1265
1266
1267# <LJFUNC>
1268# class: time
1269# name: LJ::http_to_time
1270# des: Converts HTTP date to Unix time.
1271# info: Wrapper around HTTP::Date::str2time.
1272#       See also [func[LJ::time_to_http]].
1273# args: string
1274# des-string: HTTP Date.  See RFC 2616 for format.
1275# returns: integer; Unix time.
1276# </LJFUNC>
1277sub http_to_time {
1278    my $string = shift;
1279    return HTTP::Date::str2time($string);
1280}
1281
1282# <LJFUNC>
1283# class: time
1284# name: LJ::time_to_http
1285# des: Converts a Unix time to an HTTP date.
1286# info: Wrapper around HTTP::Date::time2str to make an
1287#       HTTP date (RFC 1123 format)  See also [func[LJ::http_to_time]].
1288# args: time
1289# des-time: Integer; Unix time.
1290# returns: String; RFC 1123 date.
1291# </LJFUNC>
1292sub time_to_http {
1293    my $time = shift;
1294    return HTTP::Date::time2str($time);
1295}
1296
1297# <LJFUNC>
1298# class: component
1299# name: LJ::ljuser
1300# des: Make link to userinfo/journal of user.
1301# info: Returns the HTML for an userinfo/journal link pair for a given user
1302#       name, just like LJUSER does in BML.  But files like cleanhtml.pl
1303#       and ljpoll.pl need to do that too, but they aren't run as BML.
1304# args: user, opts?
1305# des-user: Username to link to.
1306# des-opts: Optional hashref to control output.  Currently only recognized key
1307#           is 'full' which when true causes a link to the mode=full userinfo.
1308# returns: HTML with a little head image & bold text link.
1309# </LJFUNC>
1310sub ljuser
1311{
1312    my $user = shift;
1313    my $opts = shift;
1314    my $andfull = $opts->{'full'} ? "&amp;mode=full" : "";
1315    return "<a href=\"$LJ::SITEROOT/userinfo.bml?user=$user$andfull\"><img src=\"$LJ::IMGPREFIX/userinfo.gif\" width=\"17\" height=\"17\" align=\"absmiddle\" border=\"0\"></a><b><a href=\"$LJ::SITEROOT/users/$user/\">$user</a></b>";
1316}
1317
1318# <LJFUNC>
1319# name: LJ::get_urls
1320# des: Returns a list of all referenced URLs from a string
1321# args: text
1322# des-text: Text to extra URLs from
1323# returns: list of URLs
1324# </LJFUNC>
1325sub get_urls
1326{
1327    my $text = shift;
1328    my @urls;
1329    while ($text =~ s!http://[^\s\"\'\<\>]+!!) {
1330        push @urls, $&;
1331    }
1332    return @urls;
1333}
1334
1335# <LJFUNC>
1336# name: LJ::record_meme
1337# des: Records a URL reference from a journal entry to the meme table.
1338# args: dbarg, url, posterid, itemid, journalid?
1339# des-url: URL to log
1340# des-posterid: Userid of person posting
1341# des-itemid: Itemid URL appears in.  For non-clustered users, this is just
1342#             the itemid.  For clustered users, this is the display itemid,
1343#             which is the jitemid*256+anum from the [dbtable[log2]] table.
1344# des-journalid: Optional, journal id of item, if item is clustered.  Otherwise
1345#                this should be zero or undef.
1346# </LJFUNC>
1347sub record_meme
1348{
1349    my ($dbarg, $url, $posterid, $itemid, $jid) = @_;
1350    my $dbs = LJ::make_dbs_from_arg($dbarg);
1351    my $dbh = $dbs->{'dbh'};
1352
1353    $url =~ s!/$!!;  # strip / at end
1354    LJ::run_hooks("canonicalize_url", \$url);
1355
1356    # canonicalize_url hook might just erase it, so
1357    # we don't want to record it.
1358    return unless $url;
1359
1360    my $qurl = $dbh->quote($url);
1361    $posterid += 0;
1362    $itemid += 0;
1363    $jid += 0;
1364    LJ::query_buffer_add($dbs, "meme",
1365                         "REPLACE INTO meme (url, posterid, journalid, itemid) " .
1366                         "VALUES ($qurl, $posterid, $jid, $itemid)");
1367}
1368
1369# <LJFUNC>
1370# name: LJ::name_caps
1371# des: Given a user's capability class bit mask, returns a
1372#      site-specific string representing the capability class name.
1373# args: caps
1374# des-caps: 16 bit capability bitmask
1375# </LJFUNC>
1376sub name_caps
1377{
1378    return undef unless LJ::are_hooks("name_caps");
1379    my $caps = shift;
1380    my @r = LJ::run_hooks("name_caps", $caps);
1381    return $r[0]->[0];
1382}
1383
1384# <LJFUNC>
1385# name: LJ::name_caps_short
1386# des: Given a user's capability class bit mask, returns a
1387#      site-specific short string code.
1388# args: caps
1389# des-caps: 16 bit capability bitmask
1390# </LJFUNC>
1391sub name_caps_short
1392{
1393    return undef unless LJ::are_hooks("name_caps_short");
1394    my $caps = shift;
1395    my @r = LJ::run_hooks("name_caps_short", $caps);
1396    return $r[0]->[0];
1397}
1398
1399# <LJFUNC>
1400# name: LJ::get_cap
1401# des: Given a user object or capability class bit mask and a capability/limit name,
1402#      returns the maximum value allowed for given user or class, considering
1403#      all the limits in each class the user is a part of.
1404# args: u_cap, capname
1405# des-u_cap: 16 bit capability bitmask or a user object from which the
1406#            bitmask could be obtained
1407# des-capname: the name of a limit, defined in doc/capabilities.txt
1408# </LJFUNC>
1409sub get_cap
1410{
1411    my $caps = shift;   # capability bitmask (16 bits), or user object
1412    my $cname = shift;  # capability limit name
1413    if (! defined $caps) { $caps = 0; }
1414    elsif (ref $caps eq "HASH") { $caps = $caps->{'caps'}; }
1415    my $max = undef;
1416    foreach my $bit (keys %LJ::CAP) {
1417        next unless ($caps & (1 << $bit));
1418        my $v = $LJ::CAP{$bit}->{$cname};
1419        next unless (defined $v);
1420        next if (defined $max && $max > $v);
1421        $max = $v;
1422    }
1423    return defined $max ? $max : $LJ::CAP_DEF{$cname};
1424}
1425
1426# <LJFUNC>
1427# name: LJ::get_cap_min
1428# des: Just like [func[LJ::get_cap]], but returns the minimum value.
1429#      Although it might not make sense at first, some things are
1430#      better when they're low, like the minimum amount of time
1431#      a user might have to wait between getting updates or being
1432#      allowed to refresh a page.
1433# args: u_cap, capname
1434# des-u_cap: 16 bit capability bitmask or a user object from which the
1435#            bitmask could be obtained
1436# des-capname: the name of a limit, defined in doc/capabilities.txt
1437# </LJFUNC>
1438sub get_cap_min
1439{
1440    my $caps = shift;   # capability bitmask (16 bits), or user object
1441    my $cname = shift;  # capability name
1442    if (! defined $caps) { $caps = 0; }
1443    elsif (ref $caps eq "HASH") { $caps = $caps->{'caps'}; }
1444    my $min = undef;
1445    foreach my $bit (keys %LJ::CAP) {
1446        next unless ($caps & (1 << $bit));
1447        my $v = $LJ::CAP{$bit}->{$cname};
1448        next unless (defined $v);
1449        next if (defined $min && $min < $v);
1450        $min = $v;
1451    }
1452    return defined $min ? $min : $LJ::CAP_DEF{$cname};
1453}
1454
1455# <LJFUNC>
1456# name: LJ::help_icon
1457# des: Returns BML to show a help link/icon given a help topic, or nothing
1458#      if the site hasn't defined a URL for that topic.  Optional arguments
1459#      include HTML/BML to place before and after the link/icon, should it
1460#      be returned.
1461# args: topic, pre?, post?
1462# des-topic: Help topic key.  See doc/ljconfig.pl.txt for examples.
1463# des-pre: HTML/BML to place before the help icon.
1464# des-post: HTML/BML to place after the help icon.
1465# </LJFUNC>
1466sub help_icon
1467{
1468    my $topic = shift;
1469    my $pre = shift;
1470    my $post = shift;
1471    return "" unless (defined $LJ::HELPURL{$topic});
1472    return "$pre(=HELP $LJ::HELPURL{$topic} HELP=)$post";
1473}
1474
1475# <LJFUNC>
1476# name: LJ::are_hooks
1477# des: Returns true if the site has one or more hooks installed for
1478#      the given hookname.
1479# args: hookname
1480# </LJFUNC>
1481sub are_hooks
1482{
1483    my $hookname = shift;
1484    return defined $LJ::HOOKS{$hookname};
1485}
1486
1487# <LJFUNC>
1488# name: LJ::clear_hooks
1489# des: Removes all hooks.
1490# </LJFUNC>
1491sub clear_hooks
1492{
1493    %LJ::HOOKS = ();
1494}
1495
1496# <LJFUNC>
1497# name: LJ::run_hooks
1498# des: Runs all the site-specific hooks of the given name.
1499# returns: list of arrayrefs, one for each hook ran, their
1500#          contents being their own return values.
1501# args: hookname, args*
1502# des-args: Arguments to be passed to hook.
1503# </LJFUNC>
1504sub run_hooks
1505{
1506    my $hookname = shift;
1507    my @args = shift;
1508    my @ret;
1509    foreach my $hook (@{$LJ::HOOKS{$hookname}}) {
1510        push @ret, [ $hook->(@args) ];
1511    }
1512    return @ret;
1513}
1514
1515# <LJFUNC>
1516# name: LJ::register_hook
1517# des: Installs a site-specific hook.
1518# info: Installing multiple hooks per hookname is valid.
1519#       They're run later in the order they're registered.
1520# args: hookname, subref
1521# des-subref: Subroutine reference to run later.
1522# </LJFUNC>
1523sub register_hook
1524{
1525    my $hookname = shift;
1526    my $subref = shift;
1527    push @{$LJ::HOOKS{$hookname}}, $subref;
1528}
1529
1530# <LJFUNC>
1531# name: LJ::make_auth_code
1532# des: Makes a random string of characters of a given length.
1533# returns: string of random characters, from an alphabet of 30
1534#          letters & numbers which aren't easily confused.
1535# args: length
1536# des-length: length of auth code to return
1537# </LJFUNC>
1538sub make_auth_code
1539{
1540    my $length = shift;
1541    my $digits = "abcdefghjkmnpqrstvwxyz23456789";
1542    my $auth;
1543    for (1..$length) { $auth .= substr($digits, int(rand(30)), 1); }
1544    return $auth;
1545}
1546
1547# <LJFUNC>
1548# name: LJ::acid_encode
1549# des: Given a decimal number, returns base 30 encoding
1550#      using an alphabet of letters & numbers that are
1551#      not easily mistaken for each other.
1552# returns: Base 30 encoding, alwyas 7 characters long.
1553# args: number
1554# des-number: Number to encode in base 30.
1555# </LJFUNC>
1556sub acid_encode
1557{
1558    my $num = shift;
1559    my $acid = "";
1560    my $digits = "abcdefghjkmnpqrstvwxyz23456789";
1561    while ($num) {
1562        my $dig = $num % 30;
1563        $acid = substr($digits, $dig, 1) . $acid;
1564        $num = ($num - $dig) / 30;
1565    }
1566    return ("a"x(7-length($acid)) . $acid);
1567}
1568
1569# <LJFUNC>
1570# name: LJ::acid_decode
1571# des: Given an acid encoding from [func[LJ::acid_encode]],
1572#      returns the original decimal number.
1573# returns: Integer.
1574# args: acid
1575# des-acid: base 30 number from [func[LJ::acid_encode]].
1576# </LJFUNC>
1577sub acid_decode
1578{
1579    my $acid = shift;
1580    $acid = lc($acid);
1581    my %val;
1582    my $digits = "abcdefghjkmnpqrstvwxyz23456789";
1583    for (0..30) { $val{substr($digits,$_,1)} = $_; }
1584    my $num = 0;
1585    my $place = 0;
1586    while ($acid) {
1587        return 0 unless ($acid =~ s/[$digits]$//o);
1588        $num += $val{$&} * (30 ** $place++);
1589    }
1590    return $num;
1591}
1592
1593# <LJFUNC>
1594# name: LJ::acct_code_generate
1595# des: Creates an invitation code from an optional userid
1596#      for use by anybody.
1597# returns: Account/Invite code.
1598# args: dbarg, userid?
1599# des-userid: Userid to make the invitation code from,
1600#             else the code will be from userid 0 (system)
1601# </LJFUNC>
1602sub acct_code_generate
1603{
1604    my $dbarg = shift;
1605    my $userid = shift;
1606
1607    my $dbs = LJ::make_dbs_from_arg($dbarg);
1608    my $dbh = $dbs->{'dbh'};
1609    my $auth = LJ::make_auth_code(5);
1610    $userid = int($userid);
1611    $dbh->do("INSERT INTO acctcode (acid, userid, rcptid, auth) ".
1612             "VALUES (NULL, $userid, 0, \"$auth\")");
1613    my $acid = $dbh->{'mysql_insertid'};
1614    return undef unless $acid;
1615    return acct_code_encode($acid, $auth);
1616}
1617
1618# <LJFUNC>
1619# name: LJ::acct_code_encode
1620# des: Given an account ID integer and a 5 digit auth code, returns
1621#      a 12 digit account code.
1622# returns: 12 digit account code.
1623# args: acid, auth
1624# des-acid: account ID, a 4 byte unsigned integer
1625# des-auth: 5 random characters from base 30 alphabet.
1626# </LJFUNC>
1627sub acct_code_encode
1628{
1629    my $acid = shift;
1630    my $auth = shift;
1631    return lc($auth) . acid_encode($acid);
1632}
1633
1634# <LJFUNC>
1635# name: LJ::acct_code_decode
1636# des: Breaks an account code down into its two parts
1637# returns: list of (account ID, auth code)
1638# args: code
1639# des-code: 12 digit account code
1640# </LJFUNC>
1641sub acct_code_decode
1642{
1643    my $code = shift;
1644    return (acid_decode(substr($code, 5, 7)), lc(substr($code, 0, 5)));
1645}
1646
1647# <LJFUNC>
1648# name: LJ::acct_code_check
1649# des: Checks the validity of a given account code
1650# returns: boolean; 0 on failure, 1 on validity. sets $$err on failure.
1651# args: dbarg, code, err?, userid?
1652# des-code: account code to check
1653# des-err: optional scalar ref to put error message into on failure
1654# des-userid: optional userid which is allowed in the rcptid field,
1655#             to allow for htdocs/create.bml case when people double
1656#             click the submit button.
1657# </LJFUNC>
1658sub acct_code_check
1659{
1660    my $dbarg = shift;
1661    my $code = shift;
1662    my $err = shift;     # optional; scalar ref
1663    my $userid = shift;  # optional; acceptable userid (double-click proof)
1664
1665    my $dbs = LJ::make_dbs_from_arg($dbarg);
1666    my $dbh = $dbs->{'dbh'};
1667    my $dbr = $dbs->{'reader'};
1668
1669    unless (length($code) == 12) {
1670        $$err = "Malformed code; not 12 characters.";
1671        return 0;
1672    }
1673
1674    my ($acid, $auth) = acct_code_decode($code);
1675
1676    # are we sure this is what the master has?  if we have a slave, could be behind.
1677    my $definitive = ! $dbs->{'has_slave'};
1678
1679    # try to load from slave
1680    my $ac = $dbr->selectrow_hashref("SELECT userid, rcptid, auth FROM acctcode WHERE acid=$acid");
1681
1682    # if we loaded something, and that code's used, it must be what master has
1683    if ($ac && $ac->{'rcptid'}) {
1684        $definitive = 1;
1685    }
1686
1687    # unless we're sure we have a clean record, load from master:
1688    unless ($definitive) {
1689        $ac = $dbh->selectrow_hashref("SELECT userid, rcptid, auth FROM acctcode WHERE acid=$acid");
1690    }
1691
1692    unless ($ac && $ac->{'auth'} eq $auth) {
1693        $$err = "Invalid account code.";
1694        return 0;
1695    }
1696
1697    if ($ac->{'rcptid'} && $ac->{'rcptid'} != $userid) {
1698        $$err = "This code has already been used.";
1699        return 0;
1700    }
1701
1702    # is the journal this code came from suspended?
1703    my $statusvis = LJ::dbs_selectrow_array($dbs, "SELECT statusvis FROM user ".
1704                                            "WHERE userid=$ac->{'userid'}");
1705    if ($statusvis eq "S") {
1706        $$err = "Code belongs to a suspended account.";
1707        return 0;
1708    }
1709
1710    return 1;
1711}
1712
1713# <LJFUNC>
1714# name: LJ::load_mood_theme
1715# des: Loads and caches a mood theme, or returns immediately if already loaded.
1716# args: dbarg, themeid
1717# des-themeid: the mood theme ID to load
1718# </LJFUNC>
1719sub load_mood_theme
1720{
1721    my $dbarg = shift;
1722    my $themeid = shift;
1723    return if ($LJ::CACHE_MOOD_THEME{$themeid});
1724
1725    my $dbs = make_dbs_from_arg($dbarg);
1726    my $dbr = $dbs->{'reader'};
1727
1728    $themeid += 0;
1729    my $sth = $dbr->prepare("SELECT moodid, picurl, width, height FROM moodthemedata WHERE moodthemeid=$themeid");
1730    $sth->execute;
1731    while (my ($id, $pic, $w, $h) = $sth->fetchrow_array) {
1732        $LJ::CACHE_MOOD_THEME{$themeid}->{$id} = { 'pic' => $pic, 'w' => $w, 'h' => $h };
1733    }
1734    $sth->finish;
1735}
1736
1737# <LJFUNC>
1738# name: LJ::load_props
1739# des: Loads and caches one or more of the various *proplist tables:
1740#      logproplist, talkproplist, and userproplist, which describe
1741#      the various meta-data that can be stored on log (journal) items,
1742#      comments, and users, respectively.
1743# args: dbarg, table*
1744# des-table: a list of tables' proplists to load.  can be one of
1745#            "log", "talk", or "user".
1746# </LJFUNC>
1747sub load_props
1748{
1749    my $dbarg = shift;
1750    my @tables = @_;
1751
1752    my $dbs = make_dbs_from_arg($dbarg);
1753    my $dbr = $dbs->{'reader'};
1754
1755    my %keyname = qw(log  propid
1756                     talk tpropid
1757                     user upropid);
1758
1759    foreach my $t (@tables) {
1760        next unless defined $keyname{$t};
1761        next if (defined $LJ::CACHE_PROP{$t});
1762        my $sth = $dbr->prepare("SELECT * FROM ${t}proplist");
1763        $sth->execute;
1764        while (my $p = $sth->fetchrow_hashref) {
1765            $p->{'id'} = $p->{$keyname{$t}};
1766            $LJ::CACHE_PROP{$t}->{$p->{'name'}} = $p;
1767            $LJ::CACHE_PROPID{$t}->{$p->{'id'}} = $p;
1768        }
1769        $sth->finish;
1770    }
1771}
1772
1773# <LJFUNC>
1774# name: LJ::get_prop
1775# des: This is used after [func[LJ::load_props]] is called to retrieve
1776#      a hashref of a row from the given tablename's proplist table.
1777#      One difference from getting it straight from the database is
1778#      that the 'id' key is always present, as a copy of the real
1779#      proplist unique id for that table.
1780# args: table, name
1781# returns: hashref of proplist row from db
1782# des-table: the tables to get a proplist hashref from.  can be one of
1783#            "log", "talk", or "user".
1784# des-name: the name of the prop to get the hashref of.
1785# </LJFUNC>
1786sub get_prop
1787{
1788    my $table = shift;
1789    my $name = shift;
1790    return 0 unless defined $LJ::CACHE_PROP{$table};
1791    return $LJ::CACHE_PROP{$table}->{$name};
1792}
1793
1794# <LJFUNC>
1795# name: LJ::load_codes
1796# des: Populates hashrefs with lookup data from the database or from memory,
1797#      if already loaded in the past.  Examples of such lookup data include
1798#      state codes, country codes, color name/value mappings, etc.
1799# args: dbarg, whatwhere
1800# des-whatwhere: a hashref with keys being the code types you want to load
1801#                and their associated values being hashrefs to where you
1802#                want that data to be populated.
1803# </LJFUNC>
1804sub load_codes
1805{
1806    my $dbarg = shift;
1807    my $req = shift;
1808
1809    my $dbs = make_dbs_from_arg($dbarg);
1810    my $dbh = $dbs->{'dbh'};
1811    my $dbr = $dbs->{'reader'};
1812
1813    foreach my $type (keys %{$req})
1814    {
1815        unless ($LJ::CACHE_CODES{$type})
1816        {
1817            $LJ::CACHE_CODES{$type} = [];
1818            my $qtype = $dbr->quote($type);
1819            my $sth = $dbr->prepare("SELECT code, item FROM codes WHERE type=$qtype ORDER BY sortorder");
1820            $sth->execute;
1821            while (my ($code, $item) = $sth->fetchrow_array)
1822            {
1823                push @{$LJ::CACHE_CODES{$type}}, [ $code, $item ];
1824            }
1825        }
1826
1827        foreach my $it (@{$LJ::CACHE_CODES{$type}})
1828        {
1829            if (ref $req->{$type} eq "HASH") {
1830                $req->{$type}->{$it->[0]} = $it->[1];
1831            } elsif (ref $req->{$type} eq "ARRAY") {
1832                push @{$req->{$type}}, { 'code' => $it->[0], 'item' => $it->[1] };
1833            }
1834        }
1835    }
1836}
1837
1838# <LJFUNC>
1839# name: LJ::img
1840# des: Returns an HTML &lt;img&gt; or &lt;input&gt; tag to an named image
1841#      code, which each site may define with a different image file with
1842#      its own dimensions.  This prevents hard-coding filenames & sizes
1843#      into the source.  The real image data is stored in LJ::Img, which
1844#      has default values provided in cgi-bin/imageconf.pl but can be
1845#      overridden in cgi-bin/ljconfig.pl.
1846# args: imagecode, type?, attrs?
1847# des-imagecode: The unique string key to reference the image.  Not a filename,
1848#                but the purpose or location of the image.
1849# des-type: By default, the tag returned is an &lt;img&gt; tag, but if 'type'
1850#           is "input", then an input tag is returned.
1851# des-attrs: Optional hashref of other attributes.  If this isn't a hashref,
1852#            then it's assumed to be a scalar for the 'name' attribute for
1853#            input controls.
1854# </LJFUNC>
1855sub img
1856{
1857    my $ic = shift;
1858    my $type = shift;  # either "" or "input"
1859    my $attr = shift;
1860
1861    my $attrs;
1862    if ($attr) {
1863        if (ref $attr eq "HASH") {
1864            foreach (keys %$attr) {
1865                $attrs .= " $_=\"" . LJ::ehtml($attr->{$_}) . "\"";
1866            }
1867        } else {
1868            $attrs = " name=\"$attr\"";
1869        }
1870    }
1871
1872    my $i = $LJ::Img::img{$ic};
1873    if ($type eq "") {
1874        return "<img src=\"$LJ::IMGPREFIX$i->{'src'}\" width=\"$i->{'width'}\" ".
1875            "height=\"$i->{'height'}\" alt=\"$i->{'alt'}\" border='0'$attrs>";
1876    }
1877    if ($type eq "input") {
1878        return "<input type=\"image\" src=\"$LJ::IMGPREFIX$i->{'src'}\" ".
1879            "width=\"$i->{'width'}\" height=\"$i->{'height'}\" ".
1880            "alt=\"$i->{'alt'}\" border='0'$attrs>";
1881    }
1882    return "<b>XXX</b>";
1883}
1884
1885# <LJFUNC>
1886# name: LJ::load_user_props
1887# des: Given a user hashref, loads the values of the given named properties
1888#      into that user hashref.
1889# args: dbarg, u, propname*
1890# des-propname: the name of a property from the userproplist table.
1891# </LJFUNC>
1892sub load_user_props
1893{
1894    my $dbarg = shift;
1895
1896    my $dbs = make_dbs_from_arg($dbarg);
1897    my $dbh = $dbs->{'dbh'};
1898    my $dbr = $dbs->{'reader'};
1899    my ($sql, $sth);
1900
1901    LJ::load_props($dbs, "user");
1902
1903    ## user reference
1904    my ($uref, @props) = @_;
1905    return unless ref $uref eq "HASH";  # example: undefined $remote
1906    my $uid = $uref->{'userid'}+0;
1907    $uid = LJ::get_userid($dbarg, $uref->{'user'}) unless $uid;
1908
1909    my %loadfrom;
1910    unless (@props) {
1911        # case 1: load all props for a given user.
1912        $loadfrom{'userprop'} = 1;
1913        $loadfrom{'userproplite'} = 1;
1914    } else {
1915        # case 2: load only certain things
1916        foreach (@props) {
1917            my $p = LJ::get_prop("user", $_);
1918            next unless $p;
1919            my $source = $p->{'indexed'} ? "userprop" : "userproplite";
1920            push @{$loadfrom{$source}}, $p->{'id'};
1921        }
1922    }
1923
1924    foreach my $table (keys %loadfrom) {
1925        $sql = "SELECT upropid, value FROM $table WHERE userid=$uid";
1926        if (ref $loadfrom{$table}) {
1927            $sql .= " AND upropid IN (" . join(",", @{$loadfrom{$table}}) . ")";
1928        }
1929        $sth = $dbr->prepare($sql);
1930        $sth->execute;
1931        while (my ($id, $v) = $sth->fetchrow_array) {
1932            $uref->{$LJ::CACHE_PROPID{'user'}->{$id}->{'name'}} = $v;
1933        }
1934    }
1935
1936    # Add defaults to user object.
1937
1938    # If this was called with no @props, then the function tried
1939    # to load all metadata.  but we don't know what's missing, so
1940    # try to apply all defaults.
1941    unless (@props) { @props = keys %LJ::USERPROP_DEF; }
1942
1943    foreach my $prop (@props) {
1944        next if (defined $uref->{$prop});
1945        $uref->{$prop} = $LJ::USERPROP_DEF{$prop};
1946    }
1947}
1948
1949# <LJFUNC>
1950# name: LJ::bad_input
1951# des: Returns common BML for reporting form validation errors in
1952#      a bulletted list.
1953# returns: BML showing errors.
1954# args: error*
1955# des-error: A list of errors
1956# </LJFUNC>
1957sub bad_input
1958{
1959    my @errors = @_;
1960    my $ret = "";
1961    $ret .= "(=BADCONTENT=)\n<ul>\n";
1962    foreach (@errors) {
1963        $ret .= "<li>$_</li>\n";
1964    }
1965    $ret .= "</ul>\n";
1966    return $ret;
1967}
1968
1969# <LJFUNC>
1970# name: LJ::debug
1971# des: When $LJ::DEBUG is set, logs the given message to
1972#      $LJ::VAR/debug.log.  Or, if $LJ::DEBUG is 2, then
1973#      prints to STDOUT.
1974# returns: 1 if logging disabled, 0 on failure to open log, 1 otherwise
1975# args: message
1976# des-message: Message to log.
1977# </LJFUNC>
1978sub debug
1979{
1980    return 1 unless ($LJ::DEBUG);
1981    if ($LJ::DEBUG == 2) {
1982        print $_[0], "\n";
1983        return 1;
1984    }
1985    open (L, ">>$LJ::VAR/debug.log") or return 0;
1986    print L scalar(time), ": $_[0]\n";
1987    close L;
1988    return 1;
1989}
1990
1991# <LJFUNC>
1992# name: LJ::auth_okay
1993# des: Validates a user's password.  The "clear" or "md5" argument
1994#      must be present, and either the "actual" argument (the correct
1995#      password) must be set, or the first argument must be a user
1996#      object ($u) with the 'password' key set.  Note that this is
1997#      the preferred way to validate a password (as opposed to doing
1998#      it by hand) since this function will use a pluggable authenticator
1999#      if one is defined, so LiveJournal installations can be based
2000#      off an LDAP server, for example.
2001# returns: boolean; 1 if authentication succeeded, 0 on failure
2002# args: user_u, clear, md5, actual?
2003# des-user_u: Either the user name or a user object.
2004# des-clear: Clear text password the client is sending. (need this or md5)
2005# des-md5: MD5 of the password the client is sending. (need this or clear).
2006#          If this value instead of clear, clear can be anything, as md5
2007#          validation will take precedence.
2008# des-actual: The actual password for the user.  Ignored if a pluggable
2009#             authenticator is being used.  Required unless the first
2010#             argument is a user object instead of a username scalar.
2011# </LJFUNC>
2012sub auth_okay
2013{
2014    my $user = shift;
2015    my $clear = shift;
2016    my $md5 = shift;
2017    my $actual = shift;
2018
2019    # first argument can be a user object instead of a string, in
2020    # which case the actual password (last argument) is got from the
2021    # user object.
2022    if (ref $user eq "HASH") {
2023        $actual = $user->{'password'};
2024        $user = $user->{'user'};
2025    }
2026
2027    ## custom authorization:
2028    if (ref $LJ::AUTH_CHECK eq "CODE") {
2029        my $type = $md5 ? "md5" : "clear";
2030        my $try = $md5 || $clear;
2031        return $LJ::AUTH_CHECK->($user, $try, $type);
2032    }
2033
2034    ## LJ default authorization:   
2035    return 0 unless $actual;
2036    return 1 if ($md5 && lc($md5) eq LJ::hash_password($actual));
2037    return 1 if ($clear eq $actual);
2038    return 0;
2039}
2040
2041# <LJFUNC>
2042# name: LJ::create_account
2043# des: Creates a new basic account.  <b>Note:</b> This function is
2044#      not really too useful but should be extended to be useful so
2045#      htdocs/create.bml can use it, rather than doing the work itself.
2046# returns: integer of userid created, or 0 on failure.
2047# args: dbarg, opts
2048# des-opts: hashref containing keys 'user', 'name', and 'password'
2049# </LJFUNC>
2050sub create_account
2051{
2052    my $dbarg = shift;
2053    my $o = shift;
2054
2055    my $dbs = make_dbs_from_arg($dbarg);
2056    my $dbh = $dbs->{'dbh'};
2057    my $dbr = $dbs->{'reader'};
2058
2059    my $user = LJ::canonical_username($o->{'user'});
2060    unless ($user)  {
2061        return 0;
2062    }
2063
2064    my $quser = $dbr->quote($user);
2065    my $qpassword = $dbr->quote($o->{'password'});
2066    my $qname = $dbr->quote($o->{'name'});
2067
2068    my $cluster = $LJ::DEFAULT_CLUSTER + 0;
2069
2070    my $sth = $dbh->prepare("INSERT INTO user (user, name, password, clusterid, dversion) ".
2071                            "VALUES ($quser, $qname, $qpassword, $cluster, 2)");
2072    $sth->execute;
2073    if ($dbh->err) { return 0; }
2074
2075    my $userid = $sth->{'mysql_insertid'};
2076    $dbh->do("INSERT INTO useridmap (userid, user) VALUES ($userid, $quser)");
2077    $dbh->do("INSERT INTO userusage (userid, timecreate) VALUES ($userid, NOW())");
2078
2079    LJ::run_hooks("post_create", {
2080        'dbs' => $dbs,
2081        'userid' => $userid,
2082        'user' => $user,
2083        'code' => undef,
2084    });
2085    return $userid;
2086}
2087
2088# <LJFUNC>
2089# name: LJ::is_friend
2090# des: Checks to see if a user is a friend of another user.
2091# returns: boolean; 1 if user B is a friend of user A or if A == B
2092# args: dbarg, usera, userb
2093# des-usera: Source user hashref or userid.
2094# des-userb: Destination user hashref or userid. (can be undef)
2095# </LJFUNC>
2096sub is_friend
2097{
2098    my $dbarg = shift;
2099    my $ua = shift;
2100    my $ub = shift;
2101
2102    my $uaid = (ref $ua ? $ua->{'userid'} : $ua)+0;
2103    my $ubid = (ref $ub ? $ub->{'userid'} : $ub)+0;
2104
2105    my $dbs = make_dbs_from_arg($dbarg);
2106    my $dbh = $dbs->{'dbh'};
2107    my $dbr = $dbs->{'reader'};
2108
2109    return 0 unless $uaid;
2110    return 0 unless $ubid;
2111    return 1 if ($uaid == $ubid);
2112
2113    my $sth = $dbr->prepare("SELECT COUNT(*) FROM friends WHERE ".
2114                            "userid=$uaid AND friendid=$ubid");
2115    $sth->execute;
2116    my ($is_friend) = $sth->fetchrow_array;
2117    $sth->finish;
2118    return $is_friend;
2119}
2120
2121# <LJFUNC>
2122# name: LJ::is_banned
2123# des: Checks to see if a user is banned from a journal.
2124# returns: boolean; 1 iff user B is banned from journal A
2125# args: dbarg, user, journal
2126# des-user: User hashref or userid.
2127# des-journal: Journal hashref or userid.
2128# </LJFUNC>
2129sub is_banned
2130{
2131    my $dbarg = shift;
2132    my $u = shift;
2133    my $j = shift;
2134
2135    my $uid = (ref $u ? $u->{'userid'} : $u)+0;
2136    my $jid = (ref $j ? $j->{'userid'} : $j)+0;
2137
2138    my $dbs = LJ::make_dbs_from_arg($dbarg);
2139    my $dbh = $dbs->{'dbh'};
2140    my $dbr = $dbs->{'reader'};
2141
2142    return 1 unless $uid;
2143    return 1 unless $jid;
2144
2145    # for speed: common case is non-community posting and replies
2146    # in own journal.  avoid db hit.
2147    return 0 if ($uid == $jid);
2148
2149    my $sth = $dbr->prepare("SELECT COUNT(*) FROM ban WHERE ".
2150                            "userid=$jid AND banneduserid=$uid");
2151    $sth->execute;
2152    my $is_banned = $sth->fetchrow_array;
2153    $sth->finish;
2154    return $is_banned;
2155}
2156
2157# <LJFUNC>
2158# name: LJ::can_view
2159# des: Checks to see if the remote user can view a given journal entry.
2160#      <b>Note:</b> This is meant for use on single entries at a time,
2161#      not for calling many times on every entry in a journal.
2162# returns: boolean; 1 if remote user can see item
2163# args: dbarg, remote, item
2164# des-item: Hashref from the 'log' table.
2165# </LJFUNC>
2166sub can_view
2167{
2168    my $dbarg = shift;
2169    my $remote = shift;
2170    my $item = shift;
2171
2172    # public is okay
2173    return 1 if ($item->{'security'} eq "public");
2174
2175    # must be logged in otherwise
2176    return 0 unless $remote;
2177
2178    my $userid = int($item->{'ownerid'});
2179    my $remoteid = int($remote->{'userid'});
2180
2181    # owners can always see their own.
2182    return 1 if ($userid == $remoteid);
2183
2184    # other people can't read private
2185    return 0 if ($item->{'security'} eq "private");
2186
2187    # should be 'usemask' security from here out, otherwise
2188    # assume it's something new and return 0
2189    return 0 unless ($item->{'security'} eq "usemask");
2190
2191    # usemask
2192    my $dbs = make_dbs_from_arg($dbarg);
2193    my $dbr = $dbs->{'reader'};
2194
2195    my $sth = $dbr->prepare("SELECT groupmask FROM friends WHERE ".
2196                            "userid=$userid AND friendid=$remoteid");
2197    $sth->execute;
2198    my ($gmask) = $sth->fetchrow_array;
2199    my $allowed = (int($gmask) & int($item->{'allowmask'}));
2200    return $allowed ? 1 : 0;  # no need to return matching mask
2201}
2202
2203# <LJFUNC>
2204# name: LJ::get_talktext
2205# des: Efficiently retrieves a large number of comments, trying first
2206#      slave database servers for recent items, then the master in
2207#      cases of old items the slaves have already disposed of.  See also:
2208#      [func[LJ::get_logtext]].
2209# args: dbs, opts?, talkid*
2210# returns: hashref with keys being talkids, values being [ $subject, $body ]
2211# des-opts: Optional hashref of flags.  Currently supported key: 'onlysubjects',
2212#           which won't return body text:  $body will be undef.
2213# des-talkid: List of talkids to retrieve the subject & text for.
2214# </LJFUNC>
2215sub get_talktext
2216{
2217    my $dbs = shift;
2218    my $opts = ref $_[0] eq "HASH" ? shift : {};
2219
2220    # return structure.
2221    my $lt = {};
2222
2223    # keep track of itemids we still need to load.
2224    my %need;
2225    foreach (@_) { $need{$_+0} = 1; }
2226
2227    # always consider hitting the master database, but if a slave is
2228    # available, hit that first.
2229    my @sources = ([$dbs->{'dbh'}, "talktext"]);
2230    if ($dbs->{'has_slave'}) {
2231        if ($LJ::USE_RECENT_TABLES) {
2232            my $dbt = LJ::get_dbh("recenttext");
2233            unshift @sources, [ $dbt || $dbs->{'dbr'}, "recent_talktext" ];
2234        } else {
2235            unshift @sources, [ $dbs->{'dbr'}, "talktext" ];
2236        }
2237    }
2238
2239    my $bodycol = $opts->{'onlysubjects'} ? "" : ", body";
2240
2241    while (@sources && %need)
2242    {
2243        my $s = shift @sources;
2244        my ($db, $table) = ($s->[0], $s->[1]);
2245        my $talkid_in = join(", ", keys %need);
2246
2247        my $sth = $db->prepare("SELECT talkid, subject $bodycol FROM $table ".
2248                               "WHERE talkid IN ($talkid_in)");
2249        $sth->execute;
2250        while (my ($id, $subject, $body) = $sth->fetchrow_array) {
2251            $lt->{$id} = [ $subject, $body ];
2252            delete $need{$id};
2253        }
2254    }
2255    return $lt;
2256}
2257
2258# <LJFUNC>
2259# name: LJ::get_logtext
2260# des: Efficiently retrieves a large number of journal entry text, trying first
2261#      slave database servers for recent items, then the master in
2262#      cases of old items the slaves have already disposed of.  See also:
2263#      [func[LJ::get_talktext]].
2264# args: dbs, opts?, itemid*
2265# des-opts: Optional hashref of special options.  Currently only 'prefersubjects'
2266#           key is supported, which returns subjects instead of events when
2267#           there's a subject, and the subject always being undef.
2268# des-itemid: List of itemids to retrieve the subject & text for.
2269# returns: hashref with keys being itemids, values being [ $subject, $body ]
2270# </LJFUNC>
2271sub get_logtext
2272{
2273    my $dbs = shift;
2274
2275    my $opts = ref $_[0] ? shift : {};
2276
2277    # return structure.
2278    my $lt = {};
2279
2280    # keep track of itemids we still need to load.
2281    my %need;
2282    foreach (@_) { $need{$_+0} = 1; }
2283
2284    # always consider hitting the master database, but if a slave is
2285    # available, hit that first.
2286    my @sources = ([$dbs->{'dbh'}, "logtext"]);
2287    if ($dbs->{'has_slave'} && ! $opts->{'usemaster'}) {
2288        if ($LJ::USE_RECENT_TABLES) {
2289            my $dbt = LJ::get_dbh("recenttext");
2290            unshift @sources, [ $dbt || $dbs->{'dbr'}, "recent_logtext" ];
2291        } else {
2292            unshift @sources, [ $dbs->{'dbr'}, "logtext" ];
2293        }
2294    }
2295
2296    my $snag_what = "subject, event";
2297    $snag_what = "NULL, IF(LENGTH(subject), subject, event)"
2298        if $opts->{'prefersubjects'};
2299
2300    while (@sources && %need)
2301    {
2302        my $s = shift @sources;
2303        my ($db, $table) = ($s->[0], $s->[1]);
2304        my $itemid_in = join(", ", keys %need);
2305
2306        my $sth = $db->prepare("SELECT itemid, $snag_what FROM $table ".
2307                               "WHERE itemid IN ($itemid_in)");
2308        $sth->execute;
2309        while (my ($id, $subject, $event) = $sth->fetchrow_array) {
2310            $lt->{$id} = [ $subject, $event ];
2311            delete $need{$id};
2312        }
2313    }
2314    return $lt;
2315}
2316
2317# <LJFUNC>
2318# name: LJ::get_logtext2
2319# des: Efficiently retrieves a large number of journal entry text, trying first
2320#      slave database servers for recent items, then the master in
2321#      cases of old items the slaves have already disposed of.  See also:
2322#      [func[LJ::get_talktext2]].
2323# args: u, opts?, jitemid*
2324# returns: hashref with keys being jitemids, values being [ $subject, $body ]
2325# des-opts: Optional hashref of special options.  Currently only 'prefersubjects'
2326#           key is supported, which returns subjects instead of events when
2327#           there's a subject, and the subject always being undef.
2328# des-jitemid: List of jitemids to retrieve the subject & text for.
2329# </LJFUNC>
2330sub get_logtext2
2331{
2332    my $u = shift;
2333    my $clusterid = $u->{'clusterid'};
2334    my $journalid = $u->{'userid'}+0;
2335
2336    my $opts = ref $_[0] ? shift : {};
2337
2338    # return structure.
2339    my $lt = {};
2340    return $lt unless $clusterid;
2341
2342    my $dbh = LJ::get_dbh("cluster$clusterid");
2343    my $dbr = $opts->{'usemaster'} ? undef : LJ::get_dbh("cluster${clusterid}slave");
2344
2345    # keep track of itemids we still need to load.
2346    my %need;
2347    foreach (@_) { $need{$_+0} = 1; }
2348
2349    # always consider hitting the master database, but if a slave is
2350    # available, hit that first.
2351    my @sources = ([$dbh, "logtext2"]);
2352    if ($dbr) {
2353        unshift @sources, [ $dbr, "logtext2" ];
2354    }
2355
2356    my $snag_what = "subject, event";
2357    $snag_what = "NULL, IF(LENGTH(subject), subject, event)"
2358        if $opts->{'prefersubjects'};
2359
2360    while (@sources && %need)
2361    {
2362        my $s = shift @sources;
2363        my ($db, $table) = ($s->[0], $s->[1]);
2364        next unless $db;
2365        my $jitemid_in = join(", ", keys %need);
2366
2367        my $sth = $db->prepare("SELECT jitemid, $snag_what FROM $table ".
2368                               "WHERE journalid=$journalid AND jitemid IN ($jitemid_in)");
2369        $sth->execute;
2370        while (my ($id, $subject, $event) = $sth->fetchrow_array) {
2371            $lt->{$id} = [ $subject, $event ];
2372            delete $need{$id};
2373        }
2374    }
2375    return $lt;
2376}
2377
2378# <LJFUNC>
2379# name: LJ::get_talktext2
2380# des: Retrieves comment text. Tries slave servers first, then master.
2381# info: Efficiently retreives batches of comment text. Will try alternate
2382#       servers first. See also [func[LJ::get_logtext2]].
2383# returns: Hashref with the talkids as keys, values being [ $subject, $event ].
2384# args: u, opts?, jtalkids
2385# des-opts: A hashref of options. 'usermaster' will force checking of the
2386#           master only.
2387# des-jtalkids: A list of talkids to get text for.
2388# </LJFUNC>
2389sub get_talktext2
2390{
2391    my $u = shift;
2392    my $clusterid = $u->{'clusterid'};
2393    my $journalid = $u->{'userid'}+0;
2394
2395    my $opts = ref $_[0] ? shift : {};
2396
2397    # return structure.
2398    my $lt = {};
2399    return $lt unless $clusterid;
2400
2401    my $dbh = LJ::get_dbh("cluster$clusterid");
2402    my $dbr = $opts->{'usemaster'} ? undef : LJ::get_dbh("cluster${clusterid}slave");
2403
2404    # keep track of itemids we still need to load.
2405    my %need;
2406    foreach (@_) { $need{$_+0} = 1; }
2407
2408    # always consider hitting the master database, but if a slave is
2409    # available, hit that first.
2410    my @sources = ([$dbh, "talktext2"]);
2411    if ($dbr) {
2412        unshift @sources, [ $dbr, "talktext2" ];
2413    }
2414
2415    while (@sources && %need)
2416    {
2417        my $s = shift @sources;
2418        my ($db, $table) = ($s->[0], $s->[1]);
2419        my $in = join(", ", keys %need);
2420
2421        my $sth = $db->prepare("SELECT jtalkid, subject, body FROM $table ".
2422                               "WHERE journalid=$journalid AND jtalkid IN ($in)");
2423        $sth->execute;
2424        while (my ($id, $subject, $event) = $sth->fetchrow_array) {
2425            $lt->{$id} = [ $subject, $event ];
2426            delete $need{$id};
2427        }
2428    }
2429    return $lt;
2430}
2431
2432# <LJFUNC>
2433# name: LJ::get_logtext2multi
2434# des: Gets log text from clusters.
2435# info: Fetches log text from clusters. Trying slaves first if available.
2436# returns: hashref with keys being "jid jitemid", values being [ $subject, $body ]
2437# args: idsbyc
2438# des-idsbyc: A hashref where the key is the clusterid, and the data
2439#             is an arrayref of [ ownerid, itemid ] array references.
2440# </LJFUNC>
2441sub get_logtext2multi
2442{
2443    my ($dbs, $idsbyc) = @_;
2444    my $sth;
2445
2446    # return structure.
2447    my $lt = {};
2448
2449    # keep track of itemids we still need to load per cluster
2450    my %need;
2451    my @needold;
2452    foreach my $c (keys %$idsbyc) {
2453        foreach (@{$idsbyc->{$c}}) {
2454            if ($c) {
2455                $need{$c}->{"$_->[0] $_->[1]"} = 1;
2456            } else {
2457                push @needold, $_+0;
2458            }
2459        }
2460    }
2461
2462    # don't handle non-cluster stuff ourselves
2463    if (@needold)
2464    {
2465        my $olt = LJ::get_logtext($dbs, @needold);
2466        foreach (keys %$olt) {
2467            $lt->{"0 $_"} = $olt->{$_};
2468        }
2469    }
2470
2471    # pass 1: slave (trying recent), pass 2: master
2472    foreach my $pass (1, 2)
2473    {
2474        foreach my $c (keys %need)
2475        {
2476            next unless keys %{$need{$c}};
2477            my $table = "logtext2";
2478            my $db = $pass == 1 ? LJ::get_dbh("cluster${c}slave") :
2479                LJ::get_dbh("cluster${c}");
2480            next unless $db;
2481
2482            my $fattyin;
2483            foreach (keys %{$need{$c}}) {
2484                $fattyin .= " OR " if $fattyin;
2485                my ($a, $b) = split(/ /, $_);
2486                $fattyin .= "(journalid=$a AND jitemid=$b)";
2487            }
2488
2489            $sth = $db->prepare("SELECT journalid, jitemid, subject, event ".
2490                                "FROM $table WHERE $fattyin");
2491            $sth->execute;
2492            while (my ($jid, $jitemid, $subject, $event) = $sth->fetchrow_array) {
2493                delete $need{$c}->{"$jid $jitemid"};
2494                $lt->{"$jid $jitemid"} = [ $subject, $event ];
2495            }
2496        }
2497    }
2498
2499    return $lt;
2500}
2501
2502# <LJFUNC>
2503# name: LJ::make_text_link
2504# des: The most pathetic function of them all.  AOL's shitty mail
2505#      reader interprets all incoming mail as HTML formatted, even if
2506#      the content type says otherwise.  And AOL users are all too often
2507#      confused by a a URL that isn't clickable, so to make it easier on
2508#      them (*sigh*) this function takes a URL and an email address, and
2509#      if the address is @aol.com, then this function wraps the URL in
2510#      an anchor tag to its own address.  I'm sorry.
2511# returns: the same URL, or the URL wrapped in an anchor tag for AOLers
2512# args: url, email
2513# des-url: URL to return or wrap.
2514# des-email: Email address this is going to.  If it's @aol.com, the URL
2515#            will be wrapped.
2516# </LJFUNC>
2517sub make_text_link
2518{
2519    my ($url, $email) = @_;
2520    if ($email =~ /\@aol\.com$/i) {
2521        return "<a href=\"$url\">$url</a>";
2522    }
2523    return $url;
2524}
2525
2526# <LJFUNC>
2527# name: LJ::get_remote
2528# des: authenticates the user at the remote end based on their cookies
2529#      and returns a hashref representing them
2530# returns: hashref containing 'user' and 'userid' if valid user, else
2531#          undef.
2532# args: dbarg, criterr?, cgi?
2533# des-criterr: scalar ref to set critical error flag.  if set, caller
2534#              should stop processing whatever it's doing and complain
2535#              about an invalid login with a link to the logout page.
2536# des-cgi: Optional CGI.pm reference if using in a script which
2537#          already uses CGI.pm.
2538# </LJFUNC>
2539sub get_remote
2540{
2541    my $dbarg = shift;
2542    my $criterr = shift;
2543    my $cgi = shift;
2544
2545    my $dbs = make_dbs_from_arg($dbarg);
2546    my $dbh = $dbs->{'dbh'};
2547    my $dbr = $dbs->{'reader'};
2548
2549    $$criterr = 0;
2550
2551    my $cookie = sub {
2552        return $cgi ? $cgi->cookie($_[0]) : $BMLClient::COOKIE{$_[0]};
2553    };
2554
2555    my ($user, $userid, $caps);
2556
2557    my $validate = sub {
2558        my $a = shift;
2559        # let hooks reject credentials, or set criterr true:
2560        my $hookparam = {
2561            'user' => $a->{'user'},
2562            'userid' => $a->{'userid'},
2563            'dbs' => $dbs,
2564            'caps' => $a->{'caps'},
2565            'criterr' => $criterr,
2566            'cookiesource' => $cookie,
2567        };
2568        my @r = LJ::run_hooks("validate_get_remote", $hookparam);
2569        return undef if grep { ! $_->[0] } @r;
2570        return 1;
2571    };
2572
2573    ### are they logged in?
2574    unless ($user = $cookie->('ljuser')) {
2575        $validate->();
2576        return undef;
2577    }
2578
2579    ### does their login password match their login?
2580    my $hpass = $cookie->('ljhpass');
2581    unless ($hpass =~ /^$user:(.+)/) {
2582        $validate->();
2583        return undef;
2584    }
2585    my $remhpass = $1;
2586    my $correctpass;     # find this out later.
2587
2588    unless (ref $LJ::AUTH_CHECK eq "CODE") {
2589        my $quser = $dbr->quote($user);
2590        ($userid, $correctpass, $caps) =
2591            $dbr->selectrow_array("SELECT userid, password, caps ".
2592                                  "FROM user WHERE user=$quser");
2593
2594        # each handler must return true, else credentials are ignored:
2595        return undef unless $validate->({
2596            'userid' => $userid,
2597            'user' => $user,
2598            'caps' => $caps,
2599        });
2600
2601    } else {
2602        $userid = LJ::get_userid($dbh, $user);
2603    }
2604
2605    unless ($userid && LJ::auth_okay($user, undef, $remhpass, $correctpass)) {
2606        $validate->();
2607        return undef;
2608    }
2609
2610    return { 'user' => $user,
2611             'userid' => $userid, };
2612}
2613
2614# <LJFUNC>
2615# name: LJ::load_remote
2616# des: Given a partial remote user hashref (from [func[LJ::get_remote]]),
2617#      loads in the rest, unless it's already loaded.
2618# args: dbarg, remote
2619# des-remote: Hashref containing 'user' and 'userid' keys at least.  This
2620#             hashref will be populated with the rest of the 'user' table
2621#             data.  If undef, does nothing.
2622# </LJFUNC>
2623sub load_remote
2624{
2625    my $dbarg = shift;
2626    my $dbs = LJ::get_dbs();
2627    my $dbh = $dbs->{'dbh'};
2628    my $dbr = $dbs->{'reader'};
2629
2630    my $remote = shift;
2631    return unless $remote;
2632
2633    # if all three of these are loaded, this hashref is probably full.
2634    # (don't want to just test for 2 keys, since keys like '_priv' and
2635    # _privloaded might be present)
2636    return if (defined $remote->{'email'} &&
2637               defined $remote->{'caps'} &&
2638               defined $remote->{'status'});
2639
2640    # try to load this remote user's record
2641    my $ru = LJ::load_userid($dbs, $remote->{'userid'});
2642    return unless $ru;
2643
2644    # merge user record (so we preserve underscore key data structures)
2645    foreach my $k (keys %$ru) {
2646        $remote->{$k} = $ru->{$k};
2647    }
2648}
2649
2650# <LJFUNC>
2651# name: LJ::get_remote_noauth
2652# des: returns who the remote user says they are, but doesn't check
2653#      their login token.  disadvantage: insecure, only use when
2654#      you're not doing anything critical.  advantage:  faster.
2655# returns: hashref containing only key 'user', not 'userid' like
2656#          [func[LJ::get_remote]].
2657# </LJFUNC>
2658sub get_remote_noauth
2659{
2660    ### are they logged in?
2661    my $remuser = $BMLClient::COOKIE{"ljuser"};
2662    return undef unless ($remuser =~ /^\w{1,15}$/);
2663
2664    ### does their login password match their login?
2665    return undef unless ($BMLClient::COOKIE{"ljhpass"} =~ /^$remuser:(.+)/);
2666    return { 'user' => $remuser, };
2667}
2668
2669# <LJFUNC>
2670# name: LJ::did_post
2671# des: When web pages using cookie authentication, you can't just trust that
2672#      the remote user wants to do the action they're requesting.  It's way too
2673#      easy for people to force other people into making GET requests to
2674#      a server.  What if a user requested http://server/delete_all_journal.bml
2675#      and that URL checked the remote user and immediately deleted the whole
2676#      journal.  Now anybody has to do is embed that address in an image
2677#      tag and a lot of people's journals will be deleted without them knowing.
2678#      Cookies should only show pages which make no action.  When an action is
2679#      being made, check that it's a POST request.
2680# returns: true if REQUEST_METHOD == "POST"
2681# </LJFUNC>
2682sub did_post
2683{
2684    return ($ENV{'REQUEST_METHOD'} eq "POST");
2685}
2686
2687# <LJFUNC>
2688# name: LJ::clear_caches
2689# des: This function is called from a HUP signal handler and is intentionally
2690#      very very simple (1 line) so we don't core dump on a system without
2691#      reentrant libraries.  It just sets a flag to clear the caches at the
2692#      beginning of the next request (see [func[LJ::handle_caches]]).
2693#      There should be no need to ever call this function directly.
2694# </LJFUNC>
2695sub clear_caches
2696{
2697    $LJ::CLEAR_CACHES = 1;
2698}
2699
2700# <LJFUNC>
2701# name: LJ::handle_caches
2702# des: clears caches if the CLEAR_CACHES flag is set from an earlier
2703#      HUP signal that called [func[LJ::clear_caches]], otherwise
2704#      does nothing.
2705# returns: true (always) so you can use it in a conjunction of
2706#          statements in a while loop around the application like:
2707#          while (LJ::handle_caches() && FCGI::accept())
2708# </LJFUNC>
2709sub handle_caches
2710{
2711    return 1 unless ($LJ::CLEAR_CACHES);
2712    $LJ::CLEAR_CACHES = 0;
2713
2714    do "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
2715
2716    foreach (keys %LJ::DBCACHE) {
2717        my $v = $LJ::DBCACHE{$_};
2718        next unless ref $v;
2719        $v->disconnect;
2720    }
2721    %LJ::DBCACHE = ();
2722
2723    %LJ::CACHE_PROP = ();
2724    %LJ::CACHE_STYLE = ();
2725    $LJ::CACHED_MOODS = 0;
2726    $LJ::CACHED_MOOD_MAX = 0;
2727    %LJ::CACHE_MOODS = ();
2728    %LJ::CACHE_MOOD_THEME = ();
2729    %LJ::CACHE_USERID = ();
2730    %LJ::CACHE_USERNAME = ();
2731    %LJ::CACHE_USERPIC_SIZE = ();
2732    %LJ::CACHE_CODES = ();
2733    %LJ::CACHE_USERPROP = ();  # {$prop}->{ 'upropid' => ... , 'indexed' => 0|1 };
2734    %LJ::CACHE_ENCODINGS = ();
2735    return 1;
2736}
2737
2738# <LJFUNC>
2739# name: LJ::start_request
2740# des: Before a new web request is obtained, this should be called to
2741#      determine if process should die or keep working, clean caches,
2742#      reload config files, etc.
2743# returns: 1 if a new request is to be processed, 0 if process should die.
2744# </LJFUNC>
2745sub start_request
2746{
2747    handle_caches();
2748    # TODO: check process growth size
2749    # TODO: auto-restat and reload ljconfig.pl if changed.
2750
2751    # clear %LJ::DBREQCACHE (like DBCACHE, but verified already for
2752    # this request to be ->ping'able).
2753    %LJ::DBREQCACHE = ();
2754
2755    # need to suck db weights down on every request (we check
2756    # the serial number of last db weight change on every request
2757    # to validate master db connection, instead of selecting
2758    # the connection ID... just as fast, but with a point!)
2759    if ($LJ::DBWEIGHTS_FROM_DB) {  # defined in ljconfig.pl
2760        $LJ::NEED_DBWEIGHTS = 1;
2761    }
2762
2763    return 1;
2764}
2765
2766# <LJFUNC>
2767# name: LJ::load_userpics
2768# des: Loads a bunch of userpic at once.
2769# args: dbarg, upics, idlist
2770# des-upics: hashref to load pictures into, keys being the picids
2771# des-idlist: arrayref of picids to load
2772# </LJFUNC>
2773sub load_userpics
2774{
2775    my ($dbarg, $upics, $idlist) = @_;
2776
2777    my $dbs = make_dbs_from_arg($dbarg);
2778    my $dbh = $dbs->{'dbh'};
2779    my $dbr = $dbs->{'reader'};
2780
2781    my @load_list;
2782    foreach my $id (@{$idlist})
2783    {
2784        if ($LJ::CACHE_USERPIC_SIZE{$id}) {
2785            $upics->{$id}->{'width'} = $LJ::CACHE_USERPIC_SIZE{$id}->{'width'};
2786            $upics->{$id}->{'height'} = $LJ::CACHE_USERPIC_SIZE{$id}->{'height'};
2787        } elsif ($id+0) {
2788            push @load_list, ($id+0);
2789        }
2790    }
2791    return unless (@load_list);
2792    my $picid_in = join(",", @load_list);
2793    my $sth = $dbr->prepare("SELECT picid, width, height FROM userpic WHERE picid IN ($picid_in)");
2794    $sth->execute;
2795    while ($_ = $sth->fetchrow_hashref) {
2796        my $id = $_->{'picid'};
2797        undef $_->{'picid'};
2798        $upics->{$id} = $_;
2799        $LJ::CACHE_USERPIC_SIZE{$id}->{'width'} = $_->{'width'};
2800        $LJ::CACHE_USERPIC_SIZE{$id}->{'height'} = $_->{'height'};
2801    }
2802}
2803
2804# <LJFUNC>
2805# name: LJ::send_mail
2806# des: Sends email.
2807# args: opt
2808# des-opt: Hashref of arguments.  <b>Required:</b> to, from, subject, body.
2809#          <b>Optional:</b> toname, fromname, cc, bcc
2810# </LJFUNC>
2811sub send_mail
2812{
2813    my $opt = shift;
2814    open (MAIL, "|$LJ::SENDMAIL");
2815    my $toname;
2816    if ($opt->{'toname'}) {
2817        $opt->{'toname'} =~ s/[\n\t\(\)]//g;
2818        $toname = " ($opt->{'toname'})";
2819    }
2820    print MAIL "To: $opt->{'to'}$toname\n";
2821    print MAIL "Cc: $opt->{'bcc'}\n" if ($opt->{'cc'});
2822    print MAIL "Bcc: $opt->{'bcc'}\n" if ($opt->{'bcc'});
2823    print MAIL "From: $opt->{'from'}";
2824    if ($opt->{'fromname'}) {
2825        print MAIL " ($opt->{'fromname'})";
2826    }
2827    print MAIL "\nSubject: $opt->{'subject'}\n\n";
2828    print MAIL $opt->{'body'};
2829    close MAIL;
2830}
2831
2832# <LJFUNC>
2833# name: LJ::strip_bad_code
2834# class: security
2835# des: Removes malicious/annoying HTML.
2836# info: This is just a wrapper function around [func[LJ::CleanHTML::clean]].
2837# args: textref
2838# des-textref: Scalar reference to text to be cleaned.
2839# returns: Nothing.
2840# </LJFUNC>
2841sub strip_bad_code
2842{
2843    my $data = shift;
2844    LJ::CleanHTML::clean($data, {
2845        'eat' => [qw[layer iframe script]],
2846        'mode' => 'allow',
2847        'keepcomments' => 1, # Allows CSS to work
2848    });
2849}
2850
2851# <LJFUNC>
2852# name: LJ::load_user_theme
2853# des: Populates a variable hash with color theme data.
2854# returns: Nothing. Modifies a hash reference.
2855# args: user, u, vars
2856# des-user: The username to search for data with.
2857# des-vars: A hashref to fill with color data. Adds keys "color-$coltype"
2858#           with values $color.
2859# </LJFUNC>
2860sub load_user_theme
2861{
2862    # hashref, hashref
2863    my ($dbarg, $user, $u, $vars) = @_;
2864
2865    my $dbs = make_dbs_from_arg($dbarg);
2866    my $dbh = $dbs->{'dbh'};
2867    my $dbr = $dbs->{'reader'};
2868
2869    my $sth;
2870    my $quser = $dbh->quote($user);
2871
2872    if ($u->{'themeid'} == 0) {
2873        $sth = $dbr->prepare("SELECT coltype, color FROM themecustom WHERE user=$quser");
2874    } else {
2875        my $qtid = $dbh->quote($u->{'themeid'});
2876        $sth = $dbr->prepare("SELECT coltype, color FROM themedata WHERE themeid=$qtid");
2877    }
2878    $sth->execute;
2879    $vars->{"color-$_->{'coltype'}"} = $_->{'color'} while ($_ = $sth->fetchrow_hashref);
2880}
2881
2882# <LJFUNC>
2883# class: s1
2884# name: LJ::parse_vars
2885# des: Parses S1 style data into hashref.
2886# returns: Nothing.  Modifies a hashref.
2887# args: dataref, hashref
2888# des-dataref: Reference to scalar with data to parse. Format is
2889#              a BML-style full block, as used in the S1 style system.
2890# des-hashref: Hashref to populate with data.
2891# </LJFUNC>
2892sub parse_vars
2893{
2894    my ($dataref, $hashref) = @_;
2895    my @data = split(/\n/, $$dataref);
2896    my $curitem = "";
2897
2898    foreach (@data)
2899    {
2900        $_ .= "\n";
2901        s/\r//g;
2902        if ($curitem eq "" && /^([A-Z0-9\_]+)=>([^\n\r]*)/)
2903        {
2904            $hashref->{$1} = $2;
2905        }
2906        elsif ($curitem eq "" && /^([A-Z0-9\_]+)<=\s*$/)
2907        {
2908            $curitem = $1;
2909            $hashref->{$curitem} = "";
2910        }
2911        elsif ($curitem && /^<=$curitem\s*$/)
2912        {
2913            chop $hashref->{$curitem};  # remove the false newline
2914            $curitem = "";
2915        }
2916        else
2917        {
2918            $hashref->{$curitem} .= $_ if ($curitem =~ /\S/);
2919        }
2920    }
2921}
2922
2923# <LJFUNC>
2924# name: LJ::server_down_html
2925# des: Returns an HTML server down message.
2926# returns: A string with a server down message in HTML.
2927# </LJFUNC>
2928sub server_down_html
2929{
2930    return "<b>$LJ::SERVER_DOWN_SUBJECT</b><br />$LJ::SERVER_DOWN_MESSAGE";
2931}
2932
2933# <LJFUNC>
2934# class: s1
2935# name: LJ::load_style_fast
2936# des: Loads a style, and does minimal caching (data sticks for 60 seconds).
2937# returns: Nothing. Modifies a data reference.
2938# args: styleid, dataref, typeref, nocache?
2939# des-styleid: Numeric, primary key.
2940# des-dataref: Dataref to store data in.
2941# des-typeref: Optional dataref to store the style tyep in (undef for none).
2942# des-nocache: Flag to say don't cache.
2943# </LJFUNC>
2944sub load_style_fast
2945{
2946    my ($dbarg, $styleid, $dataref, $typeref, $nocache) = @_;
2947
2948    my $dbs = make_dbs_from_arg($dbarg);
2949    my $dbh = $dbs->{'dbh'};
2950    my $dbr = $dbs->{'reader'};
2951
2952    $styleid += 0;
2953    my $now = time();
2954
2955    if ((defined $LJ::CACHE_STYLE{$styleid}) &&
2956        ($LJ::CACHE_STYLE{$styleid}->{'lastpull'} > ($now-300)) &&
2957        (! $nocache)
2958        )
2959    {
2960        $$dataref = $LJ::CACHE_STYLE{$styleid}->{'data'};
2961        if (ref $typeref eq "SCALAR") { $$typeref = $LJ::CACHE_STYLE{$styleid}->{'type'}; }
2962    }
2963    else
2964    {
2965        my @h = ($dbh);
2966        if ($dbs->{'has_slave'}) {
2967            unshift @h, $dbr;
2968        }
2969        my ($data, $type, $cache);
2970        my $sth;
2971        foreach my $db (@h)
2972        {
2973            $sth = $dbr->prepare("SELECT formatdata, type, opt_cache FROM style WHERE styleid=$styleid");
2974            $sth->execute;
2975            ($data, $type, $cache) = $sth->fetchrow_array;
2976            $sth->finish;
2977            last if ($data);
2978        }
2979        if ($cache eq "Y") {
2980            $LJ::CACHE_STYLE{$styleid} = { 'lastpull' => $now,
2981                                       'data' => $data,
2982                                       'type' => $type,
2983                                   };
2984        }
2985
2986        $$dataref = $data;
2987        if (ref $typeref eq "SCALAR") { $$typeref = $type; }
2988    }
2989}
2990
2991# <LJFUNC>
2992# name: LJ::make_journal
2993# class:
2994# des:
2995# info:
2996# args: dbarg, user, view, remote, opts
2997# des-:
2998# returns:
2999# </LJFUNC>
3000sub make_journal
3001{
3002    my ($dbarg, $user, $view, $remote, $opts) = @_;
3003
3004    my $dbs = LJ::make_dbs_from_arg($dbarg);
3005    my $dbh = $dbs->{'dbh'};
3006    my $dbr = $dbs->{'reader'};
3007
3008    if ($LJ::SERVER_DOWN) {
3009        if ($opts->{'vhost'} eq "customview") {
3010            return "<!-- LJ down for maintenance -->";
3011        }
3012        return LJ::server_down_html();
3013    }
3014
3015    my ($styleid);
3016    if ($opts->{'styleid'}) {
3017        $styleid = $opts->{'styleid'}+0;
3018    } else {
3019        $view ||= "lastn";    # default view when none specified explicitly in URLs
3020        if ($LJ::viewinfo{$view})  {
3021            $styleid = -1;    # to get past the return, then checked later for -1 and fixed, once user is loaded.
3022            $view = $view;
3023        } else {
3024            $opts->{'badargs'} = 1;
3025        }
3026    }
3027    return unless ($styleid);
3028
3029    my $quser = $dbh->quote($user);
3030    my $u;
3031    if ($opts->{'u'}) {
3032        $u = $opts->{'u'};
3033    } else {
3034        $u = LJ::load_user($dbs, $user);
3035    }
3036
3037    unless ($u)
3038    {
3039        $opts->{'baduser'} = 1;
3040        return "<H1>Error</H1>No such user <B>$user</B>";
3041    }
3042
3043    if ($styleid == -1) {
3044        if ($u->{"${view}_style"}) {
3045            # NOTE: old schema.  only here to make transition easier.  remove later.
3046            $styleid = $u->{"${view}_style"};
3047        } else {
3048            my $prop = "s1_${view}_style";
3049            unless (defined $u->{$prop}) {
3050              LJ::load_user_props($dbs, $u, $prop);
3051            }
3052            $styleid = $u->{$prop};
3053        }
3054    }
3055
3056    if ($LJ::USER_VHOSTS && $opts->{'vhost'} eq "users" && ! LJ::get_cap($u, "userdomain")) {
3057        return "<b>Notice</b><br />Addresses like <tt>http://<i>username</i>.$LJ::USER_DOMAIN</tt> aren't enabled for this user's account type.  Instead, visit:<ul><font face=\"Verdana,Arial\"><b><a href=\"$LJ::SITEROOT/users/$user/\">$LJ::SITEROOT/users/$user/</a></b></font></ul>";
3058    }
3059    if ($opts->{'vhost'} eq "customview" && ! LJ::get_cap($u, "userdomain")) {
3060        return "<b>Notice</b><br />Only users with <A HREF=\"$LJ::SITEROOT/paidaccounts/\">paid accounts</A> can create and embed styles.";
3061    }
3062    if ($opts->{'vhost'} eq "community" && $u->{'journaltype'} ne "C") {
3063        return "<b>Notice</b><br />This account isn't a community journal.";
3064    }
3065
3066    return "<h1>Error</h1>Journal has been deleted.  If you are <B>$user</B>, you have a period of 30 days to decide to undelete your journal." if ($u->{'statusvis'} eq "D");
3067    return "<h1>Error</h1>This journal has been suspended." if ($u->{'statusvis'} eq "S");
3068    return "<h1>Error</h1>This journal has been deleted and purged.  This username will be available shortly." if ($u->{'statusvis'} eq "X");
3069
3070    my %vars = ();
3071    # load the base style
3072    my $basevars = "";
3073    LJ::load_style_fast($dbs, $styleid, \$basevars, \$view)
3074        unless ($LJ::viewinfo{$view}->{'nostyle'});
3075
3076    # load the overrides
3077    my $overrides = "";
3078    if ($opts->{'nooverride'}==0 && $u->{'useoverrides'} eq "Y")
3079    {
3080        my $sth = $dbr->prepare("SELECT override FROM overrides WHERE user=$quser");
3081        $sth->execute;
3082        ($overrides) = $sth->fetchrow_array;
3083        $sth->finish;
3084    }
3085
3086    # populate the variable hash
3087    LJ::parse_vars(\$basevars, \%vars);
3088    LJ::parse_vars(\$overrides, \%vars);
3089    LJ::load_user_theme($dbs, $user, $u, \%vars);
3090
3091    # kinda free some memory
3092    $basevars = "";
3093    $overrides = "";
3094
3095    # instruct some function to make this specific view type
3096    return unless (defined $LJ::viewinfo{$view}->{'creator'});
3097    my $ret = "";
3098
3099    # call the view creator w/ the buffer to fill and the construction variables
3100    &{$LJ::viewinfo{$view}->{'creator'}}($dbs, \$ret, $u, \%vars, $remote, $opts);
3101
3102    # remove bad stuff
3103    unless ($opts->{'trusted_html'}) {
3104        LJ::strip_bad_code(\$ret);
3105    }
3106
3107    # return it...
3108    return $ret;
3109}
3110
3111# <LJFUNC>
3112# name: LJ::html_datetime
3113# class: component
3114# des:
3115# info: Parse output later with [func[LJ::html_datetime_decode]].
3116# args:
3117# des-:
3118# returns:
3119# </LJFUNC>
3120sub html_datetime
3121{
3122    my $opts = shift;
3123    my $lang = $opts->{'lang'} || "EN";
3124    my ($yyyy, $mm, $dd, $hh, $nn, $ss);
3125    my $ret;
3126    my $name = $opts->{'name'};
3127    my $disabled = $opts->{'disabled'} ? "DISABLED" : "";
3128    if ($opts->{'default'} =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(?: (\d\d):(\d\d):(\d\d))/) {
3129        ($yyyy, $mm, $dd, $hh, $nn, $ss) = ($1 > 0 ? $1 : "",
3130                                            $2+0,
3131                                            $3 > 0 ? $3+0 : "",
3132                                            $4 > 0 ? $4 : "",
3133                                            $5 > 0 ? $5 : "",
3134                                            $6 > 0 ? $6 : "");
3135    }
3136    $ret .= LJ::html_select({ 'name' => "${name}_mm", 'selected' => $mm, 'disabled' => $opts->{'disabled'} },
3137                         map { $_, LJ::Lang::month_long($lang, $_) } (0..12));
3138    $ret .= "<INPUT SIZE=2 MAXLENGTH=2 NAME=${name}_dd VALUE=\"$dd\" $disabled>, <INPUT SIZE=4 MAXLENGTH=4 NAME=${name}_yyyy VALUE=\"$yyyy\" $disabled>";
3139    unless ($opts->{'notime'}) {
3140        $ret.= " <INPUT SIZE=2 MAXLENGTH=2 NAME=${name}_hh VALUE=\"$hh\" $disabled>:<INPUT SIZE=2 MAXLENGTH=2 NAME=${name}_nn VALUE=\"$nn\" $disabled>";
3141        if ($opts->{'seconds'}) {
3142            $ret .= "<INPUT SIZE=2 MAXLENGTH=2 NAME=${name}_ss VALUE=\"$ss\" $disabled>";
3143        }
3144    }
3145
3146    return $ret;
3147}
3148
3149# <LJFUNC>
3150# name: LJ::html_datetime_decode
3151# class: component
3152# des:
3153# info: Generate the form controls with [func[LJ::html_datetime]].
3154# args:
3155# des-:
3156# returns:
3157# </LJFUNC>
3158sub html_datetime_decode
3159{
3160    my $opts = shift;
3161    my $hash = shift;
3162    my $name = $opts->{'name'};
3163    return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
3164                   $hash->{"${name}_yyyy"},
3165                   $hash->{"${name}_mm"},
3166                   $hash->{"${name}_dd"},
3167                   $hash->{"${name}_hh"},
3168                   $hash->{"${name}_nn"},
3169                   $hash->{"${name}_ss"});
3170}
3171
3172# <LJFUNC>
3173# name: LJ::html_select
3174# class: component
3175# des:
3176# info:
3177# args:
3178# des-:
3179# returns:
3180# </LJFUNC>
3181sub html_select
3182{
3183    my $opts = shift;
3184    my @items = @_;
3185    my $disabled = $opts->{'disabled'} ? " disabled='1'" : "";
3186    my $ret;
3187    $ret .= "<select";
3188    if ($opts->{'name'}) { $ret .= " name='$opts->{'name'}'"; }
3189    if ($opts->{'raw'}) { $ret .= " $opts->{'raw'}"; }
3190    $ret .= "$disabled>";
3191    while (my ($value, $text) = splice(@items, 0, 2)) {
3192        my $sel = "";
3193        if ($value eq $opts->{'selected'}) { $sel = " selected"; }
3194        $ret .= "<option value=\"$value\"$sel>$text</option>";
3195    }
3196    $ret .= "</select>";
3197    return $ret;
3198}
3199
3200# <LJFUNC>
3201# name: LJ::html_check
3202# class: component
3203# des:
3204# info:
3205# args:
3206# des-:
3207# returns:
3208# </LJFUNC>
3209sub html_check
3210{
3211    my $opts = shift;
3212
3213    my $disabled = $opts->{'disabled'} ? " DISABLED" : "";
3214    my $ret;
3215    if ($opts->{'type'} eq "radio") {
3216        $ret .= "<input type=\"radio\" ";
3217    } else {
3218        $ret .= "<input type=\"checkbox\" ";
3219    }
3220    if ($opts->{'selected'}) { $ret .= " checked='1'"; }
3221    if ($opts->{'raw'}) { $ret .= " $opts->{'raw'}"; }
3222    if ($opts->{'name'}) { $ret .= " name=\"$opts->{'name'}\""; }
3223    if (defined $opts->{'value'}) { $ret .= " value=\"$opts->{'value'}\""; }
3224    $ret .= "$disabled>";
3225    return $ret;
3226}
3227
3228# <LJFUNC>
3229# name: LJ::html_text
3230# class: component
3231# des:
3232# info:
3233# args:
3234# des-:
3235# returns:
3236# </LJFUNC>
3237sub html_text
3238{
3239    my $opts = shift;
3240
3241    my $disabled = $opts->{'disabled'} ? " DISABLED" : "";
3242    my $ret;
3243    $ret .= "<input type=\"text\"";
3244    if ($opts->{'size'}) { $ret .= " size=\"$opts->{'size'}\""; }
3245    if ($opts->{'maxlength'}) { $ret .= " maxlength=\"$opts->{'maxlength'}\""; }
3246    if ($opts->{'name'}) { $ret .= " name=\"" . LJ::ehtml($opts->{'name'}) . "\""; }
3247    if ($opts->{'value'}) { $ret .= " value=\"" . LJ::ehtml($opts->{'value'}) . "\""; }
3248    $ret .= "$disabled>";
3249    return $ret;
3250}
3251
3252# <LJFUNC>
3253# name: LJ::canonical_username
3254# des:
3255# info:
3256# args: user
3257# returns: the canonical username given, or blank if the username is not well-formed
3258# </LJFUNC>
3259sub canonical_username
3260{
3261    my $user = shift;
3262    if ($user =~ /^\s*([\w\-]{1,15})\s*$/) {
3263        $user = lc($1);
3264        $user =~ s/-/_/g;
3265        return $user;
3266    }
3267    return "";  # not a good username.
3268}
3269
3270# <LJFUNC>
3271# name: LJ::decode_url_string
3272# class: web
3273# des: Parse URL-style arg/value pairs into a hash.
3274# args: buffer, hashref
3275# des-buffer: Scalar or scalarref of buffer to parse.
3276# des-hashref: Hashref to populate.
3277# returns: boolean; true.
3278# </LJFUNC>
3279sub decode_url_string
3280{
3281    my $a = shift;
3282    my $buffer = ref $a ? $a : \$a;
3283    my $hashref = shift;  # output hash
3284
3285    my $pair;
3286    my @pairs = split(/&/, $$buffer);
3287    my ($name, $value);
3288    foreach $pair (@pairs)
3289    {
3290        ($name, $value) = split(/=/, $pair);
3291        $value =~ tr/+/ /;
3292        $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
3293        $name =~ tr/+/ /;
3294        $name =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
3295        $hashref->{$name} .= $hashref->{$name} ? "\0$value" : $value;
3296    }
3297    return 1;
3298}
3299
3300# given two db roles, returns true only if the two roles are for sure
3301# served by different database servers.  this is useful for, say,
3302# the moveusercluster script:  you wouldn't want to select something
3303# from one db, copy it into another, and then delete it from the
3304# source if they were both the same machine.
3305# <LJFUNC>
3306# name: LJ::use_diff_db
3307# class:
3308# des:
3309# info:
3310# args:
3311# des-:
3312# returns:
3313# </LJFUNC>
3314sub use_diff_db
3315{
3316    my ($role1, $role2) = @_;
3317
3318    return 0 if $role1 eq $role2;
3319
3320    # this is implied:  (makes logic below more readable by forcing it)
3321    $LJ::DBINFO{'master'}->{'role'}->{'master'} = 1;
3322
3323    foreach (keys %LJ::DBINFO) {
3324        next if /^_/;
3325        next unless ref $LJ::DBINFO{$_} eq "HASH";
3326        if ($LJ::DBINFO{$_}->{'role'}->{$role1} &&
3327            $LJ::DBINFO{$_}->{'role'}->{$role2}) {
3328            return 0;
3329        }
3330    }
3331
3332    return 1;
3333}
3334
3335# <LJFUNC>
3336# name: LJ::get_dbh
3337# class: db
3338# des: Given one or more roles, returns a database handle.
3339# info:
3340# args:
3341# des-:
3342# returns:
3343# </LJFUNC>
3344sub get_dbh
3345{
3346    my @roles = @_;
3347    my $role = shift @roles;
3348    return undef unless $role;
3349
3350    my $now = time();
3351
3352    # if non-master request and we haven't yet hit the master to get
3353    # the dbinfo, do that first.  (normal code path is something
3354    # calls LJ::start_request(), then gets master, then gets other)
3355    # but this path happens also.
3356    if ($role ne "master" && $LJ::DBWEIGHTS_FROM_DB &&
3357        ! $LJ::DBINFO{'_fromdb'})
3358    {
3359        # this might be enough to do it, if master isn't loaded:
3360        $LJ::NEED_DBWEIGHTS = 1;
3361        my $dbh = LJ::get_dbh("master");
3362
3363        # or, if we already had a master cached, we have to
3364        # load it by hand:
3365        unless ($LJ::DBINFO{'_fromdb'}) {
3366            _reload_weights($dbh);
3367        }
3368    }
3369
3370    # otherwise, see if we have a role -> full DSN mapping already
3371    my ($fdsn, $dbh);
3372    if ($role eq "master") {
3373        $fdsn = _make_dbh_fdsn($LJ::DBINFO{'master'});
3374    } else {
3375        if ($LJ::DBCACHE{$role}) {
3376            $fdsn = $LJ::DBCACHE{$role};
3377            if ($now > $LJ::DBCACHE_UNTIL{$role}) {
3378                # this role -> DSN mapping is too old.  invalidate,
3379                # and while we're at it, clean up any connections we have
3380                # that are too idle.
3381                undef $fdsn;
3382
3383                foreach (keys %LJ::DB_USED_AT) {
3384                    next if $LJ::DB_USED_AT{$_} > $now - 60;
3385                    delete $LJ::DB_USED_AT{$_};
3386                    delete $LJ::DBCACHE{$_};
3387                }
3388            }
3389        }
3390    }
3391
3392    if ($fdsn) {
3393        $dbh = _get_dbh_conn($fdsn, $role);
3394        return $dbh if $dbh;
3395        delete $LJ::DBCACHE{$role};  # guess it was bogus
3396    }
3397    return undef if $role eq "master";  # no hope now
3398
3399    # time to randomly weightedly select one.
3400    my @applicable;
3401    my $total_weight;
3402    foreach (keys %LJ::DBINFO) {
3403        next if /^_/;
3404        next unless ref $LJ::DBINFO{$_} eq "HASH";
3405        my $weight = $LJ::DBINFO{$_}->{'role'}->{$role};
3406        next unless $weight;
3407        push @applicable, [ $LJ::DBINFO{$_}, $weight ];
3408        $total_weight += $weight;
3409    }
3410
3411    while (@applicable)
3412    {
3413        my $rand = rand($total_weight);
3414        my ($i, $t) = (0, 0);
3415        for (; $i<@applicable; $i++) {
3416            $t += $applicable[$i]->[1];
3417            last if $t > $rand;
3418        }
3419        my $fdsn = _make_dbh_fdsn($applicable[$i]->[0]);
3420        $dbh = _get_dbh_conn($fdsn);
3421        if ($dbh) {
3422            $LJ::DBCACHE{$role} = $fdsn;
3423            $LJ::DBCACHE_UNTIL{$role} = $now + 20 + int(rand(10));
3424            return $dbh;
3425        }
3426
3427        # otherwise, discard that one.
3428        $total_weight -= $applicable[$i]->[1];
3429        splice(@applicable, $i, 1);
3430    }
3431
3432    # try others
3433    return get_dbh(@roles);
3434}
3435
3436sub _make_dbh_fdsn
3437{
3438    my $db = shift;   # hashref with DSN info, from ljconfig.pl's %LJ::DBINFO
3439    return $db->{'_fdsn'} if $db->{'_fdsn'};  # already made?
3440
3441    my $fdsn = "DBI:mysql";  # join("|",$dsn,$user,$pass) (because no refs as hash keys)
3442    $db->{'dbname'} ||= "livejournal";
3443    $fdsn .= ":$db->{'dbname'}:";
3444    if ($db->{'host'}) {
3445        $fdsn .= "host=$db->{'host'};";
3446    }
3447    if ($db->{'sock'}) {
3448        $fdsn .= "mysql_socket=$db->{'sock'};";
3449    }
3450    $fdsn .= "|$db->{'user'}|$db->{'pass'}";
3451
3452    $db->{'_fdsn'} = $fdsn;
3453    return $fdsn;
3454}
3455
3456sub _get_dbh_conn
3457{
3458    my $fdsn = shift;
3459    my $role = shift;  # optional.
3460    my $now = time();
3461
3462    my $retdb = sub {
3463        my $db = shift;
3464        $LJ::DBREQCACHE{$fdsn} = $db;
3465        $LJ::DB_USED_AT{$fdsn} = $now;
3466        return $db;
3467    };
3468
3469    # have we already created or verified a handle this request for this DSN?
3470    return $retdb->($LJ::DBREQCACHE{$fdsn})
3471        if $LJ::DBREQCACHE{$fdsn};
3472
3473    # check to see if we recently tried to connect to that dead server
3474    return undef if $now < $LJ::DBDEADUNTIL{$fdsn};
3475
3476    # if not, we'll try to find one we used sometime in this process lifetime
3477    my $dbh = $LJ::DBCACHE{$fdsn};
3478
3479    # if it exists, verify it's still alive and return it:
3480    if ($dbh)
3481    {
3482        if ($role eq "master" && $LJ::NEED_DBWEIGHTS) {
3483            return $retdb->($dbh) if _reload_weights($dbh);
3484        } else {
3485            return $retdb->($dbh) if $dbh->selectrow_array("SELECT CONNECTION_ID()");
3486        }
3487
3488        # bogus:
3489        undef $dbh;
3490        undef $LJ::DBCACHE{$fdsn};
3491    }
3492
3493    # time to make one!
3494    my ($dsn, $user, $pass) = split(/\|/, $fdsn);
3495    $dbh = DBI->connect($dsn, $user, $pass, {
3496        PrintError => 0,
3497    });
3498
3499    # mark server as dead if dead.  won't try to reconnect again for 5 seconds.
3500    if ($dbh) {
3501        $LJ::DB_USED_AT{$fdsn} = $now;
3502        if ($role eq "master" && $LJ::NEED_DBWEIGHTS) {
3503            _reload_weights($dbh);
3504        }
3505    } else {
3506        $LJ::DB_DEAD_UNTIL{$fdsn} = $now + 5;
3507    }
3508
3509    return $LJ::DBREQCACHE{$fdsn} = $LJ::DBCACHE{$fdsn} = $dbh;
3510}
3511
3512sub _reload_weights
3513{
3514    my $dbh = shift;
3515
3516    my $serial =
3517        $dbh->selectrow_array("SELECT fdsn AS 'serial' FROM dbinfo WHERE dbid=0");
3518
3519    return 0 if $dbh->err;
3520    $LJ::NEED_DBWEIGHTS = 0;
3521    return 1 if $serial == $LJ::CACHE_DBWEIGHT_SERIAL;
3522
3523    my $sth = $dbh->prepare("SELECT i.masterid, i.name, i.fdsn, ".
3524                            "w.role, w.curr FROM dbinfo i, dbweights w ".
3525                            "WHERE i.dbid=w.dbid");
3526    $sth->execute;
3527
3528    my %dbinfo;
3529    while (my $r = $sth->fetchrow_hashref) {
3530        my $name = $r->{'masterid'} ? $r->{'name'} : "master";
3531        $dbinfo{$name}->{'_fdsn'} = $r->{'fdsn'};
3532        $dbinfo{$name}->{'role'}->{$r->{'role'}} = $r->{'curr'};
3533        $dbinfo{$name}->{'_totalweight'} += $r->{'curr'};
3534    }
3535
3536    # any host that has no total weight (temporarily disabled?), we want
3537    # to kill all its live connections.
3538    foreach my $h (keys %dbinfo) {
3539        my $i = $dbinfo{$h};
3540        next if $i->{'_totalweight'};
3541
3542        # kill open OAconnections to it
3543        delete $LJ::DBCACHE{$i->{'_fdsn'}};
3544
3545        # mark nothing as wanting to use it.
3546        foreach my $k (keys %LJ::DBCACHE) {
3547            next if ref $LJ::DBCACHE{$k};
3548            if ($LJ::DBCACHE{$k} eq $i->{'_fdsn'}) {
3549                delete $LJ::DBCACHE{$k};
3550            }
3551        }
3552    }
3553
3554    # copy new config.  good to go!
3555    %LJ::DBINFO = %dbinfo;
3556    $LJ::DBINFO{'_fromdb'} = 1;
3557    1;
3558}
3559
3560# <LJFUNC>
3561# name: LJ::get_dbs
3562# des: Returns a set of database handles to master and a slave,
3563#      if this site is using slave databases.  Only use this
3564#      once per connection and pass around the same $dbs, since
3565#      this function calls [func[LJ::get_dbh]] which uses cached
3566#      connections, but validates the connection is still live.
3567# returns: $dbs (see [func[LJ::make_dbs]])
3568# </LJFUNC>
3569sub get_dbs
3570{
3571    my $dbh = LJ::get_dbh("master");
3572    my $dbr = LJ::get_dbh("slave");
3573
3574    # check to see if fdsns of connections we just got match.  if
3575    # slave ends up being master, we want to pretend we just have no
3576    # slave (avoids some queries being run twice on master).  this is
3577    # common when somebody sets up a master and 2 slaves, but has the
3578    # master doing 1 of the 3 configured slave roles
3579    $dbr = undef if $LJ::DBCACHE{"slave"} eq $LJ::DBCACHE{"master"};
3580
3581    return make_dbs($dbh, $dbr);
3582}
3583
3584# <LJFUNC>
3585# name: LJ::get_cluster_reader
3586# class: db
3587# des: Returns a cluster slave for a user, or cluster master if no slaves exist.
3588# args: uarg
3589# des-uarg: Either a userid scalar or a user object.
3590# returns: DB handle.  Or undef if all dbs are unavailable.
3591# </LJFUNC>
3592sub get_cluster_reader
3593{
3594    my $arg = shift;
3595    my $id = ref $arg eq "HASH" ? $arg->{'clusterid'} : $arg;
3596    return LJ::get_dbh("cluster${id}slave",
3597                       "cluster${id}");
3598}
3599
3600# <LJFUNC>
3601# name: LJ::get_cluster_master
3602# class: db
3603# des: Returns a cluster master for a given user.
3604# args: uarg
3605# des-uarg: Either a userid scalar or a user object.
3606# returns: DB handle.  Or undef if master is unavailable.
3607# </LJFUNC>
3608sub get_cluster_master
3609{
3610    my $arg = shift;
3611    my $id = ref $arg eq "HASH" ? $arg->{'clusterid'} : $arg;
3612    return LJ::get_dbh("cluster${id}");
3613}
3614
3615# <LJFUNC>
3616# name: LJ::get_cluster_set
3617# class: db
3618# des: Returns a dbset structure for a user's db clusters.
3619# args: uarg
3620# des-uarg: Either a userid scalar or a user object.
3621# returns: dbset.
3622# </LJFUNC>
3623sub get_cluster_set
3624{
3625    my $arg = shift;
3626    my $id = ref $arg eq "HASH" ? $arg->{'clusterid'} : $arg;
3627    my $dbs = {};
3628    $dbs->{'dbh'} = LJ::get_dbh("cluster${id}");
3629    $dbs->{'dbr'} = LJ::get_dbh("cluster${id}slave");
3630
3631    # see note in LJ::get_dbs about why we do this:
3632    $dbs->{'dbr'} = undef
3633        if $LJ::DBCACHE{"cluster${id}"} eq $LJ::DBCACHE{"cluster${id}slave"};
3634
3635    $dbs->{'has_slave'} = defined $dbs->{'dbr'};
3636    $dbs->{'reader'} = $dbs->{'has_slave'} ? $dbs->{'dbr'} : $dbs->{'dbh'};
3637    return $dbs;
3638}
3639
3640# <LJFUNC>
3641# name: LJ::make_dbs
3642# class: db
3643# des: Makes a $dbs structure from a master db
3644#      handle and optionally a slave.  This function
3645#      is called from [func[LJ::get_dbs]].  You shouldn't need
3646#      to call it yourself.
3647# returns: $dbs: hashref with 'dbh' (master), 'dbr' (slave or undef),
3648#          'has_slave' (boolean) and 'reader' (dbr if defined, else dbh)
3649# </LJFUNC>
3650sub make_dbs
3651{
3652    my ($dbh, $dbr) = @_;
3653    my $dbs = {};
3654    $dbs->{'dbh'} = $dbh;
3655    $dbs->{'dbr'} = $dbr;
3656    $dbs->{'has_slave'} = defined $dbr ? 1 : 0;
3657    $dbs->{'reader'} = defined $dbr ? $dbr : $dbh;
3658    return $dbs;
3659}
3660
3661# <LJFUNC>
3662# name: LJ::make_dbs_from_arg
3663# class: db
3664# des: Convert unknown arg to a dbset.
3665# info: Functions use this to let their callers use either db handles
3666#       or dbsets.  If argument is a single handle, turns it into a
3667#       dbset.  If already a dbset, just returns it unchanged.
3668# args: something
3669# des-something: Either a db handle or a dbset.
3670# returns: A dbset.
3671# </LJFUNC>
3672sub make_dbs_from_arg
3673{
3674    my $dbarg = shift;
3675    my $dbs;
3676    if (ref($dbarg) eq "HASH") {
3677        $dbs = $dbarg;
3678    } else {
3679        $dbs = LJ::make_dbs($dbarg, undef);
3680    }
3681    return $dbs;
3682}
3683
3684
3685# <LJFUNC>
3686# name: LJ::date_to_view_links
3687# class: component
3688# des: Returns HTML of date with links to user's journal.
3689# args: u, date
3690# des-date: date in yyyy-mm-dd form.
3691# returns: HTML with yyy, mm, and dd all links to respective views.
3692# </LJFUNC>
3693sub date_to_view_links
3694{
3695    my ($u, $date) = @_;
3696
3697    return unless ($date =~ /(\d\d\d\d)-(\d\d)-(\d\d)/);
3698    my ($y, $m, $d) = ($1, $2, $3);
3699    my ($nm, $nd) = ($m+0, $d+0);   # numeric, without leading zeros
3700    my $user = $u->{'user'};
3701
3702    my $ret;
3703    $ret .= "<a href=\"$LJ::SITEROOT/users/$user/calendar/$y\">$y</a>-";
3704    $ret .= "<a href=\"$LJ::SITEROOT/view/?type=month&amp;user=$user&amp;y=$y&amp;m=$nm\">$m</a>-";
3705    $ret .= "<a href=\"$LJ::SITEROOT/users/$user/day/$y/$m/$d\">$d</a>";
3706    return $ret;
3707}
3708
3709# <LJFUNC>
3710# name: LJ::item_link
3711# class: component
3712# des: Returns URL to view an individual journal item.
3713# info: The returned URL may have an ampersand in it.  In an HTML/XML attribute,
3714#       these must first be escaped by, say, [func[LJ::ehtml]].  This
3715#       function doesn't return it pre-escaped because the caller may
3716#       use it in, say, a plain-text email message.
3717# args: u, itemid, anum?
3718# des-itemid: Itemid of entry to link to.
3719# des-anum: If present, $u is assumed to be on a cluster and itemid is assumed
3720#           to not be a $ditemid already, and the $itemid will be turned into one
3721#           by multiplying by 256 and adding $anum.
3722# returns: scalar; unescaped URL string
3723# </LJFUNC>
3724sub item_link
3725{
3726    my ($u, $itemid, $anum) = @_;
3727    my $jarg = $u->{'clusterid'} ? "journal=$u->{'user'}&" : "";
3728    my $ditemid = defined $anum ? ($itemid*256 + $anum) : $itemid;
3729    return "$LJ::SITEROOT/talkread.bml?${jarg}itemid=$ditemid";
3730}
3731
3732# <LJFUNC>
3733# name: LJ::make_graphviz_dot_file
3734# class:
3735# des:
3736# info:
3737# args:
3738# des-:
3739# returns:
3740# </LJFUNC>
3741sub make_graphviz_dot_file
3742{
3743    my $dbarg = shift;
3744    my $user = shift;
3745
3746    my $dbs = make_dbs_from_arg($dbarg);
3747    my $dbh = $dbs->{'dbh'};
3748    my $dbr = $dbs->{'reader'};
3749
3750    my $quser = $dbr->quote($user);
3751    my $sth;
3752    my $ret;
3753
3754    $sth = $dbr->prepare("SELECT u.*, UNIX_TIMESTAMP()-UNIX_TIMESTAMP(uu.timeupdate) AS 'secondsold' FROM user u, userusage uu WHERE u.userid=uu.userid AND u.user=$quser");
3755    $sth->execute;
3756    my $u = $sth->fetchrow_hashref;
3757
3758    unless ($u) {
3759        return "";
3760    }
3761
3762    $ret .= "digraph G {\n";
3763    $ret .= "  node [URL=\"$LJ::SITEROOT/userinfo.bml?user=\\N\"]\n";
3764    $ret .= "  node [fontsize=10, color=lightgray, style=filled]\n";
3765    $ret .= "  \"$user\" [color=yellow, style=filled]\n";
3766
3767    my @friends = ();
3768    $sth = $dbr->prepare("SELECT friendid FROM friends WHERE userid=$u->{'userid'} AND userid<>friendid");
3769    $sth->execute;
3770    while ($_ = $sth->fetchrow_hashref) {
3771        push @friends, $_->{'friendid'};
3772    }
3773
3774    my $friendsin = join(", ", map { $dbh->quote($_); } ($u->{'userid'}, @friends));
3775    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)))";
3776    $sth = $dbr->prepare($sql);
3777    $sth->execute;
3778    while ($_ = $sth->fetchrow_hashref) {
3779        $ret .= "  \"$_->{'user'}\"->\"$_->{'friend'}\"\n";
3780    }
3781
3782    $ret .= "}\n";
3783
3784    return $ret;
3785}
3786
3787# <LJFUNC>
3788# name: LJ::expand_embedded
3789# class:
3790# des:
3791# info:
3792# args:
3793# des-:
3794# returns:
3795# </LJFUNC>
3796sub expand_embedded
3797{
3798    my $dbs = shift;
3799    my $ditemid = shift;
3800    my $remote = shift;
3801    my $eventref = shift;
3802
3803    LJ::Poll::show_polls($dbs, $ditemid, $remote, $eventref);
3804}
3805
3806# <LJFUNC>
3807# name: LJ::make_remote
3808# des: Returns a minimal user structure ($remote-like) from
3809#      a username and userid.
3810# args: user, userid
3811# des-user: Username.
3812# des-userid: User ID.
3813# returns: hashref with 'user' and 'userid' keys, or undef if
3814#          either argument was bogus (so caller can pass
3815#          untrusted input)
3816# </LJFUNC>
3817sub make_remote
3818{
3819    my $user = LJ::canonical_username(shift);
3820    my $userid = shift;
3821    if ($user && $userid && $userid =~ /^\d+$/) {
3822        return { 'user' => $user,
3823                 'userid' => $userid, };
3824    }
3825    return undef;
3826}
3827
3828# <LJFUNC>
3829# name: LJ::load_userids_multiple
3830# des: Loads a number of users at once, efficiently.
3831# info: loads a few users at once, their userids given in the keys of $map
3832#       listref (not hashref: can't have dups).  values of $map listref are
3833#       scalar refs to put result in.  $have is an optional listref of user
3834#       object caller already has, but is too lazy to sort by themselves.
3835# args: dbarg, map, have
3836# des-map: Arrayref of pairs (userid, destination scalarref)
3837# des-have: Arrayref of user objects caller already has
3838# returns: Nothing.
3839# </LJFUNC>
3840sub load_userids_multiple
3841{
3842    my ($dbarg, $map, $have) = @_;
3843
3844    my $dbs = LJ::make_dbs_from_arg($dbarg);
3845    my $dbh = $dbs->{'dbh'};
3846    my $dbr = $dbs->{'reader'};
3847    my $sth;
3848
3849    my %need;
3850    while (@$map) {
3851        my $id = shift @$map;
3852        my $ref = shift @$map;
3853        push @{$need{$id}}, $ref;
3854    }
3855
3856    my $satisfy = sub {
3857        my $u = shift;
3858        next unless ref $u eq "HASH";
3859        foreach (@{$need{$u->{'userid'}}}) {
3860            $$_ = $u;
3861        }
3862        delete $need{$u->{'userid'}};
3863    };
3864
3865    if ($have) {
3866        foreach my $u (@$have) {
3867            $satisfy->($u);
3868        }
3869    }
3870
3871    if (keys %need) {
3872        my $in = join(", ", map { $_+0 } keys %need);
3873        ($sth = $dbr->prepare("SELECT * FROM user WHERE userid IN ($in)"))->execute;
3874        $satisfy->($_) while $_ = $sth->fetchrow_hashref;
3875    }
3876}
3877
3878# <LJFUNC>
3879# name: LJ::load_user
3880# des: Loads a user record given a username.
3881# info: From the [dbarg[user]] table.
3882# args: dbarg, user
3883# des-user: Username of user to load.
3884# returns: Hashref with keys being columns of [dbtable[user]] table.
3885# </LJFUNC>
3886sub load_user
3887{
3888    my $dbarg = shift;
3889    my $user = shift;
3890
3891    my $dbs = LJ::make_dbs_from_arg($dbarg);
3892    my $dbh = $dbs->{'dbh'};
3893    my $dbr = $dbs->{'reader'};
3894    my $sth;
3895
3896    $user = LJ::canonical_username($user);
3897    my $quser = $dbr->quote($user);
3898    my $u = $dbr->selectrow_hashref("SELECT * FROM user WHERE user=$quser");
3899
3900    # if user doesn't exist in the LJ database, it's possible we're using
3901    # an external authentication source and we should create the account
3902    # implicitly.
3903    if (! $u && ref $LJ::AUTH_EXISTS eq "CODE") {
3904        if ($LJ::AUTH_EXISTS->($user)) {
3905            if (LJ::create_account($dbh, {
3906                'user' => $user,
3907                'name' => $user,
3908                'password' => "",
3909            }))
3910            {
3911                # NOTE: this should pull from the master, since it was _just_
3912                # created and the elsif below won't catch.
3913                $sth = $dbh->prepare("SELECT * FROM user WHERE user=$quser");
3914                $sth->execute;
3915                $u = $sth->fetchrow_hashref;
3916                $sth->finish;
3917                return $u;
3918            } else {
3919                return undef;
3920            }
3921        }
3922    } elsif (! $u && $dbs->{'has_slave'}) {
3923        # If the user still doesn't exist, and there isn't an alternate auth code
3924        # try grabbing it from the master.
3925        $sth = $dbh->prepare("SELECT * FROM user WHERE user=$quser");
3926        $sth->execute;
3927        $u = $sth->fetchrow_hashref;
3928        $sth->finish;
3929    }
3930
3931    return $u;
3932}
3933
3934# <LJFUNC>
3935# name: LJ::load_userid
3936# des: Loads a user record given a userid.
3937# info: From the [dbarg[user]] table.
3938# args: dbarg, userid
3939# des-userid: Userid of user to load.
3940# returns: Hashref with keys being columns of [dbtable[user]] table.
3941# </LJFUNC>
3942sub load_userid
3943{
3944    my $dbarg = shift;
3945    my $userid = shift;
3946    return undef unless $userid;
3947
3948    my $dbs = make_dbs_from_arg($dbarg);
3949    my $dbh = $dbs->{'dbh'};
3950    my $dbr = $dbs->{'reader'};
3951
3952    my $quserid = $dbr->quote($userid);
3953    return LJ::dbs_selectrow_hashref($dbs, "SELECT * FROM user WHERE userid=$quserid");
3954}
3955
3956# <LJFUNC>
3957# name: LJ::load_moods
3958# class:
3959# des:
3960# info:
3961# args:
3962# des-:
3963# returns:
3964# </LJFUNC>
3965sub load_moods
3966{
3967    return if ($LJ::CACHED_MOODS);
3968    my $dbarg = shift;
3969
3970    my $dbs = make_dbs_from_arg($dbarg);
3971    my $dbh = $dbs->{'dbh'};
3972    my $dbr = $dbs->{'reader'};
3973
3974    my $sth = $dbr->prepare("SELECT moodid, mood, parentmood FROM moods");
3975    $sth->execute;
3976    while (my ($id, $mood, $parent) = $sth->fetchrow_array) {
3977        $LJ::CACHE_MOODS{$id} = { 'name' => $mood, 'parent' => $parent };
3978        if ($id > $LJ::CACHED_MOOD_MAX) { $LJ::CACHED_MOOD_MAX = $id; }
3979    }
3980    $LJ::CACHED_MOODS = 1;
3981}
3982
3983# <LJFUNC>
3984# name: LJ::query_buffer_add
3985# des: Schedules an insert/update query to be run on a certain table sometime
3986#      in the near future in a batch with a lot of similar updates, or
3987#      immediately if the site doesn't provide query buffering.  Returns
3988#      nothing (no db error code) since there's the possibility it won't
3989#      run immediately anyway.
3990# args: dbarg, table, query
3991# des-table: Table to modify.
3992# des-query: Query that'll update table.  The query <b>must not</b> access
3993#            any table other than that one, since the update is done inside
3994#            an explicit table lock for performance.
3995# </LJFUNC>
3996sub query_buffer_add
3997{
3998    my ($dbarg, $table, $query) = @_;
3999
4000    my $dbs = make_dbs_from_arg($dbarg);
4001    my $dbh = $dbs->{'dbh'};
4002    my $dbr = $dbs->{'reader'};
4003
4004    if ($LJ::BUFFER_QUERIES)
4005    {
4006        # if this is a high load site, you'll want to batch queries up and send them at once.
4007
4008        my $table = $dbh->quote($table);
4009        my $query = $dbh->quote($query);
4010        $dbh->do("INSERT INTO querybuffer (qbid, tablename, instime, query) VALUES (NULL, $table, NOW(), $query)");
4011    }
4012    else
4013    {
4014        # low load sites can skip this, and just have queries go through immediately.
4015        $dbh->do($query);
4016    }
4017}
4018
4019# <LJFUNC>
4020# name: LJ::cmd_buffer_add
4021# des: Schedules some command to be run sometime in the future which would
4022#      be too slow to do syncronously with the web request.  An example
4023#      is deleting a journal entry, which requires recursing through a lot
4024#      of tables and deleting all the appropriate stuff.
4025# args: db, journalid, cmd, hargs
4026# des-db: Cluster master db handle to run command on.
4027# des-journalid: Journal id command affects.  This is indexed in the
4028#                [dbtable[cmdbuffer]] table so that all of a user's queued
4029#                actions can be run before that user is potentially moved
4030#                between clusters.
4031# des-cmd: Text of the command name.  30 chars max.
4032# des-hargs: Hashref of command arguments.
4033# </LJFUNC>
4034sub cmd_buffer_add
4035{
4036    my ($db, $journalid, $cmd, $h_args) = @_;
4037
4038    return 0 unless $db;
4039    $journalid += 0;
4040    my $qcmd = $db->quote($cmd);
4041    my $qargs;
4042    if (ref $h_args eq "HASH") {
4043        foreach (sort keys %$h_args) {
4044            $qargs .= LJ::eurl($_) . "=" . LJ::eurl($h_args->{$_}) . "&";
4045        }
4046        chop $qargs;
4047    }
4048    $qargs = $db->quote($qargs);
4049    $db->do("INSERT INTO cmdbuffer (journalid, cmd, instime, args) ".
4050            "VALUES ($journalid, $qcmd, NOW(), $qargs)");
4051}
4052
4053# <LJFUNC>
4054# name: LJ::cmd_buffer_flush
4055# class:
4056# des:
4057# info:
4058# args:
4059# des-:
4060# returns:
4061# </LJFUNC>
4062sub cmd_buffer_flush
4063{
4064    my ($dbh, $db, $cmd, $userid) = @_;
4065    return 0 unless $cmd;
4066
4067    my $cmds = {
4068        'delitem' => {
4069            'run' => sub {
4070                my ($dbh, $db, $c) = @_;
4071                my $a = $c->{'args'};
4072                LJ::delete_item2($dbh, $db, $c->{'journalid'}, $a->{'itemid'},
4073                                 0, $a->{'anum'});
4074            },
4075        },
4076    };
4077    # TODO: call hook to augment dispatch table with site-defined commands
4078    return 0 unless defined $cmds->{$cmd};
4079
4080    my $clist;
4081    my $loop = 1;
4082    my $cd = $cmds->{$cmd};
4083    my $where = "cmd=" . $dbh->quote($cmd);
4084    if ($userid) {
4085        $where .= " AND journalid=" . $dbh->quote($userid);
4086    }
4087
4088    while ($loop &&
4089           ($clist = $db->selectcol_arrayref("SELECT cbid FROM cmdbuffer ".
4090                                             "WHERE $where ORDER BY cbid LIMIT 20")) &&
4091           $clist && @$clist)
4092    {
4093        foreach my $cbid (@$clist) {
4094            my $got_lock = $db->selectrow_array("SELECT GET_LOCK('cbid-$cbid',10)");
4095            return 0 unless $got_lock;
4096            my $c = $db->selectrow_hashref("SELECT * FROM cmdbuffer WHERE cbid=$cbid");
4097            next unless $c;
4098
4099            my $a = {};
4100            LJ::decode_url_string($c->{'args'}, $a);
4101            $c->{'args'} = $a;
4102            $cmds->{$cmd}->{'run'}->($dbh, $db, $c);
4103
4104            $db->do("DELETE FROM cmdbuffer WHERE cbid=$cbid");
4105            $db->do("SELECT RELEASE_LOCK('cbid-$cbid')");
4106        }
4107        $loop = 0 unless scalar(@$clist) == 20;
4108    }
4109    return 1;
4110}
4111
4112# <LJFUNC>
4113# name: LJ::query_buffer_flush
4114# class:
4115# des:
4116# info:
4117# args:
4118# des-:
4119# returns:
4120# </LJFUNC>
4121sub query_buffer_flush
4122{
4123    my ($dbarg, $table) = @_;
4124
4125    my $dbs = make_dbs_from_arg($dbarg);
4126    my $dbh = $dbs->{'dbh'};
4127    my $dbr = $dbs->{'reader'};
4128
4129    return -1 unless ($table);
4130    return -1 if ($table =~ /[^\w]/);
4131
4132    $dbh->do("LOCK TABLES $table WRITE, querybuffer WRITE");
4133
4134    my $count = 0;
4135    my $max = 0;
4136    my $qtable = $dbh->quote($table);
4137
4138    # We want to leave this pointed to the master to ensure we are
4139    # getting the most recent data!  (also, querybuffer doesn't even
4140    # replicate to slaves in the recommended configuration... it's
4141    # pointless to do so)
4142    my $sth = $dbh->prepare("SELECT qbid, query FROM querybuffer WHERE tablename=$qtable ORDER BY qbid");
4143    if ($dbh->err) { $dbh->do("UNLOCK TABLES"); die $dbh->errstr; }
4144    $sth->execute;
4145    if ($dbh->err) { $dbh->do("UNLOCK TABLES"); die $dbh->errstr; }
4146    while (my ($id, $query) = $sth->fetchrow_array)
4147    {
4148        $dbh->do($query);
4149        $count++;
4150        $max = $id;
4151    }
4152    $sth->finish;
4153
4154    $dbh->do("DELETE FROM querybuffer WHERE tablename=$qtable");
4155    if ($dbh->err) { $dbh->do("UNLOCK TABLES"); die $dbh->errstr; }
4156
4157    $dbh->do("UNLOCK TABLES");
4158    return $count;
4159}
4160
4161# <LJFUNC>
4162# name: LJ::journal_base
4163# des: Returns URL of a user's journal.
4164# info: The tricky thing is that users with underscores in their usernames
4165#       can't have some_user.site.com as a hostname, so that's changed into
4166#       some-user.site.com.
4167# args: user, vhost?
4168# des-user: Username of user whose URL to make.
4169# des-vhost: What type of URL.  Acceptable options are "users", to make a
4170#            http://user.site.com/ URL; "tilde" to make http://site.com/~user/;
4171#            "community" for http://site.com/community/user; or the default
4172#            will be http://site.com/users/user
4173# returns: scalar; a URL.
4174# </LJFUNC>
4175sub journal_base
4176{
4177    my ($user, $vhost) = @_;
4178    if ($vhost eq "users") {
4179        my $he_user = $user;
4180        $he_user =~ s/_/-/g;
4181        return "http://$he_user.$LJ::USER_DOMAIN";
4182    } elsif ($vhost eq "tilde") {
4183        return "$LJ::SITEROOT/~$user";
4184    } elsif ($vhost eq "community") {
4185        return "$LJ::SITEROOT/community/$user";
4186    } else {
4187        return "$LJ::SITEROOT/users/$user";
4188    }
4189}
4190
4191# loads all of the given privs for a given user into a hashref
4192# inside the user record ($u->{_privs}->{$priv}->{$arg} = 1)
4193# <LJFUNC>
4194# name: LJ::load_user_privs
4195# class:
4196# des:
4197# info:
4198# args:
4199# des-:
4200# returns:
4201# </LJFUNC>
4202sub load_user_privs
4203{
4204    my $dbarg = shift;
4205    my $remote = shift;
4206    my @privs = @_;
4207
4208    my $dbs = make_dbs_from_arg($dbarg);
4209    my $dbh = $dbs->{'dbh'};
4210    my $dbr = $dbs->{'reader'};
4211
4212    return unless ($remote and @privs);
4213
4214    # return if we've already loaded these privs for this user.
4215    @privs = map { $dbr->quote($_) }
4216             grep { ! $remote->{'_privloaded'}->{$_}++ } @privs;
4217
4218    return unless (@privs);
4219
4220    my $sth = $dbr->prepare("SELECT pl.privcode, pm.arg ".
4221                            "FROM priv_map pm, priv_list pl ".
4222                            "WHERE pm.prlid=pl.prlid AND ".
4223                            "pl.privcode IN (" . join(',',@privs) . ") ".
4224                            "AND pm.userid=$remote->{'userid'}");
4225    $sth->execute;
4226    while (my ($priv, $arg) = $sth->fetchrow_array)
4227    {
4228        unless (defined $arg) { $arg = ""; }  # NULL -> ""
4229        $remote->{'_priv'}->{$priv}->{$arg} = 1;
4230    }
4231}
4232
4233# <LJFUNC>
4234# name: LJ::check_priv
4235# des: Check to see if a user has a certain privilege.
4236# info: Usually this is used to check the privs of a $remote user.
4237#       See [func[LJ::get_remote]].  As such, a $u argument of undef
4238#       is okay to pass: 0 will be returned, as an unknown user can't
4239#       have any rights.
4240# args: dbarg, u, priv, arg?
4241# des-priv: Priv name to check for (see [dbtable[priv_list]])
4242# des-arg: Optional argument.  If defined, function only returns true
4243#          when $remote has a priv of type $priv also with arg $arg, not
4244#          just any priv of type $priv, which is the behavior without
4245#          an $arg
4246# returns: boolean; true if user has privilege
4247# </LJFUNC>
4248sub check_priv
4249{
4250    my ($dbarg, $u, $priv, $arg) = @_;
4251    return 0 unless $u;
4252
4253    my $dbs = make_dbs_from_arg($dbarg);
4254    my $dbh = $dbs->{'dbh'};
4255    my $dbr = $dbs->{'reader'};
4256
4257    if (! $u->{'_privloaded'}->{$priv}) {
4258        if ($dbr) {
4259            load_user_privs($dbr, $u, $priv);
4260        } else {
4261            return 0;
4262        }
4263    }
4264
4265    if (defined $arg) {
4266        return (defined $u->{'_priv'}->{$priv} &&
4267                defined $u->{'_priv'}->{$priv}->{$arg});
4268    } else {
4269        return (defined $u->{'_priv'}->{$priv});
4270    }
4271}
4272
4273#
4274#
4275# <LJFUNC>
4276# name: LJ::remote_has_priv
4277# class:
4278# des: Check to see if the given remote user has a certain priviledge
4279# info: DEPRECATED.  should use load_user_privs + check_priv
4280# args:
4281# des-:
4282# returns:
4283# </LJFUNC>
4284sub remote_has_priv
4285{
4286    my $dbarg = shift;
4287    my $remote = shift;
4288    my $privcode = shift;     # required.  priv code to check for.
4289    my $ref = shift;  # optional, arrayref or hashref to populate
4290
4291    my $dbs = make_dbs_from_arg($dbarg);
4292    my $dbh = $dbs->{'dbh'};
4293    my $dbr = $dbs->{'reader'};
4294
4295    return 0 unless ($remote);
4296
4297    ### authentication done.  time to authorize...
4298
4299    my $qprivcode = $dbh->quote($privcode);
4300    my $sth = $dbr->prepare("SELECT pm.arg FROM priv_map pm, priv_list pl WHERE pm.prlid=pl.prlid AND pl.privcode=$qprivcode AND pm.userid=$remote->{'userid'}");
4301    $sth->execute;
4302
4303    my $match = 0;
4304    if (ref $ref eq "ARRAY") { @$ref = (); }
4305    if (ref $ref eq "HASH") { %$ref = (); }
4306    while (my ($arg) = $sth->fetchrow_array) {
4307        $match++;
4308        if (ref $ref eq "ARRAY") { push @$ref, $arg; }
4309        if (ref $ref eq "HASH") { $ref->{$arg} = 1; }
4310    }
4311    return $match;
4312}
4313
4314# <LJFUNC>
4315# name: LJ::get_userid
4316# des: Returns a userid given a username.
4317# info: Results cached in memory.  On miss, does DB call.  Not advised
4318#       to use this many times in a row... only once or twice perhaps
4319#       per request.  Tons of serialized db requests, even when small,
4320#       are slow.  Opposite of [func[LJ::get_username]].
4321# args: dbarg, user
4322# des-user: Username whose userid to look up.
4323# returns: Userid, or 0 if invalid user.
4324# </LJFUNC>
4325sub get_userid
4326{
4327    my $dbarg = shift;
4328    my $user = shift;
4329
4330    my $dbs = make_dbs_from_arg($dbarg);
4331    my $dbh = $dbs->{'dbh'};
4332    my $dbr = $dbs->{'reader'};
4333
4334    $user = canonical_username($user);
4335
4336    my $userid;
4337    if ($LJ::CACHE_USERID{$user}) { return $LJ::CACHE_USERID{$user}; }
4338
4339    my $quser = $dbr->quote($user);
4340    my $sth = $dbr->prepare("SELECT userid FROM useridmap WHERE user=$quser");
4341    $sth->execute;
4342    ($userid) = $sth->fetchrow_array;
4343    if ($userid) { $LJ::CACHE_USERID{$user} = $userid; }
4344
4345    # implictly create an account if we're using an external
4346    # auth mechanism
4347    if (! $userid && ref $LJ::AUTH_EXISTS eq "CODE")
4348    {
4349        # TODO: eventual $dbs conversion (even though create_account will ALWAYS
4350        # use the master)
4351        $userid = LJ::create_account($dbh, { 'user' => $user,
4352                                             'name' => $user,
4353                                             'password' => '', });
4354    }
4355
4356    return ($userid+0);
4357}
4358
4359# <LJFUNC>
4360# name: LJ::get_username
4361# des: Returns a username given a userid.
4362# info: Results cached in memory.  On miss, does DB call.  Not advised
4363#       to use this many times in a row... only once or twice perhaps
4364#       per request.  Tons of serialized db requests, even when small,
4365#       are slow.  Opposite of [func[LJ::get_userid]].
4366# args: dbarg, user
4367# des-user: Username whose userid to look up.
4368# returns: Userid, or 0 if invalid user.
4369# </LJFUNC>
4370sub get_username
4371{
4372    my $dbarg = shift;
4373    my $userid = shift;
4374    my $user;
4375    $userid += 0;
4376
4377    # Checked the cache first.
4378    if ($LJ::CACHE_USERNAME{$userid}) { return $LJ::CACHE_USERNAME{$userid}; }
4379
4380    my $dbs = LJ::make_dbs_from_arg($dbarg);
4381    my $dbr = $dbs->{'reader'};
4382
4383    my $sth = $dbr->prepare("SELECT user FROM useridmap WHERE userid=$userid");
4384    $sth->execute;
4385    $user = $sth->fetchrow_array;
4386
4387    # Fall back to master if it doesn't exist.
4388    if (! defined($user) && $dbs->{'has_slave'}) {
4389        my $dbh = $dbs->{'dbh'};
4390        $sth = $dbh->prepare("SELECT user FROM useridmap WHERE userid=$userid");
4391        $sth->execute;
4392        $user = $sth->fetchrow_array;
4393    }
4394    if (defined($user)) { $LJ::CACHE_USERNAME{$userid} = $user; }
4395    return ($user);
4396}
4397
4398# <LJFUNC>
4399# name: LJ::get_itemid_near
4400# class:
4401# des:
4402# info:
4403# args:
4404# des-:
4405# returns:
4406# </LJFUNC>
4407sub get_itemid_near
4408{
4409    my $dbarg = shift;
4410    my $itemid = shift;
4411    my $after_before = shift;
4412
4413    my $dbs = LJ::make_dbs_from_arg($dbarg);
4414    my $dbh = $dbs->{'dbh'};
4415    my $dbr = $dbs->{'reader'};
4416
4417    my ($inc, $order);
4418    if ($after_before eq "after") {
4419        ($inc, $order) = (-1, "DESC");
4420    } elsif ($after_before eq "before") {
4421        ($inc, $order) = (1, "ASC");
4422    } else {
4423        return 0;
4424    }
4425
4426    $itemid += 0;
4427    my $lr = $dbr->selectrow_hashref("SELECT u.userid, u.journaltype, l.rlogtime, l.revttime ".
4428                                     "FROM user u, log l WHERE l.itemid=$itemid ".
4429                                     "AND l.ownerid=u.userid");
4430    return 0 unless $lr;
4431    my $jid = $lr->{'userid'};
4432    my $field = $lr->{'journaltype'} eq "P" ? "revttime" : "rlogtime";
4433    my $stime = $lr->{$field};
4434
4435    my $day = 86400;
4436    foreach my $distance ($day, $day*7, $day*30, $day*90) {
4437        my ($one_away, $further) = ($stime + $inc, $stime + $inc*$distance);
4438        if ($further < $one_away) {
4439            # swap them, BETWEEN needs lower number first
4440            ($one_away, $further) = ($further, $one_away);
4441        }
4442        my ($id, $anum) =
4443            $dbr->selectrow_array("SELECT itemid FROM log WHERE ownerid=$jid ".
4444                                  "AND $field BETWEEN $one_away AND $further ".
4445                                  "ORDER BY $field $order LIMIT 1");
4446        return $id if $id;
4447    }
4448    return 0;
4449}
4450
4451
4452# <LJFUNC>
4453# name: LJ::get_itemid_after
4454# class:
4455# des:
4456# info:
4457# args:
4458# des-:
4459# returns:
4460# </LJFUNC>
4461sub get_itemid_after  { return get_itemid_near(@_, "after");  }
4462# <LJFUNC>
4463# name: LJ::get_itemid_before
4464# class:
4465# des:
4466# info:
4467# args:
4468# des-:
4469# returns:
4470# </LJFUNC>
4471sub get_itemid_before { return get_itemid_near(@_, "before"); }
4472
4473
4474sub get_itemid_near2
4475{
4476    my $u = shift;
4477    my $jitemid = shift;
4478    my $after_before = shift;
4479
4480    $jitemid += 0;
4481
4482    my ($inc, $order);
4483    if ($after_before eq "after") {
4484        ($inc, $order) = (-1, "DESC");
4485    } elsif ($after_before eq "before") {
4486        ($inc, $order) = (1, "ASC");
4487    } else {
4488        return 0;
4489    }
4490
4491    my $dbr = LJ::get_cluster_reader($u);
4492    my $jid = $u->{'userid'}+0;
4493    my $field = $u->{'journaltype'} eq "P" ? "revttime" : "rlogtime";
4494
4495    my $stime = $dbr->selectrow_array("SELECT $field FROM log2 WHERE ".
4496                                      "journalid=$jid AND jitemid=$jitemid");
4497    return 0 unless $stime;
4498
4499
4500    my $day = 86400;
4501    foreach my $distance ($day, $day*7, $day*30, $day*90) {
4502        my ($one_away, $further) = ($stime + $inc, $stime + $inc*$distance);
4503        if ($further < $one_away) {
4504            # swap them, BETWEEN needs lower number first
4505            ($one_away, $further) = ($further, $one_away);
4506        }
4507        my ($id, $anum) =
4508            $dbr->selectrow_array("SELECT jitemid, anum FROM log2 WHERE journalid=$jid ".
4509                                  "AND $field BETWEEN $one_away AND $further ".
4510                                  "ORDER BY $field $order LIMIT 1");
4511        if ($id) {
4512            return wantarray() ? ($id, $anum) : ($id*256 + $anum);
4513        }
4514    }
4515    return 0;
4516}
4517
4518sub get_itemid_after2  { return get_itemid_near2(@_, "after");  }
4519sub get_itemid_before2 { return get_itemid_near2(@_, "before"); }
4520
4521
4522# <LJFUNC>
4523# name: LJ::mysql_time
4524# des:
4525# class: time
4526# info:
4527# args:
4528# des-:
4529# returns:
4530# </LJFUNC>
4531sub mysql_time
4532{
4533    my $time = shift;
4534    $time ||= time();
4535    my @ltime = localtime($time);
4536    return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
4537                   $ltime[5]+1900,
4538                   $ltime[4]+1,
4539                   $ltime[3],
4540                   $ltime[2],
4541                   $ltime[1],
4542                   $ltime[0]);
4543}
4544
4545# <LJFUNC>
4546# name: LJ::get_keyword_id
4547# class:
4548# des:
4549# info:
4550# args:
4551# des-:
4552# returns:
4553# </LJFUNC>
4554sub get_keyword_id
4555{
4556    my $dbarg = shift;
4557    my $kw = shift;
4558    unless ($kw =~ /\S/) { return 0; }
4559    $kw = LJ::text_trim($kw, $LJ::BMAX_KEYWORD, $LJ::CMAX_KEYWORD);
4560
4561    my $dbs = LJ::make_dbs_from_arg($dbarg);
4562    my $dbh = $dbs->{'dbh'};
4563    my $dbr = $dbs->{'reader'};
4564
4565    my $qkw = $dbh->quote($kw);
4566
4567    # Making this a $dbr could cause problems due to the insertion of
4568    # data based on the results of this query. Leave as a $dbh.
4569    my $sth = $dbh->prepare("SELECT kwid FROM keywords WHERE keyword=$qkw");
4570    $sth->execute;
4571    my ($kwid) = $sth->fetchrow_array;
4572    unless ($kwid) {
4573        $sth = $dbh->prepare("INSERT INTO keywords (kwid, keyword) VALUES (NULL, $qkw)");
4574        $sth->execute;
4575        $kwid = $dbh->{'mysql_insertid'};
4576    }
4577    return $kwid;
4578}
4579
4580# <LJFUNC>
4581# name: LJ::trim
4582# class: text
4583# des: Removes whitespace from left and right side of a string.
4584# args: string
4585# des-string: string to be trimmed
4586# returns: string trimmed
4587# </LJFUNC>
4588sub trim
4589{
4590    my $a = $_[0];
4591    $a =~ s/^\s+//;
4592    $a =~ s/\s+$//;
4593    return $a;
4594}
4595
4596# <LJFUNC>
4597# name: LJ::delete_user
4598# class:
4599# des:
4600# info:
4601# args:
4602# des-:
4603# returns:
4604# </LJFUNC>
4605sub delete_user
4606{
4607                # TODO: Is this function even being called?
4608                # It doesn't look like it does anything useful
4609    my $dbh = shift;
4610    my $user = shift;
4611    my $quser = $dbh->quote($user);
4612    my $sth;
4613    $sth = $dbh->prepare("SELECT user, userid FROM useridmap WHERE user=$quser");
4614    my $u = $sth->fetchrow_hashref;
4615    unless ($u) { return; }
4616
4617    ### so many issues.
4618}
4619
4620# <LJFUNC>
4621# name: LJ::hash_password
4622# class:
4623# des:
4624# info:
4625# args:
4626# des-:
4627# returns:
4628# </LJFUNC>
4629sub hash_password
4630{
4631    return Digest::MD5::md5_hex($_[0]);
4632}
4633
4634# $dbarg can be either a $dbh (master) or a $dbs (db set, master & slave hashref)
4635# <LJFUNC>
4636# name: LJ::can_use_journal
4637# class:
4638# des:
4639# info:
4640# args:
4641# des-:
4642# returns:
4643# </LJFUNC>
4644sub can_use_journal
4645{
4646    my ($dbarg, $posterid, $reqownername, $res) = @_;
4647
4648    my $dbs = LJ::make_dbs_from_arg($dbarg);
4649    my $dbh = $dbs->{'dbh'};
4650    my $dbr = $dbs->{'reader'};
4651
4652    my $qposterid = $posterid+0;
4653
4654    ## find the journal owner's info
4655    my $uowner = LJ::load_user($dbs, $reqownername);
4656    unless ($uowner) {
4657        $res->{'errmsg'} = "Journal \"$reqownername\" does not exist.";
4658        return 0;
4659    }
4660    my $ownerid = $uowner->{'userid'};
4661
4662    ## check if user has access
4663    my $sql = "SELECT COUNT(*) FROM logaccess WHERE ownerid=$ownerid AND posterid=$qposterid";
4664    if ($dbr->selectrow_array($sql) || $dbh->selectrow_array($sql))
4665    {
4666        # the 'ownerid' necessity came first, way back when.  but then
4667        # with clusters, everything needed to know more, like the
4668        # journal's dversion and clusterid, so now it also returns the
4669        # user row.
4670        $res->{'ownerid'} = $ownerid;
4671        $res->{'u_owner'} = $uowner;
4672        return 1;
4673    } else {
4674        $res->{'errmsg'} = "You do not have access to post to this journal.";
4675        return 0;
4676    }
4677}
4678
4679# <LJFUNC>
4680# name: LJ::load_log_props
4681# class:
4682# des:
4683# info:
4684# args:
4685# des-:
4686# returns:
4687# </LJFUNC>
4688sub load_log_props
4689{
4690    my ($dbarg, $listref, $hashref) = @_;
4691
4692    my $dbs = make_dbs_from_arg($dbarg);
4693    my $dbr = $dbs->{'reader'};
4694
4695    my $itemin = join(", ", map { $_+0; } @{$listref});
4696    unless ($itemin) { return ; }
4697    unless (ref $hashref eq "HASH") { return; }
4698
4699    my $sth = $dbr->prepare("SELECT p.itemid, l.name, p.value ".
4700                            "FROM logprop p, logproplist l ".
4701                            "WHERE p.propid=l.propid AND p.itemid IN ($itemin)");
4702    $sth->execute;
4703    while ($_ = $sth->fetchrow_hashref) {
4704        $hashref->{$_->{'itemid'}}->{$_->{'name'}} = $_->{'value'};
4705    }
4706}
4707
4708# Note: requires caller to first call LJ::load_props($dbs, "log")
4709# <LJFUNC>
4710# name: LJ::load_log_props2
4711# class:
4712# des:
4713# info:
4714# args:
4715# des-:
4716# returns:
4717# </LJFUNC>
4718sub load_log_props2
4719{
4720    my ($db, $journalid, $listref, $hashref) = @_;
4721
4722    my $jitemin = join(", ", map { $_+0; } @$listref);
4723    return unless $jitemin;
4724    return unless ref $hashref eq "HASH";
4725    return unless defined $LJ::CACHE_PROPID{'log'};
4726
4727    my $sth = $db->prepare("SELECT jitemid, propid, value FROM logprop2 ".
4728                           "WHERE journalid=$journalid AND jitemid IN ($jitemin)");
4729    $sth->execute;
4730    while (my ($jitemid, $propid, $value) = $sth->fetchrow_array) {
4731        $hashref->{$jitemid}->{$LJ::CACHE_PROPID{'log'}->{$propid}->{'name'}} = $value;
4732    }
4733}
4734
4735# Note: requires caller to first call LJ::load_props($dbs, "log")
4736# <LJFUNC>
4737# name: LJ::load_log_props2multi
4738# class:
4739# des:
4740# info:
4741# args:
4742# des-:
4743# returns:
4744# </LJFUNC>
4745sub load_log_props2multi
4746{
4747    # ids by cluster (hashref),  output hashref (keys = "$ownerid $jitemid",
4748    # where ownerid could be 0 for unclustered)
4749    my ($dbs, $idsbyc, $hashref) = @_;
4750    my $sth;
4751    return unless ref $idsbyc eq "HASH";
4752    return unless defined $LJ::CACHE_PROPID{'log'};
4753
4754    foreach my $c (keys %$idsbyc)
4755    {
4756        if ($c) {
4757            # clustered:
4758            my $fattyin = join(" OR ", map {
4759                "(journalid=" . ($_->[0]+0) . " AND jitemid=" . ($_->[1]+0) . ")"
4760            } @{$idsbyc->{$c}});
4761            my $db = LJ::get_cluster_reader($c);
4762            $sth = $db->prepare("SELECT journalid, jitemid, propid, value ".
4763                                "FROM logprop2 WHERE $fattyin");
4764            $sth->execute;
4765            while (my ($jid, $jitemid, $propid, $value) = $sth->fetchrow_array) {
4766                $hashref->{"$jid $jitemid"}->{$LJ::CACHE_PROPID{'log'}->{$propid}->{'name'}} = $value;
4767            }
4768        } else {
4769            # unclustered:
4770            my $dbr = $dbs->{'reader'};
4771            my $in = join(",", map { $_+0 } @{$idsbyc->{'0'}});
4772            $sth = $dbr->prepare("SELECT itemid, propid, value FROM logprop ".
4773                                 "WHERE itemid IN ($in)");
4774            $sth->execute;
4775            while (my ($itemid, $propid, $value) = $sth->fetchrow_array) {
4776                $hashref->{"0 $itemid"}->{$LJ::CACHE_PROPID{'log'}->{$propid}->{'name'}} = $value;
4777            }
4778
4779        }
4780    }
4781    foreach my $c (keys %$idsbyc)
4782    {
4783        if ($c) {
4784            # clustered:
4785            my $fattyin = join(" OR ", map {
4786                "(journalid=" . ($_->[0]+0) . " AND jitemid=" . ($_->[1]+0) . ")"
4787            } @{$idsbyc->{$c}});
4788            my $db = LJ::get_cluster_reader($c);
4789            $sth = $db->prepare("SELECT journalid, jitemid, propid, value ".
4790                                "FROM logprop2 WHERE $fattyin");
4791            $sth->execute;
4792            while (my ($jid, $jitemid, $propid, $value) = $sth->fetchrow_array) {
4793                $hashref->{"$jid $jitemid"}->{$LJ::CACHE_PROPID{'log'}->{$propid}->{'name'}} = $value;
4794            }
4795        } else {
4796            # unclustered:
4797            my $dbr = $dbs->{'reader'};
4798            my $in = join(",", map { $_+0 } @{$idsbyc->{'0'}});
4799            $sth = $dbr->prepare("SELECT itemid, propid, value FROM logprop ".
4800                                 "WHERE itemid IN ($in)");
4801            $sth->execute;
4802            while (my ($itemid, $propid, $value) = $sth->fetchrow_array) {
4803                $hashref->{"0 $itemid"}->{$LJ::CACHE_PROPID{'log'}->{$propid}->{'name'}} = $value;
4804            }
4805
4806        }
4807    }
4808}
4809
4810# <LJFUNC>
4811# name: LJ::load_talk_props
4812# class:
4813# des:
4814# info:
4815# args:
4816# des-:
4817# returns:
4818# </LJFUNC>
4819sub load_talk_props
4820{
4821    my ($dbarg, $listref, $hashref) = @_;
4822    my $itemin = join(", ", map { $_+0; } @{$listref});
4823    unless ($itemin) { return ; }
4824    unless (ref $hashref eq "HASH") { return; }
4825
4826    my $dbs = make_dbs_from_arg($dbarg);
4827    my $dbh = $dbs->{'dbh'};
4828    my $dbr = $dbs->{'reader'};
4829
4830    my $sth = $dbr->prepare("SELECT tp.talkid, tpl.name, tp.value ".
4831                            "FROM talkproplist tpl, talkprop tp ".
4832                            "WHERE tp.tpropid=tpl.tpropid ".
4833                            "AND tp.talkid IN ($itemin)");
4834    $sth->execute;
4835    while (my ($id, $name, $val) = $sth->fetchrow_array) {
4836        $hashref->{$id}->{$name} = $val;
4837    }
4838}
4839
4840# Note: requires caller to first call LJ::load_props($dbs, "talk")
4841# <LJFUNC>
4842# name: LJ::load_talk_props2
4843# class:
4844# des:
4845# info:
4846# args:
4847# des-:
4848# returns:
4849# </LJFUNC>
4850sub load_talk_props2
4851{
4852    my ($db, $journalid, $listref, $hashref) = @_;
4853
4854    my $in = join(", ", map { $_+0; } @$listref);
4855    return unless $in;
4856    die "Last param not hash" unless ref $hashref eq "HASH";
4857    die "talkprops not loaded" unless defined $LJ::CACHE_PROPID{'talk'};
4858
4859    my $sth = $db->prepare("SELECT jtalkid, tpropid, value FROM talkprop2 ".
4860                           "WHERE journalid=$journalid AND jtalkid IN ($in)");
4861    $sth->execute;
4862    while (my ($jtalkid, $propid, $value) = $sth->fetchrow_array) {
4863        my $p = $LJ::CACHE_PROPID{'talk'}->{$propid};
4864        next unless $p;
4865        $hashref->{$jtalkid}->{$p->{'name'}} = $value;
4866    }
4867}
4868
4869# <LJFUNC>
4870# name: LJ::eurl
4871# class: text
4872# des: Escapes a value before it can be put in a URL.  See also [func[LJ::durl]].
4873# args: string
4874# des-string: string to be escaped
4875# returns: string escaped
4876# </LJFUNC>
4877sub eurl
4878{
4879    my $a = $_[0];
4880    $a =~ s/([^a-zA-Z0-9_\,\-.\/\\\: ])/uc sprintf("%%%02x",ord($1))/eg;
4881    $a =~ tr/ /+/;
4882    return $a;
4883}
4884
4885# <LJFUNC>
4886# name: LJ::durl
4887# class: text
4888# des: Decodes a value that's URL-escaped.  See also [func[LJ::eurl]].
4889# args: string
4890# des-string: string to be decoded
4891# returns: string decoded
4892# </LJFUNC>
4893sub durl
4894{
4895    my ($a) = @_;
4896    $a =~ tr/+/ /;
4897    $a =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
4898    return $a;
4899}
4900
4901# <LJFUNC>
4902# name: LJ::exml
4903# class: text
4904# des: Escapes a value before it can be put in XML.
4905# args: string
4906# des-string: string to be escaped
4907# returns: string escaped.
4908# </LJFUNC>
4909sub exml
4910{
4911    my $a = shift;
4912    $a =~ s/\&/&amp;/g;
4913    $a =~ s/\"/&quot;/g;
4914    $a =~ s/\'/&apos;/g;
4915    $a =~ s/</&lt;/g;
4916    $a =~ s/>/&gt;/g;
4917    return $a;
4918}
4919
4920# <LJFUNC>
4921# name: LJ::ehtml
4922# class: text
4923# des: Escapes a value before it can be put in HTML.
4924# args: string
4925# des-string: string to be escaped
4926# returns: string escaped.
4927# </LJFUNC>
4928sub ehtml
4929{
4930    my $a = $_[0];
4931    $a =~ s/\&/&amp;/g;
4932    $a =~ s/\"/&quot;/g;
4933    $a =~ s/\'/&\#39;/g;
4934    $a =~ s/</&lt;/g;
4935    $a =~ s/>/&gt;/g;
4936    return $a;
4937}
4938
4939
4940# <LJFUNC>
4941# name: LJ::eall
4942# class: text
4943# des: Escapes HTML and BML.
4944# args: text
4945# des-text: Text to escape.
4946# returns: Escaped text.
4947# </LJFUNC>
4948sub eall
4949{
4950    my $a = shift;
4951
4952    ### escape HTML
4953    $a =~ s/\&/&amp;/g;
4954    $a =~ s/\"/&quot;/g;
4955    $a =~ s/</&lt;/g;
4956    $a =~ s/>/&gt;/g;
4957
4958    ### and escape BML
4959    $a =~ s/\(=/\(&\#0061;/g;
4960    $a =~ s/=\)/&\#0061;\)/g;
4961    return $a;
4962}
4963
4964# <LJFUNC>
4965# name: LJ::days_in_month
4966# class: time
4967# des: Figures out the number of days in a month.
4968# args: month, year?
4969# des-month: Month
4970# des-year: Year.  Necessary for February.  If undefined or zero, function
4971#           will return 29.
4972# returns: Number of days in that month in that year.
4973# </LJFUNC>
4974sub days_in_month
4975{
4976    my ($month, $year) = @_;
4977    if ($month == 2)
4978    {
4979        return 29 unless $year;  # assume largest
4980        if ($year % 4 == 0)
4981        {
4982          # years divisible by 400 are leap years
4983          return 29 if ($year % 400 == 0);
4984
4985          # if they're divisible by 100, they aren't.
4986          return 28 if ($year % 100 == 0);
4987
4988          # otherwise, if divisible by 4, they are.
4989          return 29;
4990        }
4991    }
4992    return ((31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)[$month-1]);
4993}
4994
4995# <LJFUNC>
4996# name: LJ::delete_item
4997# des: Deletes a journal item from a user's journal that resides in the old schema (cluster0).
4998# info: This function is deprecated, just as the old schema is deprecated.  In a
4999#       few months this function will be removed.  The new equivalent to this
5000#       function is [func[LJ::delete_item2]].
5001# args: dbarg, journalid, itemid, quick?, deleter?
5002# des-journalid: Userid of journal to delete item from.
5003# des-itemid: Itemid of item to delete.
5004# des-quick: Optional flag to make the delete be a little quicker when many deletes
5005#            are occuring.  It just doesn't update lastitemid in [dbtable[userusage]].
5006# des-deleter: Optional code reference to run to handle a deletion.  Mass-delete
5007#              tools can use this to batch deletes in table locks for speed.  Arguments
5008#              to this coderef are ($tablename, $col, @ids).  The default implementation
5009#              is: "DELETE FROM $table WHERE $col IN (@ids)"
5010# returns:
5011# </LJFUNC>
5012sub delete_item
5013{
5014    my ($dbarg, $ownerid, $itemid, $quick, $deleter) = @_;
5015    my $sth;
5016
5017    my $dbs = make_dbs_from_arg($dbarg);
5018    my $dbh = $dbs->{'dbh'};
5019    my $dbr = $dbs->{'reader'};
5020
5021    $ownerid += 0;
5022    $itemid += 0;
5023
5024    $deleter ||= sub {
5025        my $table = shift;
5026        my $col = shift;
5027        my @ids = @_;
5028        return unless @ids;
5029        my $in = join(",", @ids);
5030        $dbh->do("DELETE FROM $table WHERE $col IN ($in)");
5031    };
5032
5033    $deleter->("memorable", "itemid", $itemid);
5034    $dbh->do("UPDATE userusage SET lastitemid=0 WHERE userid=$ownerid AND lastitemid=$itemid") unless ($quick);
5035    foreach my $t (qw(log logtext logsubject logprop)) {
5036        $deleter->($t, "itemid", $itemid);
5037    }
5038    $dbh->do("DELETE FROM logsec WHERE ownerid=$ownerid AND itemid=$itemid");
5039
5040    my @talkids = ();
5041    $sth = $dbh->prepare("SELECT talkid FROM talk WHERE nodetype='L' AND nodeid=$itemid");
5042    $sth->execute;
5043    push @talkids, $_ while ($_ = $sth->fetchrow_array);
5044    foreach my $t (qw(talk talktext talkprop)) {
5045        $deleter->($t, "talkid", @talkids);
5046    }
5047}
5048
5049# <LJFUNC>
5050# name: LJ::delete_item2
5051# des: Deletes a user's journal item from a cluster.
5052# args: dbh, dbcm, journalid, jitemid, quick?, anum?
5053# des-journalid: Journal ID item is in.
5054# des-jitemid: Journal itemid of item to delete.
5055# des-quick: Optional boolean.  If set, only [dbtable[log2]] table
5056#            is deleted from and the rest of the content is deleted
5057#            later using [func[LJ::cmd_buffer_add]].
5058# des-anum: The log item's anum, which'll be needed to delete lazily
5059#           some data in tables which includes the anum, but the
5060#           log row will already be gone so we'll need to store it for later.
5061# returns: boolean; 1 on success, 0 on failure.
5062# </LJFUNC>
5063sub delete_item2
5064{
5065    my ($dbh, $dbcm, $jid, $jitemid, $quick, $anum) = @_;
5066    $jid += 0; $jitemid += 0;
5067
5068    $dbcm->do("DELETE FROM log2 WHERE journalid=$jid AND jitemid=$jitemid");
5069
5070    return LJ::cmd_buffer_add($dbcm, $jid, "delitem", {
5071        'itemid' => $jitemid,
5072        'anum' => $anum,
5073    }) if $quick;
5074
5075    # delete from clusters
5076    foreach my $t (qw(logtext2 logprop2 logsec2 logsubject2)) {
5077        $dbcm->do("DELETE FROM $t WHERE journalid=$jid AND jitemid=$jitemid");
5078    }
5079    LJ::dudata_set($dbcm, $jid, 'L', $jitemid, 0);
5080
5081    # delete stuff from meta cluster
5082    my $aitemid = $jitemid * 256 + $anum;
5083    foreach my $t (qw(memorable topic_map)) {
5084        $dbh->do("DELETE FROM $t WHERE journalid=$jid AND jitemid=$aitemid");
5085    }
5086
5087    # delete comments
5088    my ($t, $loop) = (undef, 1);
5089    while ($loop &&
5090           ($t = $dbcm->selectcol_arrayref("SELECT jtalkid FROM talk2 WHERE ".
5091                                           "nodetype='L' AND journalid=$jid ".
5092                                           "AND nodeid=$jitemid LIMIT 50"))
5093           && $t && @$t)
5094    {
5095        foreach my $jtalkid (@$t) {
5096            LJ::delete_talkitem($dbcm, $jid, $jtalkid);
5097        }
5098        $loop = 0 unless @$t == 50;
5099    }
5100    return 1;
5101}
5102
5103# <LJFUNC>
5104# name: LJ::delete_talkitem
5105# des: Deletes a comment and associated metadata.
5106# info: The tables [dbtable[talk2]], [dbtabke[talkprop2]], [dbtable[talktext2]],
5107#       and [dbtable[dudata]] are all
5108#       deleted from, immediately. Unlike [func[LJ::delete_item2]], there is
5109#       no $quick flag to queue the delete for later, nor is one really
5110#       necessary, since deleting from 4 tables won't be too slow.
5111# args: dbcm, journalid, jtalkid, light?
5112# des-journalid: Journalid (userid from [dbtable[user]] to delete comment from).
5113#                The journal must reside on the $dbcm you provide.
5114# des-jtalkid: The jtalkid of the comment.
5115# des-dbcm: Cluster master db to delete item from.
5116# des-light: boolean; if true, only mark entry as deleted, so children will thread.
5117# returns: boolean; 1 on success, 0 on failure.# des-dbh: Master database handle.
5118# </LJFUNC>
5119sub delete_talkitem
5120{
5121    my ($dbcm, $jid, $jtalkid, $light) = @_;
5122    $jid += 0; $jtalkid += 0;
5123
5124    my $where = "WHERE journalid=$jid AND jtalkid=$jtalkid";
5125    my @delfrom = qw(talkprop2);
5126    if ($light) {
5127        $dbcm->do("UPDATE talk2 SET state='D' $where");
5128        $dbcm->do("UPDATE talktext2 SET subject=NULL, body=NULL $where");
5129    } else {
5130        push @delfrom, qw(talk2 talktext2);
5131    }
5132
5133    foreach my $t (@delfrom) {
5134        $dbcm->do("DELETE FROM $t $where");
5135        return 0 if $dbcm->err;
5136    }
5137    LJ::dudata_set($dbcm, $jid, 'T', $jtalkid, 0);
5138    return 0 if $dbcm->err;
5139    return 1;
5140}
5141
5142# <LJFUNC>
5143# name: LJ::alldateparts_to_hash
5144# class: s1
5145# des: Given a date/time format from MySQL, breaks it into a hash.
5146# info: This is used by S1.
5147# args: alldatepart
5148# des-alldatepart: The output of the MySQL function
5149#                  DATE_FORMAT(sometime, "%a %W %b %M %y %Y %c %m %e %d
5150#                  %D %p %i %l %h %k %H")
5151# returns: Hash (whole, not reference), with keys: dayshort, daylong,
5152#          monshort, monlong, yy, yyyy, m, mm, d, dd, dth, ap, AP,
5153#          ampm, AMPM, min, 12h, 12hh, 24h, 24hh
5154
5155# </LJFUNC>
5156sub alldateparts_to_hash
5157{
5158    my $alldatepart = shift;
5159    my @dateparts = split(/ /, $alldatepart);
5160    return (
5161            'dayshort' => $dateparts[0],
5162            'daylong' => $dateparts[1],
5163            'monshort' => $dateparts[2],
5164            'monlong' => $dateparts[3],
5165            'yy' => $dateparts[4],
5166            'yyyy' => $dateparts[5],
5167            'm' => $dateparts[6],
5168            'mm' => $dateparts[7],
5169            'd' => $dateparts[8],
5170            'dd' => $dateparts[9],
5171            'dth' => $dateparts[10],
5172            'ap' => substr(lc($dateparts[11]),0,1),
5173            'AP' => substr(uc($dateparts[11]),0,1),
5174            'ampm' => lc($dateparts[11]),
5175            'AMPM' => $dateparts[11],
5176            'min' => $dateparts[12],
5177            '12h' => $dateparts[13],
5178            '12hh' => $dateparts[14],
5179            '24h' => $dateparts[15],
5180            '24hh' => $dateparts[16],
5181            );
5182}
5183
5184# <LJFUNC>
5185# name: LJ::dudata_set
5186# class: logging
5187# des: Record or delete disk usage data for a journal
5188# args: dbcm, journalid, area, areaid, bytes
5189# journalid: Journal userid to record space for.
5190# area: One character: "L" for log, "T" for talk, "B" for bio, "P" for pic.
5191# areaid: Unique ID within $area, or '0' if area has no ids (like bio)
5192# bytes: Number of bytes item takes up.  Or 0 to delete record.
5193# returns: 1.
5194# </LJFUNC>
5195sub dudata_set
5196{
5197    my ($dbcm, $journalid, $area, $areaid, $bytes) = @_;
5198    $bytes += 0; $areaid += 0; $journalid += 0;
5199    $area = $dbcm->quote($area);
5200    if ($bytes) {
5201        $dbcm->do("REPLACE INTO dudata (userid, area, areaid, bytes) ".
5202                  "VALUES ($journalid, $area, $areaid, $bytes)");
5203    } else {
5204        $dbcm->do("DELETE FROM dudata WHERE userid=$journalid AND ".
5205                  "area=$area AND areaid=$areaid");
5206    }
5207    return 1;
5208}
5209
5210# <LJFUNC>
5211# name: LJ::color_fromdb
5212# des: Takes a value of unknown type from the db and returns an #rrggbb string.
5213# args: color
5214# des-color: either a 24-bit decimal number, or an #rrggbb string.
5215# returns: scalar; #rrggbb string, or undef if unknown input format
5216# </LJFUNC>
5217sub color_fromdb
5218{
5219    my $c = shift;
5220    return $c if $c =~ /^\#[0-9a-f]{6,6}$/i;
5221    return sprintf("\#%06x", $c) if $c =~ /^\d+$/;
5222    return undef;
5223}
5224
5225# <LJFUNC>
5226# name: LJ::color_todb
5227# des: Takes an #rrggbb value and returns a 24-bit decimal number.
5228# args: color
5229# des-color: scalar; an #rrggbb string.
5230# returns: undef if bogus color, else scalar; 24-bit decimal number, can be up to 8 chars wide as a string.
5231# </LJFUNC>
5232sub color_todb
5233{
5234    my $c = shift;
5235    return undef unless $c =~ /^\#[0-9a-f]{6,6}$/i;
5236    return hex(substr($c, 1, 6));
5237}
5238
5239# <LJFUNC>
5240# name: LJ::add_friend
5241# des: Simple interface to add a friend edge.
5242# args: dbh, userida, useridb
5243# des-userida: Userid of source user (befriender)
5244# des-useridb: Userid of target user (befriendee)
5245# returns: boolean; 1 on success (or already friend), 0 on failure (bogus args)
5246# </LJFUNC>
5247sub add_friend
5248{
5249    my ($dbh, $ida, $idb) = @_;
5250    return 0 unless $dbh;
5251    return 0 unless $ida =~ /^\d+$/ && $ida;
5252    return 0 unless $idb =~ /^\d+$/ && $idb;
5253    my $black = LJ::color_todb("#000000");
5254    my $white = LJ::color_todb("#ffffff");
5255    $dbh->do("INSERT INTO friends (userid, friendid, fgcolor, bgcolor, groupmask) ".
5256             "VALUES ($ida, $idb, $black, $white, 1)");
5257    return 1;
5258}
5259
5260# <LJFUNC>
5261# name: LJ::event_register
5262# des: Logs a subscribable event, if anybody's subscribed to it.
5263# args: dbarg, dbc, etype, ejid, eiarg, duserid, diarg
5264# des-dbc: Cluster master of event
5265# des-type: One character event type.
5266# des-ejid: Journalid event occured in.
5267# des-eiarg: 4 byte numeric argument
5268# des-duserid: Event doer's userid
5269# des-diarg: Event's 4 byte numeric argument
5270# returns: boolean; 1 on success; 0 on fail.
5271# </LJFUNC>
5272sub event_register
5273{
5274    my ($dbarg, $dbc, $etype, $ejid, $eiarg, $duserid, $diarg) = @_;
5275    my $dbs = make_dbs_from_arg($dbarg);
5276    my $dbh = $dbs->{'dbh'};
5277    my $dbr = $dbs->{'reader'};
5278
5279    # see if any subscribers first of all (reads cheap; writes slow)
5280    return 0 unless $dbr;
5281    my $qetype = $dbr->quote($etype);
5282    my $qejid = $ejid+0;
5283    my $qeiarg = $eiarg+0;
5284    my $qduserid = $duserid+0;
5285    my $qdiarg = $diarg+0;
5286
5287    my $has_sub = $dbr->selectrow_array("SELECT userid FROM subs WHERE etype=$qetype AND ".
5288                                        "ejournalid=$qejid AND eiarg=$qeiarg LIMIT 1");
5289    return 1 unless $has_sub;
5290
5291    # so we're going to need to log this event
5292    return 0 unless $dbc;
5293    $dbc->do("INSERT INTO events (evtime, etype, ejournalid, eiarg, duserid, diarg) ".
5294             "VALUES (NOW(), $qetype, $qejid, $qeiarg, $qduserid, $qdiarg)");
5295    return $dbc->err ? 0 : 1;
5296}
5297
5298# <LJFUNC>
5299# name: LJ::is_ascii
5300# des: checks if text is pure ASCII
5301# args: text
5302# des-text: text to check for being pure 7-bit ASCII text
5303# returns: 1 if text is indeed pure 7-bit, 0 otherwise.
5304# </LJFUNC>
5305sub is_ascii {
5306    my $text = shift;
5307    return ($text !~ m/[\x00\x80-\xff]/);
5308}
5309
5310# <LJFUNC>
5311# name: LJ::is_utf8
5312# des: check text for UTF-8 validity
5313# args: text
5314# des-text: text to check for UTF-8 validity
5315# returns: 1 if text is a valid UTF-8 stream, 0 otherwise.
5316# </LJFUNC>
5317sub is_utf8 {
5318    my $text = shift;
5319
5320    if (LJ::are_hooks("is_utf8")) {
5321        my @r = LJ::run_hooks("is_utf8", $text);
5322        return 0 if grep { ! $_->[0] } @r;
5323        return 1;
5324    }
5325    else {
5326        $text =~ m/^([\x00-\x7f]|[\xc2-\xdf][\x80-\xbf]|\xe0[\xa0-\xbf][\x80-\xbf]|[\xe1-\xef][\x80-\xbf][\x80-\xbf]|\xf0[\x90-\xbf][\x80-\xbf][\x80-\xbf]|[\xf1-\xf7][\x80-\xbf][\x80-\xbf][\x80-\xbf])*(.*)/;
5327
5328        return 1 unless $2;
5329        return 0;
5330    }
5331}
5332
5333# <LJFUNC>
5334# name: LJ::text_out
5335# des: force outgoing text into valid UTF-8
5336# args: text
5337# des-text: reference to text to pass to output. Text if modified in-place.
5338# returns: nothing.
5339# </LJFUNC>
5340sub text_out
5341{
5342    my $rtext = shift;
5343
5344    # if we're not Unicode, do nothing
5345    return unless $LJ::UNICODE;
5346
5347    # is this valid UTF-8 already?
5348    return if LJ::is_utf8($$rtext);
5349
5350    # no. Blot out all non-ASCII chars
5351    $$rtext =~ s/[\x00\x80-\xff]/\?/g;
5352    return;
5353}
5354
5355# <LJFUNC>
5356# name: LJ::text_in
5357# des: do appropriate checks on input text. Should be called on all
5358#      user-generated text.
5359# args: text
5360# des-text: text to check
5361# returns: 1 if the text is valid, 0 if not.
5362# </LJFUNC>
5363sub text_in
5364{
5365    my $text = shift;
5366    return 1 unless $LJ::UNICODE;
5367    if (ref ($text) eq "HASH") {
5368        return ! (grep { !LJ::is_utf8($_) } values %{$text});
5369    }
5370    return LJ::is_utf8($text);
5371}
5372
5373# <LJFUNC>
5374# name: LJ::text_convert
5375# des: convert old entries/comments to UTF-8 using user's default encoding
5376# args: dbs, text, u, error
5377# des-text: old possibly non-ASCII text to convert
5378# des-u: user hashref of the journal's owner
5379# des-error: ref to a scalar variable which is set to 1 on error
5380#            (when user has no default encoding defined, but
5381#            text needs to be translated)
5382# returns: converted text or undef on error
5383# </LJFUNC>
5384sub text_convert
5385{
5386    my ($dbs, $text, $u, $error) = @_;
5387
5388    # maybe it's pure ASCII?
5389    return $text if LJ::is_ascii($text);
5390
5391    # load encoding id->name mapping if it's not loaded yet
5392    LJ::load_codes($dbs, { "encoding" => \%LJ::CACHE_ENCODINGS } )
5393        unless %LJ::CACHE_ENCODINGS;
5394
5395    if ($u->{'oldenc'} == 0 ||
5396        not defined $LJ::CACHE_ENCODINGS{$u->{'oldenc'}}) {
5397        $$error = 1;
5398        return undef;
5399    };
5400
5401    # convert!
5402    my $name = $LJ::CACHE_ENCODINGS{$u->{'oldenc'}};
5403    unless (Unicode::MapUTF8::utf8_supported_charset($name)) {
5404        $$error = 1;
5405        return undef;
5406    }
5407
5408    return Unicode::MapUTF8::to_utf8({-string=>$text, -charset=>$name});
5409}
5410
5411
5412# <LJFUNC>
5413# name: LJ::text_trim
5414# des: truncate string according to requirements on byte length, char
5415#      length, or both. "char length" means number of UTF-8 characters if
5416#      $LJ::UNICODE is set, or the same thing as byte length otherwise.
5417# args: text, byte_max, char_max
5418# des-text: the string to trim
5419# des-byte_max: maximum allowed length in bytes; if 0, there's no restriction
5420# des-char_max: maximum allowed length in chars; if 0, there's no restriction
5421# returns: the truncated string.
5422# </LJFUNC>
5423sub text_trim
5424{
5425    my ($text, $byte_max, $char_max) = @_;
5426    return $text unless $byte_max or $char_max;
5427    if ($char_max == 0 || !$LJ::UNICODE) {
5428        $byte_max = $char_max if $char_max and $char_max < $byte_max;
5429        $byte_max = $char_max unless $byte_max;
5430        return substr($text, 0, $byte_max);
5431    }
5432    my $cur = 0;
5433    my $utf_char = "([\x00-\x7f]|[\xc0-\xdf].|[\xe0-\xef]..|[\xf0-\xf7]...)";
5434
5435    while ($text =~ m/$utf_char/gco) {
5436        last unless $char_max;
5437        last if $cur + length($1) > $byte_max and $byte_max;
5438        $cur += length($1);
5439        $char_max--;
5440    }
5441    return substr($text,0,$cur);
5442}
5443
5444# <LJFUNC>
5445# name: LJ::item_toutf8
5446# des: convert one item's subject, text and props to UTF8.
5447#      item can be an entry or a comment (in which cases props can be
5448#      left empty, since there are no 8bit talkprops).
5449# args: dbs, u, subject, text, props
5450# des-u: user hashref of the journal's owner
5451# des-subject: ref to the item's subject
5452# des-text: ref to the item's text
5453# des-props: hashref of the item's props
5454# returns: nothing.
5455# </LJFUNC>
5456sub item_toutf8
5457{
5458    my ($dbs, $u, $subject, $text, $props) = @_;
5459    return unless $LJ::UNICODE;
5460
5461    my $convert = sub {
5462        my $rtext = shift;
5463        my $error = 0;
5464        my $res = LJ::text_convert($dbs, $$rtext, $u, \$error);
5465        if ($error) {
5466            LJ::text_out($rtext);
5467        } else {
5468            $$rtext = $res;
5469        };
5470        return;
5471    };
5472
5473    $convert->($subject);
5474    $convert->($text);
5475    foreach(keys %$props) {
5476        $convert->(\$props->{$_});
5477    }
5478    return;
5479}
5480
5481# <LJFUNC>
5482# name: LJ::set_interests
5483# des: Change a user's interests
5484# args: dbh, userid, old, new
5485# arg-old: hashref of old interests (hasing being interest => intid)
5486# arg-new: listref of new interests
5487# returns: 1
5488# </LJFUNC>
5489sub set_interests
5490{
5491    my ($dbarg, $userid, $old, $new) = @_;
5492    my $dbs = make_dbs_from_arg($dbarg);
5493    my $dbh = $dbs->{'dbh'};
5494    my $dbr = $dbs->{'reader'};
5495
5496    my %int_new = ();
5497    my %int_del = %$old;  # assume deleting everything, unless in @$new
5498
5499    foreach my $int (@$new)
5500    {
5501        $int = lc($int);       # FIXME: use utf8?
5502        $int =~ s/^i like //;  # *sigh*
5503        next unless $int;
5504        next if $int =~ / .+ .+ .+ /;  # prevent sentences
5505        next if $int =~ /[\<\>]/;
5506        next if length($int) > 35;
5507        $int_new{$int} = 1 unless $old->{$int};
5508        delete $int_del{$int};
5509    }
5510
5511    ### were interests removed?
5512    if (%int_del)
5513    {
5514        ## easy, we know their IDs, so delete them en masse
5515        my $intid_in = join(", ", values %int_del);
5516        $dbh->do("DELETE FROM userinterests WHERE userid=$userid AND intid IN ($intid_in)");
5517        $dbh->do("UPDATE interests SET intcount=intcount-1 WHERE intid IN ($intid_in)");
5518    }
5519
5520    ### do we have new interests to add?
5521    if (%int_new)
5522    {
5523        ## difficult, have to find intids of interests, and create new ints for interests
5524        ## that nobody has ever entered before
5525        my $int_in = join(", ", map { $dbh->quote($_); } keys %int_new);
5526        my %int_exist;
5527        my @new_intids = ();  ## existing IDs we'll add for this user
5528
5529        ## find existing IDs
5530        my $sth = $dbr->prepare("SELECT interest, intid FROM interests WHERE interest IN ($int_in)");
5531        $sth->execute;
5532        while ($_ = $sth->fetchrow_hashref) {
5533            push @new_intids, $_->{'intid'};     # - we'll add this later.
5534            delete $int_new{$_->{'interest'}};   # - so we don't have to make a new intid for
5535                                                 #   this next pass.
5536        }
5537
5538        if (@new_intids) {
5539            my $sql = "";
5540            foreach my $newid (@new_intids) {
5541                if ($sql) { $sql .= ", "; }
5542                else { $sql = "REPLACE INTO userinterests (userid, intid) VALUES "; }
5543                $sql .= "($userid, $newid)";
5544            }
5545            $dbh->do($sql);
5546
5547            my $intid_in = join(", ", @new_intids);
5548            $dbh->do("UPDATE interests SET intcount=intcount+1 WHERE intid IN ($intid_in)");
5549        }
5550    }
5551
5552    ### do we STILL have interests to add?  (must make new intids)
5553    if (%int_new)
5554    {
5555        foreach my $int (keys %int_new)
5556        {
5557            my $intid;
5558            my $qint = $dbh->quote($int);
5559
5560            $dbh->do("INSERT INTO interests (intid, intcount, interest) ".
5561                     "VALUES (NULL, 1, $qint)");
5562            if ($dbh->err) {
5563                # somebody beat us to creating it.  find its id.
5564                $intid = $dbh->selectrow_array("SELECT intid FROM interests WHERE interest=$qint");
5565                $dbh->do("UPDATE interests SET intcount=intcount+1 WHERE intid=$intid");
5566            } else {
5567                # newly created
5568                $intid = $dbh->{'mysql_insertid'};
5569            }
5570            if ($intid) {
5571                ## now we can actually insert it into the userinterests table:
5572                $dbh->do("INSERT INTO userinterests (userid, intid) ".
5573                         "VALUES ($userid, $intid)");
5574            }
5575        }
5576    }
5577    return 1;
5578}
5579
55801;
Note: See TracBrowser for help on using the browser.