#!/usr/bin/perl
#
package LJ;
use strict;
# load the bread crumb hash
require "$ENV{'LJHOME'}/cgi-bin/crumbs.pl";
#
# name: LJ::img
# des: Returns an HTML <img> or <input> tag to an named image
# code, which each site may define with a different image file with
# its own dimensions. This prevents hard-coding filenames & sizes
# into the source. The real image data is stored in LJ::Img, which
# has default values provided in cgi-bin/imageconf.pl but can be
# overridden in cgi-bin/ljconfig.pl.
# args: imagecode, type?, attrs?
# des-imagecode: The unique string key to reference the image. Not a filename,
# but the purpose or location of the image.
# des-type: By default, the tag returned is an <img> tag, but if 'type'
# is "input", then an input tag is returned.
# des-attrs: Optional hashref of other attributes. If this isn't a hashref,
# then it's assumed to be a scalar for the 'name' attribute for
# input controls.
#
sub img
{
my $ic = shift;
my $type = shift; # either "" or "input"
my $attr = shift;
my $attrs;
if ($attr) {
if (ref $attr eq "HASH") {
foreach (keys %$attr) {
$attrs .= " $_=\"" . LJ::ehtml($attr->{$_}) . "\"";
}
} else {
$attrs = " name=\"$attr\"";
}
}
my $i = $LJ::Img::img{$ic};
if ($type eq "") {
return "{'src'}\" width=\"$i->{'width'}\" ".
"height=\"$i->{'height'}\" alt=\"$i->{'alt'}\" title=\"$i->{'alt'}\" ".
"border='0'$attrs />";
}
if ($type eq "input") {
return "{'src'}\" ".
"width=\"$i->{'width'}\" height=\"$i->{'height'}\" title=\"$i->{'alt'}\" ".
"alt=\"$i->{'alt'}\" border='0'$attrs />";
}
return "XXX";
}
#
# name: LJ::date_to_view_links
# class: component
# des: Returns HTML of date with links to user's journal.
# args: u, date
# des-date: date in yyyy-mm-dd form.
# returns: HTML with yyy, mm, and dd all links to respective views.
#
sub date_to_view_links
{
my ($u, $date) = @_;
return unless $date =~ /^(\d\d\d\d)-(\d\d)-(\d\d)/;
my ($y, $m, $d) = ($1, $2, $3);
my ($nm, $nd) = ($m+0, $d+0); # numeric, without leading zeros
my $user = $u->{'user'};
my $base = LJ::journal_base($u);
my $ret;
$ret .= "$y-";
$ret .= "$m-";
$ret .= "$d";
return $ret;
}
#
# name: LJ::auto_linkify
# des: Takes a plain-text string and changes URLs into tags (auto-linkification)
# args: str
# arg-str: The string to perform auto-linkification on.
# returns: The auto-linkified text.
#
sub auto_linkify
{
my $str = shift;
my $match = sub {
my $str = shift;
if ($str =~ /^(.*?)(&(#39|quot|lt|gt)(;.*)?)$/) {
return "$1$2";
} else {
return "$str";
}
};
$str =~ s!https?://[^\s\'\"\<\>]+[a-zA-Z0-9_/&=\-]! $match->($&); !ge;
return $str;
}
#
# name: LJ::make_authas_select
# des: Given a u object and some options, determines which users the given user
# can switch to. If the list exists, returns a select list and a submit
# button with labels. Otherwise returns a hidden element.
# returns: string of html elements
# args: u, opts?
# des-opts: Optional. Valid keys are:
# 'authas' - current user, gets selected in drop-down
# 'label' - label to go before form elements
# 'button' - button label for submit button
# others - arguments to pass to LJ::get_authas_list
#
sub make_authas_select {
my ($u, $opts) = @_; # type, authas, label, button
my @list = LJ::get_authas_list($u, $opts);
# only do most of form if there are options to select from
if (@list > 1) {
return ($opts->{'label'} || 'Work as user:') . " " .
LJ::html_select({ 'name' => 'authas',
'selected' => $opts->{'authas'} || $u->{'user'}},
map { $_, $_ } @list) . " " .
LJ::html_submit(undef, $opts->{'button'} || 'Switch');
}
# no communities to choose from, give the caller a hidden
return LJ::html_hidden('authas', $opts->{'authas'} || $u->{'user'});
}
#
# name: LJ::help_icon
# des: Returns BML to show a help link/icon given a help topic, or nothing
# if the site hasn't defined a URL for that topic. Optional arguments
# include HTML/BML to place before and after the link/icon, should it
# be returned.
# args: topic, pre?, post?
# des-topic: Help topic key. See doc/ljconfig.pl.txt for examples.
# des-pre: HTML/BML to place before the help icon.
# des-post: HTML/BML to place after the help icon.
#
sub help_icon
{
my $topic = shift;
my $pre = shift;
my $post = shift;
return "" unless (defined $LJ::HELPURL{$topic});
return "$pre$post";
}
#
# name: LJ::bad_input
# des: Returns common BML for reporting form validation errors in
# a bulletted list.
# returns: BML showing errors.
# args: error*
# des-error: A list of errors
#
sub bad_input
{
my @errors = @_;
my $ret = "";
$ret .= "\n
\n";
foreach (@errors) {
$ret .= "
$_
\n";
}
$ret .= "
\n";
return $ret;
}
#
# name: LJ::error_list
# des: Returns an error bar with bulleted list of errors
# returns: BML showing errors
# args: error*
# des-error: A list of errors
#
sub error_list
{
my @errors = @_;
my $ret;
$ret .= "";
$ret .= BML::ml('error.procrequest');
$ret .= "
";
foreach (@errors) {
$ret .= "
$_
";
}
$ret .= "
errorbar?>";
return $ret;
}
#
# name: LJ::warning_list
# des: Returns a warning bar with bulleted list of warnings
# returns: BML showing warnings
# args: warnings*
# des-warnings: A list of warnings
#
sub warning_list
{
my @warnings = @_;
my $ret;
$ret .= "";
$ret .= BML::ml('label.warning');
$ret .= "
";
foreach (@warnings) {
$ret .= "
$_
";
}
$ret .= "
warningbar?>";
return $ret;
}
sub tosagree_widget {
my ($checked, $errstr) = @_;
return
"
" . LJ::html_check({ name => 'agree_tos', id => 'agree_tos',
value => '1', selected => $checked }) .
"
" .
($errstr ? "" : '');
}
sub tosagree_html {
my $domain = shift;
my $ret = "";
my $html_str = LJ::tosagree_str($domain => 'html');
$ret .= "" if $html_str;
$ret .= "
";
$ret .= LJ::tosagree_widget(@_);
$ret .= "
";
return $ret;
}
sub tosagree_str {
my ($domain, $key) = @_;
return ref $LJ::REQUIRED_TOS{$domain} && $LJ::REQUIRED_TOS{$domain}->{$key} ?
$LJ::REQUIRED_TOS{$domain}->{$key} : $LJ::REQUIRED_TOS{$key};
}
#
# name: LJ::did_post
# des: When web pages using cookie authentication, you can't just trust that
# the remote user wants to do the action they're requesting. It's way too
# easy for people to force other people into making GET requests to
# a server. What if a user requested http://server/delete_all_journal.bml
# and that URL checked the remote user and immediately deleted the whole
# journal. Now anybody has to do is embed that address in an image
# tag and a lot of people's journals will be deleted without them knowing.
# Cookies should only show pages which make no action. When an action is
# being made, check that it's a POST request.
# returns: true if REQUEST_METHOD == "POST"
#
sub did_post
{
return (BML::get_method() eq "POST");
}
#
# name: LJ::robot_meta_tags
# des: Returns meta tags to block a robot from indexing or following links
# returns: A string with appropriate meta tags
#
sub robot_meta_tags
{
return "\n" .
"\n";
}
sub paging_bar
{
my ($page, $pages, $opts) = @_;
my $self_link = $opts->{'self_link'} ||
sub { BML::self_link({ 'page' => $_[0] }) };
my $navcrap;
if ($pages > 1) {
$navcrap .= "
\n";
$navcrap = BML::fill_template("standout", { 'DATA' => $navcrap });
}
return $navcrap;
}
#
# class: web
# name: LJ::make_cookie
# des: Prepares cookie header lines.
# returns: An array of cookie lines.
# args: name, value, expires, path?, domain?
# des-name: The name of the cookie.
# des-value: The value to set the cookie to.
# des-expires: The time (in seconds) when the cookie is supposed to expire.
# Set this to 0 to expire when the browser closes. Set it to
# undef to delete the cookie.
# des-path: The directory path to bind the cookie to.
# des-domain: The domain (or domains) to bind the cookie to.
#
sub make_cookie
{
my ($name, $value, $expires, $path, $domain) = @_;
my $cookie = "";
my @cookies = ();
# let the domain argument be an array ref, so callers can set
# cookies in both .foo.com and foo.com, for some broken old browsers.
if ($domain && ref $domain eq "ARRAY") {
foreach (@$domain) {
push(@cookies, LJ::make_cookie($name, $value, $expires, $path, $_));
}
return;
}
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = gmtime($expires);
$year+=1900;
my @day = qw{Sunday Monday Tuesday Wednesday Thursday Friday Saturday};
my @month = qw{Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec};
$cookie = sprintf "%s=%s", LJ::eurl($name), LJ::eurl($value);
# this logic is confusing potentially
unless (defined $expires && $expires==0) {
$cookie .= sprintf "; expires=$day[$wday], %02d-$month[$mon]-%04d %02d:%02d:%02d GMT",
$mday, $year, $hour, $min, $sec;
}
$cookie .= "; path=$path" if $path;
$cookie .= "; domain=$domain" if $domain;
push(@cookies, $cookie);
return @cookies;
}
#
# name: LJ::set_interests
# des: Change a user's interests
# args: dbarg?, u, old, new
# arg-old: hashref of old interests (hashing being interest => intid)
# arg-new: listref of new interests
# returns: 1 on success, undef on failure
#
sub set_interests
{
my ($u, $old, $new) = @_;
$u = LJ::want_user($u);
my $userid = $u->{'userid'};
return undef unless $userid;
return undef unless ref $old eq 'HASH';
return undef unless ref $new eq 'ARRAY';
my $dbh = LJ::get_db_writer();
my %int_new = ();
my %int_del = %$old; # assume deleting everything, unless in @$new
# user interests go in a different table than user interests,
# though the schemas are the same so we can run the same queries on them
my $uitable = $u->{'journaltype'} eq 'C' ? 'comminterests' : 'userinterests';
# track if we made changes to refresh memcache later.
my $did_mod = 0;
foreach my $int (@$new)
{
$int = lc($int); # FIXME: use utf8?
$int =~ s/^i like //; # *sigh*
next unless $int;
next if $int =~ / .+ .+ .+ /; # prevent sentences
next if $int =~ /[\<\>]/;
my ($bl, $cl) = LJ::text_length($int);
next if $bl > LJ::BMAX_INTEREST or $cl > LJ::CMAX_INTEREST;
$int_new{$int} = 1 unless $old->{$int};
delete $int_del{$int};
}
### were interests removed?
if (%int_del)
{
## easy, we know their IDs, so delete them en masse
my $intid_in = join(", ", values %int_del);
$dbh->do("DELETE FROM $uitable WHERE userid=$userid AND intid IN ($intid_in)");
$dbh->do("UPDATE interests SET intcount=intcount-1 WHERE intid IN ($intid_in)");
$did_mod = 1;
}
### do we have new interests to add?
if (%int_new)
{
$did_mod = 1;
## difficult, have to find intids of interests, and create new ints for interests
## that nobody has ever entered before
my $int_in = join(", ", map { $dbh->quote($_); } keys %int_new);
my %int_exist;
my @new_intids = (); ## existing IDs we'll add for this user
## find existing IDs
my $sth = $dbh->prepare("SELECT interest, intid FROM interests WHERE interest IN ($int_in)");
$sth->execute;
while (my ($intr, $intid) = $sth->fetchrow_array) {
push @new_intids, $intid; # - we'll add this later.
delete $int_new{$intr}; # - so we don't have to make a new intid for
# this next pass.
}
if (@new_intids) {
my $sql = "";
foreach my $newid (@new_intids) {
if ($sql) { $sql .= ", "; }
else { $sql = "REPLACE INTO $uitable (userid, intid) VALUES "; }
$sql .= "($userid, $newid)";
}
$dbh->do($sql);
my $intid_in = join(", ", @new_intids);
$dbh->do("UPDATE interests SET intcount=intcount+1 WHERE intid IN ($intid_in)");
}
}
### do we STILL have interests to add? (must make new intids)
if (%int_new)
{
foreach my $int (keys %int_new)
{
my $intid;
my $qint = $dbh->quote($int);
$dbh->do("INSERT INTO interests (intid, intcount, interest) ".
"VALUES (NULL, 1, $qint)");
if ($dbh->err) {
# somebody beat us to creating it. find its id.
$intid = $dbh->selectrow_array("SELECT intid FROM interests WHERE interest=$qint");
$dbh->do("UPDATE interests SET intcount=intcount+1 WHERE intid=$intid");
} else {
# newly created
$intid = $dbh->{'mysql_insertid'};
}
if ($intid) {
## now we can actually insert it into the userinterests table:
$dbh->do("INSERT INTO $uitable (userid, intid) ".
"VALUES ($userid, $intid)");
}
}
}
### if journaltype is community, clean their old userinterests from 'userinterests'
if ($u->{'journaltype'} eq 'C') {
$dbh->do("DELETE FROM userinterests WHERE userid=?", undef, $u->{'userid'});
}
LJ::memcache_kill($u, "intids") if $did_mod;
return 1;
}
# $opts is optional, with keys:
# forceids => 1 : don't use memcache for loading the intids
# forceints => 1 : don't use memcache for loading the interest rows
# justids => 1 : return arrayref of intids only, not names/counts
# returns otherwise an arrayref of interest rows, sorted by interest name
sub get_interests
{
my ($u, $opts) = @_;
$opts ||= {};
return undef unless $u;
my $uid = $u->{userid};
my $uitable = $u->{'journaltype'} eq 'C' ? 'comminterests' : 'userinterests';
# load the ids
my $ids;
my $mk_ids = [$uid, "intids:$uid"];
$ids = LJ::MemCache::get($mk_ids) unless $opts->{'forceids'};
unless ($ids && ref $ids eq "ARRAY") {
$ids = [];
my $dbh = LJ::get_db_writer();
my $sth = $dbh->prepare("SELECT intid FROM $uitable WHERE userid=?");
$sth->execute($uid);
push @$ids, $_ while ($_) = $sth->fetchrow_array;
LJ::MemCache::add($mk_ids, $ids, 3600*12);
}
return $ids if $opts->{'justids'};
# load interest rows
my %need;
$need{$_} = 1 foreach @$ids;
my @ret;
unless ($opts->{'forceints'}) {
if (my $mc = LJ::MemCache::get_multi(map { [$_, "introw:$_"] } @$ids)) {
while (my ($k, $v) = each %$mc) {
next unless $k =~ /^introw:(\d+)/;
delete $need{$1};
push @ret, $v;
}
}
}
if (%need) {
my $ids = join(",", map { $_+0 } keys %need);
my $dbr = LJ::get_db_reader();
my $sth = $dbr->prepare("SELECT intid, interest, intcount FROM interests ".
"WHERE intid IN ($ids)");
$sth->execute;
my $memc_store = 0;
while (my ($intid, $int, $count) = $sth->fetchrow_array) {
# minimize latency... only store 25 into memcache at a time
# (too bad we don't have set_multi.... hmmmm)
my $aref = [$intid, $int, $count];
if ($memc_store++ < 25) {
# if the count is fairly high, keep item in memcache longer,
# since count's not so important.
my $expire = $count < 10 ? 3600*12 : 3600*48;
LJ::MemCache::add([$intid, "introw:$intid"], $aref, $expire);
}
push @ret, $aref;
}
}
@ret = sort { $a->[1] cmp $b->[1] } @ret;
return \@ret;
}
sub set_active_crumb
{
$LJ::ACTIVE_CRUMB = shift;
return undef;
}
sub set_dynamic_crumb
{
my ($title, $parent) = @_;
$LJ::ACTIVE_CRUMB = [ $title, $parent ];
}
sub get_parent_crumb
{
my $thiscrumb = LJ::get_crumb(LJ::get_active_crumb());
return LJ::get_crumb($thiscrumb->[2]);
}
sub get_active_crumb
{
return $LJ::ACTIVE_CRUMB;
}
sub get_crumb_path
{
my $cur = LJ::get_active_crumb();
my @list;
while ($cur) {
# get crumb, fix it up, and then put it on the list
if (ref $cur) {
# dynamic crumb
push @list, [ $cur->[0], '', $cur->[1], 'dynamic' ];
$cur = $cur->[1];
} else {
# just a regular crumb
my $crumb = LJ::get_crumb($cur);
last unless $crumb;
last if $cur eq $crumb->[2];
$crumb->[3] = $cur;
push @list, $crumb;
# now get the next one we're going after
$cur = $crumb->[2]; # parent of this crumb
}
}
return @list;
}
sub get_crumb
{
my $crumbkey = shift;
if (defined $LJ::CRUMBS_LOCAL{$crumbkey}) {
return $LJ::CRUMBS_LOCAL{$crumbkey};
} else {
return $LJ::CRUMBS{$crumbkey};
}
}
#
# name: LJ::check_referer
# class: web
# des: Checks if the user is coming from a given URI.
# args: uri?, referer?
# des-uri: string; the URI we want the user to come from
# des-referer: string; the location the user is posting from. if not supplied,
# will be retrieved with BML::get_client_header. in general, you don't want to
# pass this yourself unless you already have it or know we can't get it from BML.
# returns: 1 if they're coming from that URI, else undef
#
sub check_referer {
my $uri = shift(@_) || '';
my $referer = shift(@_) || BML::get_client_header('Referer');
# get referer and check
return 1 unless $referer;
return 1 if $LJ::SITEROOT && $referer =~ m!^$LJ::SITEROOT$uri!;
return 1 if $LJ::DOMAIN && $referer =~ m!^http://$LJ::DOMAIN$uri!;
return 1 if $LJ::DOMAIN_WEB && $referer =~ m!^http://$LJ::DOMAIN_WEB$uri!;
return 1 if $uri =~ m!^http://! && $referer eq $uri;
return undef;
}
#
# name: LJ::form_auth
# class: web
# des: Creates an authentication token to be used later to verify that a form
# submission came from a particular user.
# returns: HTML hidden field to be inserted into the output of a page.
#
sub form_auth {
my $remote = LJ::get_remote() or return "";
my $sess = $remote->{'_session'} or return "";
my $auth = join('-',
LJ::rand_chars(10),
$remote->{userid},
$sess->{auth});
return LJ::html_hidden("lj_form_auth", LJ::challenge_generate(86400, $auth));
}
#
# name: LJ::check_form_auth
# class: web
# des: Verifies form authentication created with LJ::form_auth.
# returns: Boolean; true if the current data in %POST is a valid form submitted
# by the user in $remote using the current session, false if the user has changed,
# the challenge has expired, or the user has changed session (logged out and in
# again, or something).
#
sub check_form_auth {
my $remote = LJ::get_remote() or return 0;
my $sess = $remote->{'_session'} or return 0;
my $formauth = $BMLCodeBlock::POST{'lj_form_auth'} or return 0;
# check the attributes are as they should be
my $attr = LJ::get_challenge_attributes($formauth);
my ($randchars, $userid, $sessauth) = split(/\-/, $attr);
return 0 unless $userid == $remote->{userid} &&
$sessauth eq $sess->{auth};
# check the signature is good and not expired
my $opts = { dont_check_count => 1 }; # in/out
LJ::challenge_check($formauth, $opts);
return $opts->{valid} && ! $opts->{expired};
}
#
# name: LJ::create_qr_div
# class: web
# des: Creates the hidden div that stores the Quick Reply form
# returns: undef upon failure or HTML for the div upon success
# args: user, remote, ditemid, stylemine, userpic
# des-u: user object or userid for journal reply in
# des-ditemid: ditemid for this comment
# des-stylemine: if the user has specified style=mine for this page
# des-userpic: alternate default userpic
#
sub create_qr_div {
my ($user, $ditemid, $stylemine, $userpic, $viewing_thread) = @_;
my $u = LJ::want_user($user);
my $remote = LJ::get_remote();
return undef unless $u && $remote && $ditemid;
return undef if $remote->underage;
$stylemine ||= 0;
my $qrhtml;
LJ::load_user_props($remote, "opt_no_quickreply");
return undef if $remote->{'opt_no_quickreply'};
my $stylemineuri = $stylemine ? "style=mine&" : "";
my $basepath = LJ::journal_base($u) . "/$ditemid.html?${stylemineuri}replyto=";
$qrhtml .= LJ::html_hidden({'name' => 'replyto', 'id' => 'replyto', 'value' => ''},
{'name' => 'parenttalkid', 'id' => 'parenttalkid', 'value' => ''},
{'name' => 'itemid', 'id' => 'itemid', 'value' => $ditemid},
{'name' => 'usertype', 'id' => 'usertype', 'value' => 'cookieuser'},
{'name' => 'userpost', 'id' => 'userpost', 'value' => $remote->{'user'}},
{'name' => 'qr', 'id' => 'qr', 'value' => '1'},
{'name' => 'cookieuser', 'id' => 'cookieuser', 'value' => $remote->{'user'}},
{'name' => 'dtid', 'id' => 'dtid', 'value' => ''},
{'name' => 'basepath', 'id' => 'basepath', 'value' => $basepath},
{'name' => 'stylemine', 'id' => 'stylemine', 'value' => $stylemine},
{'name' => 'saved_subject', 'id' => 'saved_subject'},
{'name' => 'saved_body', 'id' => 'saved_body'},
{'name' => 'saved_spell', 'id' => 'saved_spell'},
{'name' => 'saved_upic', 'id' => 'saved_upic'},
{'name' => 'saved_dtid', 'id' => 'saved_dtid'},
{'name' => 'saved_ptid', 'id' => 'saved_ptid'},
{'name' => 'viewing_thread', 'id' => 'viewing_thread', 'value' => $viewing_thread},
);
# rate limiting challenge
{
my ($time, $secret) = LJ::get_secret();
my $rchars = LJ::rand_chars(20);
my $chal = $ditemid . "-$u->{userid}-$time-$rchars";
my $res = Digest::MD5::md5_hex($secret . $chal);
$qrhtml .= LJ::html_hidden("chrp1", "$chal-$res");
}
# Start making the div itself
$qrhtml .= "
";
my $ret;
$ret = "";
return $ret;
}
#
# name: LJ::make_qr_link
# class: web
# des: Creates the link to toggle the QR reply form or if
# JavaScript is not enabled, then forwards the user through
# to replyurl.
# returns: undef upon failure or HTML for the link
# args: dtid, basesubject, linktext, replyurl
# des-dtid: dtalkid for this comment
# des-basesubject: parent comment's subject
# des-linktext: text for the user to click
# des-replyurl: URL to forward user to if their browser
# does not support QR
#
sub make_qr_link
{
my ($dtid, $basesubject, $linktext, $replyurl) = @_;
return undef unless defined $dtid && $linktext && $replyurl;
my $remote = LJ::get_remote();
LJ::load_user_props($remote, "opt_no_quickreply");
unless ($remote->{'opt_no_quickreply'}) {
my $pid = int($dtid / 256);
$basesubject =~ s/^(Re:\s*)*//i;
$basesubject = "Re: $basesubject" if $basesubject;
$basesubject = LJ::ejs($basesubject);
my $onclick = "return quickreply('$dtid', $pid, '$basesubject')";
$onclick = LJ::ehtml($onclick);
return "$linktext";
} else { # QR Disabled
return "$linktext";
}
}
#
# name: LJ::get_lastcomment
# class: web
# des: Looks up the last talkid and journal the remote user posted in
# returns: talkid, jid
# args:
#
sub get_lastcomment {
my $remote = LJ::get_remote;
return (undef, undef) unless $remote;
# Figure out their last post
my $memkey = [$remote->{'userid'}, "lastcomm:$remote->{'userid'}"];
my $memval = LJ::MemCache::get($memkey);
my ($jid, $talkid) = split(/:/, $memval) if $memval;
return ($talkid, $jid);
}
#
# name: LJ::make_qr_target
# class: web
# des: Returns a div usable for Quick Reply boxes
# returns: HMTML for the div
# args:
#
sub make_qr_target {
my $name = shift;
return "";
}
#
# name: LJ::set_lastcomment
# class: web
# des: Sets the lastcomm Memcache key for this user's last comment
# returns: undef on failure
# args: u, remote, dtalkid, life?
# des-u: Journal they just posted in, either u or userid
# des-remote: Remote user
# des-dtalkid: Talkid for the comment they just posted
# des-life: How long, in seconds, the Memcache key should live
#
sub set_lastcomment
{
my ($u, $remote, $dtalkid, $life) = @_;
my $userid = LJ::want_userid($u);
return undef unless $userid && $remote && $dtalkid;
# By default, this key lasts for 10 seconds.
$life ||= 10;
# Set memcache key for highlighting the comment
my $memkey = [$remote->{'userid'}, "lastcomm:$remote->{'userid'}"];
LJ::MemCache::set($memkey, "$userid:$dtalkid", time()+$life);
return;
}
#
# name: LJ::entry_form
# class: web
# des: Returns a properly formatted form for creating/editing entries
# args: opts, head
# des-head: string reference for the section (javascript previews, etc)
# des-onload: string reference for javascript functions to be called on page load
# des-opts: hashref of keys/values:
# mode: either "update" or "edit", depending on context
# datetime: date and time, formatted yyyy-mm-dd hh:mm
# remote: remote u object
# subject: entry subject
# event: entry text
# richtext: allow rich text formatting
# richtext_on: rich text formatting has been turned on
# auth_as_remote: bool option to authenticate as remote user, prefilling pic/friend groups/etc
# return: form to include in BML pages
#
sub entry_form {
my ($opts, $head, $onload, $errors) = @_;
my $out = "";
my $remote = $opts->{'remote'};
my ($moodlist, $moodpics, $userpics);
# usejournal has no point if you're trying to use the account you're logged in as,
# so disregard it so we can assume that if it exists, we're trying to post to an
# account that isn't us
if ($remote && $opts->{usejournal} && $remote->{user} eq $opts->{usejournal}) {
delete $opts->{usejournal};
}
my $tabnum = 1;
my $tabindex = sub { return $tabnum++; };
$opts->{'event'} = LJ::durl($opts->{'event'}) if $opts->{'mode'} eq "edit";
# 15 minute auth token, should be adequate
my $chal = LJ::challenge_generate(900);
$out .= "";
$out .= "";
$out .= "
";
return $out;
}
#
# name: LJ::entry_form_decode
# class: web
# des: Decodes an entry_form into a protocol compatible hash
# info: Generate form with [func[entry_form]].
# args: req, post
# des-req: protocol request hash to build
# des-post: entry_form POST contents
# returns: req
#
sub entry_form_decode
{
my ($req, $POST) = @_;
# find security
my $sec = "public";
my $amask = 0;
if ($POST->{'security'} eq "private") {
$sec = "private";
} elsif ($POST->{'security'} eq "friends") {
$sec = "usemask"; $amask = 1;
} elsif ($POST->{'security'} eq "custom") {
$sec = "usemask";
foreach my $bit (1..30) {
next unless $POST->{"custom_bit_$bit"};
$amask |= (1 << $bit);
}
}
$req->{'security'} = $sec;
$req->{'allowmask'} = $amask;
# date/time
my $date = LJ::html_datetime_decode({ 'name' => "date_ymd", }, $POST);
my ($year, $mon, $day) = split( /\D/, $date);
$req->{'year'} = $year; $req->{'mon'} = $mon; $req->{'day'} = $day;
foreach ( "year", "mon", "day" ) {
$req->{$_} = $POST->{$_} if $POST->{$_} ne "";
}
# copy some things from %POST
foreach (qw(subject hour min
prop_picture_keyword prop_current_moodid
prop_current_mood prop_current_music
prop_opt_screening prop_opt_noemail
prop_opt_preformatted prop_opt_nocomments
prop_taglist)) {
$req->{$_} = $POST->{$_};
}
$req->{"prop_opt_preformatted"} ||= $POST->{'event_format'} eq "preformatted" ? 1 : 0;
$req->{"prop_opt_nocomments"} ||= $POST->{'comment_settings'} eq "nocomments" ? 1 : 0;
$req->{"prop_opt_noemail"} ||= $POST->{'comment_settings'} eq "noemail" ? 1 : 0;
$req->{'prop_opt_backdated'} = $POST->{'prop_opt_backdated'} ? 1 : 0;
# Convert the rich text editor output back to parsable lj tags.
my $event = $POST->{'event'};
if ($POST->{'richtext'}) {
# check for blank entry
(my $event_tmp = $event) =~ s!(?: |
(?: |\s)+
| )\s*?!!gm;
if ($event_tmp =~ /\w/) { # ok, we still have content
$event =~ s/<(\/)?lj-cut(.*?)(?: \/)?>/<$1lj-cut$2>/ig;
$event =~ s/<lj user=['"]?(\w{1,15})['"]?\s?\/?>//ig; # manually typed tags
$event =~ s/<\/a>(?:<\/span>)?//ig;
} else { # RTE blanks (just , newlines, - no real content)
$event = undef; # force protocol error
}
}
$req->{'event'} = $event;
## see if an "other" mood they typed in has an equivalent moodid
if ($POST->{'prop_current_mood'}) {
if (my $id = LJ::mood_id($POST->{'prop_current_mood'})) {
$req->{'prop_current_moodid'} = $id;
delete $req->{'prop_current_mood'};
}
}
return $req;
}
# returns exactly what was passed to it normally. but in developer mode,
# it includes a link to a page that automatically grants the needed priv.
sub no_access_error {
my ($text, $priv, $privarg) = @_;
if ($LJ::IS_DEV_SERVER) {
my $remote = LJ::get_remote();
return "$text (DEVMODE: Grant $priv\[$privarg\])";
} else {
return $text;
}
}
# Data::Dumper for JavaScript
sub js_dumper {
my $obj = shift;
if (ref $obj eq "HASH") {
my $ret = "{";
foreach my $k (keys %$obj) {
$ret .= "$k: " . js_dumper($obj->{$k}) . ",";
}
chop $ret;
$ret .= "}";
return $ret;
} elsif (ref $obj eq "ARRAY") {
my $ret = "[" . join(", ", map { js_dumper($_) } @$obj) . "]";
return $ret;
} else {
return $obj if $obj =~ /^\d+$/;
return "\"" . LJ::ejs($obj) . "\"";
}
}
# Common challenge/response javascript, needed by both login pages and comment pages alike.
# Forms that use this should onclick='return sendForm()' in the submit button.
# Returns true to let the submit continue.
$LJ::COMMON_CODE{'chalresp_js'} = qq{
};
# Common Javascript function for auto-checking radio buttons on form
# input field data changes
$LJ::COMMON_CODE{'autoradio_check'} = q{
};
# Common Javascript functions for Quick Reply
$LJ::COMMON_CODE{'quickreply'} = q{
};
1;