init
This commit is contained in:
96
livejournal/cgi-bin/Apache/DebateSuicide.pm
Executable file
96
livejournal/cgi-bin/Apache/DebateSuicide.pm
Executable file
@@ -0,0 +1,96 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Apache::DebateSuicide;
|
||||
|
||||
use strict;
|
||||
use Apache::Constants qw(:common);
|
||||
|
||||
use vars qw($gtop);
|
||||
our %known_parent;
|
||||
our $ppid;
|
||||
|
||||
# oh btw, this is totally linux-specific. gtop didn't work, so so much for portability.
|
||||
sub handler
|
||||
{
|
||||
my $r = shift;
|
||||
return OK if $r->main;
|
||||
return OK unless $LJ::HAVE_GTOP && $LJ::SUICIDE;
|
||||
|
||||
my $meminfo;
|
||||
return OK unless open (MI, "/proc/meminfo");
|
||||
$meminfo = join('', <MI>);
|
||||
close MI;
|
||||
|
||||
my %meminfo;
|
||||
while ($meminfo =~ m/(\w+):\s*(\d+)\skB/g) {
|
||||
$meminfo{$1} = $2;
|
||||
}
|
||||
|
||||
my $memfree = $meminfo{'MemFree'} + $meminfo{'Cached'};
|
||||
return OK unless $memfree;
|
||||
|
||||
my $goodfree = $LJ::SUICIDE_UNDER{$LJ::SERVER_NAME} || $LJ::SUICIDE_UNDER || 150_000;
|
||||
return OK if $memfree > $goodfree;
|
||||
|
||||
unless ($ppid) {
|
||||
my $self = pid_info($$);
|
||||
$ppid = $self->[3];
|
||||
}
|
||||
|
||||
my $pids = child_info($ppid);
|
||||
my @pids = keys %$pids;
|
||||
|
||||
$gtop ||= GTop->new;
|
||||
|
||||
my %stats;
|
||||
my $sum_uniq = 0;
|
||||
foreach my $pid (@pids) {
|
||||
my $pm = $gtop->proc_mem($pid);
|
||||
$stats{$pid} = [ $pm->rss - $pm->share, $pm ];
|
||||
$sum_uniq += $stats{$pid}->[0];
|
||||
}
|
||||
|
||||
@pids = (sort { $stats{$b}->[0] <=> $stats{$a}->[0] } @pids, 0, 0);
|
||||
|
||||
my $my_pid = $$;
|
||||
if (grep { $my_pid == $_ } @pids[0,1]) {
|
||||
my $my_use_k = $stats{$$}[0] >> 10;
|
||||
$r->log_error("Suicide [$$]: system memory free = ${memfree}k; i'm big, using ${my_use_k}k") if $LJ::DEBUG{'suicide'};
|
||||
Apache::LiveJournal::db_logger($r) unless $r->pnotes('did_lj_logging');
|
||||
$r->child_terminate;
|
||||
}
|
||||
|
||||
return OK;
|
||||
}
|
||||
|
||||
sub pid_info {
|
||||
my $pid = shift;
|
||||
|
||||
open (F, "/proc/$pid/stat") or next;
|
||||
$_ = <F>;
|
||||
close(F);
|
||||
my @f = split;
|
||||
return \@f;
|
||||
}
|
||||
|
||||
sub child_info {
|
||||
my $ppid = shift;
|
||||
opendir(D, "/proc") or return undef;
|
||||
my @pids = grep { /^\d+$/ } readdir(D);
|
||||
closedir(D);
|
||||
|
||||
my %ret;
|
||||
foreach my $p (@pids) {
|
||||
next if (defined $known_parent{$p} &&
|
||||
$known_parent{$p} != $ppid);
|
||||
my $ary = pid_info($p);
|
||||
my $this_ppid = $ary->[3];
|
||||
$known_parent{$p} = $this_ppid;
|
||||
next unless $this_ppid == $ppid;
|
||||
$ret{$p} = $ary;
|
||||
}
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
1;
|
||||
1508
livejournal/cgi-bin/Apache/LiveJournal.pm
Executable file
1508
livejournal/cgi-bin/Apache/LiveJournal.pm
Executable file
File diff suppressed because it is too large
Load Diff
610
livejournal/cgi-bin/Apache/LiveJournal/Interface/AtomAPI.pm
Executable file
610
livejournal/cgi-bin/Apache/LiveJournal/Interface/AtomAPI.pm
Executable file
@@ -0,0 +1,610 @@
|
||||
# AtomAPI support for LJ
|
||||
|
||||
package Apache::LiveJournal::Interface::AtomAPI;
|
||||
|
||||
use strict;
|
||||
use Apache::Constants qw(:common);
|
||||
use Digest::SHA1;
|
||||
use MIME::Base64;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
require 'parsefeed.pl';
|
||||
require 'fbupload.pl';
|
||||
|
||||
BEGIN {
|
||||
$LJ::OPTMOD_XMLATOM = eval q{
|
||||
use XML::Atom::Feed;
|
||||
use XML::Atom::Entry;
|
||||
use XML::Atom::Link;
|
||||
XML::Atom->VERSION < 0.09 ? 0 : 1;
|
||||
};
|
||||
};
|
||||
|
||||
# check allowed Atom upload filetypes
|
||||
sub check_mime
|
||||
{
|
||||
my $mime = shift;
|
||||
return unless $mime;
|
||||
|
||||
# TODO: add audio/etc support
|
||||
my %allowed_mime = (
|
||||
image => qr{^image\/(?:gif|jpe?g|png|tiff?)$}i,
|
||||
#audio => qr{^(?:application|audio)\/(?:(?:x-)?ogg|wav)$}i
|
||||
);
|
||||
|
||||
foreach (keys %allowed_mime) {
|
||||
return $_ if $mime =~ $allowed_mime{$_}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub respond {
|
||||
my ($r, $status, $body, $type) = @_;
|
||||
|
||||
my %msgs = (
|
||||
200 => 'OK',
|
||||
201 => 'Created',
|
||||
|
||||
400 => 'Bad Request',
|
||||
401 => 'Authentication Failed',
|
||||
403 => 'Forbidden',
|
||||
404 => 'Not Found',
|
||||
500 => 'Server Error',
|
||||
),
|
||||
|
||||
my %mime = (
|
||||
html => 'text/html',
|
||||
atom => 'application/x.atom+xml',
|
||||
xml => "text/xml; charset='utf-8'",
|
||||
);
|
||||
|
||||
# if the passed in body was a reference, send it
|
||||
# without any modification. otherwise, send some
|
||||
# prettier html to the client.
|
||||
my $out;
|
||||
if (ref $body) {
|
||||
$out = $$body;
|
||||
} else {
|
||||
$out = <<HTML;
|
||||
<html><head><title>$status $msgs{$status}</title></head><body>
|
||||
<h1>$msgs{$status}</h1><hr /><p>$body</p>
|
||||
</body></html>
|
||||
HTML
|
||||
}
|
||||
|
||||
$type = $mime{$type} || 'text/html';
|
||||
$r->status_line("$status $msgs{$status}");
|
||||
$r->content_type($type);
|
||||
$r->send_http_header();
|
||||
$r->print($out);
|
||||
return OK;
|
||||
};
|
||||
|
||||
sub handle_upload
|
||||
{
|
||||
my ($r, $remote, $u, $opts, $entry) = @_;
|
||||
|
||||
# entry could already be populated from a standalone
|
||||
# service.post posting.
|
||||
my $standalone = $entry ? 1 : 0;
|
||||
unless ($entry) {
|
||||
my $buff;
|
||||
$r->read($buff, $r->header_in("Content-length"));
|
||||
|
||||
eval { $entry = XML::Atom::Entry->new( \$buff ); };
|
||||
return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
|
||||
if $@;
|
||||
}
|
||||
|
||||
my $mime = $entry->content()->type();
|
||||
my $mime_area = check_mime( $mime );
|
||||
return respond($r, 400, "Unsupported MIME type: $mime") unless $mime_area;
|
||||
|
||||
if ($mime_area eq 'image') {
|
||||
|
||||
return respond($r, 400, "Unable to upload media. Your account doesn't have the required access.")
|
||||
unless LJ::get_cap($u, 'fb_can_upload') && $LJ::FB_SITEROOT;
|
||||
|
||||
my $err;
|
||||
LJ::load_user_props(
|
||||
$u,
|
||||
qw/ emailpost_gallery emailpost_imgsecurity /
|
||||
);
|
||||
|
||||
my $summary = LJ::trim( $entry->summary() );
|
||||
|
||||
my $fb = LJ::FBUpload::do_upload(
|
||||
$u, \$err,
|
||||
{
|
||||
path => $entry->title(),
|
||||
rawdata => \$entry->content()->body(),
|
||||
imgsec => $u->{emailpost_imgsecurity},
|
||||
caption => $summary,
|
||||
galname => $u->{emailpost_gallery} || 'AtomUpload',
|
||||
}
|
||||
);
|
||||
|
||||
return respond($r, 500, "There was an error uploading the media: $err")
|
||||
if $err || ! $fb;
|
||||
|
||||
if (ref $fb && $fb->{Error}->{code}) {
|
||||
my $errstr = $fb->{Error}->{content};
|
||||
return respond($r, 500, "There was an error uploading the media: $errstr");
|
||||
}
|
||||
|
||||
my $atom_reply = XML::Atom::Entry->new();
|
||||
$atom_reply->title( $fb->{Title} );
|
||||
|
||||
if ($standalone) {
|
||||
$atom_reply->summary('Media post');
|
||||
my $id = "atom:$u->{user}:$fb->{PicID}";
|
||||
$fb->{Summary} = $summary;
|
||||
LJ::MemCache::set( $id, $fb, 1800 );
|
||||
$atom_reply->id( "urn:fb:$LJ::FB_DOMAIN:$id" );
|
||||
}
|
||||
|
||||
my $link = XML::Atom::Link->new();
|
||||
$link->type('text/html');
|
||||
$link->rel('alternate');
|
||||
$link->href( $fb->{URL} );
|
||||
$atom_reply->add_link($link);
|
||||
|
||||
$r->header_out("Location", $fb->{URL});
|
||||
return respond($r, 201, \$atom_reply->as_xml(), 'atom');
|
||||
}
|
||||
}
|
||||
|
||||
sub handle_post {
|
||||
my ($r, $remote, $u, $opts) = @_;
|
||||
my ($buff, $entry);
|
||||
|
||||
# read the content
|
||||
$r->read($buff, $r->header_in("Content-length"));
|
||||
|
||||
# try parsing it
|
||||
eval { $entry = XML::Atom::Entry->new( \$buff ); };
|
||||
return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
|
||||
if $@;
|
||||
|
||||
# on post, the entry must NOT include an id
|
||||
return respond($r, 400, "Must not include an <b><id></b> field in a new entry.")
|
||||
if $entry->id();
|
||||
|
||||
# detect 'standalone' media posts
|
||||
return handle_upload( @_, $entry )
|
||||
if $entry->get("http://sixapart.com/atom/typepad#", 'standalone');
|
||||
|
||||
# remove the SvUTF8 flag. See same code in synsuck.pl for
|
||||
# an explanation
|
||||
$entry->title( pack( 'C*', unpack( 'C*', $entry->title() ) ) );
|
||||
$entry->link( pack( 'C*', unpack( 'C*', $entry->link() ) ) );
|
||||
$entry->content( pack( 'C*', unpack( 'C*', $entry->content()->body() ) ) );
|
||||
|
||||
# Retrieve fotobilder media links from clients that embed via
|
||||
# standalone tags or service.upload transfers. Add to post entry
|
||||
# body.
|
||||
my $body = $entry->content()->body();
|
||||
my @links = $entry->link();
|
||||
my (@images, $link_count);
|
||||
foreach my $link (@links) {
|
||||
# $link is now a valid XML::Atom::Link object
|
||||
my $rel = $link->get('rel');
|
||||
my $type = $link->get('type');
|
||||
my $id = $link->get('href');
|
||||
|
||||
next unless $rel eq 'related' && check_mime($type) && $id;
|
||||
$id =~ s/^urn:fb:$LJ::FB_DOMAIN://;
|
||||
my $fb = LJ::MemCache::get( $id );
|
||||
next unless $fb;
|
||||
|
||||
push @images, {
|
||||
url => $fb->{URL},
|
||||
width => $fb->{Width},
|
||||
height => $fb->{Height},
|
||||
caption => $fb->{Summary},
|
||||
title => $fb->{Title}
|
||||
};
|
||||
}
|
||||
|
||||
$body .= LJ::FBUpload::make_html( $u, \@images );
|
||||
|
||||
# build a post event request.
|
||||
my $req = {
|
||||
'usejournal' => ( $remote->{'userid'} != $u->{'userid'} ) ? $u->{'user'} : undef,
|
||||
'ver' => 1,
|
||||
'username' => $u->{'user'},
|
||||
'lineendings' => 'unix',
|
||||
'subject' => $entry->title(),
|
||||
'event' => $body,
|
||||
'props' => {},
|
||||
'security' => 'public',
|
||||
'tz' => 'guess',
|
||||
};
|
||||
|
||||
my $err;
|
||||
my $res = LJ::Protocol::do_request("postevent",
|
||||
$req, \$err, { 'noauth' => 1 });
|
||||
|
||||
if ($err) {
|
||||
my $errstr = LJ::Protocol::error_message($err);
|
||||
return respond($r, 500, "Unable to post new entry. Protocol error: <b>$errstr</b>.");
|
||||
}
|
||||
|
||||
my $atom_reply = XML::Atom::Entry->new();
|
||||
$atom_reply->title( $entry->title() );
|
||||
$atom_reply->summary( substr( $entry->content->body(), 0, 100 ) );
|
||||
|
||||
my $link;
|
||||
my $edit_url = "$LJ::SITEROOT/interface/atom/edit/$res->{'itemid'}";
|
||||
|
||||
$link = XML::Atom::Link->new();
|
||||
$link->type('application/x.atom+xml');
|
||||
$link->rel('service.edit');
|
||||
$link->href( $edit_url );
|
||||
$link->title( $entry->title() );
|
||||
$atom_reply->add_link($link);
|
||||
|
||||
$link = XML::Atom::Link->new();
|
||||
$link->type('text/html');
|
||||
$link->rel('alternate');
|
||||
$link->href( $res->{url} );
|
||||
$link->title( $entry->title() );
|
||||
$atom_reply->add_link($link);
|
||||
|
||||
$r->header_out("Location", $edit_url);
|
||||
return respond($r, 201, \$atom_reply->as_xml(), 'atom');
|
||||
}
|
||||
|
||||
sub handle_edit {
|
||||
my ($r, $remote, $u, $opts) = @_;
|
||||
|
||||
my $method = $opts->{'method'};
|
||||
|
||||
# first, try to load the item and fail if it's not there
|
||||
my $jitemid = $opts->{'param'};
|
||||
my $req = {
|
||||
'usejournal' => ($remote->{'userid'} != $u->{'userid'}) ?
|
||||
$u->{'user'} : undef,
|
||||
'ver' => 1,
|
||||
'username' => $u->{'user'},
|
||||
'selecttype' => 'one',
|
||||
'itemid' => $jitemid,
|
||||
};
|
||||
|
||||
my $err;
|
||||
my $olditem = LJ::Protocol::do_request("getevents",
|
||||
$req, \$err, { 'noauth' => 1 });
|
||||
|
||||
if ($err) {
|
||||
my $errstr = LJ::Protocol::error_message($err);
|
||||
return respond($r, 404, "Unable to retrieve the item requested for editing. Protocol error: <b>$errstr</b>.");
|
||||
}
|
||||
$olditem = $olditem->{'events'}->[0];
|
||||
|
||||
if ($method eq "GET") {
|
||||
# return an AtomEntry for this item
|
||||
# use the interface between make_feed and create_view_atom in
|
||||
# ljfeed.pl
|
||||
|
||||
# get the log2 row (need logtime for createtime)
|
||||
my $row = LJ::get_log2_row($u, $jitemid) ||
|
||||
return respond($r, 404, "Could not load the original entry.");
|
||||
|
||||
# we need to put into $item: itemid, ditemid, subject, event,
|
||||
# createtime, eventtime, modtime
|
||||
|
||||
my $ctime = LJ::mysqldate_to_time($row->{'logtime'}, 1);
|
||||
|
||||
my $item = {
|
||||
'itemid' => $olditem->{'itemid'},
|
||||
'ditemid' => $olditem->{'itemid'}*256 + $olditem->{'anum'},
|
||||
'eventtime' => LJ::alldatepart_s2($row->{'eventtime'}),
|
||||
'createtime' => $ctime,
|
||||
'modtime' => $olditem->{'props'}->{'revtime'} || $ctime,
|
||||
'subject' => $olditem->{'subject'},
|
||||
'event' => $olditem->{'event'},
|
||||
};
|
||||
|
||||
my $ret = LJ::Feed::create_view_atom(
|
||||
{ 'u' => $u },
|
||||
$u,
|
||||
{
|
||||
'saycharset' => "utf-8",
|
||||
'noheader' => 1,
|
||||
'apilinks' => 1,
|
||||
},
|
||||
[$item]
|
||||
);
|
||||
|
||||
return respond($r, 200, \$ret, 'xml');
|
||||
}
|
||||
|
||||
if ($method eq "PUT") {
|
||||
# read the content
|
||||
my $buff;
|
||||
$r->read($buff, $r->header_in("Content-length"));
|
||||
|
||||
# try parsing it
|
||||
my $entry;
|
||||
eval { $entry = XML::Atom::Entry->new( \$buff ); };
|
||||
return respond($r, 400, "Could not parse the entry due to invalid markup.<br /><pre>$@</pre>")
|
||||
if $@;
|
||||
|
||||
# remove the SvUTF8 flag. See same code in synsuck.pl for
|
||||
# an explanation
|
||||
$entry->title( pack( 'C*', unpack( 'C*', $entry->title() ) ) );
|
||||
$entry->link( pack( 'C*', unpack( 'C*', $entry->link() ) ) );
|
||||
$entry->content( pack( 'C*', unpack( 'C*', $entry->content()->body() ) ) );
|
||||
|
||||
# the AtomEntry must include <id> which must match the one we sent
|
||||
# on GET
|
||||
unless ($entry->id() =~ m#atom1:$u->{'user'}:(\d+)$# &&
|
||||
$1 == $olditem->{'itemid'}*256 + $olditem->{'anum'}) {
|
||||
return respond($r, 400, "Incorrect <b><id></b> field in this request.");
|
||||
}
|
||||
|
||||
# build an edit event request. Preserve fields that aren't being
|
||||
# changed by this item (perhaps the AtomEntry isn't carrying the
|
||||
# complete information).
|
||||
|
||||
$req = {
|
||||
'usejournal' => ( $remote->{'userid'} != $u->{'userid'} ) ? $u->{'user'} : undef,
|
||||
'ver' => 1,
|
||||
'username' => $u->{'user'},
|
||||
'itemid' => $jitemid,
|
||||
'lineendings' => 'unix',
|
||||
'subject' => $entry->title() || $olditem->{'subject'},
|
||||
'event' => $entry->content()->body() || $olditem->{'event'},
|
||||
'props' => $olditem->{'props'},
|
||||
'security' => $olditem->{'security'},
|
||||
'allowmask' => $olditem->{'allowmask'},
|
||||
};
|
||||
|
||||
$err = undef;
|
||||
my $res = LJ::Protocol::do_request("editevent",
|
||||
$req, \$err, { 'noauth' => 1 });
|
||||
|
||||
if ($err) {
|
||||
my $errstr = LJ::Protocol::error_message($err);
|
||||
return respond($r, 500, "Unable to update entry. Protocol error: <b>$errstr</b>.");
|
||||
}
|
||||
|
||||
return respond($r, 200, "The entry was successfully updated.");
|
||||
}
|
||||
|
||||
if ($method eq "DELETE") {
|
||||
|
||||
# build an edit event request to delete the entry.
|
||||
|
||||
$req = {
|
||||
'usejournal' => ($remote->{'userid'} != $u->{'userid'}) ?
|
||||
$u->{'user'}:undef,
|
||||
'ver' => 1,
|
||||
'username' => $u->{'user'},
|
||||
'itemid' => $jitemid,
|
||||
'lineendings' => 'unix',
|
||||
'event' => '',
|
||||
};
|
||||
|
||||
$err = undef;
|
||||
my $res = LJ::Protocol::do_request("editevent",
|
||||
$req, \$err, { 'noauth' => 1 });
|
||||
|
||||
if ($err) {
|
||||
my $errstr = LJ::Protocol::error_message($err);
|
||||
return respond($r, 500, "Unable to delete entry. Protocol error: <b>$errstr</b>.");
|
||||
}
|
||||
|
||||
return respond($r, 200, "Entry successfully deleted.");
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
# fetch lj tags, display as categories
|
||||
sub handle_categories
|
||||
{
|
||||
my ($r, $remote, $u, $opts) = @_;
|
||||
my $ret = '<?xml version="1.0"?>';
|
||||
$ret .= '<categories xmlns="http://sixapart.com/atom/category#">';
|
||||
|
||||
my $tags = LJ::Tags::get_usertags($u, { remote => $remote }) || {};
|
||||
foreach (sort { $a->{name} cmp $b->{name} } values %$tags) {
|
||||
$ret .= "<subject xmlns=\"http://purl.org/dc/elements/1.1/\">$_->{name}</subject>";
|
||||
}
|
||||
$ret .= '</categories>';
|
||||
|
||||
return respond($r, 200, \$ret, 'xml');
|
||||
}
|
||||
|
||||
sub handle_feed {
|
||||
my ($r, $remote, $u, $opts) = @_;
|
||||
|
||||
# simulate a call to the S1 data view creator, with appropriate
|
||||
# options
|
||||
|
||||
my %op = ('pathextra' => "/atom",
|
||||
'saycharset'=> "utf-8",
|
||||
'apilinks' => 1,
|
||||
);
|
||||
my $ret = LJ::Feed::make_feed($r, $u, $remote, \%op);
|
||||
|
||||
unless (defined $ret) {
|
||||
if ($op{'redir'}) {
|
||||
# this happens if the account was renamed or a syn account.
|
||||
# the redir URL is wrong because ljfeed.pl is too
|
||||
# dataview-specific. Since this is an admin interface, we can
|
||||
# just fail.
|
||||
return respond ($r, 404, "The account <b>$u->{'user'} </b> is of a wrong type and does not allow AtomAPI administration.");
|
||||
}
|
||||
if ($op{'handler_return'}) {
|
||||
# this could be a conditional GET shortcut, honor it
|
||||
$r->status($op{'handler_return'});
|
||||
return OK;
|
||||
}
|
||||
# should never get here
|
||||
return respond ($r, 404, "Unknown error.");
|
||||
}
|
||||
|
||||
# everything's fine, return the XML body with the correct content type
|
||||
return respond($r, 200, \$ret, 'xml');
|
||||
|
||||
}
|
||||
|
||||
# this routine accepts the apache request handle, performs
|
||||
# authentication, calls the appropriate method handler, and
|
||||
# prints the response.
|
||||
sub handle {
|
||||
my $r = shift;
|
||||
|
||||
return respond($r, 404, "This server does not support the Atom API.")
|
||||
unless $LJ::OPTMOD_XMLATOM;
|
||||
|
||||
# break the uri down: /interface/atom/<verb>[/<number>]
|
||||
my ( $action, $param, $oldparam ) = ( $1, $2, $3 )
|
||||
if $r->uri =~ m#^/interface/atom(?:api)?/?(\w+)?(?:/(\w+))?(?:/(\d+))?$#;
|
||||
|
||||
my $valid_actions = qr{feed|edit|post|upload|categories};
|
||||
|
||||
# old uri was was: /interface/atomapi/<username>/<verb>[/<number>]
|
||||
# support both by shifting params around if we see something extra.
|
||||
if ($action !~ /$valid_actions/ && $r->uri =~ /atomapi/ ) {
|
||||
$action = $param;
|
||||
$param = $oldparam;
|
||||
}
|
||||
|
||||
# let's authenticate.
|
||||
#
|
||||
# if wsse information is supplied, use it.
|
||||
# if not, fall back to digest.
|
||||
my $wsse = $r->header_in('X-WSSE');
|
||||
my $nonce_dup;
|
||||
my $u = $wsse ? auth_wsse($wsse, \$nonce_dup) : LJ::auth_digest($r);
|
||||
return respond( $r, 401, "Authentication failed for this AtomAPI request.")
|
||||
unless $u;
|
||||
|
||||
return respond( $r, 401, "Authentication failed for this AtomAPI request.")
|
||||
if $nonce_dup && $action && $action ne 'post';
|
||||
|
||||
# service autodiscovery
|
||||
# TODO: Add communities?
|
||||
my $method = $r->method;
|
||||
if ( $method eq 'GET' && ! $action ) {
|
||||
LJ::load_user_props( $u, 'journaltitle' );
|
||||
my $title = $u->{journaltitle} || 'Untitled Journal';
|
||||
my $feed = XML::Atom::Feed->new();
|
||||
foreach (qw/ post feed upload categories /) {
|
||||
my $link = XML::Atom::Link->new();
|
||||
$link->title($title);
|
||||
$link->type('application/x.atom+xml');
|
||||
$link->rel("service.$_");
|
||||
$link->href("$LJ::SITEROOT/interface/atom/$_");
|
||||
$feed->add_link($link);
|
||||
}
|
||||
my $link = XML::Atom::Link->new();
|
||||
$link->title($title);
|
||||
$link->type('text/html');
|
||||
$link->rel('alternate');
|
||||
$link->href( LJ::journal_base($u) );
|
||||
$feed->add_link($link);
|
||||
|
||||
return respond($r, 200, \$feed->as_xml(), 'atom');
|
||||
}
|
||||
|
||||
$action =~ /$valid_actions/
|
||||
or return respond($r, 400, "Unknown URI scheme: /interface/atom/<b>$action</b>");
|
||||
|
||||
unless (($action eq 'feed' and $method eq 'GET') or
|
||||
($action eq 'categories' and $method eq 'GET') or
|
||||
($action eq 'post' and $method eq 'POST') or
|
||||
($action eq 'upload' and $method eq 'POST') or
|
||||
($action eq 'edit' and
|
||||
{'GET'=>1,'PUT'=>1,'DELETE'=>1}->{$method})) {
|
||||
return respond($r, 400, "URI scheme /interface/atom/<b>$action</b> is incompatible with request method <b>$method</b>.");
|
||||
}
|
||||
|
||||
if (($action ne 'edit' && $param) or
|
||||
($action eq 'edit' && $param !~ m#^\d+$#)) {
|
||||
return respond($r, 400, "Either the URI lacks a required parameter, or its format is improper.");
|
||||
}
|
||||
|
||||
# we've authenticated successfully and remote is set. But can remote
|
||||
# manage the requested account?
|
||||
my $remote = LJ::get_remote();
|
||||
unless (LJ::can_manage($remote, $u)) {
|
||||
return respond($r, 403, "User <b>$remote->{'user'}</b> has no administrative access to account <b>$u->{user}</b>.");
|
||||
}
|
||||
|
||||
# handle the requested action
|
||||
my $opts = {
|
||||
'action' => $action,
|
||||
'method' => $method,
|
||||
'param' => $param
|
||||
};
|
||||
|
||||
{
|
||||
'feed' => \&handle_feed,
|
||||
'post' => \&handle_post,
|
||||
'edit' => \&handle_edit,
|
||||
'upload' => \&handle_upload,
|
||||
'categories' => \&handle_categories,
|
||||
}->{$action}->( $r, $remote, $u, $opts );
|
||||
|
||||
return OK;
|
||||
}
|
||||
|
||||
# Authenticate via the WSSE header.
|
||||
# Returns valid $u on success, undef on failure.
|
||||
sub auth_wsse
|
||||
{
|
||||
my ($wsse, $nonce_dup) = @_;
|
||||
$wsse =~ s/UsernameToken // or return undef;
|
||||
|
||||
# parse credentials into a hash.
|
||||
my %creds;
|
||||
foreach (split /, /, $wsse) {
|
||||
my ($k, $v) = split '=', $_, 2;
|
||||
$v =~ s/^['"]//;
|
||||
$v =~ s/['"]$//;
|
||||
$v =~ s/=$// if $k =~ /passworddigest/i; # strip base64 newline char
|
||||
$creds{ lc($k) } = $v;
|
||||
}
|
||||
|
||||
# invalid create time? invalid wsse.
|
||||
my $ctime = LJ::ParseFeed::w3cdtf_to_time( $creds{created} ) or return undef;
|
||||
|
||||
# prevent replay attacks.
|
||||
$ctime = LJ::mysqldate_to_time( $ctime, 'gmt' );
|
||||
return undef if abs(time() - $ctime) > 42300;
|
||||
|
||||
my $u = LJ::load_user( LJ::canonical_username( $creds{'username'} ) )
|
||||
or return undef;
|
||||
|
||||
if (@LJ::MEMCACHE_SERVERS && ref $nonce_dup) {
|
||||
$$nonce_dup = 1
|
||||
unless LJ::MemCache::add( "wsse_auth:$creds{username}:$creds{nonce}", 1, 180 )
|
||||
}
|
||||
|
||||
# validate hash
|
||||
my $hash =
|
||||
Digest::SHA1::sha1_base64(
|
||||
$creds{nonce} . $creds{created} . $u->{password} );
|
||||
|
||||
# Nokia's WSSE implementation is incorrect as of 1.5, and they
|
||||
# base64 encode their nonce *value*. If the initial comparison
|
||||
# fails, we need to try this as well before saying it's invalid.
|
||||
if ($hash ne $creds{passworddigest}) {
|
||||
|
||||
$hash =
|
||||
Digest::SHA1::sha1_base64(
|
||||
MIME::Base64::decode_base64( $creds{nonce} ) .
|
||||
$creds{created} .
|
||||
$u->{password} );
|
||||
|
||||
return undef if $hash ne $creds{passworddigest};
|
||||
}
|
||||
|
||||
# If we're here, we're valid.
|
||||
LJ::set_remote($u);
|
||||
return $u;
|
||||
}
|
||||
|
||||
1;
|
||||
232
livejournal/cgi-bin/Apache/LiveJournal/Interface/Blogger.pm
Executable file
232
livejournal/cgi-bin/Apache/LiveJournal/Interface/Blogger.pm
Executable file
@@ -0,0 +1,232 @@
|
||||
# Blogger API wrapper for LJ
|
||||
|
||||
use strict;
|
||||
package LJ::Util;
|
||||
|
||||
sub blogger_deserialize {
|
||||
my $content = shift;
|
||||
my $event = { 'props' => {} };
|
||||
if ($content =~ s!<title>(.*?)</title>!!) {
|
||||
$event->{'subject'} = $1;
|
||||
}
|
||||
if ($content =~ s/(^|\n)lj-mood:\s*(.*)\n//i) {
|
||||
$event->{'props'}->{'current_mood'} = $2;
|
||||
}
|
||||
if ($content =~ s/(^|\n)lj-music:\s*(.*)\n//i) {
|
||||
$event->{'props'}->{'current_music'} = $2;
|
||||
}
|
||||
$content =~ s/^\s+//; $content =~ s/\s+$//;
|
||||
$event->{'event'} = $content;
|
||||
return $event;
|
||||
}
|
||||
|
||||
sub blogger_serialize {
|
||||
my $event = shift;
|
||||
my $header;
|
||||
my $content;
|
||||
if ($event->{'subject'}) {
|
||||
$header .= "<title>$event->{'subject'}</title>";
|
||||
}
|
||||
if ($event->{'props'}->{'current_mood'}) {
|
||||
$header .= "lj-mood: $event->{'props'}->{'current_mood'}\n";
|
||||
}
|
||||
if ($event->{'props'}->{'current_music'}) {
|
||||
$header .= "lj-music: $event->{'props'}->{'current_music'}\n";
|
||||
}
|
||||
$content .= "$header\n" if $header;
|
||||
$content .= $event->{'event'};
|
||||
return $content;
|
||||
}
|
||||
|
||||
# ISO 8601 (many formats available)
|
||||
# "yyyy-mm-dd hh:mm:ss" => "yyyymmddThh:mm:ss" (literal T)
|
||||
sub mysql_date_to_iso {
|
||||
my $dt = shift;
|
||||
$dt =~ s/ /T/;
|
||||
$dt =~ s/\-//g;
|
||||
return $dt;
|
||||
}
|
||||
|
||||
package Apache::LiveJournal::Interface::Blogger;
|
||||
|
||||
sub newPost {
|
||||
shift;
|
||||
my ($appkey, $journal, $user, $password, $content, $publish) = @_;
|
||||
|
||||
my $err;
|
||||
my $event = LJ::Util::blogger_deserialize($content);
|
||||
|
||||
my $req = {
|
||||
'usejournal' => $journal ne $user ? $journal : undef,
|
||||
'ver' => 1,
|
||||
'username' => $user,
|
||||
'password' => $password,
|
||||
'event' => $event->{'event'},
|
||||
'subject' => $event->{'subject'},
|
||||
'props' => $event->{'props'},
|
||||
'tz' => 'guess',
|
||||
};
|
||||
|
||||
my $res = LJ::Protocol::do_request("postevent", $req, \$err);
|
||||
|
||||
if ($err) {
|
||||
die SOAP::Fault
|
||||
->faultstring(LJ::Protocol::error_message($err))
|
||||
->faultcode(substr($err, 0, 3));
|
||||
}
|
||||
|
||||
return "$journal:$res->{'itemid'}";
|
||||
}
|
||||
|
||||
sub deletePost {
|
||||
shift;
|
||||
my ($appkey, $postid, $user, $password, $content, $publish) = @_;
|
||||
return editPost(undef, $appkey, $postid, $user, $password, "", $publish);
|
||||
}
|
||||
|
||||
sub editPost {
|
||||
shift;
|
||||
my ($appkey, $postid, $user, $password, $content, $publish) = @_;
|
||||
|
||||
die "Invalid postid\n" unless $postid =~ /^(\w+):(\d+)$/;
|
||||
my ($journal, $itemid) = ($1, $2);
|
||||
|
||||
my $event = LJ::Util::blogger_deserialize($content);
|
||||
|
||||
my $req = {
|
||||
'usejournal' => $journal ne $user ? $journal : undef,
|
||||
'ver' => 1,
|
||||
'username' => $user,
|
||||
'password' => $password,
|
||||
'event' => $event->{'event'},
|
||||
'subject' => $event->{'subject'},
|
||||
'props' => $event->{'props'},
|
||||
'itemid' => $itemid,
|
||||
};
|
||||
|
||||
my $err;
|
||||
my $res = LJ::Protocol::do_request("editevent", $req, \$err);
|
||||
|
||||
if ($err) {
|
||||
die SOAP::Fault
|
||||
->faultstring(LJ::Protocol::error_message($err))
|
||||
->faultcode(substr($err, 0, 3));
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub getUsersBlogs {
|
||||
shift;
|
||||
my ($appkey, $user, $password) = @_;
|
||||
|
||||
my $u = LJ::load_user($user) or die "Invalid login\n";
|
||||
die "Invalid login\n" unless LJ::auth_okay($u, $password);
|
||||
|
||||
my $ids = LJ::load_rel_target($u, 'P');
|
||||
my $us = LJ::load_userids(@$ids);
|
||||
my @list = ($u);
|
||||
foreach (sort { $a->{user} cmp $b->{user} } values %$us) {
|
||||
next unless $_->{'statusvis'} eq "V";
|
||||
push @list, $_;
|
||||
}
|
||||
|
||||
return [ map { {
|
||||
'url' => LJ::journal_base($_) . "/",
|
||||
'blogid' => $_->{'user'},
|
||||
'blogName' => $_->{'name'},
|
||||
} } @list ];
|
||||
}
|
||||
|
||||
sub getRecentPosts {
|
||||
shift;
|
||||
my ($appkey, $journal, $user, $password, $numposts) = @_;
|
||||
|
||||
$numposts = int($numposts);
|
||||
$numposts = 1 if $numposts < 1;
|
||||
$numposts = 50 if $numposts > 50;
|
||||
|
||||
my $req = {
|
||||
'usejournal' => $journal ne $user ? $journal : undef,
|
||||
'ver' => 1,
|
||||
'username' => $user,
|
||||
'password' => $password,
|
||||
'selecttype' => 'lastn',
|
||||
'howmany' => $numposts,
|
||||
};
|
||||
|
||||
my $err;
|
||||
my $res = LJ::Protocol::do_request("getevents", $req, \$err);
|
||||
|
||||
if ($err) {
|
||||
die SOAP::Fault
|
||||
->faultstring(LJ::Protocol::error_message($err))
|
||||
->faultcode(substr($err, 0, 3));
|
||||
}
|
||||
|
||||
return [ map { {
|
||||
'content' => LJ::Util::blogger_serialize($_),
|
||||
'userID' => $_->{'poster'} || $journal,
|
||||
'postId' => "$journal:$_->{'itemid'}",
|
||||
'dateCreated' => LJ::Util::mysql_date_to_iso($_->{'eventtime'}),
|
||||
} } @{$res->{'events'}} ];
|
||||
}
|
||||
|
||||
sub getPost {
|
||||
shift;
|
||||
my ($appkey, $postid, $user, $password) = @_;
|
||||
|
||||
die "Invalid postid\n" unless $postid =~ /^(\w+):(\d+)$/;
|
||||
my ($journal, $itemid) = ($1, $2);
|
||||
|
||||
my $req = {
|
||||
'usejournal' => $journal ne $user ? $journal : undef,
|
||||
'ver' => 1,
|
||||
'username' => $user,
|
||||
'password' => $password,
|
||||
'selecttype' => 'one',
|
||||
'itemid' => $itemid,
|
||||
};
|
||||
|
||||
my $err;
|
||||
my $res = LJ::Protocol::do_request("getevents", $req, \$err);
|
||||
|
||||
if ($err) {
|
||||
die SOAP::Fault
|
||||
->faultstring(LJ::Protocol::error_message($err))
|
||||
->faultcode(substr($err, 0, 3));
|
||||
}
|
||||
|
||||
die "Post not found\n" unless $res->{'events'}->[0];
|
||||
|
||||
return map { {
|
||||
'content' => LJ::Util::blogger_serialize($_),
|
||||
'userID' => $_->{'poster'} || $journal,
|
||||
'postId' => "$journal:$_->{'itemid'}",
|
||||
'dateCreated' => LJ::Util::mysql_date_to_iso($_->{'eventtime'}),
|
||||
} } $res->{'events'}->[0];
|
||||
}
|
||||
|
||||
sub getTemplate { die "$LJ::SITENAME doesn't support Blogger Templates. To customize your journal, visit $LJ::SITENAME/customize/"; }
|
||||
*setTemplate = \&getTemplate;
|
||||
|
||||
sub getUserInfo {
|
||||
shift;
|
||||
my ($appkey, $user, $password) = @_;
|
||||
|
||||
my $u = LJ::load_user($user) or die "Invalid login\n";
|
||||
die "Invalid login\n" unless LJ::auth_okay($u, $password);
|
||||
|
||||
LJ::load_user_props($u, "url");
|
||||
|
||||
return {
|
||||
'userid' => $u->{'userid'},
|
||||
'nickname' => $u->{'user'},
|
||||
'firstname' => $u->{'name'},
|
||||
'lastname' => $u->{'name'},
|
||||
'email' => $u->{'email'},
|
||||
'url' => $u->{'url'},
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
207
livejournal/cgi-bin/Apache/LiveJournal/Interface/FotoBilder.pm
Executable file
207
livejournal/cgi-bin/Apache/LiveJournal/Interface/FotoBilder.pm
Executable file
@@ -0,0 +1,207 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Apache::LiveJournal::Interface::FotoBilder;
|
||||
|
||||
use strict;
|
||||
use Apache::Constants qw(:common REDIRECT HTTP_NOT_MODIFIED
|
||||
HTTP_MOVED_PERMANENTLY BAD_REQUEST);
|
||||
|
||||
sub run_method
|
||||
{
|
||||
my $cmd = shift;
|
||||
|
||||
# Available functions for this interface.
|
||||
my $interface = {
|
||||
'checksession' => \&checksession,
|
||||
'get_user_info' => \&get_user_info,
|
||||
'makechals' => \&makechals,
|
||||
'set_quota' => \&set_quota,
|
||||
'user_exists' => \&user_exists,
|
||||
'get_auth_challenge' => \&get_auth_challenge,
|
||||
'get_groups' => \&get_groups,
|
||||
};
|
||||
return undef unless $interface->{$cmd};
|
||||
|
||||
return $interface->{$cmd}->(@_);
|
||||
}
|
||||
|
||||
sub handler
|
||||
{
|
||||
my $r = shift;
|
||||
my $uri = $r->uri;
|
||||
return 404 unless $uri =~ m#^/interface/fotobilder(?:/(\w+))?$#;
|
||||
my $cmd = $1;
|
||||
|
||||
return BAD_REQUEST unless $r->method eq "POST";
|
||||
|
||||
$r->content_type("text/plain");
|
||||
$r->send_http_header();
|
||||
|
||||
my %POST = $r->content;
|
||||
my $res = run_method($cmd, \%POST)
|
||||
or return BAD_REQUEST;
|
||||
|
||||
$res->{"fotobilder-interface-version"} = 1;
|
||||
|
||||
$r->print(join("", map { "$_: $res->{$_}\n" } keys %$res));
|
||||
|
||||
return OK;
|
||||
}
|
||||
|
||||
# Is there a current LJ session?
|
||||
# If so, return info.
|
||||
sub get_user_info
|
||||
{
|
||||
my $POST = shift;
|
||||
BML::reset_cookies();
|
||||
$LJ::_XFER_REMOTE_IP = $POST->{'remote_ip'};
|
||||
|
||||
# try to get a $u from the passed uid or user, falling back to the ljsession cookie
|
||||
my $u;
|
||||
if ($POST->{uid}) {
|
||||
$u = LJ::load_userid($POST->{uid});
|
||||
} elsif ($POST->{user}) {
|
||||
$u = LJ::load_user($POST->{user});
|
||||
} else {
|
||||
$u = LJ::get_remote();
|
||||
}
|
||||
return {} unless $u && $u->{'journaltype'} eq 'P';
|
||||
|
||||
my %ret = (
|
||||
user => $u->{user},
|
||||
userid => $u->{userid},
|
||||
statusvis => $u->{statusvis},
|
||||
can_upload => can_upload($u),
|
||||
gallery_enabled => can_upload($u),
|
||||
diskquota => LJ::get_cap($u, 'disk_quota') * (1 << 20), # mb -> bytes
|
||||
fb_account => LJ::get_cap($u, 'fb_account'),
|
||||
fb_usage => LJ::Blob::get_disk_usage($u, 'fotobilder'),
|
||||
);
|
||||
|
||||
# when the set_quota rpc call is executed (below), a placholder row is inserted
|
||||
# into userblob. it's just used for livejournal display of what we last heard
|
||||
# fotobilder disk usage was, but we need to subtract that out before we report
|
||||
# to fotobilder how much disk the user is using on livejournal's end
|
||||
$ret{diskused} = LJ::Blob::get_disk_usage($u) - $ret{fb_usage};
|
||||
|
||||
return \%ret unless $POST->{fullsync};
|
||||
|
||||
LJ::fill_groups_xmlrpc($u, \%ret);
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
# Forcefully push user info out to FB.
|
||||
# We use this for cases where we don't want to wait for
|
||||
# sync cache timeouts, such as user suspensions.
|
||||
sub push_user_info
|
||||
{
|
||||
my $uid = LJ::want_userid( shift() );
|
||||
return unless $uid;
|
||||
|
||||
my $ret = get_user_info({ uid => $uid });
|
||||
|
||||
eval "use XMLRPC::Lite;";
|
||||
return if $@;
|
||||
|
||||
return XMLRPC::Lite
|
||||
-> proxy("$LJ::FB_SITEROOT/interface/xmlrpc")
|
||||
-> call('FB.XMLRPC.update_userinfo', $ret)
|
||||
-> result;
|
||||
}
|
||||
|
||||
# get_user_info above used to be called 'checksession', maintain
|
||||
# an alias for compatibility
|
||||
sub checksession { get_user_info(@_); }
|
||||
|
||||
sub get_groups {
|
||||
my $POST = shift;
|
||||
my $u = LJ::load_user($POST->{user});
|
||||
return {} unless $u;
|
||||
|
||||
my %ret = ();
|
||||
LJ::fill_groups_xmlrpc($u, \%ret);
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
# Pregenerate a list of challenge/responses.
|
||||
sub makechals
|
||||
{
|
||||
my $POST = shift;
|
||||
my $count = int($POST->{'count'}) || 1;
|
||||
if ($count > 50) { $count = 50; }
|
||||
my $u = LJ::load_user($POST->{'user'});
|
||||
return {} unless $u;
|
||||
|
||||
my %ret = ( count => $count );
|
||||
|
||||
for (my $i=1; $i<=$count; $i++) {
|
||||
my $chal = LJ::rand_chars(40);
|
||||
my $resp = Digest::MD5::md5_hex($chal . Digest::MD5::md5_hex($u->{'password'}));
|
||||
$ret{"chal_$i"} = $chal;
|
||||
$ret{"resp_$i"} = $resp;
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
# Does the user exist?
|
||||
sub user_exists
|
||||
{
|
||||
my $POST = shift;
|
||||
my $u = LJ::load_user($POST->{'user'});
|
||||
return {} unless $u;
|
||||
|
||||
return {
|
||||
exists => 1,
|
||||
can_upload => can_upload($u),
|
||||
};
|
||||
}
|
||||
|
||||
# Mirror FB quota information over to LiveJournal.
|
||||
# 'user' - username
|
||||
# 'used' - FB disk usage in bytes
|
||||
sub set_quota
|
||||
{
|
||||
my $POST = shift;
|
||||
my $u = LJ::load_userid($POST->{'uid'});
|
||||
return {} unless $u && defined $POST->{'used'};
|
||||
|
||||
return {} unless $u->writer;
|
||||
|
||||
my $used = $POST->{'used'} * (1 << 10); # Kb -> bytes
|
||||
my $result = $u->do('REPLACE INTO userblob SET ' .
|
||||
'domain=?, length=?, journalid=?, blobid=0',
|
||||
undef, LJ::get_blob_domainid('fotobilder'),
|
||||
$used, $u->{'userid'});
|
||||
|
||||
LJ::set_userprop($u, "fb_num_pubpics", $POST->{'pub_pics'});
|
||||
|
||||
return {
|
||||
status => ($result ? 1 : 0),
|
||||
};
|
||||
}
|
||||
|
||||
sub get_auth_challenge
|
||||
{
|
||||
my $POST = shift;
|
||||
|
||||
return {
|
||||
chal => LJ::challenge_generate($POST->{goodfor}+0),
|
||||
};
|
||||
}
|
||||
|
||||
#########################################################################
|
||||
# non-interface helper functions
|
||||
#
|
||||
|
||||
# Does the user have upload access?
|
||||
sub can_upload
|
||||
{
|
||||
my $u = shift;
|
||||
|
||||
return LJ::get_cap($u, 'fb_account')
|
||||
&& LJ::get_cap($u, 'fb_can_upload') ? 1 : 0;
|
||||
}
|
||||
|
||||
1;
|
||||
124
livejournal/cgi-bin/Apache/LiveJournal/Interface/S2.pm
Executable file
124
livejournal/cgi-bin/Apache/LiveJournal/Interface/S2.pm
Executable file
@@ -0,0 +1,124 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Apache::LiveJournal::Interface::S2;
|
||||
|
||||
use strict;
|
||||
use MIME::Base64 ();
|
||||
use Apache::Constants;
|
||||
|
||||
sub handler {
|
||||
my $r = shift;
|
||||
|
||||
my $meth = $r->method();
|
||||
my %GET = $r->args();
|
||||
my $uri = $r->uri();
|
||||
my $id;
|
||||
if ($uri =~ m!^/interface/s2/(\d+)$!) {
|
||||
$id = $1 + 0;
|
||||
} else {
|
||||
return NOT_FOUND;
|
||||
}
|
||||
|
||||
my $lay = LJ::S2::load_layer($id);
|
||||
return error($r, 404, 'Layer not found', "There is no layer with id $id at this site")
|
||||
unless $lay;
|
||||
|
||||
LJ::auth_digest($r);
|
||||
my $u = LJ::get_remote();
|
||||
unless ($u) {
|
||||
# Tell the client how it can authenticate
|
||||
# use digest authorization.
|
||||
|
||||
$r->send_http_header("text/plain; charset=utf-8");
|
||||
$r->print("Unauthorized\nYou must send your $LJ::SITENAME username and password or a valid session cookie\n");
|
||||
|
||||
return OK;
|
||||
}
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
|
||||
my $lu = LJ::load_userid($lay->{'userid'});
|
||||
|
||||
return error($r, 500, "Error", "Unable to find layer owner.")
|
||||
unless $lu;
|
||||
|
||||
if ($meth eq 'GET') {
|
||||
|
||||
return error($r, 403, "Forbidden", "You are not authorized to retrieve this layer")
|
||||
unless $lu->{'user'} eq 'system' || LJ::can_manage($u, $lu);
|
||||
|
||||
my $layerinfo = {};
|
||||
LJ::S2::load_layer_info($layerinfo, [ $id ]);
|
||||
my $srcview = exists $layerinfo->{$id}->{'source_viewable'} ?
|
||||
$layerinfo->{$id}->{'source_viewable'} : 1;
|
||||
|
||||
# Disallow retrieval of protected system layers
|
||||
return error($r, 403, "Forbidden", "The requested layer is restricted")
|
||||
if $lu->{'user'} eq 'system' && ! $srcview;
|
||||
|
||||
my $s2code = $dbr->selectrow_array("SELECT s2code FROM s2source WHERE s2lid=?", undef, $id);
|
||||
|
||||
$r->send_http_header("application/x-danga-s2-layer");
|
||||
$r->print($s2code);
|
||||
|
||||
}
|
||||
elsif ($meth eq 'PUT') {
|
||||
|
||||
return error($r, 403, "Forbidden", "You are not authorized to edit this layer")
|
||||
unless LJ::can_manage($u, $lu);
|
||||
|
||||
return error($r, 403, "Forbidden", "Your account type is not allowed to edit layers")
|
||||
unless LJ::get_cap($u, "s2styles");
|
||||
|
||||
# Read in the entity body to get the source
|
||||
my $len = $r->header_in("Content-length")+0;
|
||||
|
||||
return error($r, 400, "Bad Request", "Supply S2 layer code in the request entity body and set Content-length")
|
||||
unless $len;
|
||||
|
||||
return error($r, 415, "Bad Media Type", "Request body must be of type application/x-danga-s2-layer")
|
||||
unless lc($r->header_in("Content-type")) eq 'application/x-danga-s2-layer';
|
||||
|
||||
my $s2code;
|
||||
$r->read($s2code, $len);
|
||||
|
||||
my $error = "";
|
||||
LJ::S2::layer_compile($lay, \$error, { 's2ref' => \$s2code });
|
||||
|
||||
if ($error) {
|
||||
error($r, 500, "Layer Compile Error", "An error was encountered while compiling the layer.");
|
||||
|
||||
## Strip any absolute paths
|
||||
$error =~ s/LJ::.+//s;
|
||||
$error =~ s!, .+?(src/s2|cgi-bin)/!, !g;
|
||||
|
||||
print $error;
|
||||
return OK;
|
||||
}
|
||||
else {
|
||||
$r->status_line("201 Compiled and Saved");
|
||||
$r->header_out("Location" => "$LJ::SITEROOT/interface/s2/$id");
|
||||
$r->send_http_header("text/plain; charset=utf-8");
|
||||
$r->print("Compiled and Saved\nThe layer was uploaded successfully.\n");
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Return 'method not allowed' so that we can add methods in future
|
||||
# and clients will get a sensible error from old servers.
|
||||
return error($r, 405, 'Method Not Allowed', 'Only GET and PUT are supported for this resource');
|
||||
}
|
||||
}
|
||||
|
||||
sub error {
|
||||
my ($r, $code, $string, $long) = @_;
|
||||
|
||||
$r->status_line("$code $string");
|
||||
$r->send_http_header("text/plain; charset=utf-8");
|
||||
$r->print("$string\n$long\n");
|
||||
|
||||
# Tell Apache OK so it won't try to handle the error
|
||||
return OK;
|
||||
}
|
||||
|
||||
1;
|
||||
152
livejournal/cgi-bin/Apache/LiveJournal/PalImg.pm
Executable file
152
livejournal/cgi-bin/Apache/LiveJournal/PalImg.pm
Executable file
@@ -0,0 +1,152 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Apache::LiveJournal::PalImg;
|
||||
|
||||
use strict;
|
||||
use Apache::Constants qw(:common REDIRECT HTTP_NOT_MODIFIED);
|
||||
use PaletteModify;
|
||||
|
||||
# URLs of form /palimg/somedir/file.gif[extra]
|
||||
# where extras can be:
|
||||
# /p... - palette modify
|
||||
|
||||
sub handler
|
||||
{
|
||||
my $r = shift;
|
||||
my $uri = $r->uri;
|
||||
my ($base, $ext, $extra) = $uri =~ m!^/palimg/(.+)\.(\w+)(.*)$!;
|
||||
$r->notes("codepath" => "img.palimg");
|
||||
return 404 unless $base && $base !~ m!\.\.!;
|
||||
|
||||
my $disk_file = "$LJ::HOME/htdocs/palimg/$base.$ext";
|
||||
return 404 unless -e $disk_file;
|
||||
|
||||
my @st = stat(_);
|
||||
my $size = $st[7];
|
||||
my $modtime = $st[9];
|
||||
my $etag = "$modtime-$size";
|
||||
|
||||
my $mime = {
|
||||
'gif' => 'image/gif',
|
||||
'png' => 'image/png',
|
||||
}->{$ext};
|
||||
|
||||
my $palspec;
|
||||
if ($extra) {
|
||||
if ($extra =~ m!^/p(.+)$!) {
|
||||
$palspec = $1;
|
||||
} else {
|
||||
return 404;
|
||||
}
|
||||
}
|
||||
|
||||
return send_file($r, $disk_file, {
|
||||
'mime' => $mime,
|
||||
'etag' => $etag,
|
||||
'palspec' => $palspec,
|
||||
'size' => $size,
|
||||
'modtime' => $modtime,
|
||||
});
|
||||
}
|
||||
|
||||
sub parse_hex_color
|
||||
{
|
||||
my $color = shift;
|
||||
return [ map { hex(substr($color, $_, 2)) } (0,2,4) ];
|
||||
}
|
||||
|
||||
sub send_file
|
||||
{
|
||||
my ($r, $disk_file, $opts) = @_;
|
||||
|
||||
my $etag = $opts->{'etag'};
|
||||
|
||||
# palette altering
|
||||
my %pal_colors;
|
||||
if (my $pals = $opts->{'palspec'}) {
|
||||
my $hx = "[0-9a-f]";
|
||||
if ($pals =~ /^g($hx{2,2})($hx{6,6})($hx{2,2})($hx{6,6})$/) {
|
||||
# gradient from index $1, color $2, to index $3, color $4
|
||||
my $from = hex($1);
|
||||
my $to = hex($3);
|
||||
return 404 if $from == $to;
|
||||
my $fcolor = parse_hex_color($2);
|
||||
my $tcolor = parse_hex_color($4);
|
||||
if ($to < $from) {
|
||||
($from, $to, $fcolor, $tcolor) =
|
||||
($to, $from, $tcolor, $fcolor);
|
||||
}
|
||||
$etag .= ":pg$pals";
|
||||
for (my $i=$from; $i<=$to; $i++) {
|
||||
$pal_colors{$i} = [ map {
|
||||
int($fcolor->[$_] +
|
||||
($tcolor->[$_] - $fcolor->[$_]) *
|
||||
($i-$from) / ($to-$from))
|
||||
} (0..2) ];
|
||||
}
|
||||
} elsif ($pals =~ /^t($hx{6,6})($hx{6,6})?$/) {
|
||||
# tint everything towards color
|
||||
my ($t, $td) = ($1, $2);
|
||||
$pal_colors{'tint'} = parse_hex_color($t);
|
||||
$pal_colors{'tint_dark'} = $td ? parse_hex_color($td) : [0,0,0];
|
||||
} elsif (length($pals) > 42 || $pals =~ /[^0-9a-f]/) {
|
||||
return 404;
|
||||
} else {
|
||||
my $len = length($pals);
|
||||
return 404 if $len % 7; # must be multiple of 7 chars
|
||||
for (my $i = 0; $i < $len/7; $i++) {
|
||||
my $palindex = hex(substr($pals, $i*7, 1));
|
||||
$pal_colors{$palindex} = [
|
||||
hex(substr($pals, $i*7+1, 2)),
|
||||
hex(substr($pals, $i*7+3, 2)),
|
||||
hex(substr($pals, $i*7+5, 2)),
|
||||
substr($pals, $i*7+1, 6),
|
||||
];
|
||||
}
|
||||
$etag .= ":p$_($pal_colors{$_}->[3])" for (sort keys %pal_colors);
|
||||
}
|
||||
}
|
||||
|
||||
$etag = '"' . $etag . '"';
|
||||
my $ifnonematch = $r->header_in("If-None-Match");
|
||||
return HTTP_NOT_MODIFIED if
|
||||
defined $ifnonematch && $etag eq $ifnonematch;
|
||||
|
||||
# send the file
|
||||
$r->content_type($opts->{'mime'});
|
||||
$r->header_out("Content-length", $opts->{'size'});
|
||||
$r->header_out("ETag", $etag);
|
||||
if ($opts->{'modtime'}) {
|
||||
$r->update_mtime($opts->{'modtime'});
|
||||
$r->set_last_modified();
|
||||
}
|
||||
$r->send_http_header();
|
||||
|
||||
# HEAD request?
|
||||
return OK if $r->method eq "HEAD";
|
||||
|
||||
my $fh = Apache::File->new($disk_file);
|
||||
return 404 unless $fh;
|
||||
binmode($fh);
|
||||
|
||||
my $palette;
|
||||
if (%pal_colors) {
|
||||
if ($opts->{'mime'} eq "image/gif") {
|
||||
$palette = PaletteModify::new_gif_palette($fh, \%pal_colors);
|
||||
} elsif ($opts->{'mime'} == "image/png") {
|
||||
$palette = PaletteModify::new_png_palette($fh, \%pal_colors);
|
||||
}
|
||||
unless ($palette) {
|
||||
return 404; # image isn't palette changeable?
|
||||
}
|
||||
}
|
||||
|
||||
$r->print($palette) if $palette; # when palette modified.
|
||||
$r->send_fd($fh); # sends remaining data (or all of it) quickly
|
||||
$fh->close();
|
||||
return OK;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
148
livejournal/cgi-bin/Apache/SendStats.pm
Executable file
148
livejournal/cgi-bin/Apache/SendStats.pm
Executable file
@@ -0,0 +1,148 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package Apache::SendStats;
|
||||
|
||||
BEGIN {
|
||||
$LJ::HAVE_INLINE = eval q{
|
||||
use Inline (C => 'DATA',
|
||||
DIRECTORY => $ENV{LJ_INLINE_DIR} ||"$ENV{'LJHOME'}/Inline",
|
||||
);
|
||||
1;
|
||||
};
|
||||
}
|
||||
use strict;
|
||||
use IO::Socket::INET;
|
||||
use Apache::Constants qw(:common);
|
||||
|
||||
if ($LJ::HAVE_INLINE && $LJ::FREECHILDREN_BCAST) {
|
||||
eval {
|
||||
Inline->init();
|
||||
};
|
||||
if ($@ && ! $LJ::JUST_COMPILING) {
|
||||
print STDERR "Warning: You seem to have Inline.pm, but you haven't run \$LJHOME/bin/lj-inline.pl. " .
|
||||
"Continuing without it, but stats won't broadcast.\n";
|
||||
$LJ::HAVE_INLINE = 0;
|
||||
}
|
||||
}
|
||||
|
||||
use vars qw(%udp_sock);
|
||||
|
||||
sub handler
|
||||
{
|
||||
my $r = shift;
|
||||
return OK if $r->main;
|
||||
return OK unless $LJ::HAVE_INLINE && $LJ::FREECHILDREN_BCAST;
|
||||
|
||||
my $callback = $r->current_callback() if $r;
|
||||
my $cleanup = $callback eq "PerlCleanupHandler";
|
||||
my $childinit = $callback eq "PerlChildInitHandler";
|
||||
|
||||
if ($LJ::TRACK_URL_ACTIVE)
|
||||
{
|
||||
my $key = "url_active:$LJ::SERVER_NAME:$$";
|
||||
if ($cleanup) {
|
||||
LJ::MemCache::delete($key);
|
||||
} else {
|
||||
LJ::MemCache::set($key, $r->uri . "(" . $r->method . "/" . scalar($r->args) . ")");
|
||||
}
|
||||
}
|
||||
|
||||
my ($active, $free) = count_servers();
|
||||
|
||||
$free += $cleanup;
|
||||
$free += $childinit;
|
||||
$active -= $cleanup if $active;
|
||||
|
||||
my $list = ref $LJ::FREECHILDREN_BCAST ?
|
||||
$LJ::FREECHILDREN_BCAST : [ $LJ::FREECHILDREN_BCAST ];
|
||||
|
||||
foreach my $host (@$list) {
|
||||
next unless $host =~ /^(\S+):(\d+)$/;
|
||||
my $bcast = $1;
|
||||
my $port = $2;
|
||||
my $sock = $udp_sock{$host};
|
||||
unless ($sock) {
|
||||
$udp_sock{$host} = $sock = IO::Socket::INET->new(Proto => 'udp');
|
||||
if ($sock) {
|
||||
$sock->sockopt(SO_BROADCAST, 1);
|
||||
} else {
|
||||
$r->log_error("SendStats: couldn't create socket: $host");
|
||||
next;
|
||||
}
|
||||
}
|
||||
|
||||
my $ipaddr = inet_aton($bcast);
|
||||
my $portaddr = sockaddr_in($port, $ipaddr);
|
||||
my $message = "bcast_ver=1\nfree=$free\nactive=$active\n";
|
||||
my $res = $sock->send($message, 0, $portaddr);
|
||||
$r->log_error("SendStats: couldn't broadcast")
|
||||
unless $res;
|
||||
}
|
||||
|
||||
return OK;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__DATA__
|
||||
__C__
|
||||
|
||||
extern unsigned char *ap_scoreboard_image;
|
||||
|
||||
/*
|
||||
* the following structure is for Linux on i32 ONLY! It makes certan
|
||||
* choices where apache's scoreboard.h has #ifdef's. See scoreboard.h
|
||||
* for real declarations, here we only name a few things we actually need.
|
||||
*/
|
||||
|
||||
/* total length of struct should be 164 bytes */
|
||||
typedef struct {
|
||||
int foo1;
|
||||
short foo2;
|
||||
unsigned char status;
|
||||
int foo3[39];
|
||||
} short_score;
|
||||
|
||||
/* length should be 16 bytes */
|
||||
typedef struct {
|
||||
int pid;
|
||||
int foo[3];
|
||||
} parent_score;
|
||||
|
||||
static int hard_limit = 512; /* array size on debian */
|
||||
|
||||
/*
|
||||
* Scoreboard is laid out like this: array of short_score structs,
|
||||
* then array of parent_score structs, then one int, the generation
|
||||
* number. Both arrays are of size HARD_SERVERS_LIMIT, 256 by default
|
||||
* on Unixes.
|
||||
*/
|
||||
|
||||
|
||||
void count_servers() {
|
||||
int i, count_free, count_active;
|
||||
short_score *ss;
|
||||
parent_score *ps;
|
||||
Inline_Stack_Vars;
|
||||
|
||||
ss = (short_score *)ap_scoreboard_image;
|
||||
ps = (parent_score *) ((unsigned char *)ap_scoreboard_image + sizeof(short_score)*hard_limit);
|
||||
|
||||
count_free = 0; count_active = 0;
|
||||
for (i=0; i<hard_limit; i++) {
|
||||
if(ss[i].status == 2) /* READY */
|
||||
count_free++;
|
||||
if(ss[i].status > 2) /* busy doing something */
|
||||
count_active++;
|
||||
}
|
||||
Inline_Stack_Reset;
|
||||
Inline_Stack_Push(newSViv(count_active));
|
||||
Inline_Stack_Push(newSViv(count_free));
|
||||
Inline_Stack_Done;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
|
||||
51
livejournal/cgi-bin/BlobClient.pm
Executable file
51
livejournal/cgi-bin/BlobClient.pm
Executable file
@@ -0,0 +1,51 @@
|
||||
#!/usr/bin/perl
|
||||
# vim:ts=4 sw=4 et:
|
||||
|
||||
use strict;
|
||||
use BlobClient::Remote;
|
||||
use BlobClient::Local;
|
||||
|
||||
package BlobClient;
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
$self->{path} = $args->{path};
|
||||
$self->{path} =~ s!/$!!;
|
||||
$self->{backup_path} = $args->{backup_path};
|
||||
$self->{backup_path} =~ s!/$!!;
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _make_path {
|
||||
my ($cid, $uid, $domain, $fmt, $bid) = @_;
|
||||
die "bogus domain" unless $domain =~ /^\w{1,40}$/;
|
||||
die "bogus format" unless $fmt =~ /^\w{1,10}$/;
|
||||
|
||||
sprintf("%07d", $uid) =~ /^(\d+)(\d\d\d)(\d\d\d)$/;
|
||||
my ($uid1, $uid2, $uid3) = ($1, $2, $3);
|
||||
|
||||
sprintf("%04d", $bid) =~ /^(\d+)(\d\d\d)$/;
|
||||
my ($bid1, $bid2) = ($1, $2);
|
||||
return join('/', int($cid), $uid1, $uid2, $uid3, $domain, $bid1, $bid2) . ".$fmt";
|
||||
}
|
||||
|
||||
sub make_path {
|
||||
my $self = shift;
|
||||
return $self->{path} . '/' . _make_path(@_);
|
||||
}
|
||||
|
||||
sub make_backup_path {
|
||||
my $self = shift;
|
||||
my $path = $self->{backup_path};
|
||||
return undef unless $path; # if no backup_path, just return undef
|
||||
return $path . '/' . _make_path(@_);
|
||||
}
|
||||
|
||||
# derived classes will override this.
|
||||
sub is_dead {
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
114
livejournal/cgi-bin/BlobClient/Local.pm
Executable file
114
livejournal/cgi-bin/BlobClient/Local.pm
Executable file
@@ -0,0 +1,114 @@
|
||||
#!/usr/bin/perl
|
||||
# vim:ts=4 sw=4 et:
|
||||
|
||||
use strict;
|
||||
package BlobClient::Local;
|
||||
|
||||
use IO::File;
|
||||
use File::Path;
|
||||
use Time::HiRes qw{gettimeofday tv_interval};
|
||||
|
||||
use constant DEBUG => 0;
|
||||
|
||||
use BlobClient;
|
||||
our @ISA = ("BlobClient");
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = $class->SUPER::new($args);
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
### Time a I<block> and send a report for the specified I<op> with the given
|
||||
### I<notes> when it finishes.
|
||||
sub report_blocking_time (&@) {
|
||||
my ( $block, $op, $notes, $host ) = ( @_ );
|
||||
|
||||
my $start = [gettimeofday()];
|
||||
my $rval = $block->();
|
||||
LJ::blocking_report( $host, "blob_$op", tv_interval($start), $notes );
|
||||
|
||||
return $rval;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid) = @_;
|
||||
my $fh = new IO::File;
|
||||
local $/ = undef;
|
||||
my $path = make_path(@_);
|
||||
print STDERR "Blob::Local: requesting $path\n" if DEBUG;
|
||||
|
||||
my $data;
|
||||
report_blocking_time {
|
||||
unless (open($fh, '<', $path)) {
|
||||
return undef;
|
||||
}
|
||||
print STDERR "Blob::Local: serving $path\n" if DEBUG;
|
||||
$data = <$fh>;
|
||||
close($fh);
|
||||
} "get", $path, $self->{path};
|
||||
|
||||
return $data;
|
||||
}
|
||||
|
||||
sub get_stream {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid, $callback, $errref) = @_;
|
||||
|
||||
my $fh = new IO::File;
|
||||
my $path = make_path(@_);
|
||||
|
||||
my $data;
|
||||
report_blocking_time {
|
||||
unless (open($fh, '<', $path)) {
|
||||
$$errref = "Error opening '$path'";
|
||||
return undef;
|
||||
}
|
||||
while (read($fh, $data, 1024*50)) {
|
||||
$callback->($data);
|
||||
}
|
||||
close($fh);
|
||||
} "get_stream", $path, $self->{path};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub put {
|
||||
my ($self, $cid, $uid, $fmt, $domain, $bid, $content) = @_;
|
||||
|
||||
my $filename = make_path(@_);
|
||||
|
||||
my $dir = File::Basename::dirname($filename);
|
||||
eval { File::Path::mkpath($dir, 0, 0775); };
|
||||
return undef if $@;
|
||||
|
||||
report_blocking_time {
|
||||
my $fh = new IO::File;
|
||||
unless (open($fh, '>', $filename)) {
|
||||
return undef;
|
||||
}
|
||||
print $fh $content;
|
||||
close $fh;
|
||||
} "put", $filename, $self->{path};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
my ($self, $cid, $uid, $fmt, $domain, $bid) = @_;
|
||||
|
||||
my $filename = make_path(@_);
|
||||
|
||||
return 0 unless -e $filename;
|
||||
my $rval;
|
||||
report_blocking_time {
|
||||
# FIXME: rmdir up the tree
|
||||
$rval = unlink($filename);
|
||||
} "delete", $filename, $self->{path};
|
||||
|
||||
return $rval;
|
||||
}
|
||||
|
||||
sub make_path { my $self = shift; return $self->SUPER::make_path(@_); }
|
||||
|
||||
1;
|
||||
164
livejournal/cgi-bin/BlobClient/Remote.pm
Executable file
164
livejournal/cgi-bin/BlobClient/Remote.pm
Executable file
@@ -0,0 +1,164 @@
|
||||
#!/usr/bin/perl
|
||||
# vim:ts=4 sw=4 et:
|
||||
|
||||
package BlobClient::Remote;
|
||||
|
||||
use BlobClient;
|
||||
use LWP::UserAgent;
|
||||
use Time::HiRes qw{gettimeofday tv_interval};
|
||||
use vars qw(@ISA);
|
||||
@ISA = qw(BlobClient);
|
||||
|
||||
use strict;
|
||||
|
||||
use constant DEBUG => 0;
|
||||
use constant DEADTIME => 30;
|
||||
|
||||
use BlobClient;
|
||||
|
||||
### Time a I<block> and send a report for the specified I<op> with the given
|
||||
### I<notes> when it finishes.
|
||||
sub report_blocking_time (&@) {
|
||||
my ( $block, $op, $notes, $host ) = ( @_ );
|
||||
|
||||
my $start = [gettimeofday()];
|
||||
my $rval = $block->();
|
||||
LJ::blocking_report( $host, "blob_$op", tv_interval($start), $notes );
|
||||
|
||||
return $rval;
|
||||
}
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = $class->SUPER::new($args);
|
||||
|
||||
$self->{ua} = LWP::UserAgent->new(agent=>'blobclient', timeout => 4);
|
||||
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid, $use_backup) = @_;
|
||||
my $path = $use_backup ? make_backup_path(@_) : make_path(@_);
|
||||
return undef unless $path; # if no path, we fail
|
||||
|
||||
print STDERR "Blob::Remote requesting $path (backup path? $use_backup)\n" if DEBUG;
|
||||
my $req = HTTP::Request->new(GET => $path);
|
||||
|
||||
my $res;
|
||||
report_blocking_time {
|
||||
eval { $res = $self->{ua}->request($req); };
|
||||
} "get", $path, $self->{path};
|
||||
return $res->content if $res->is_success;
|
||||
|
||||
# two types of failure: server dead, or just a 404.
|
||||
# a 404 doesn't mean the server is necessarily bad.
|
||||
|
||||
if ($res->code == 500) {
|
||||
# server dead.
|
||||
if ($use_backup) {
|
||||
# can't reach backup server, we're really dead
|
||||
$self->{deaduntil} = time() + DEADTIME;
|
||||
} else {
|
||||
# try using a backup
|
||||
return $self->get($cid, $uid, $domain, $fmt, $bid, 1);
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub get_stream {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid, $callback, $use_backup) = @_;
|
||||
my $path = $use_backup ? make_backup_path(@_) : make_path(@_);
|
||||
return undef unless $path; # if no path, we fail
|
||||
|
||||
my $req = HTTP::Request->new(GET => $path);
|
||||
|
||||
my $res;
|
||||
report_blocking_time {
|
||||
eval { $res = $self->{ua}->request($req, $callback, 1024*50); };
|
||||
} "get_stream", $path, $self->{path};
|
||||
|
||||
return $res->is_success if $res->is_success;
|
||||
|
||||
# must have failed
|
||||
if ($res->code == 500) {
|
||||
# server dead.
|
||||
if ($use_backup) {
|
||||
# can't reach backup server, we're really dead
|
||||
$self->{deaduntil} = time() + DEADTIME;
|
||||
} else {
|
||||
# try using a backup
|
||||
return $self->get_stream($cid, $uid, $domain, $fmt, $bid, $callback, 1);
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub put {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid, $content, $errref, $use_backup) = @_;
|
||||
my $path = $use_backup ? make_backup_path(@_) : make_path(@_);
|
||||
return 0 unless $path; # if no path, we fail
|
||||
|
||||
my $req = HTTP::Request->new(PUT => $path);
|
||||
|
||||
$req->content($content);
|
||||
|
||||
my $res;
|
||||
report_blocking_time {
|
||||
eval { $res = $self->{ua}->request($req); };
|
||||
} "put", $path, $self->{path};
|
||||
|
||||
unless ($res->is_success) {
|
||||
if ($use_backup) {
|
||||
# total failure
|
||||
$$errref = "$path: " . $res->status_line if $errref;
|
||||
return 0;
|
||||
} else {
|
||||
# try backup
|
||||
return $self->put($cid, $uid, $domain, $fmt, $bid, $content, $errref, 1);
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
my ($self, $cid, $uid, $domain, $fmt, $bid, $use_backup) = @_;
|
||||
my $path = $use_backup ? make_backup_path(@_) : make_path(@_);
|
||||
return 0 unless $path; # if no path, we fail
|
||||
|
||||
my $req = HTTP::Request->new(DELETE => $path);
|
||||
|
||||
my $res;
|
||||
report_blocking_time {
|
||||
eval { $res = $self->{ua}->request($req); };
|
||||
} "delete", $path, $self->{path};
|
||||
|
||||
return 1 if $res && $res->code == 404;
|
||||
unless ($res->is_success) {
|
||||
if ($res->code == 500) {
|
||||
if ($use_backup) {
|
||||
# total failure!
|
||||
return 0;
|
||||
} else {
|
||||
# try again
|
||||
return $self->delete($cid, $uid, $domain, $fmt, $bid, 1);
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is_dead {
|
||||
my $self = shift;
|
||||
delete $self->{deaduntil} if $self->{deaduntil} <= time();
|
||||
return $self->{deaduntil} > 0;
|
||||
}
|
||||
|
||||
### [MG]: Hmmm... no-op?
|
||||
sub make_path { my $self = shift; return $self->SUPER::make_path(@_); }
|
||||
sub make_backup_path { my $self = shift; return $self->SUPER::make_backup_path(@_); }
|
||||
|
||||
1;
|
||||
150
livejournal/cgi-bin/LJ/Blob.pm
Executable file
150
livejournal/cgi-bin/LJ/Blob.pm
Executable file
@@ -0,0 +1,150 @@
|
||||
# Wrapper around BlobClient.
|
||||
|
||||
use strict;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
use BlobClient;
|
||||
|
||||
package LJ::Blob;
|
||||
|
||||
my %bc_cache = ();
|
||||
my %bc_reader_cache = ();
|
||||
my %bc_path_reader_cache = ();
|
||||
|
||||
# read-write (i.e. HTTP connection to BlobServer, with NetApp NFS mounted)
|
||||
sub get_blobclient {
|
||||
my $u = shift;
|
||||
my $bcid = $u->{blob_clusterid} or die "No blob_clusterid";
|
||||
return $bc_cache{$bcid} ||=
|
||||
_bc_from_path($LJ::BLOBINFO{clusters}->{$bcid},
|
||||
$LJ::BLOBINFO{clusters}->{"$bcid-BACKUP"});
|
||||
}
|
||||
|
||||
# read-only access. (i.e. direct HTTP connection to NetApp)
|
||||
sub get_blobclient_reader {
|
||||
my $u = shift;
|
||||
my $bcid = $u->{blob_clusterid} or die "No blob_clusterid";
|
||||
|
||||
return $bc_reader_cache{$bcid} if $bc_reader_cache{$bcid};
|
||||
|
||||
my $path = $LJ::BLOBINFO{clusters}->{"$bcid-GET"} ||
|
||||
$LJ::BLOBINFO{clusters}->{$bcid};
|
||||
my $bpath = $LJ::BLOBINFO{clusters}->{"$bcid-BACKUP"};
|
||||
|
||||
return $bc_reader_cache{$bcid} = _bc_from_path($path, $bpath);
|
||||
}
|
||||
|
||||
sub _bc_from_path {
|
||||
my ($path, $bpath) = @_;
|
||||
if ($path =~ /^http/) {
|
||||
$bpath = undef unless $bpath =~ /^http/;
|
||||
return BlobClient::Remote->new({ path => $path, backup_path => $bpath });
|
||||
} elsif ($path) {
|
||||
return BlobClient::Local->new({ path => $path });
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# given a $u, returns that user's blob_clusterid, conditionally loading it
|
||||
sub _load_bcid {
|
||||
my $u = shift;
|
||||
die "No user" unless $u;
|
||||
return $u->{blob_clusterid} if $u->{blob_clusterid};
|
||||
|
||||
# if the entire system only has one blob_clusterid, use that
|
||||
# without querying the database/memcache
|
||||
return $u->{blob_clusterid} = $LJ::ONLY_BLOB_CLUSTERID
|
||||
if defined $LJ::ONLY_BLOB_CLUSTERID;
|
||||
|
||||
LJ::load_user_props($u, "blob_clusterid");
|
||||
return $u->{blob_clusterid} if $u->{blob_clusterid};
|
||||
die "Couldn't find user $u->{user}'s blob_clusterid\n";
|
||||
}
|
||||
|
||||
# args: u, domain, fmt, bid
|
||||
# des-fmt: string file extension ("jpg", "gif", etc)
|
||||
# des-bid: numeric blob id for this domain
|
||||
# des-domain: string name of domain ("userpic", "phonephost", etc)
|
||||
sub get {
|
||||
my ($u, $domain, $fmt, $bid) = @_;
|
||||
_load_bcid($u);
|
||||
my $bc = get_blobclient_reader($u);
|
||||
return $bc->get($u->{blob_clusterid}, $u->{userid}, $domain, $fmt, $bid);
|
||||
}
|
||||
|
||||
# Return a path relative to the specified I<root> for the given arguments.
|
||||
# args: root, u, domain, fmt, bid
|
||||
# des-root: Root path
|
||||
# des-fmt: string file extension ("jpg", "gif", etc)
|
||||
# des-bid: numeric blob id for this domain
|
||||
# des-domain: string name of domain ("userpic", "phonephost", etc)
|
||||
sub get_rel_path {
|
||||
my ( $root, $u, $domain, $fmt, $bid ) = @_;
|
||||
|
||||
my $bcid = _load_bcid( $u );
|
||||
my $bc = $bc_path_reader_cache{ "$bcid:$root" } ||= new BlobClient::Local ({ path => $root });
|
||||
|
||||
return $bc->make_path( $bcid, $u->{userid}, $domain, $fmt, $bid );
|
||||
}
|
||||
|
||||
|
||||
sub get_stream {
|
||||
my ($u, $domain, $fmt, $bid, $callback) = @_;
|
||||
_load_bcid($u);
|
||||
my $bc = get_blobclient_reader($u);
|
||||
return $bc->get_stream($u->{blob_clusterid}, $u->{userid}, $domain, $fmt, $bid, $callback);
|
||||
}
|
||||
|
||||
sub put {
|
||||
my ($u, $domain, $fmt, $bid, $data, $errref) = @_;
|
||||
_load_bcid($u);
|
||||
my $bc = get_blobclient($u);
|
||||
|
||||
unless ($u->writer) {
|
||||
$$errref = "nodb";
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($bc->put($u->{blob_clusterid}, $u->{userid}, $domain,
|
||||
$fmt, $bid, $data, $errref)) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
$u->do("INSERT IGNORE INTO userblob (journalid, domain, blobid, length) ".
|
||||
"VALUES (?, ?, ?, ?)", undef,
|
||||
$u->{userid}, LJ::get_blob_domainid($domain),
|
||||
$bid, length($data));
|
||||
die "Error doing userblob accounting: " . $u->errstr if $u->err;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub delete {
|
||||
my ($u, $domain, $fmt, $bid) = @_;
|
||||
_load_bcid($u);
|
||||
my $bc = get_blobclient($u);
|
||||
|
||||
return 0 unless $u->writer;
|
||||
|
||||
my $bdid = LJ::get_blob_domainid($domain);
|
||||
return 0 unless $bc->delete($u->{blob_clusterid}, $u->{userid}, $domain,
|
||||
$fmt, $bid);
|
||||
|
||||
$u->do("DELETE FROM userblob WHERE journalid=? AND domain=? AND blobid=?",
|
||||
undef, $u->{userid}, $bdid, $bid);
|
||||
die "Error doing userblob accounting: " . $u->errstr if $u->err;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_disk_usage {
|
||||
my ($u, $domain) = @_;
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
if ($domain) {
|
||||
return $dbcr->selectrow_array("SELECT SUM(length) FROM userblob ".
|
||||
"WHERE journalid=? AND domain=?", undef,
|
||||
$u->{userid}, LJ::get_blob_domainid($domain));
|
||||
} else {
|
||||
return $dbcr->selectrow_array("SELECT SUM(length) FROM userblob ".
|
||||
"WHERE journalid=?", undef, $u->{userid});
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
291
livejournal/cgi-bin/LJ/Cache.pm
Executable file
291
livejournal/cgi-bin/LJ/Cache.pm
Executable file
@@ -0,0 +1,291 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# LJ::Cache class
|
||||
# See perldoc documentation at the end of this file.
|
||||
#
|
||||
# -------------------------------------------------------------------------
|
||||
#
|
||||
# This package is released under the LGPL (GNU Library General Public License)
|
||||
#
|
||||
# A copy of the license has been included with the software as LGPL.txt.
|
||||
# If not, the license is available at:
|
||||
# http://www.gnu.org/copyleft/library.txt
|
||||
#
|
||||
# -------------------------------------------------------------------------
|
||||
#
|
||||
|
||||
package LJ::Cache;
|
||||
|
||||
use strict;
|
||||
use fields qw(items size tail head bytes maxsize maxbytes);
|
||||
|
||||
use vars qw($VERSION);
|
||||
use constant PREVKEY => 0;
|
||||
use constant VALUE => 1;
|
||||
use constant NEXTKEY => 2;
|
||||
use constant BYTES => 3;
|
||||
use constant INSTIME => 4;
|
||||
use constant FLAGS => 5; # caller-defined metadata
|
||||
|
||||
$VERSION = '1.0';
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = fields::new($class);
|
||||
|
||||
$self->init($args);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub walk_items {
|
||||
my LJ::Cache $self = shift;
|
||||
my $code = shift;
|
||||
|
||||
my $iter = $self->{'head'};
|
||||
while ($iter) {
|
||||
my $it = $self->{'items'}->{$iter};
|
||||
$code->($iter, $it->[BYTES], $it->[INSTIME]);
|
||||
$iter = $it->[NEXTKEY];
|
||||
}
|
||||
}
|
||||
|
||||
sub init {
|
||||
my LJ::Cache $self = shift;
|
||||
my $args = shift;
|
||||
|
||||
$self->{'head'} = 0;
|
||||
$self->{'tail'} = 0;
|
||||
$self->{'items'} = {}; # key -> arrayref, indexed by constants above
|
||||
$self->{'size'} = 0;
|
||||
$self->{'bytes'} = 0;
|
||||
$self->{'maxsize'} = $args->{'maxsize'}+0;
|
||||
$self->{'maxbytes'} = $args->{'maxbytes'}+0;
|
||||
}
|
||||
|
||||
sub get_item_count {
|
||||
my LJ::Cache $self = shift;
|
||||
$self->{'size'};
|
||||
}
|
||||
|
||||
sub get_byte_count {
|
||||
my LJ::Cache $self = shift;
|
||||
$self->{'bytes'};
|
||||
}
|
||||
|
||||
sub get_max_age {
|
||||
my LJ::Cache $self = shift;
|
||||
return undef unless $self->{'tail'};
|
||||
return $self->{'items'}->{$self->{'tail'}}->[INSTIME];
|
||||
}
|
||||
|
||||
sub validate_list
|
||||
{
|
||||
my ($self, $source) = @_;
|
||||
print "Validate list: $self->{'size'} (max: $self->{'maxsize'})\n";
|
||||
|
||||
my $count = 1;
|
||||
if ($self->{'size'} && ! defined $self->{'head'}) {
|
||||
die "$source: no head pointer\n";
|
||||
}
|
||||
if ($self->{'size'} && ! defined $self->{'tail'}) {
|
||||
die "$source: no tail pointer\n";
|
||||
}
|
||||
if ($self->{'size'}) {
|
||||
print " head: $self->{'head'}\n";
|
||||
print " tail: $self->{'tail'}\n";
|
||||
}
|
||||
|
||||
my $iter = $self->{'head'};
|
||||
my $last = undef;
|
||||
while ($count <= $self->{'size'}) {
|
||||
if (! defined $iter) {
|
||||
die "$source: undefined iterator\n";
|
||||
}
|
||||
my $item = $self->{'items'}->{$iter};
|
||||
unless (defined $item) {
|
||||
die "$source: item '$iter' isn't in items\n";
|
||||
}
|
||||
my $prevtext = $item->[PREVKEY] || "--";
|
||||
my $nexttext = $item->[NEXTKEY] || "--";
|
||||
print " #$count ($iter): [$prevtext, $item->[VALUE], $nexttext]\n";
|
||||
if ($count == 1 && defined($item->[0])) {
|
||||
die "$source: Head element shouldn't have previous pointer!\n";
|
||||
}
|
||||
if ($count == $self->{'size'} && defined($item->[NEXTKEY])) {
|
||||
die "$source: Last element shouldn't have next pointer!\n";
|
||||
}
|
||||
if (defined $last && ! defined $item->[PREVKEY]) {
|
||||
die "$source: defined \$last but not defined previous pointer.\n";
|
||||
}
|
||||
if (! defined $last && defined $item->[PREVKEY]) {
|
||||
die "$source: not defined \$last but previous pointer defined.\n";
|
||||
}
|
||||
if (defined $item->[PREVKEY] && defined $last && $item->[PREVKEY] ne $last)
|
||||
{
|
||||
die "$source: Previous pointer is wrong.\n";
|
||||
}
|
||||
|
||||
$last = $iter;
|
||||
$iter = defined $item->[NEXTKEY] ? $item->[NEXTKEY] : undef;
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
|
||||
sub drop_tail
|
||||
{
|
||||
my LJ::Cache $self = shift;
|
||||
|
||||
## who's going to die?
|
||||
my $to_die = $self->{'tail'};
|
||||
|
||||
## set the tail to the item before the one dying.
|
||||
$self->{'tail'} = $self->{'items'}->{$to_die}->[PREVKEY];
|
||||
|
||||
## adjust the forward pointer on the tail to be undef
|
||||
if (defined $self->{'tail'}) {
|
||||
undef $self->{'items'}->{$self->{'tail'}}->[NEXTKEY];
|
||||
}
|
||||
|
||||
## kill the item
|
||||
my $bytes = $self->{'items'}->{$to_die}->[BYTES];
|
||||
delete $self->{'items'}->{$to_die};
|
||||
|
||||
## shrink the overall size
|
||||
$self->{'size'}--;
|
||||
$self->{'bytes'} -= $bytes;
|
||||
}
|
||||
|
||||
sub print_list {
|
||||
my LJ::Cache $self = shift;
|
||||
|
||||
print "Size: $self->{'size'} (max: $self->{'maxsize'})\n";
|
||||
|
||||
my $count = 1;
|
||||
my $iter = $self->{'head'};
|
||||
while (defined $iter) { #$count <= $self->{'size'}) {
|
||||
my $item = $self->{'items'}->{$iter};
|
||||
print "$count: $iter = $item->[VALUE]\n";
|
||||
$iter = $item->[NEXTKEY];
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
|
||||
sub get {
|
||||
my LJ::Cache $self = shift;
|
||||
my ($key, $out_flags) = @_;
|
||||
|
||||
if (exists $self->{'items'}->{$key})
|
||||
{
|
||||
my $item = $self->{'items'}->{$key};
|
||||
|
||||
# promote this to the head
|
||||
unless ($self->{'head'} eq $key)
|
||||
{
|
||||
if ($self->{'tail'} eq $key) {
|
||||
$self->{'tail'} = $item->[PREVKEY];
|
||||
}
|
||||
# remove this element from the linked list.
|
||||
my $next = $item->[NEXTKEY];
|
||||
my $prev = $item->[PREVKEY];
|
||||
if (defined $next) { $self->{'items'}->{$next}->[PREVKEY] = $prev; }
|
||||
if (defined $prev) { $self->{'items'}->{$prev}->[NEXTKEY] = $next; }
|
||||
|
||||
# make current head point backwards to this item
|
||||
$self->{'items'}->{$self->{'head'}}->[PREVKEY] = $key;
|
||||
|
||||
# make this item point forwards to current head, and backwards nowhere
|
||||
$item->[NEXTKEY] = $self->{'head'};
|
||||
undef $item->[PREVKEY];
|
||||
|
||||
# make this the new head
|
||||
$self->{'head'} = $key;
|
||||
}
|
||||
|
||||
$$out_flags = $item->[FLAGS] if $out_flags;
|
||||
return $item->[VALUE];
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# bytes is optional
|
||||
sub set {
|
||||
my LJ::Cache $self = shift;
|
||||
my ($key, $value, $bytes, $flags) = @_;
|
||||
|
||||
$self->drop_tail() while ($self->{'maxsize'} &&
|
||||
$self->{'size'} >= $self->{'maxsize'} &&
|
||||
! exists $self->{'items'}->{$key}) ||
|
||||
($self->{'maxbytes'} && $self->{'size'} &&
|
||||
$self->{'bytes'} + $bytes >= $self->{'maxbytes'} &&
|
||||
! exists $self->{'items'}->{$key});
|
||||
|
||||
|
||||
if (exists $self->{'items'}->{$key}) {
|
||||
# update the value
|
||||
my $it = $self->{'items'}->{$key};
|
||||
$it->[VALUE] = $value;
|
||||
my $bytedelta = $bytes - $it->[BYTES];
|
||||
$self->{'bytes'} += $bytedelta;
|
||||
$it->[BYTES] = $bytes;
|
||||
$it->[FLAGS] = $flags;
|
||||
} else {
|
||||
# stick it at the end, for now
|
||||
my $it = $self->{'items'}->{$key} = [];
|
||||
$it->[PREVKEY] = undef;
|
||||
$it->[NEXTKEY] = undef;
|
||||
$it->[VALUE] = $value;
|
||||
$it->[BYTES] = $bytes;
|
||||
$it->[INSTIME] = time();
|
||||
$it->[FLAGS] = $flags;
|
||||
if ($self->{'size'}) {
|
||||
$self->{'items'}->{$self->{'tail'}}->[NEXTKEY] = $key;
|
||||
$self->{'items'}->{$key}->[PREVKEY] = $self->{'tail'};
|
||||
} else {
|
||||
$self->{'head'} = $key;
|
||||
}
|
||||
$self->{'tail'} = $key;
|
||||
$self->{'size'}++;
|
||||
$self->{'bytes'} += $bytes;
|
||||
}
|
||||
|
||||
# this will promote it to the top:
|
||||
$self->get($key);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LJ::Cache - LRU Cache
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LJ::Cache;
|
||||
my $cache = new LJ::Cache { 'maxsize' => 20 };
|
||||
my $value = $cache->get($key);
|
||||
unless (defined $value) {
|
||||
$val = "load some value";
|
||||
$cache->set($key, $value);
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class implements an LRU dictionary cache. The two operations on it
|
||||
are get() and set(), both of which promote the key being referenced to
|
||||
the "top" of the cache, so it will stay alive longest.
|
||||
|
||||
When the cache is full and and a new item needs to be added, the oldest
|
||||
one is thrown away.
|
||||
|
||||
You should be able to regenerate the data at any time, if get()
|
||||
returns undef.
|
||||
|
||||
This class is useful for caching information from a slower data source
|
||||
while also keeping a bound on memory usage.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Brad Fitzpatrick, bradfitz@bradfitz.com
|
||||
|
||||
=cut
|
||||
423
livejournal/cgi-bin/LJ/Captcha.pm
Executable file
423
livejournal/cgi-bin/LJ/Captcha.pm
Executable file
@@ -0,0 +1,423 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
package LJ::Captcha;
|
||||
use GD;
|
||||
use File::Temp;
|
||||
use Cwd ();
|
||||
use Digest::MD5 ();
|
||||
use LJ::Blob qw{};
|
||||
require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
|
||||
|
||||
|
||||
# stolen from Authen::Captcha. code was small enough that duplicating
|
||||
# was easier than requiring that module, and removing all its automatic
|
||||
# database tracking stuff and replacing it with ours. maybe we'll move
|
||||
# to using it in the future, but for now this works. (both their code
|
||||
# and ours is GPL)
|
||||
sub generate_visual
|
||||
{
|
||||
my ($code) = @_;
|
||||
|
||||
my $im_width = 25;
|
||||
my $im_height = 35;
|
||||
my $length = length($code);
|
||||
|
||||
my $img = "$LJ::HOME/htdocs/img/captcha";
|
||||
|
||||
# create a new image and color
|
||||
my $im = new GD::Image(($im_width * $length),$im_height);
|
||||
my $black = $im->colorAllocate(0,0,0);
|
||||
|
||||
# copy the character images into the code graphic
|
||||
for(my $i=0; $i < $length; $i++)
|
||||
{
|
||||
my $letter = substr($code,$i,1);
|
||||
my $letter_png = "$img/$letter.png";
|
||||
my $source = new GD::Image($letter_png);
|
||||
$im->copy($source,($i*($im_width),0,0,0,$im_width,$im_height));
|
||||
my $a = int(rand (int(($im_width)/14)))+0;
|
||||
my $b = int(rand (int(($im_height)/12)))+0;
|
||||
my $c = int(rand (int(($im_width)/3)))-(int(($im_width)/5));
|
||||
my $d = int(rand (int(($im_height)/3)))-(int(($im_height)/5));
|
||||
$im->copyResized($source,($i*($im_width))+$a,$b,0,0,($im_width)+$c,($im_height)+$d,$im_width,$im_height);
|
||||
}
|
||||
|
||||
# distort the code graphic
|
||||
for(my $i=0; $i<($length*$im_width*$im_height/14+150); $i++)
|
||||
{
|
||||
my $a = int(rand($length*$im_width));
|
||||
my $b = int(rand($im_height));
|
||||
my $c = int(rand($length*$im_width));
|
||||
my $d = int(rand($im_height));
|
||||
my $index = $im->getPixel($a,$b);
|
||||
if ($i < (($length*($im_width)*($im_height)/14+200)/100))
|
||||
{
|
||||
$im->line($a,$b,$c,$d,$index);
|
||||
} elsif ($i < (($length*($im_width)*($im_height)/14+200)/2)) {
|
||||
$im->setPixel($c,$d,$index);
|
||||
} else {
|
||||
$im->setPixel($c,$d,$black);
|
||||
}
|
||||
}
|
||||
|
||||
# generate a background
|
||||
my $a = int(rand 5)+1;
|
||||
my $background_img = "$img/background$a.png";
|
||||
my $source = new GD::Image($background_img);
|
||||
my ($background_width, $background_height) = $source->getBounds();
|
||||
my $b = int(rand (int($background_width/13)))+0;
|
||||
my $c = int(rand (int($background_height/7)))+0;
|
||||
my $d = int(rand (int($background_width/13)))+0;
|
||||
my $e = int(rand (int($background_height/7)))+0;
|
||||
my $source2 = new GD::Image(($length*($im_width)),$im_height);
|
||||
$source2->copyResized($source,0,0,$b,$c,$length*$im_width,$im_height,$background_width-$b-$d,$background_height-$c-$e);
|
||||
|
||||
# merge the background onto the image
|
||||
$im->copyMerge($source2,0,0,0,0,($length*($im_width)),$im_height,40);
|
||||
|
||||
# add a border
|
||||
$im->rectangle(0, 0, $length*$im_width-1, $im_height-1, $black);
|
||||
|
||||
return $im->png;
|
||||
|
||||
}
|
||||
|
||||
|
||||
### get_visual_id() -> ( $capid, $anum )
|
||||
sub get_visual_id { get_id('image') }
|
||||
sub get_audio_id { get_id('audio') }
|
||||
|
||||
|
||||
### get_id( $type ) -> ( $capid, $anum )
|
||||
sub get_id
|
||||
{
|
||||
my ( $type ) = @_;
|
||||
my (
|
||||
$dbh, # Database handle (writer)
|
||||
$sql, # SQL statement
|
||||
$row, # Row arrayref
|
||||
$capid, # Captcha id
|
||||
$anum, # Unseries-ifier number
|
||||
$issuedate, # unixtime of issue
|
||||
);
|
||||
|
||||
# Fetch database handle and lock the captcha table
|
||||
$dbh = LJ::get_db_writer()
|
||||
or return LJ::error( "Couldn't fetch a db writer." );
|
||||
$dbh->selectrow_array("SELECT GET_LOCK('get_captcha', 10)")
|
||||
or return LJ::error( "Failed lock on getting a captcha." );
|
||||
|
||||
# Fetch the first unassigned row
|
||||
$sql = q{
|
||||
SELECT capid, anum
|
||||
FROM captchas
|
||||
WHERE
|
||||
issuetime = 0
|
||||
AND type = ?
|
||||
LIMIT 1
|
||||
};
|
||||
$row = $dbh->selectrow_arrayref( $sql, undef, $type )
|
||||
or $dbh->do("DO RELEASE_LOCK('get_captcha')") && die "No $type captchas available";
|
||||
die "selectrow_arrayref: $sql: ", $dbh->errstr if $dbh->err;
|
||||
( $capid, $anum ) = @$row;
|
||||
|
||||
# Mark the captcha as issued
|
||||
$issuedate = time();
|
||||
$sql = qq{
|
||||
UPDATE captchas
|
||||
SET issuetime = $issuedate
|
||||
WHERE capid = $capid
|
||||
};
|
||||
$dbh->do( $sql ) or die "do: $sql: ", $dbh->errstr;
|
||||
$dbh->do("DO RELEASE_LOCK('get_captcha')");
|
||||
|
||||
return ( $capid, $anum );
|
||||
}
|
||||
|
||||
|
||||
### get_visual_data( $capid, $anum, $want_paths )
|
||||
# if want_paths is true, this function may return an arrayref containing
|
||||
# one or more paths (disk or HTTP) to the resource
|
||||
sub get_visual_data
|
||||
{
|
||||
my ( $capid, $anum, $want_paths ) = @_;
|
||||
$capid = int($capid);
|
||||
|
||||
my (
|
||||
$dbr, # Database handle (reader)
|
||||
$sql, # SQL statement
|
||||
$valid, # Are the capid/anum valid?
|
||||
$data, # The PNG data
|
||||
$u, # System user
|
||||
$location, # Location of the file (mogile/blob)
|
||||
);
|
||||
|
||||
$dbr = LJ::get_db_reader();
|
||||
$sql = q{
|
||||
SELECT capid, location
|
||||
FROM captchas
|
||||
WHERE
|
||||
capid = ?
|
||||
AND anum = ?
|
||||
};
|
||||
|
||||
( $valid, $location ) = $dbr->selectrow_array( $sql, undef, $capid, $anum );
|
||||
return undef unless $valid;
|
||||
|
||||
if ($location eq 'mogile') {
|
||||
die "MogileFS object not loaded.\n" unless LJ::mogclient();
|
||||
if ($want_paths) {
|
||||
# return path(s) to the content if they want
|
||||
my @paths = LJ::mogclient()->get_paths("captcha:$capid");
|
||||
return \@paths;
|
||||
} else {
|
||||
$data = ${LJ::mogclient()->get_file_data("captcha:$capid")};
|
||||
}
|
||||
} else {
|
||||
$u = LJ::load_user( "system" )
|
||||
or die "Couldn't load the system user.";
|
||||
|
||||
$data = LJ::Blob::get( $u, 'captcha_image', 'png', $capid )
|
||||
or die "Failed to fetch captcha_image $capid from media server";
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
### get_audio_data( $capid, $anum, $want_paths )
|
||||
# if want_paths is true, this function may return an arrayref containing
|
||||
# one or more paths (disk or HTTP) to the resource
|
||||
sub get_audio_data
|
||||
{
|
||||
my ( $capid, $anum, $want_paths ) = @_;
|
||||
$capid = int($capid);
|
||||
|
||||
my (
|
||||
$dbr, # Database handle (reader)
|
||||
$sql, # SQL statement
|
||||
$valid, # Are the capid/anum valid?
|
||||
$data, # The PNG data
|
||||
$u, # System user
|
||||
$location, # Location of the file (mogile/blob)
|
||||
);
|
||||
|
||||
$dbr = LJ::get_db_reader();
|
||||
$sql = q{
|
||||
SELECT capid, location
|
||||
FROM captchas
|
||||
WHERE
|
||||
capid = ?
|
||||
AND anum = ?
|
||||
};
|
||||
|
||||
( $valid, $location ) = $dbr->selectrow_array( $sql, undef, $capid, $anum );
|
||||
return undef unless $valid;
|
||||
|
||||
if ($location eq 'mogile') {
|
||||
die "MogileFS object not loaded.\n" unless LJ::mogclient();
|
||||
if ($want_paths) {
|
||||
# return path(s) to the content if they want
|
||||
my @paths = LJ::mogclient()->get_paths("captcha:$capid");
|
||||
return \@paths;
|
||||
} else {
|
||||
$data = ${LJ::mogclient()->get_file_data("captcha:$capid")};
|
||||
}
|
||||
} else {
|
||||
$u = LJ::load_user( "system" )
|
||||
or die "Couldn't load the system user.";
|
||||
|
||||
$data = LJ::Blob::get( $u, 'captcha_audio', 'wav', $capid )
|
||||
or die "Failed to fetch captcha_audio $capid from media server";
|
||||
}
|
||||
return $data;
|
||||
}
|
||||
|
||||
|
||||
|
||||
# ($dir) -> ("$dir/speech.wav", $code)
|
||||
# Callers must:
|
||||
# -- create unique temporary directory, shared by no other process
|
||||
# calling this function
|
||||
# -- after return, do something with speech.wav (save on disk server/
|
||||
# db/etc), remove speech.wav, then rmdir $dir
|
||||
# Requires festival and sox.
|
||||
sub generate_audio
|
||||
{
|
||||
my ($dir) = @_;
|
||||
my $old_dir = Cwd::getcwd();
|
||||
chdir($dir) or return 0;
|
||||
|
||||
my $bin_festival = $LJ::BIN_FESTIVAL || "festival";
|
||||
my $bin_sox = $LJ::BIN_SOX || "sox";
|
||||
|
||||
# make up 7 random numbers, without any numbers in a row
|
||||
my @numbers;
|
||||
my $lastnum;
|
||||
for (1..7) {
|
||||
my $num;
|
||||
do {
|
||||
$num = int(rand(9)+1);
|
||||
} while ($num == $lastnum);
|
||||
$lastnum = $num;
|
||||
push @numbers, $num;
|
||||
}
|
||||
my $numbers_speak = join("... ", @numbers);
|
||||
my $numbers_clean = join('', @numbers);
|
||||
|
||||
# generate the clean speech
|
||||
open FEST, '|-', $bin_festival or die "Couldn't invoke festival";
|
||||
print FEST "(Parameter.set 'Audio_Method 'Audio_Command)\n";
|
||||
print FEST "(Parameter.set 'Audio_Required_Format 'wav)\n";
|
||||
print FEST "(Parameter.set 'Audio_Required_Rate 44100)\n";
|
||||
print FEST "(Parameter.set 'Audio_Command \"mv \$FILE speech.wav\")\n";
|
||||
print FEST "(SayText \"$numbers_speak\")\n";
|
||||
close FEST or die "Error closing festival";
|
||||
|
||||
my $sox = sub {
|
||||
my ($effect, $filename, $inopts, $outopts) = @_;
|
||||
$effect = [] unless $effect;
|
||||
$filename = "speech.wav" unless $filename;
|
||||
$inopts = [] unless $inopts;
|
||||
$outopts = [] unless $outopts;
|
||||
command($bin_sox, @$inopts, $filename, @$outopts, "tmp.wav", @$effect);
|
||||
rename('tmp.wav', $filename)
|
||||
or die;
|
||||
};
|
||||
|
||||
# distort the speech
|
||||
$sox->([qw(reverb 0.5 200 100 60 echo 1 0.7 100 0.03 400 0.15)]);
|
||||
command($bin_sox, qw(speech.wav noise.wav synth brownnoise 0 vibro 3 0.8 vol 0.1));
|
||||
$sox->([qw(fade 0.5)], 'noise.wav');
|
||||
$sox->([qw(reverse)], 'noise.wav');
|
||||
$sox->([qw(fade 0.5)], 'noise.wav');
|
||||
|
||||
command("${bin_sox}mix", qw(-v 4 speech.wav noise.wav -r 16000 tmp.wav));
|
||||
rename('tmp.wav', 'speech.wav') or die;
|
||||
unlink('oldspeech.wav', 'noise.wav');
|
||||
|
||||
chdir($old_dir) or return 0;
|
||||
return ("$dir/speech.wav", $numbers_clean);
|
||||
}
|
||||
|
||||
sub command {
|
||||
system(@_) >> 8 == 0 or die "audio command failed, died";
|
||||
}
|
||||
|
||||
|
||||
### check_code( $capid, $anum, $code, $u ) -> <true value if code is correct>
|
||||
sub check_code {
|
||||
my ( $capid, $anum, $code, $u ) = @_;
|
||||
|
||||
my (
|
||||
$dbr, # Database handle (reader)
|
||||
$sql, # SQL query
|
||||
$answer, # Challenge answer
|
||||
$userid, # userid of previous answerer (or 0 if none)
|
||||
);
|
||||
|
||||
$sql = q{
|
||||
SELECT answer, userid
|
||||
FROM captchas
|
||||
WHERE
|
||||
capid = ?
|
||||
AND anum = ?
|
||||
};
|
||||
|
||||
# Fetch the challenge's answer based on id and anum.
|
||||
$dbr = LJ::get_db_writer();
|
||||
( $answer, $userid ) = $dbr->selectrow_array( $sql, undef, $capid, $anum );
|
||||
|
||||
# if it's already been answered, it must have been answered by the $u
|
||||
# given to this function (double-click protection)
|
||||
return 0 if $userid && ( ! $u || $u->{userid} != $userid );
|
||||
|
||||
# otherwise, just check answer.
|
||||
return lc $answer eq lc $code;
|
||||
}
|
||||
|
||||
# Verify captcha answer if using a captcha session.
|
||||
# (captcha challenge, code, $u)
|
||||
# Returns capid and anum if answer correct. (for expire)
|
||||
sub session_check_code {
|
||||
my ($sess, $code, $u) = @_;
|
||||
return 0 unless $sess && $code;
|
||||
$sess = LJ::get_challenge_attributes($sess);
|
||||
|
||||
$u = LJ::load_user('system') unless $u;
|
||||
|
||||
my $dbcm = LJ::get_cluster_master($u);
|
||||
my $dbr = LJ::get_db_reader();
|
||||
|
||||
my ($lcapid, $try) = # clustered
|
||||
$dbcm->selectrow_array('SELECT lastcapid, trynum ' .
|
||||
'FROM captcha_session ' .
|
||||
'WHERE sess=?', undef, $sess);
|
||||
my ($capid, $anum) = # global
|
||||
$dbr->selectrow_array('SELECT capid,anum ' .
|
||||
'FROM captchas '.
|
||||
'WHERE capid=?', undef, $lcapid);
|
||||
if (! LJ::Captcha::check_code($capid, $anum, $code, $u)) {
|
||||
# update try and lastcapid
|
||||
$u->do('UPDATE captcha_session SET lastcapid=NULL, ' .
|
||||
'trynum=trynum+1 WHERE sess=?', undef, $sess);
|
||||
return 0;
|
||||
}
|
||||
return ($capid, $anum);
|
||||
}
|
||||
|
||||
### expire( $capid ) -> <true value if code was expired successfully>
|
||||
sub expire {
|
||||
my ( $capid, $anum, $userid ) = @_;
|
||||
|
||||
my (
|
||||
$dbh, # Database handle (writer)
|
||||
$sql, # SQL update query
|
||||
);
|
||||
|
||||
$sql = q{
|
||||
UPDATE captchas
|
||||
SET userid = ?
|
||||
WHERE capid = ? AND anum = ? AND userid = 0
|
||||
};
|
||||
|
||||
# Fetch the challenge's answer based on id and anum.
|
||||
$dbh = LJ::get_db_writer();
|
||||
$dbh->do( $sql, undef, $userid, $capid, $anum ) or return undef;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Update/create captcha sessions, return new capid/anum pairs on success.
|
||||
# challenge, type, optional journalu->{clusterid} for clustering.
|
||||
# Type is either 'image' or 'audio'
|
||||
sub session
|
||||
{
|
||||
my ($chal, $type, $cid) = @_;
|
||||
return unless $chal && $type;
|
||||
|
||||
my $chalinfo = {};
|
||||
LJ::challenge_check($chal, $chalinfo);
|
||||
return unless $chalinfo->{valid};
|
||||
|
||||
my $sess = LJ::get_challenge_attributes($chal);
|
||||
my ($capid, $anum) = ($type eq 'image') ?
|
||||
LJ::Captcha::get_visual_id() :
|
||||
LJ::Captcha::get_audio_id();
|
||||
|
||||
|
||||
$cid = LJ::load_user('system')->{clusterid} unless $cid;
|
||||
my $dbcm = LJ::get_cluster_master($cid);
|
||||
|
||||
# Retain try count
|
||||
my $try = $dbcm->selectrow_array('SELECT trynum FROM captcha_session ' .
|
||||
'WHERE sess=?', undef, $sess);
|
||||
$try ||= 0;
|
||||
# Add/update session
|
||||
$dbcm->do('REPLACE INTO captcha_session SET sess=?, sesstime=?, '.
|
||||
'lastcapid=?, trynum=?', undef, $sess, time(), $capid, $try);
|
||||
return ($capid, $anum);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
94
livejournal/cgi-bin/LJ/LDAP.pm
Executable file
94
livejournal/cgi-bin/LJ/LDAP.pm
Executable file
@@ -0,0 +1,94 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::LDAP;
|
||||
|
||||
use strict;
|
||||
use Net::LDAP;
|
||||
use Digest::MD5 qw(md5);
|
||||
use Digest::SHA1 qw(sha1);
|
||||
use MIME::Base64;
|
||||
|
||||
sub load_ldap_user {
|
||||
my ($user) = @_;
|
||||
return undef unless $user =~ /^[\w ]+$/;
|
||||
|
||||
my $ldap = Net::LDAP->new($LJ::LDAP_HOST)
|
||||
or return undef;
|
||||
my $mesg = $ldap->bind; # an anonymous bind
|
||||
|
||||
my $uid = $LJ::LDAP_UID || "uid";
|
||||
|
||||
my $urec = $ldap->search( # perform a search
|
||||
base => $LJ::LDAP_BASE,
|
||||
scope => "sub",
|
||||
filter => "$uid=$user",
|
||||
#filter => "(&(sn=Barr) (o=Texas Instruments))"
|
||||
)->pop_entry
|
||||
or return undef;
|
||||
|
||||
my $up = $urec->get_value('userPassword')
|
||||
or return undef;
|
||||
|
||||
my ($nick, $email) = ($urec->get_value('gecos'), $urec->get_value('mailLocalAddress'));
|
||||
unless ($nick && $email) {
|
||||
$@ = "Necessary information not found in LDAP record: name=$nick; email=$email";
|
||||
return undef;
|
||||
}
|
||||
|
||||
# $res comes out as...?
|
||||
my $res = {
|
||||
name => $user,
|
||||
nick => $nick,
|
||||
email => $email,
|
||||
ldap_pass => $up,
|
||||
};
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub is_good_ldap
|
||||
{
|
||||
my ($user, $pass) = @_;
|
||||
my $lrec = load_ldap_user($user)
|
||||
or return undef;
|
||||
|
||||
# get auth type and data, then decode it
|
||||
return undef unless $lrec->{ldap_pass} =~ /^\{(\w+)\}(.+)$/;
|
||||
my ($auth, $data) = ($1, decode_base64($2));
|
||||
|
||||
if ($auth eq 'MD5') {
|
||||
unless ($data eq md5($pass)) {
|
||||
$@ = "Password mismatch (MD5) from LDAP server; is your password correct?";
|
||||
return undef;
|
||||
}
|
||||
} elsif ($auth eq 'SSHA') {
|
||||
my $salt = substr($data, 20);
|
||||
my $orig = substr($data, 0, 20);
|
||||
unless ($orig eq sha1($pass, $salt)) {
|
||||
$@ = "Password mismatch (SSHA) from LDAP server; is your password correct?";
|
||||
return undef;
|
||||
}
|
||||
|
||||
} elsif ($auth eq 'SMD5') {
|
||||
# this didn't work
|
||||
my $salt = substr($data, 16);
|
||||
my $orig = substr($data, 0, 16);
|
||||
unless ($orig eq md5($pass, $salt)) {
|
||||
$@ = "Password mismatch (SMD5) from LDAP server; is your password correct?";
|
||||
return undef;
|
||||
}
|
||||
|
||||
} else {
|
||||
print STDERR "Unsupported LDAP auth method: $auth\n";
|
||||
$@ = "userPassword field from LDAP server not of supported format; type: $auth"
|
||||
;
|
||||
return undef;
|
||||
}
|
||||
|
||||
return $lrec;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
111
livejournal/cgi-bin/LJ/MemCache.pm
Executable file
111
livejournal/cgi-bin/LJ/MemCache.pm
Executable file
@@ -0,0 +1,111 @@
|
||||
#
|
||||
# Wrapper around MemCachedClient
|
||||
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
use Cache::Memcached;
|
||||
use strict;
|
||||
|
||||
package LJ::MemCache;
|
||||
|
||||
%LJ::MEMCACHE_ARRAYFMT = (
|
||||
'user' =>
|
||||
[qw[1 userid user caps clusterid dversion email password status statusvis statusvisdate
|
||||
name bdate themeid moodthemeid opt_forcemoodtheme allow_infoshow allow_contactshow
|
||||
allow_getljnews opt_showtalklinks opt_whocanreply opt_gettalkemail opt_htmlemail
|
||||
opt_mangleemail useoverrides defaultpicid has_bio txtmsg_status is_system
|
||||
journaltype lang oldenc]],
|
||||
'fgrp' => [qw[1 userid groupnum groupname sortorder is_public]],
|
||||
# version #101 because old userpic format in memcached was an arrayref of
|
||||
# [width, height, ...] and widths could have been 1 before, although unlikely
|
||||
'userpic' => [qw[101 width height userid fmt state picdate location flags]],
|
||||
);
|
||||
|
||||
|
||||
my $memc; # memcache object
|
||||
|
||||
sub init {
|
||||
$memc = new Cache::Memcached;
|
||||
reload_conf();
|
||||
}
|
||||
|
||||
sub get_memcache {
|
||||
init() unless $memc;
|
||||
return $memc
|
||||
}
|
||||
|
||||
sub client_stats {
|
||||
return $memc->{'stats'} || {};
|
||||
}
|
||||
|
||||
sub reload_conf {
|
||||
my $stat_callback;
|
||||
|
||||
$memc->set_servers(\@LJ::MEMCACHE_SERVERS);
|
||||
$memc->set_debug($LJ::MEMCACHE_DEBUG);
|
||||
$memc->set_pref_ip(\%LJ::MEMCACHE_PREF_IP);
|
||||
$memc->set_compress_threshold($LJ::MEMCACHE_COMPRESS_THRESHOLD);
|
||||
if ($LJ::DB_LOG_HOST) {
|
||||
$stat_callback = sub {
|
||||
my ($stime, $etime, $host, $action) = @_;
|
||||
LJ::blocking_report($host, 'memcache', $etime - $stime, "memcache: $action");
|
||||
};
|
||||
} else {
|
||||
$stat_callback = undef;
|
||||
}
|
||||
$memc->set_stat_callback($stat_callback);
|
||||
$memc->set_readonly(1) if $ENV{LJ_MEMC_READONLY};
|
||||
return $memc;
|
||||
}
|
||||
|
||||
sub forget_dead_hosts { $memc->forget_dead_hosts(); }
|
||||
sub disconnect_all { $memc->disconnect_all(); }
|
||||
|
||||
sub delete {
|
||||
# use delete time if specified
|
||||
return $memc->delete(@_) if defined $_[1];
|
||||
|
||||
# else default to 4 seconds:
|
||||
# version 1.1.7 vs. 1.1.6
|
||||
$memc->delete(@_, 4) || $memc->delete(@_);
|
||||
}
|
||||
|
||||
sub add { $memc->add(@_); }
|
||||
sub replace { $memc->replace(@_); }
|
||||
sub set { $memc->set(@_); }
|
||||
sub get { $memc->get(@_); }
|
||||
sub get_multi { $memc->get_multi(@_); }
|
||||
sub incr { $memc->incr(@_); }
|
||||
sub decr { $memc->decr(@_); }
|
||||
|
||||
sub _get_sock { $memc->get_sock(@_); }
|
||||
|
||||
sub run_command { $memc->run_command(@_); }
|
||||
|
||||
|
||||
sub array_to_hash {
|
||||
my ($fmtname, $ar) = @_;
|
||||
my $fmt = $LJ::MEMCACHE_ARRAYFMT{$fmtname};
|
||||
return undef unless $fmt;
|
||||
return undef unless $ar && ref $ar eq "ARRAY" && $ar->[0] == $fmt->[0];
|
||||
my $hash = {};
|
||||
my $ct = scalar(@$fmt);
|
||||
for (my $i=1; $i<$ct; $i++) {
|
||||
$hash->{$fmt->[$i]} = $ar->[$i];
|
||||
}
|
||||
return $hash;
|
||||
}
|
||||
|
||||
sub hash_to_array {
|
||||
my ($fmtname, $hash) = @_;
|
||||
my $fmt = $LJ::MEMCACHE_ARRAYFMT{$fmtname};
|
||||
return undef unless $fmt;
|
||||
return undef unless $hash && ref $hash;
|
||||
my $ar = [$fmt->[0]];
|
||||
my $ct = scalar(@$fmt);
|
||||
for (my $i=1; $i<$ct; $i++) {
|
||||
$ar->[$i] = $hash->{$fmt->[$i]};
|
||||
}
|
||||
return $ar;
|
||||
}
|
||||
|
||||
1;
|
||||
189
livejournal/cgi-bin/LJ/OpenID.pm
Executable file
189
livejournal/cgi-bin/LJ/OpenID.pm
Executable file
@@ -0,0 +1,189 @@
|
||||
package LJ::OpenID;
|
||||
|
||||
use strict;
|
||||
use Digest::SHA1 qw(sha1 sha1_hex);
|
||||
use LWPx::ParanoidAgent;
|
||||
|
||||
BEGIN {
|
||||
$LJ::OPTMOD_OPENID_CONSUMER = $LJ::OPENID_CONSUMER ? eval "use Net::OpenID::Consumer; 1;" : 0;
|
||||
$LJ::OPTMOD_OPENID_SERVER = $LJ::OPENID_SERVER ? eval "use Net::OpenID::Server; 1;" : 0;
|
||||
}
|
||||
|
||||
# returns boolean whether consumer support is enabled and available
|
||||
sub consumer_enabled {
|
||||
return 0 unless $LJ::OPENID_CONSUMER;
|
||||
return $LJ::OPTMOD_OPENID_CONSUMER || eval "use Net::OpenID::Consumer; 1;";
|
||||
}
|
||||
|
||||
# returns boolean whether consumer support is enabled and available
|
||||
sub server_enabled {
|
||||
return 0 unless $LJ::OPENID_SERVER;
|
||||
return $LJ::OPTMOD_OPENID_CONSUMER || eval "use Net::OpenID::Server; 1;";
|
||||
}
|
||||
|
||||
sub server {
|
||||
my ($get, $post) = @_;
|
||||
|
||||
return Net::OpenID::Server->new(
|
||||
get_args => $get || {},
|
||||
post_args => $post || {},
|
||||
|
||||
get_user => \&LJ::get_remote,
|
||||
is_identity => sub {
|
||||
my ($u, $ident) = @_;
|
||||
return LJ::OpenID::is_identity($u, $ident, $get);
|
||||
},
|
||||
is_trusted => \&LJ::OpenID::is_trusted,
|
||||
|
||||
setup_url => "$LJ::SITEROOT/openid/approve.bml",
|
||||
|
||||
server_secret => \&LJ::OpenID::server_secret,
|
||||
secret_gen_interval => 3600,
|
||||
secret_expire_age => 86400 * 14,
|
||||
);
|
||||
}
|
||||
|
||||
# Returns a Consumer object
|
||||
# When planning to verify identity, needs GET
|
||||
# arguments passed in
|
||||
sub consumer {
|
||||
my $get_args = shift || {};
|
||||
|
||||
my $ua;
|
||||
unless ($LJ::IS_DEV_SERVER) {
|
||||
$ua = LWPx::ParanoidAgent->new(
|
||||
timeout => 10,
|
||||
max_size => 1024*300,
|
||||
);
|
||||
}
|
||||
|
||||
my $csr = Net::OpenID::Consumer->new(
|
||||
ua => $ua,
|
||||
args => $get_args,
|
||||
cache => eval { LJ::MemCache::get_memcache() },
|
||||
debug => $LJ::IS_DEV_SERVER || 0,
|
||||
);
|
||||
|
||||
return $csr;
|
||||
}
|
||||
|
||||
sub server_secret {
|
||||
my $time = shift;
|
||||
my ($t2, $secret) = LJ::get_secret($time);
|
||||
die "ASSERT: didn't get t2 (t1=$time)" unless $t2;
|
||||
die "ASSERT: didn't get secret (t2=$t2)" unless $secret;
|
||||
die "ASSERT: time($time) != t2($t2)\n" unless $t2 == $time;
|
||||
return $secret;
|
||||
}
|
||||
|
||||
sub is_trusted {
|
||||
my ($u, $trust_root, $is_identity) = @_;
|
||||
return 0 unless $u;
|
||||
# we always look up $is_trusted, even if $is_identity is false, to avoid timing attacks
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my ($endpointid, $duration) = $dbh->selectrow_array("SELECT t.endpoint_id, t.duration ".
|
||||
"FROM openid_trust t, openid_endpoint e ".
|
||||
"WHERE t.userid=? AND t.endpoint_id=e.endpoint_id AND e.url=?",
|
||||
undef, $u->{userid}, $trust_root);
|
||||
return 0 unless $endpointid;
|
||||
|
||||
if ($duration eq "once") {
|
||||
$dbh->do("DELETE FROM openid_trust WHERE userid=? AND endpoint_id=?", undef, $u->{userid}, $endpointid);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is_identity {
|
||||
my ($u, $ident, $get) = @_;
|
||||
return 0 unless $u && $u->{journaltype} eq "P";
|
||||
|
||||
my $user = $u->{user};
|
||||
return 1 if
|
||||
$ident eq "$LJ::SITEROOT/users/$user/" ||
|
||||
$ident eq "$LJ::SITEROOT/~$user/" ||
|
||||
$ident eq "http://$user.$LJ::USER_DOMAIN/";
|
||||
|
||||
if ($get->{'ljuser_sha1'} eq sha1_hex($user) ||
|
||||
$get->{'ljuser'} eq $user) {
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return $dbh->selectrow_array("SELECT COUNT(*) FROM openid_external WHERE userid=? AND url=?",
|
||||
undef, $u->{userid}, $ident);
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub getmake_endpointid {
|
||||
my $site = shift;
|
||||
|
||||
my $dbh = LJ::get_db_writer()
|
||||
or return undef;
|
||||
|
||||
my $rv = $dbh->do("INSERT IGNORE INTO openid_endpoint (url) VALUES (?)", undef, $site);
|
||||
my $end_id;
|
||||
if ($rv > 0) {
|
||||
$end_id = $dbh->{'mysql_insertid'};
|
||||
} else {
|
||||
$end_id = $dbh->selectrow_array("SELECT endpoint_id FROM openid_endpoint WHERE url=?",
|
||||
undef, $site);
|
||||
}
|
||||
return $end_id;
|
||||
}
|
||||
|
||||
sub add_trust {
|
||||
my ($u, $site, $dur) = @_;
|
||||
|
||||
return 0 unless $dur =~ /^always|once$/;
|
||||
|
||||
my $end_id = LJ::OpenID::getmake_endpointid($site)
|
||||
or return 0;
|
||||
|
||||
my $dbh = LJ::get_db_writer()
|
||||
or return undef;
|
||||
|
||||
my $rv = $dbh->do("REPLACE INTO openid_trust (userid, endpoint_id, duration, trust_time) ".
|
||||
"VALUES (?,?,?,UNIX_TIMESTAMP())", undef, $u->{userid}, $end_id, $dur);
|
||||
return $rv;
|
||||
}
|
||||
|
||||
# From Digest::HMAC
|
||||
sub hmac_sha1_hex {
|
||||
unpack("H*", &hmac_sha1);
|
||||
}
|
||||
sub hmac_sha1 {
|
||||
hmac($_[0], $_[1], \&sha1, 64);
|
||||
}
|
||||
sub hmac {
|
||||
my($data, $key, $hash_func, $block_size) = @_;
|
||||
$block_size ||= 64;
|
||||
$key = &$hash_func($key) if length($key) > $block_size;
|
||||
|
||||
my $k_ipad = $key ^ (chr(0x36) x $block_size);
|
||||
my $k_opad = $key ^ (chr(0x5c) x $block_size);
|
||||
|
||||
&$hash_func($k_opad, &$hash_func($k_ipad, $data));
|
||||
}
|
||||
|
||||
# Returns 1 if destination identity server
|
||||
# is blocked
|
||||
sub blocked_hosts {
|
||||
my $csr = shift;
|
||||
|
||||
return do { my $dummy = 0; \$dummy; } if $LJ::IS_DEV_SERVER;
|
||||
|
||||
my $tried_local_id = 0;
|
||||
$csr->ua->blocked_hosts(
|
||||
sub {
|
||||
my $dest = shift;
|
||||
# NEEDS TO BE NOT HARDCODED
|
||||
if ($dest =~ /livejournal\.com$/i) {
|
||||
$tried_local_id = 1;
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
});
|
||||
return \$tried_local_id;
|
||||
}
|
||||
|
||||
1;
|
||||
2669
livejournal/cgi-bin/LJ/S2.pm
Executable file
2669
livejournal/cgi-bin/LJ/S2.pm
Executable file
File diff suppressed because it is too large
Load Diff
239
livejournal/cgi-bin/LJ/S2/DayPage.pm
Executable file
239
livejournal/cgi-bin/LJ/S2/DayPage.pm
Executable file
@@ -0,0 +1,239 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub DayPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "DayPage";
|
||||
$p->{'view'} = "day";
|
||||
$p->{'entries'} = [];
|
||||
|
||||
my $user = $u->{'user'};
|
||||
my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
|
||||
"/calendar" . $opts->{'pathextra'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($u->{'opt_blockrobots'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $month = $get->{'month'};
|
||||
my $day = $get->{'day'};
|
||||
my $year = $get->{'year'};
|
||||
my @errors = ();
|
||||
|
||||
if ($opts->{'pathextra'} =~ m!^/(\d\d\d\d)/(\d\d)/(\d\d)\b!) {
|
||||
($month, $day, $year) = ($2, $3, $1);
|
||||
}
|
||||
|
||||
$opts->{'errors'} = [];
|
||||
if ($year !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant year."; }
|
||||
if ($month !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant month."; }
|
||||
if ($day !~ /^\d+$/) { push @{$opts->{'errors'}}, "Corrupt or non-existant day."; }
|
||||
if ($month < 1 || $month > 12 || int($month) != $month) { push @{$opts->{'errors'}}, "Invalid month."; }
|
||||
if ($year < 1970 || $year > 2038 || int($year) != $year) { push @{$opts->{'errors'}}, "Invalid year: $year"; }
|
||||
if ($day < 1 || $day > 31 || int($day) != $day) { push @{$opts->{'errors'}}, "Invalid day."; }
|
||||
if (scalar(@{$opts->{'errors'}})==0 && $day > LJ::days_in_month($month, $year)) { push @{$opts->{'errors'}}, "That month doesn't have that many days."; }
|
||||
return if @{$opts->{'errors'}};
|
||||
|
||||
$p->{'date'} = Date($year, $month, $day);
|
||||
|
||||
my $secwhere = "AND security='public'";
|
||||
my $viewall = 0;
|
||||
my $viewsome = 0; # see public posts from suspended users
|
||||
if ($remote) {
|
||||
|
||||
# do they have the viewall priv?
|
||||
if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
|
||||
LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
|
||||
"viewall", "day: $user, statusvis: $u->{'statusvis'}");
|
||||
$viewall = LJ::check_priv($remote, 'canview', '*');
|
||||
$viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
|
||||
}
|
||||
|
||||
if ($remote->{'userid'} == $u->{'userid'} || $viewall) {
|
||||
$secwhere = ""; # see everything
|
||||
} elsif ($remote->{'journaltype'} eq 'P') {
|
||||
my $gmask = LJ::get_groupmask($u, $remote);
|
||||
$secwhere = "AND (security='public' OR (security='usemask' AND allowmask & $gmask))"
|
||||
if $gmask;
|
||||
}
|
||||
}
|
||||
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
unless ($dbcr) {
|
||||
push @{$opts->{'errors'}}, "Database temporarily unavailable";
|
||||
return;
|
||||
}
|
||||
|
||||
# load the log items
|
||||
my $dateformat = "%Y %m %d %H %i %s %w"; # yyyy mm dd hh mm ss day_of_week
|
||||
my $sth = $dbcr->prepare("SELECT jitemid AS itemid, posterid, security, DATE_FORMAT(eventtime, \"$dateformat\") AS 'alldatepart', anum ".
|
||||
"FROM log2 " .
|
||||
"WHERE journalid=$u->{'userid'} AND year=$year AND month=$month AND day=$day $secwhere " .
|
||||
"ORDER BY eventtime, logtime LIMIT 200");
|
||||
$sth->execute;
|
||||
|
||||
my @items;
|
||||
push @items, $_ while $_ = $sth->fetchrow_hashref;
|
||||
my @itemids = map { $_->{'itemid'} } @items;
|
||||
|
||||
# load 'opt_ljcut_disable_lastn' prop for $remote.
|
||||
LJ::load_user_props($remote, "opt_ljcut_disable_lastn");
|
||||
|
||||
### load the log properties
|
||||
my %logprops = ();
|
||||
my $logtext;
|
||||
LJ::load_log_props2($dbcr, $u->{'userid'}, \@itemids, \%logprops);
|
||||
$logtext = LJ::get_logtext2($u, @itemids);
|
||||
|
||||
my (%apu, %apu_lite); # alt poster users; UserLite objects
|
||||
foreach (@items) {
|
||||
next unless $_->{'posterid'} != $u->{'userid'};
|
||||
$apu{$_->{'posterid'}} = undef;
|
||||
}
|
||||
if (%apu) {
|
||||
LJ::load_userids_multiple([map { $_, \$apu{$_} } keys %apu], [$u]);
|
||||
$apu_lite{$_} = UserLite($apu{$_}) foreach keys %apu;
|
||||
}
|
||||
|
||||
# load tags
|
||||
my $tags = LJ::Tags::get_logtags($u, \@itemids);
|
||||
|
||||
my $userlite_journal = UserLite($u);
|
||||
|
||||
ENTRY:
|
||||
foreach my $item (@items)
|
||||
{
|
||||
my ($posterid, $itemid, $security, $alldatepart, $anum) =
|
||||
map { $item->{$_} } qw(posterid itemid security alldatepart anum);
|
||||
|
||||
my $replycount = $logprops{$itemid}->{'replycount'};
|
||||
my $subject = $logtext->{$itemid}->[0];
|
||||
my $text = $logtext->{$itemid}->[1];
|
||||
if ($get->{'nohtml'}) {
|
||||
# quote all non-LJ tags
|
||||
$subject =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
$text =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
}
|
||||
|
||||
# don't show posts from suspended users
|
||||
next ENTRY if $apu{$posterid} && $apu{$posterid}->{'statusvis'} eq 'S' && ! $viewsome;
|
||||
|
||||
if ($LJ::UNICODE && $logprops{$itemid}->{'unknown8bit'}) {
|
||||
LJ::item_toutf8($u, \$subject, \$text, $logprops{$itemid});
|
||||
}
|
||||
|
||||
LJ::CleanHTML::clean_subject(\$subject) if $subject;
|
||||
|
||||
my $ditemid = $itemid*256 + $anum;
|
||||
|
||||
LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $logprops{$itemid}->{'opt_preformatted'},
|
||||
'cuturl' => LJ::item_link($u, $itemid, $anum),
|
||||
'ljcut_disable' => $remote->{'opt_ljcut_disable_lastn'}, });
|
||||
LJ::expand_embedded($u, $ditemid, $remote, \$text);
|
||||
|
||||
my $nc = "";
|
||||
$nc .= "nc=$replycount" if $replycount && $remote && $remote->{'opt_nctalklinks'};
|
||||
|
||||
my $permalink = "$journalbase/$ditemid.html";
|
||||
my $readurl = $permalink;
|
||||
$readurl .= "?$nc" if $nc;
|
||||
my $posturl = $permalink . "?mode=reply";
|
||||
|
||||
my $comments = CommentInfo({
|
||||
'read_url' => $readurl,
|
||||
'post_url' => $posturl,
|
||||
'count' => $replycount,
|
||||
'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
|
||||
'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $logprops{$itemid}->{'opt_nocomments'}) ? 1 : 0,
|
||||
'screened' => ($logprops{$itemid}->{'hasscreened'} && $remote &&
|
||||
($remote->{'user'} eq $u->{'user'} || LJ::can_manage($remote, $u))) ? 1 : 0,
|
||||
});
|
||||
|
||||
my $userlite_poster = $userlite_journal;
|
||||
my $pu = $u;
|
||||
if ($u->{'userid'} != $posterid) {
|
||||
$userlite_poster = $apu_lite{$posterid} or die "No apu_lite for posterid=$posterid";
|
||||
$pu = $apu{$posterid};
|
||||
}
|
||||
my $userpic = Image_userpic($pu, 0, $logprops{$itemid}->{'picture_keyword'});
|
||||
|
||||
my @taglist;
|
||||
while (my ($kwid, $kw) = each %{$tags->{$itemid} || {}}) {
|
||||
push @taglist, Tag($u, $kwid => $kw);
|
||||
}
|
||||
@taglist = sort { $a->{name} cmp $b->{name} } @taglist;
|
||||
|
||||
if ($opts->{enable_tags_compatibility} && @taglist) {
|
||||
$text .= LJ::S2::get_tags_text($opts->{ctx}, \@taglist);
|
||||
}
|
||||
|
||||
my $entry = Entry($u, {
|
||||
'subject' => $subject,
|
||||
'text' => $text,
|
||||
'dateparts' => $alldatepart,
|
||||
'security' => $security,
|
||||
'props' => $logprops{$itemid},
|
||||
'itemid' => $ditemid,
|
||||
'journal' => $userlite_journal,
|
||||
'poster' => $userlite_poster,
|
||||
'comments' => $comments,
|
||||
'tags' => \@taglist,
|
||||
'userpic' => $userpic,
|
||||
'permalink_url' => $permalink,
|
||||
});
|
||||
|
||||
push @{$p->{'entries'}}, $entry;
|
||||
}
|
||||
|
||||
if (@{$p->{'entries'}}) {
|
||||
$p->{'has_entries'} = 1;
|
||||
$p->{'entries'}->[0]->{'new_day'} = 1;
|
||||
$p->{'entries'}->[-1]->{'end_day'} = 1;
|
||||
}
|
||||
|
||||
# calculate previous day
|
||||
my $pdyear = $year;
|
||||
my $pdmonth = $month;
|
||||
my $pdday = $day-1;
|
||||
if ($pdday < 1)
|
||||
{
|
||||
if (--$pdmonth < 1)
|
||||
{
|
||||
$pdmonth = 12;
|
||||
$pdyear--;
|
||||
}
|
||||
$pdday = LJ::days_in_month($pdmonth, $pdyear);
|
||||
}
|
||||
|
||||
# calculate next day
|
||||
my $nxyear = $year;
|
||||
my $nxmonth = $month;
|
||||
my $nxday = $day+1;
|
||||
if ($nxday > LJ::days_in_month($nxmonth, $nxyear))
|
||||
{
|
||||
$nxday = 1;
|
||||
if (++$nxmonth > 12) { ++$nxyear; $nxmonth=1; }
|
||||
}
|
||||
|
||||
$p->{'prev_url'} = "$u->{'_journalbase'}/" . sprintf("%04d/%02d/%02d/", $pdyear, $pdmonth, $pdday);
|
||||
$p->{'prev_date'} = Date($pdyear, $pdmonth, $pdday);
|
||||
$p->{'next_url'} = "$u->{'_journalbase'}/" . sprintf("%04d/%02d/%02d/", $nxyear, $nxmonth, $nxday);
|
||||
$p->{'next_date'} = Date($nxyear, $nxmonth, $nxday);
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
1;
|
||||
377
livejournal/cgi-bin/LJ/S2/EntryPage.pm
Executable file
377
livejournal/cgi-bin/LJ/S2/EntryPage.pm
Executable file
@@ -0,0 +1,377 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub EntryPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "EntryPage";
|
||||
$p->{'view'} = "entry";
|
||||
$p->{'comment_pages'} = undef;
|
||||
$p->{'comments'} = [];
|
||||
$p->{'comment_pages'} = undef;
|
||||
|
||||
# setup viewall options
|
||||
my ($viewall, $viewsome) = (0, 0);
|
||||
if ($get->{viewall} && LJ::check_priv($remote, 'canview')) {
|
||||
# we don't log here, as we don't know what entry we're viewing yet. the logging
|
||||
# is done when we call EntryPage_entry below.
|
||||
$viewall = LJ::check_priv($remote, 'canview', '*');
|
||||
$viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
|
||||
}
|
||||
|
||||
my ($entry, $s2entry) = EntryPage_entry($u, $remote, $opts);
|
||||
return if $opts->{'suspendeduser'};
|
||||
return if $opts->{'handler_return'};
|
||||
|
||||
$p->{'multiform_on'} = $remote &&
|
||||
($remote->{'userid'} == $u->{'userid'} ||
|
||||
$remote->{'userid'} == $entry->{'posterid'} ||
|
||||
LJ::can_manage($remote, $u));
|
||||
|
||||
my $itemid = $entry->{'itemid'};
|
||||
my $ditemid = $entry->{'itemid'} * 256 + $entry->{'anum'};
|
||||
my $permalink = LJ::journal_base($u) . "/$ditemid.html";
|
||||
my $stylemine = $get->{'style'} eq "mine" ? "style=mine" : "";
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
|
||||
"/$ditemid.html" . $opts->{'pathextra'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($u->{'opt_blockrobots'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
if ($LJ::UNICODE) {
|
||||
$p->{'head_content'} .= '<meta http-equiv="Content-Type" content="text/html; charset='.$opts->{'saycharset'}."\" />\n";
|
||||
}
|
||||
|
||||
$p->{'entry'} = $s2entry;
|
||||
|
||||
# add the comments
|
||||
my %userpic;
|
||||
my %user;
|
||||
my $copts = {
|
||||
'thread' => ($get->{'thread'} >> 8),
|
||||
'page' => $get->{'page'},
|
||||
'view' => $get->{'view'},
|
||||
'userpicref' => \%userpic,
|
||||
'userref' => \%user,
|
||||
# user object is cached from call just made in EntryPage_entry
|
||||
'up' => LJ::load_user($s2entry->{'poster'}->{'username'}),
|
||||
'viewall' => $viewall,
|
||||
};
|
||||
|
||||
my $userlite_journal = UserLite($u);
|
||||
|
||||
my @comments = LJ::Talk::load_comments($u, $remote, "L", $itemid, $copts);
|
||||
|
||||
my $pics = LJ::Talk::get_subjecticons()->{'pic'}; # hashref of imgname => { w, h, img }
|
||||
my $convert_comments = sub {
|
||||
my ($self, $destlist, $srclist, $depth) = @_;
|
||||
|
||||
foreach my $com (@$srclist) {
|
||||
my $dtalkid = $com->{'talkid'} * 256 + $entry->{'anum'};
|
||||
my $text = $com->{'body'};
|
||||
if ($get->{'nohtml'}) {
|
||||
# quote all non-LJ tags
|
||||
$text =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
}
|
||||
LJ::CleanHTML::clean_comment(\$text, { 'preformatted' => $com->{'props'}->{'opt_preformatted'},
|
||||
'anon_comment' => !$com->{posterid}});
|
||||
|
||||
# local time in mysql format to gmtime
|
||||
my $datetime = DateTime_unix(LJ::mysqldate_to_time($com->{'datepost'}));
|
||||
|
||||
my $subject_icon = undef;
|
||||
if (my $si = $com->{'props'}->{'subjecticon'}) {
|
||||
my $pic = $pics->{$si};
|
||||
$subject_icon = Image("$LJ::IMGPREFIX/talk/$pic->{'img'}",
|
||||
$pic->{'w'}, $pic->{'h'}) if $pic;
|
||||
}
|
||||
|
||||
my $comment_userpic;
|
||||
if (my $pic = $userpic{$com->{'picid'}}) {
|
||||
$comment_userpic = Image("$LJ::USERPIC_ROOT/$com->{'picid'}/$pic->{'userid'}",
|
||||
$pic->{'width'}, $pic->{'height'});
|
||||
}
|
||||
|
||||
my $reply_url = LJ::Talk::talkargs($permalink, "replyto=$dtalkid", $stylemine);
|
||||
|
||||
my $par_url;
|
||||
if ($com->{'parenttalkid'}) {
|
||||
my $dparent = ($com->{'parenttalkid'} << 8) + $entry->{'anum'};
|
||||
$par_url = LJ::Talk::talkargs($permalink, "thread=$dparent", $stylemine) . "#t$dparent";
|
||||
}
|
||||
|
||||
my $poster;
|
||||
if ($com->{'posterid'}) {
|
||||
if ($user{$com->{'posterid'}}) {
|
||||
$poster = UserLite($user{$com->{'posterid'}});
|
||||
} else {
|
||||
$poster = {
|
||||
'_type' => 'UserLite',
|
||||
'username' => $com->{'userpost'},
|
||||
'name' => $com->{'userpost'}, # we don't have this, so fake it
|
||||
'journal_type' => 'P', # fake too, but only people can post, so correct
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
my $s2com = {
|
||||
'_type' => 'Comment',
|
||||
'journal' => $userlite_journal,
|
||||
'metadata' => {
|
||||
'picture_keyword' => $com->{'props'}->{'picture_keyword'},
|
||||
},
|
||||
'permalink_url' => "$permalink?thread=$dtalkid#t$dtalkid",
|
||||
'reply_url' => $reply_url,
|
||||
'poster' => $poster,
|
||||
'replies' => [],
|
||||
'subject' => LJ::ehtml($com->{'subject'}),
|
||||
'subject_icon' => $subject_icon,
|
||||
'talkid' => $dtalkid,
|
||||
'text' => $text,
|
||||
'userpic' => $comment_userpic,
|
||||
'time' => $datetime,
|
||||
'tags' => [],
|
||||
'full' => $com->{'_loaded'} ? 1 : 0,
|
||||
'depth' => $depth,
|
||||
'parent_url' => $par_url,
|
||||
'screened' => $com->{'state'} eq "S" ? 1 : 0,
|
||||
'frozen' => $com->{'state'} eq "F" ? 1 : 0,
|
||||
'link_keyseq' => [ 'delete_comment' ],
|
||||
'anchor' => "t$dtalkid",
|
||||
'dom_id' => "ljcmt$dtalkid",
|
||||
};
|
||||
|
||||
# don't show info from suspended users
|
||||
# FIXME: ideally the load_comments should only return these
|
||||
# items if there are children, otherwise they should be hidden entirely
|
||||
my $pu = $com->{'posterid'} ? $user{$com->{'posterid'}} : undef;
|
||||
if ($pu && $pu->{'statusvis'} eq "S" && !$viewsome) {
|
||||
$s2com->{'text'} = "";
|
||||
$s2com->{'subject'} = "";
|
||||
$s2com->{'full'} = 0;
|
||||
$s2com->{'subject_icon'} = undef;
|
||||
$s2com->{'userpic'} = undef;
|
||||
}
|
||||
|
||||
# Conditionally add more links to the keyseq
|
||||
my $link_keyseq = $s2com->{'link_keyseq'};
|
||||
push @$link_keyseq, $s2com->{'screened'} ? 'unscreen_comment' : 'screen_comment';
|
||||
push @$link_keyseq, $s2com->{'frozen'} ? 'unfreeze_thread' : 'freeze_thread';
|
||||
|
||||
if (@{$com->{'children'}}) {
|
||||
$s2com->{'thread_url'} = LJ::Talk::talkargs($permalink, "thread=$dtalkid", $stylemine) . "#t$dtalkid";
|
||||
}
|
||||
|
||||
# add the poster_ip metadata if remote user has
|
||||
# access to see it.
|
||||
$s2com->{'metadata'}->{'poster_ip'} = $com->{'props'}->{'poster_ip'} if
|
||||
($com->{'props'}->{'poster_ip'} && $remote &&
|
||||
($remote->{'userid'} == $entry->{'posterid'} ||
|
||||
LJ::can_manage($remote, $u) || $viewall));
|
||||
|
||||
push @$destlist, $s2com;
|
||||
|
||||
$self->($self, $s2com->{'replies'}, $com->{'children'}, $depth+1);
|
||||
}
|
||||
};
|
||||
$p->{'comments'} = [];
|
||||
$convert_comments->($convert_comments, $p->{'comments'}, \@comments, 1);
|
||||
|
||||
# prepare the javascript data structure to put in the top of the page
|
||||
# if the remote user is a manager of the comments
|
||||
my $do_commentmanage_js = $p->{'multiform_on'};
|
||||
if ($LJ::DISABLED{'commentmanage'}) {
|
||||
if (ref $LJ::DISABLED{'commentmanage'} eq "CODE") {
|
||||
$do_commentmanage_js = $LJ::DISABLED{'commentmanage'}->($remote);
|
||||
} else {
|
||||
$do_commentmanage_js = 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($do_commentmanage_js) {
|
||||
my $js = "<script>\n// don't crawl this. read http://www.livejournal.com/developer/exporting.bml\n";
|
||||
$js .= "var LJ_cmtinfo = {\n";
|
||||
my $canAdmin = LJ::can_manage($remote, $u) ? 1 : 0;
|
||||
$js .= "\tjournal: '$u->{user}',\n";
|
||||
$js .= "\tcanAdmin: $canAdmin,\n";
|
||||
$js .= "\tremote: '$remote->{user}',\n" if $remote;
|
||||
my $recurse = sub {
|
||||
my ($self, $array) = @_;
|
||||
foreach my $i (@$array) {
|
||||
my $has_threads = scalar @{$i->{'replies'}};
|
||||
my $poster = $i->{'poster'} ? $i->{'poster'}{'username'} : "";
|
||||
my $child_ids = join(',', map { $_->{'talkid'} } @{$i->{'replies'}});
|
||||
$js .= "\t$i->{'talkid'}: { rc: [$child_ids], u: '$poster' },\n";
|
||||
$self->($self, $i->{'replies'}) if $has_threads;
|
||||
}
|
||||
};
|
||||
$recurse->($recurse, $p->{'comments'});
|
||||
chop $js; chop $js; # remove final ",\n". stupid javascript.
|
||||
$js .= "\n};\n" .
|
||||
"var LJVAR;\n".
|
||||
"if (!LJVAR) LJVAR = new Object();\n".
|
||||
"LJVAR.imgprefix = \"$LJ::IMGPREFIX\";\n".
|
||||
"</script>\n";
|
||||
$p->{'head_content'} .= $js;
|
||||
$p->{'head_content'} .= "<script src='$LJ::SITEROOT/js/commentmanage.js'></script>\n";
|
||||
|
||||
}
|
||||
|
||||
|
||||
$p->{'viewing_thread'} = $get->{'thread'} ? 1 : 0;
|
||||
|
||||
# default values if there were no comments, because
|
||||
# LJ::Talk::load_comments() doesn't provide them.
|
||||
if ($copts->{'out_error'} eq 'noposts') {
|
||||
$copts->{'out_pages'} = $copts->{'out_page'} = 1;
|
||||
$copts->{'out_items'} = 0;
|
||||
$copts->{'out_itemfirst'} = $copts->{'out_itemlast'} = undef;
|
||||
}
|
||||
|
||||
$p->{'comment_pages'} = ItemRange({
|
||||
'all_subitems_displayed' => ($copts->{'out_pages'} == 1),
|
||||
'current' => $copts->{'out_page'},
|
||||
'from_subitem' => $copts->{'out_itemfirst'},
|
||||
'num_subitems_displayed' => scalar @comments,
|
||||
'to_subitem' => $copts->{'out_itemlast'},
|
||||
'total' => $copts->{'out_pages'},
|
||||
'total_subitems' => $copts->{'out_items'},
|
||||
'_url_of' => sub { return "$permalink?page=" . int($_[0]) .
|
||||
($stylemine ? "&$stylemine" : ''); },
|
||||
});
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
sub EntryPage_entry
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $r = $opts->{'r'};
|
||||
my $uri = $r->uri;
|
||||
|
||||
my ($ditemid, $itemid, $anum);
|
||||
unless ($uri =~ /(\d+)\.html/) {
|
||||
$opts->{'handler_return'} = 404;
|
||||
return;
|
||||
}
|
||||
|
||||
$ditemid = $1;
|
||||
$anum = $ditemid % 256;
|
||||
$itemid = $ditemid >> 8;
|
||||
|
||||
my $entry = LJ::Talk::get_journal_item($u, $itemid);
|
||||
unless ($entry && $entry->{'anum'} == $anum) {
|
||||
$opts->{'handler_return'} = 404;
|
||||
return;
|
||||
}
|
||||
|
||||
my $userlite_journal = UserLite($u);
|
||||
my $userlite_poster = $userlite_journal;
|
||||
my $pu = $u;
|
||||
if ($entry->{'posterid'} != $entry->{'ownerid'}) {
|
||||
$pu = LJ::load_userid($entry->{'posterid'});
|
||||
$userlite_poster = UserLite($pu);
|
||||
}
|
||||
|
||||
# do they have the viewall priv?
|
||||
my $viewall = 0;
|
||||
my $viewsome = 0;
|
||||
if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
|
||||
LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
|
||||
"viewall", "entry: $u->{'user'}, itemid: $itemid, statusvis: $u->{'statusvis'}");
|
||||
$viewall = LJ::check_priv($remote, 'canview', '*');
|
||||
$viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
|
||||
}
|
||||
|
||||
# check using normal rules
|
||||
unless (LJ::can_view($remote, $entry) || $viewall) {
|
||||
$opts->{'handler_return'} = 403;
|
||||
return;
|
||||
}
|
||||
if (($pu && $pu->{'statusvis'} eq 'S') && !$viewsome) {
|
||||
$opts->{'suspendeduser'} = 1;
|
||||
return;
|
||||
}
|
||||
|
||||
my $replycount = $entry->{'props'}->{'replycount'};
|
||||
my $nc = "";
|
||||
$nc .= "nc=$replycount" if $replycount && $remote && $remote->{'opt_nctalklinks'};
|
||||
|
||||
my $stylemine = $get->{'style'} eq "mine" ? "style=mine" : "";
|
||||
|
||||
my $userpic = Image_userpic($pu, 0, $entry->{'props'}->{'picture_keyword'});
|
||||
|
||||
my $permalink = LJ::journal_base($u) . "/$ditemid.html";
|
||||
my $readurl = LJ::Talk::talkargs($permalink, $nc, $stylemine);
|
||||
my $posturl = LJ::Talk::talkargs($permalink, "mode=reply", $stylemine);
|
||||
|
||||
my $comments = CommentInfo({
|
||||
'read_url' => $readurl,
|
||||
'post_url' => $posturl,
|
||||
'count' => $replycount,
|
||||
'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
|
||||
'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && !
|
||||
$entry->{'props'}->{'opt_nocomments'}) ? 1 : 0,
|
||||
'screened' => ($entry->{'props'}->{'hasscreened'} && $remote &&
|
||||
($remote->{'user'} eq $u->{'user'} || LJ::can_manage($remote, $u))) ? 1 : 0,
|
||||
});
|
||||
|
||||
# format it
|
||||
if ($opts->{'getargs'}->{'nohtml'}) {
|
||||
# quote all non-LJ tags
|
||||
$entry->{'subject'} =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
$entry->{'event'} =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
}
|
||||
my $raw_subj = $entry->{'subject'};
|
||||
LJ::CleanHTML::clean_subject(\$entry->{'subject'});
|
||||
LJ::CleanHTML::clean_event(\$entry->{'event'}, $entry->{'props'}->{'opt_preformatted'});
|
||||
LJ::expand_embedded($u, $ditemid, $remote, \$entry->{'event'});
|
||||
|
||||
# load tags
|
||||
my @taglist;
|
||||
my $tags = LJ::Tags::get_logtags($u, $itemid);
|
||||
while (my ($kwid, $kw) = each %{$tags->{$itemid} || {}}) {
|
||||
push @taglist, Tag($u, $kwid => $kw);
|
||||
}
|
||||
@taglist = sort { $a->{name} cmp $b->{name} } @taglist;
|
||||
|
||||
if ($opts->{enable_tags_compatibility} && @taglist) {
|
||||
$entry->{event} .= LJ::S2::get_tags_text($opts->{ctx}, \@taglist);
|
||||
}
|
||||
|
||||
my $s2entry = Entry($u, {
|
||||
'_rawsubject' => $raw_subj,
|
||||
'subject' => $entry->{'subject'},
|
||||
'text' => $entry->{'event'},
|
||||
'dateparts' => $entry->{'alldatepart'},
|
||||
'security' => $entry->{'security'},
|
||||
'props' => $entry->{'props'},
|
||||
'itemid' => $ditemid,
|
||||
'comments' => $comments,
|
||||
'journal' => $userlite_journal,
|
||||
'poster' => $userlite_poster,
|
||||
'tags' => \@taglist,
|
||||
'new_day' => 0,
|
||||
'end_day' => 0,
|
||||
'userpic' => $userpic,
|
||||
'permalink_url' => $permalink,
|
||||
});
|
||||
|
||||
return ($entry, $s2entry);
|
||||
}
|
||||
|
||||
1;
|
||||
441
livejournal/cgi-bin/LJ/S2/FriendsPage.pm
Executable file
441
livejournal/cgi-bin/LJ/S2/FriendsPage.pm
Executable file
@@ -0,0 +1,441 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub FriendsPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "FriendsPage";
|
||||
$p->{'view'} = "friends";
|
||||
$p->{'entries'} = [];
|
||||
$p->{'friends'} = {};
|
||||
$p->{'friends_title'} = LJ::ehtml($u->{'friendspagetitle'});
|
||||
$p->{'filter_active'} = 0;
|
||||
$p->{'filter_name'} = "";
|
||||
|
||||
my $sth;
|
||||
my $user = $u->{'user'};
|
||||
|
||||
# see how often the remote user can reload this page.
|
||||
# "friendsviewupdate" time determines what granularity time
|
||||
# increments by for checking for new updates
|
||||
my $nowtime = time();
|
||||
|
||||
# update delay specified by "friendsviewupdate"
|
||||
my $newinterval = LJ::get_cap_min($remote, "friendsviewupdate") || 1;
|
||||
|
||||
# when are we going to say page was last modified? back up to the
|
||||
# most recent time in the past where $time % $interval == 0
|
||||
my $lastmod = $nowtime;
|
||||
$lastmod -= $lastmod % $newinterval;
|
||||
|
||||
# see if they have a previously cached copy of this page they
|
||||
# might be able to still use.
|
||||
if ($opts->{'header'}->{'If-Modified-Since'}) {
|
||||
my $theirtime = LJ::http_to_time($opts->{'header'}->{'If-Modified-Since'});
|
||||
|
||||
# send back a 304 Not Modified if they say they've reloaded this
|
||||
# document in the last $newinterval seconds:
|
||||
unless ($theirtime < $lastmod) {
|
||||
$opts->{'handler_return'} = 304;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
$opts->{'headers'}->{'Last-Modified'} = LJ::time_to_http($lastmod);
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $ret;
|
||||
|
||||
if ($get->{'mode'} eq "live") {
|
||||
$ret .= "<html><head><title>${user}'s friends: live!</title></head>\n";
|
||||
$ret .= "<frameset rows=\"100%,0%\" border=0>\n";
|
||||
$ret .= " <frame name=livetop src=\"friends?mode=framed\">\n";
|
||||
$ret .= " <frame name=livebottom src=\"friends?mode=livecond&lastitemid=0\">\n";
|
||||
$ret .= "</frameset></html>\n";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) . "/friends";
|
||||
return 1;
|
||||
}
|
||||
|
||||
LJ::load_user_props($remote, "opt_nctalklinks", "opt_stylemine", "opt_imagelinks", "opt_ljcut_disable_friends");
|
||||
|
||||
# load options for image links
|
||||
my ($maximgwidth, $maximgheight) = (undef, undef);
|
||||
($maximgwidth, $maximgheight) = ($1, $2)
|
||||
if ($remote && $remote->{'userid'} == $u->{'userid'} &&
|
||||
$remote->{'opt_imagelinks'} =~ m/^(\d+)\|(\d+)$/);
|
||||
|
||||
## never have spiders index friends pages (change too much, and some
|
||||
## people might not want to be indexed)
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
|
||||
my $itemshow = S2::get_property_value($opts->{'ctx'}, "page_friends_items")+0;
|
||||
if ($itemshow < 1) { $itemshow = 20; }
|
||||
elsif ($itemshow > 50) { $itemshow = 50; }
|
||||
|
||||
my $skip = $get->{'skip'}+0;
|
||||
my $maxskip = ($LJ::MAX_SCROLLBACK_FRIENDS || 1000) - $itemshow;
|
||||
if ($skip > $maxskip) { $skip = $maxskip; }
|
||||
if ($skip < 0) { $skip = 0; }
|
||||
my $itemload = $itemshow+$skip;
|
||||
|
||||
my $filter;
|
||||
my $group;
|
||||
my $common_filter = 1;
|
||||
|
||||
if (defined $get->{'filter'} && $remote && $remote->{'user'} eq $user) {
|
||||
$filter = $get->{'filter'};
|
||||
$common_filter = 0;
|
||||
$p->{'filter_active'} = 1;
|
||||
$p->{'filter_name'} = "";
|
||||
} else {
|
||||
if ($opts->{'pathextra'}) {
|
||||
$group = $opts->{'pathextra'};
|
||||
$group =~ s!^/!!;
|
||||
$group =~ s!/$!!;
|
||||
if ($group) { $group = LJ::durl($group); $common_filter = 0; }
|
||||
}
|
||||
if ($group) {
|
||||
$p->{'filter_active'} = 1;
|
||||
$p->{'filter_name'} = LJ::ehtml($group);
|
||||
}
|
||||
my $grp = LJ::get_friend_group($u, { 'name' => $group || "Default View" });
|
||||
my $bit = $grp->{'groupnum'};
|
||||
my $public = $grp->{'is_public'};
|
||||
if ($bit && ($public || ($remote && $remote->{'user'} eq $user))) {
|
||||
$filter = (1 << $bit);
|
||||
} elsif ($group) {
|
||||
$opts->{'badfriendgroup'} = 1;
|
||||
return 1;
|
||||
}
|
||||
}
|
||||
|
||||
if ($opts->{'view'} eq "friendsfriends") {
|
||||
$p->{'friends_mode'} = "friendsfriends";
|
||||
}
|
||||
|
||||
if ($get->{'mode'} eq "livecond")
|
||||
{
|
||||
## load the itemids
|
||||
my @items = LJ::get_friend_items({
|
||||
'u' => $u,
|
||||
'userid' => $u->{'userid'},
|
||||
'remote' => $remote,
|
||||
'itemshow' => 1,
|
||||
'skip' => 0,
|
||||
'filter' => $filter,
|
||||
'common_filter' => $common_filter,
|
||||
});
|
||||
my $first = @items ? $items[0]->{'itemid'} : 0;
|
||||
|
||||
$ret .= "time = " . scalar(time()) . "<br />";
|
||||
$opts->{'headers'}->{'Refresh'} = "30;URL=$LJ::SITEROOT/users/$user/friends?mode=livecond&lastitemid=$first";
|
||||
if ($get->{'lastitemid'} == $first) {
|
||||
$ret .= "nothing new!";
|
||||
} else {
|
||||
if ($get->{'lastitemid'}) {
|
||||
$ret .= "<b>New stuff!</b>\n";
|
||||
$ret .= "<script language=\"JavaScript\">\n";
|
||||
$ret .= "window.parent.livetop.location.reload(true);\n";
|
||||
$ret .= "</script>\n";
|
||||
$opts->{'trusted_html'} = 1;
|
||||
} else {
|
||||
$ret .= "Friends Live! started.";
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
## load the itemids
|
||||
my %friends;
|
||||
my %friends_row;
|
||||
my %idsbycluster;
|
||||
my @items = LJ::get_friend_items({
|
||||
'u' => $u,
|
||||
'userid' => $u->{'userid'},
|
||||
'remote' => $remote,
|
||||
'itemshow' => $itemshow,
|
||||
'skip' => $skip,
|
||||
'filter' => $filter,
|
||||
'common_filter' => $common_filter,
|
||||
'friends_u' => \%friends,
|
||||
'friends' => \%friends_row,
|
||||
'idsbycluster' => \%idsbycluster,
|
||||
'showtypes' => $get->{'show'},
|
||||
'friendsoffriends' => $opts->{'view'} eq "friendsfriends",
|
||||
'dateformat' => 'S2',
|
||||
});
|
||||
|
||||
while ($_ = each %friends) {
|
||||
# we expect fgcolor/bgcolor to be in here later
|
||||
$friends{$_}->{'fgcolor'} = $friends_row{$_}->{'fgcolor'} || '#ffffff';
|
||||
$friends{$_}->{'bgcolor'} = $friends_row{$_}->{'bgcolor'} || '#000000';
|
||||
}
|
||||
|
||||
return $p unless %friends;
|
||||
|
||||
### load the log properties
|
||||
my %logprops = (); # key is "$owneridOrZero $[j]itemid"
|
||||
LJ::load_log_props2multi(\%idsbycluster, \%logprops);
|
||||
|
||||
# load the text of the entries
|
||||
my $logtext = LJ::get_logtext2multi(\%idsbycluster);
|
||||
|
||||
# load tags on these entries
|
||||
my $logtags = LJ::Tags::get_logtagsmulti(\%idsbycluster);
|
||||
|
||||
my %posters;
|
||||
{
|
||||
my @posterids;
|
||||
foreach my $item (@items) {
|
||||
next if $friends{$item->{'posterid'}};
|
||||
push @posterids, $item->{'posterid'};
|
||||
}
|
||||
LJ::load_userids_multiple([ map { $_ => \$posters{$_} } @posterids ])
|
||||
if @posterids;
|
||||
}
|
||||
|
||||
my %objs_of_picid;
|
||||
my @userpic_load;
|
||||
|
||||
my %lite; # posterid -> s2_UserLite
|
||||
my $get_lite = sub {
|
||||
my $id = shift;
|
||||
return $lite{$id} if $lite{$id};
|
||||
return $lite{$id} = UserLite($posters{$id} || $friends{$id});
|
||||
};
|
||||
|
||||
my $eventnum = 0;
|
||||
my $hiddenentries = 0;
|
||||
ENTRY:
|
||||
foreach my $item (@items)
|
||||
{
|
||||
my ($friendid, $posterid, $itemid, $security, $alldatepart) =
|
||||
map { $item->{$_} } qw(ownerid posterid itemid security alldatepart);
|
||||
|
||||
my $fr = $friends{$friendid};
|
||||
$p->{'friends'}->{$fr->{'user'}} ||= Friend($fr);
|
||||
|
||||
my $clusterid = $item->{'clusterid'}+0;
|
||||
my $datakey = "$friendid $itemid";
|
||||
|
||||
my $replycount = $logprops{$datakey}->{'replycount'};
|
||||
my $subject = $logtext->{$datakey}->[0];
|
||||
my $text = $logtext->{$datakey}->[1];
|
||||
if ($get->{'nohtml'}) {
|
||||
# quote all non-LJ tags
|
||||
$subject =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
$text =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
}
|
||||
|
||||
if ($LJ::UNICODE && $logprops{$datakey}->{'unknown8bit'}) {
|
||||
LJ::item_toutf8($friends{$friendid}, \$subject, \$text, $logprops{$datakey});
|
||||
}
|
||||
|
||||
my ($friend, $poster);
|
||||
$friend = $poster = $friends{$friendid}->{'user'};
|
||||
|
||||
LJ::CleanHTML::clean_subject(\$subject) if $subject;
|
||||
|
||||
my $ditemid = $itemid * 256 + $item->{'anum'};
|
||||
|
||||
my $stylemine = "";
|
||||
$stylemine .= "style=mine" if $remote && $remote->{'opt_stylemine'} &&
|
||||
$remote->{'userid'} != $friendid;
|
||||
|
||||
LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $logprops{$datakey}->{'opt_preformatted'},
|
||||
'cuturl' => LJ::item_link($friends{$friendid}, $itemid, $item->{'anum'}, $stylemine),
|
||||
'maximgwidth' => $maximgwidth,
|
||||
'maximgheight' => $maximgheight,
|
||||
'ljcut_disable' => $remote->{'opt_ljcut_disable_friends'}, });
|
||||
LJ::expand_embedded($friends{$friendid}, $ditemid, $remote, \$text);
|
||||
|
||||
my $userlite_poster = $get_lite->($posterid);
|
||||
my $userlite_journal = $get_lite->($friendid);
|
||||
|
||||
# get the poster user
|
||||
my $po = $posters{$posterid} || $friends{$posterid};
|
||||
|
||||
# don't allow posts from suspended users
|
||||
if ($po->{'statusvis'} eq 'S') {
|
||||
$hiddenentries++; # Remember how many we've skipped for later
|
||||
next ENTRY;
|
||||
}
|
||||
|
||||
# do the picture
|
||||
my $picid = 0;
|
||||
my $picu = undef;
|
||||
if ($friendid != $posterid && S2::get_property_value($opts->{ctx}, 'use_shared_pic')) {
|
||||
# using the community, the user wants to see shared pictures
|
||||
$picu = $friends{$friendid};
|
||||
|
||||
# use shared pic for community
|
||||
$picid = $friends{$friendid}->{defaultpicid};
|
||||
} else {
|
||||
# we're using the poster for this picture
|
||||
$picu = $po;
|
||||
|
||||
# check if they specified one
|
||||
$picid = LJ::get_picid_from_keyword($po, $logprops{$datakey}->{picture_keyword})
|
||||
if $logprops{$datakey}->{picture_keyword};
|
||||
|
||||
# fall back on the poster's default
|
||||
$picid ||= $po->{defaultpicid};
|
||||
}
|
||||
|
||||
my $nc = "";
|
||||
$nc .= "nc=$replycount" if $replycount && $remote && $remote->{'opt_nctalklinks'};
|
||||
|
||||
my $journalbase = LJ::journal_base($friends{$friendid});
|
||||
my $permalink = "$journalbase/$ditemid.html";
|
||||
my $readurl = LJ::Talk::talkargs($permalink, $nc, $stylemine);
|
||||
my $posturl = LJ::Talk::talkargs($permalink, "mode=reply", $stylemine);
|
||||
|
||||
my $comments = CommentInfo({
|
||||
'read_url' => $readurl,
|
||||
'post_url' => $posturl,
|
||||
'count' => $replycount,
|
||||
'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
|
||||
'enabled' => ($friends{$friendid}->{'opt_showtalklinks'} eq "Y" &&
|
||||
! $logprops{$datakey}->{'opt_nocomments'}) ? 1 : 0,
|
||||
'screened' => ($logprops{$datakey}->{'hasscreened'} && $remote &&
|
||||
($remote->{'user'} eq $fr->{'user'} || LJ::can_manage($remote, $fr))) ? 1 : 0,
|
||||
});
|
||||
|
||||
my $moodthemeid = $u->{'opt_forcemoodtheme'} eq 'Y' ?
|
||||
$u->{'moodthemeid'} : $friends{$friendid}->{'moodthemeid'};
|
||||
|
||||
my @taglist;
|
||||
while (my ($kwid, $kw) = each %{$logtags->{$datakey} || {}}) {
|
||||
push @taglist, Tag($friends{$friendid}, $kwid => $kw);
|
||||
}
|
||||
@taglist = sort { $a->{name} cmp $b->{name} } @taglist;
|
||||
|
||||
if ($opts->{enable_tags_compatibility} && @taglist) {
|
||||
$text .= LJ::S2::get_tags_text($opts->{ctx}, \@taglist);
|
||||
}
|
||||
|
||||
my $entry = Entry($u, {
|
||||
'subject' => $subject,
|
||||
'text' => $text,
|
||||
'dateparts' => $alldatepart,
|
||||
'security' => $security,
|
||||
'props' => $logprops{$datakey},
|
||||
'itemid' => $ditemid,
|
||||
'journal' => $userlite_journal,
|
||||
'poster' => $userlite_poster,
|
||||
'comments' => $comments,
|
||||
'new_day' => 0, # setup below
|
||||
'end_day' => 0, # setup below
|
||||
'userpic' => undef,
|
||||
'tags' => \@taglist,
|
||||
'permalink_url' => $permalink,
|
||||
'moodthemeid' => $moodthemeid,
|
||||
});
|
||||
$entry->{'_ymd'} = join('-', map { $entry->{'time'}->{$_} } qw(year month day));
|
||||
|
||||
if ($picid && $picu) {
|
||||
push @userpic_load, [ $picu, $picid ];
|
||||
push @{$objs_of_picid{$picid}}, \$entry->{'userpic'};
|
||||
}
|
||||
|
||||
push @{$p->{'entries'}}, $entry;
|
||||
$eventnum++;
|
||||
|
||||
} # end while
|
||||
|
||||
# set the new_day and end_day members.
|
||||
if ($eventnum) {
|
||||
for (my $i = 0; $i < $eventnum; $i++) {
|
||||
my $entry = $p->{'entries'}->[$i];
|
||||
$entry->{'new_day'} = 1;
|
||||
my $last = $i;
|
||||
for (my $j = $i+1; $j < $eventnum; $j++) {
|
||||
my $ej = $p->{'entries'}->[$j];
|
||||
if ($ej->{'_ymd'} eq $entry->{'_ymd'}) {
|
||||
$last = $j;
|
||||
}
|
||||
}
|
||||
$p->{'entries'}->[$last]->{'end_day'} = 1;
|
||||
$i = $last;
|
||||
}
|
||||
}
|
||||
|
||||
# load the pictures that were referenced, then retroactively populate
|
||||
# the userpic fields of the Entries above
|
||||
my %userpics;
|
||||
LJ::load_userpics(\%userpics, \@userpic_load);
|
||||
|
||||
foreach my $picid (keys %userpics) {
|
||||
my $up = Image("$LJ::USERPIC_ROOT/$picid/$userpics{$picid}->{'userid'}",
|
||||
$userpics{$picid}->{'width'},
|
||||
$userpics{$picid}->{'height'});
|
||||
foreach (@{$objs_of_picid{$picid}}) { $$_ = $up; }
|
||||
}
|
||||
|
||||
# make the skip links
|
||||
my $nav = {
|
||||
'_type' => 'RecentNav',
|
||||
'version' => 1,
|
||||
'skip' => $skip,
|
||||
'count' => $eventnum,
|
||||
};
|
||||
|
||||
my $base = "$u->{'_journalbase'}/$opts->{'view'}";
|
||||
if ($group) {
|
||||
$base .= "/" . LJ::eurl($group);
|
||||
}
|
||||
|
||||
# $linkfilter is distinct from $filter: if user has a default view,
|
||||
# $filter is now set according to it but we don't want it to show in the links.
|
||||
# $incfilter may be true even if $filter is 0: user may use filter=0 to turn
|
||||
# off the default group
|
||||
my $linkfilter = $get->{'filter'} + 0;
|
||||
my $incfilter = defined $get->{'filter'};
|
||||
|
||||
# if we've skipped down, then we can skip back up
|
||||
if ($skip) {
|
||||
my %linkvars;
|
||||
$linkvars{'filter'} = $linkfilter if $incfilter;
|
||||
$linkvars{'show'} = $get->{'show'} if $get->{'show'} =~ /^\w+$/;
|
||||
my $newskip = $skip - $itemshow;
|
||||
if ($newskip > 0) { $linkvars{'skip'} = $newskip; }
|
||||
else { $newskip = 0; }
|
||||
$nav->{'forward_url'} = LJ::make_link($base, \%linkvars);
|
||||
$nav->{'forward_skip'} = $newskip;
|
||||
$nav->{'forward_count'} = $itemshow;
|
||||
}
|
||||
|
||||
## unless we didn't even load as many as we were expecting on this
|
||||
## page, then there are more (unless there are exactly the number shown
|
||||
## on the page, but who cares about that)
|
||||
# Must remember to count $hiddenentries or we'll have no skiplinks when > 1
|
||||
unless (($eventnum + $hiddenentries) != $itemshow || $skip == $maxskip) {
|
||||
my %linkvars;
|
||||
$linkvars{'filter'} = $linkfilter if $incfilter;
|
||||
$linkvars{'show'} = $get->{'show'} if $get->{'show'} =~ /^\w+$/;
|
||||
my $newskip = $skip + $itemshow;
|
||||
$linkvars{'skip'} = $newskip;
|
||||
$nav->{'backward_url'} = LJ::make_link($base, \%linkvars);
|
||||
$nav->{'backward_skip'} = $newskip;
|
||||
$nav->{'backward_count'} = $itemshow;
|
||||
}
|
||||
|
||||
$p->{'nav'} = $nav;
|
||||
|
||||
if ($get->{'mode'} eq "framed") {
|
||||
$p->{'head_content'} .= "<base target='_top' />";
|
||||
}
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
1;
|
||||
232
livejournal/cgi-bin/LJ/S2/MonthPage.pm
Executable file
232
livejournal/cgi-bin/LJ/S2/MonthPage.pm
Executable file
@@ -0,0 +1,232 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub MonthPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "MonthPage";
|
||||
$p->{'view'} = "month";
|
||||
$p->{'days'} = [];
|
||||
|
||||
my $ctx = $opts->{'ctx'};
|
||||
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
|
||||
my $user = $u->{'user'};
|
||||
my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
|
||||
"/" . $opts->{'pathextra'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($u->{'opt_blockrobots'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
|
||||
my ($year, $month);
|
||||
if ($opts->{'pathextra'} =~ m!^/(\d\d\d\d)/(\d\d)\b!) {
|
||||
($year, $month) = ($1, $2);
|
||||
}
|
||||
|
||||
$opts->{'errors'} = [];
|
||||
if ($month < 1 || $month > 12) { push @{$opts->{'errors'}}, "Invalid month: $month"; }
|
||||
if ($year < 1970 || $year > 2038) { push @{$opts->{'errors'}}, "Invalid year: $year"; }
|
||||
unless ($dbcr) { push @{$opts->{'errors'}}, "Database temporarily unavailable"; }
|
||||
return if @{$opts->{'errors'}};
|
||||
|
||||
$p->{'date'} = Date($year, $month, 0);
|
||||
|
||||
# load the log items
|
||||
my $dateformat = "%Y %m %d %H %i %s %w"; # yyyy mm dd hh mm ss day_of_week
|
||||
my $sth;
|
||||
|
||||
my $secwhere = "AND l.security='public'";
|
||||
my $viewall = 0;
|
||||
my $viewsome = 0;
|
||||
if ($remote) {
|
||||
|
||||
# do they have the viewall priv?
|
||||
if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
|
||||
LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
|
||||
"viewall", "month: $user, statusvis: $u->{'statusvis'}");
|
||||
$viewall = LJ::check_priv($remote, 'canview', '*');
|
||||
$viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
|
||||
}
|
||||
|
||||
if ($remote->{'userid'} == $u->{'userid'} || $viewall) {
|
||||
$secwhere = ""; # see everything
|
||||
} elsif ($remote->{'journaltype'} eq 'P') {
|
||||
my $gmask = LJ::get_groupmask($u, $remote);
|
||||
$secwhere = "AND (l.security='public' OR (l.security='usemask' AND l.allowmask & $gmask))"
|
||||
if $gmask;
|
||||
}
|
||||
}
|
||||
|
||||
$sth = $dbcr->prepare("SELECT l.jitemid, l.posterid, l.anum, l.day, ".
|
||||
" DATE_FORMAT(l.eventtime, '$dateformat') AS 'alldatepart', ".
|
||||
" l.replycount, l.security ".
|
||||
"FROM log2 l ".
|
||||
"WHERE l.journalid=? AND l.year=? AND l.month=? ".
|
||||
"$secwhere LIMIT 2000");
|
||||
$sth->execute($u->{userid}, $year, $month);
|
||||
|
||||
my @items;
|
||||
push @items, $_ while $_ = $sth->fetchrow_hashref;
|
||||
@items = sort { $a->{'alldatepart'} cmp $b->{'alldatepart'} } @items;
|
||||
|
||||
my @itemids = map { $_->{'jitemid'} } @items;
|
||||
|
||||
# load the log properties
|
||||
my %logprops = ();
|
||||
LJ::load_log_props2($u->{'userid'}, \@itemids, \%logprops);
|
||||
my $lt = LJ::get_logtext2($u, @itemids);
|
||||
|
||||
my (%pu, %pu_lite); # poster users; UserLite objects
|
||||
foreach (@items) {
|
||||
$pu{$_->{'posterid'}} = undef;
|
||||
}
|
||||
LJ::load_userids_multiple([map { $_, \$pu{$_} } keys %pu], [$u]);
|
||||
$pu_lite{$_} = UserLite($pu{$_}) foreach keys %pu;
|
||||
|
||||
my %day_entries; # <day> -> [ Entry+ ]
|
||||
|
||||
my $opt_text_subjects = S2::get_property_value($ctx, "page_month_textsubjects");
|
||||
my $userlite_journal = UserLite($u);
|
||||
|
||||
ENTRY:
|
||||
foreach my $item (@items)
|
||||
{
|
||||
my ($posterid, $itemid, $security, $alldatepart, $replycount, $anum) =
|
||||
map { $item->{$_} } qw(posterid jitemid security alldatepart replycount anum);
|
||||
my $subject = $lt->{$itemid}->[0];
|
||||
my $day = $item->{'day'};
|
||||
|
||||
# don't show posts from suspended users
|
||||
next unless $pu{$posterid};
|
||||
next ENTRY if $pu{$posterid}->{'statusvis'} eq 'S' && !$viewsome;
|
||||
|
||||
if ($LJ::UNICODE && $logprops{$itemid}->{'unknown8bit'}) {
|
||||
my $text;
|
||||
LJ::item_toutf8($u, \$subject, \$text, $logprops{$itemid});
|
||||
}
|
||||
|
||||
if ($opt_text_subjects) {
|
||||
LJ::CleanHTML::clean_subject_all(\$subject);
|
||||
} else {
|
||||
LJ::CleanHTML::clean_subject(\$subject);
|
||||
}
|
||||
|
||||
my $ditemid = $itemid*256 + $anum;
|
||||
my $nc = "";
|
||||
$nc .= "nc=$replycount" if $replycount && $remote && $remote->{'opt_nctalklinks'};
|
||||
my $permalink = "$journalbase/$ditemid.html";
|
||||
my $readurl = $permalink;
|
||||
$readurl .= "?$nc" if $nc;
|
||||
my $posturl = $permalink . "?mode=reply";
|
||||
|
||||
my $comments = CommentInfo({
|
||||
'read_url' => $readurl,
|
||||
'post_url' => $posturl,
|
||||
'count' => $replycount,
|
||||
'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
|
||||
'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $logprops{$itemid}->{'opt_nocomments'}) ? 1 : 0,
|
||||
'screened' => ($logprops{$itemid}->{'hasscreened'} && $remote &&
|
||||
($remote->{'user'} eq $u->{'user'} || LJ::can_manage($remote, $u))) ? 1 : 0,
|
||||
});
|
||||
|
||||
my $userlite_poster = $userlite_journal;
|
||||
my $userpic = $p->{'journal'}->{'default_pic'};
|
||||
if ($u->{'userid'} != $posterid) {
|
||||
$userlite_poster = $pu_lite{$posterid};
|
||||
$userpic = Image_userpic($pu{$posterid}, 0, $logprops{$itemid}->{'picture_keyword'});
|
||||
}
|
||||
|
||||
my $entry = Entry($u, {
|
||||
'subject' => $subject,
|
||||
'text' => "",
|
||||
'dateparts' => $alldatepart,
|
||||
'security' => $security,
|
||||
'props' => $logprops{$itemid},
|
||||
'itemid' => $ditemid,
|
||||
'journal' => $userlite_journal,
|
||||
'poster' => $userlite_poster,
|
||||
'comments' => $comments,
|
||||
'userpic' => $userpic,
|
||||
'permalink_url' => $permalink,
|
||||
});
|
||||
|
||||
push @{$day_entries{$day}}, $entry;
|
||||
}
|
||||
|
||||
my $days_month = LJ::days_in_month($month, $year);
|
||||
for my $day (1..$days_month) {
|
||||
my $entries = $day_entries{$day} || [];
|
||||
my $month_day = {
|
||||
'_type' => 'MonthDay',
|
||||
'date' => Date($year, $month, $day),
|
||||
'day' => $day,
|
||||
'has_entries' => scalar @$entries > 0,
|
||||
'num_entries' => scalar @$entries,
|
||||
'url' => $journalbase . sprintf("/%04d/%02d/%02d/", $year, $month, $day),
|
||||
'entries' => $entries,
|
||||
};
|
||||
push @{$p->{'days'}}, $month_day;
|
||||
}
|
||||
|
||||
# populate redirector
|
||||
my $vhost = $opts->{'vhost'};
|
||||
$vhost =~ s/:.*//;
|
||||
$p->{'redir'} = {
|
||||
'_type' => "Redirector",
|
||||
'user' => $u->{'user'},
|
||||
'vhost' => $vhost,
|
||||
'type' => 'monthview',
|
||||
'url' => "$LJ::SITEROOT/go.bml",
|
||||
};
|
||||
|
||||
# figure out what months have been posted into
|
||||
my $nowval = $year*12 + $month;
|
||||
|
||||
$p->{'months'} = [];
|
||||
|
||||
my $days = LJ::get_daycounts($u, $remote) || [];
|
||||
my $lastmo;
|
||||
foreach my $day (@$days) {
|
||||
my ($oy, $om) = ($day->[0], $day->[1]);
|
||||
my $mo = "$oy-$om";
|
||||
next if $mo eq $lastmo;
|
||||
$lastmo = $mo;
|
||||
|
||||
my $date = Date($oy, $om, 0);
|
||||
my $url = $journalbase . sprintf("/%04d/%02d/", $oy, $om);
|
||||
push @{$p->{'months'}}, {
|
||||
'_type' => "MonthEntryInfo",
|
||||
'date' => $date,
|
||||
'url' => $url,
|
||||
'redir_key' => sprintf("%04d%02d", $oy, $om),
|
||||
};
|
||||
|
||||
my $val = $oy*12+$om;
|
||||
if ($val < $nowval) {
|
||||
$p->{'prev_url'} = $url;
|
||||
$p->{'prev_date'} = $date;
|
||||
}
|
||||
if ($val > $nowval && ! $p->{'next_date'}) {
|
||||
$p->{'next_url'} = $url;
|
||||
$p->{'next_date'} = $date;
|
||||
}
|
||||
}
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
1;
|
||||
240
livejournal/cgi-bin/LJ/S2/RecentPage.pm
Executable file
240
livejournal/cgi-bin/LJ/S2/RecentPage.pm
Executable file
@@ -0,0 +1,240 @@
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub RecentPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "RecentPage";
|
||||
$p->{'view'} = "recent";
|
||||
$p->{'entries'} = [];
|
||||
|
||||
my $user = $u->{'user'};
|
||||
my $journalbase = LJ::journal_base($user, $opts->{'vhost'});
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'});
|
||||
return;
|
||||
}
|
||||
|
||||
LJ::load_user_props($remote, "opt_nctalklinks", "opt_ljcut_disable_lastn");
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
if ($opts->{'pathextra'}) {
|
||||
$opts->{'badargs'} = 1;
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($u->{'opt_blockrobots'} || $get->{'skip'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
|
||||
$p->{'head_content'} .= qq{<link rel="openid.server" href="$LJ::OPENID_SERVER" />\n}
|
||||
if LJ::OpenID::server_enabled();
|
||||
|
||||
my $itemshow = S2::get_property_value($opts->{'ctx'}, "page_recent_items")+0;
|
||||
if ($itemshow < 1) { $itemshow = 20; }
|
||||
elsif ($itemshow > 50) { $itemshow = 50; }
|
||||
|
||||
my $skip = $get->{'skip'}+0;
|
||||
my $maxskip = $LJ::MAX_HINTS_LASTN-$itemshow;
|
||||
if ($skip < 0) { $skip = 0; }
|
||||
if ($skip > $maxskip) { $skip = $maxskip; }
|
||||
|
||||
# do they want to view all entries, regardless of security?
|
||||
my $viewall = 0;
|
||||
my $viewsome = 0;
|
||||
if ($get->{'viewall'} && LJ::check_priv($remote, "canview")) {
|
||||
LJ::statushistory_add($u->{'userid'}, $remote->{'userid'},
|
||||
"viewall", "lastn: $user, statusvis: $u->{'statusvis'}");
|
||||
$viewall = LJ::check_priv($remote, 'canview', '*');
|
||||
$viewsome = $viewall || LJ::check_priv($remote, 'canview', 'suspended');
|
||||
}
|
||||
|
||||
## load the itemids
|
||||
my @itemids;
|
||||
my $err;
|
||||
my @items = LJ::get_recent_items({
|
||||
'clusterid' => $u->{'clusterid'},
|
||||
'clustersource' => 'slave',
|
||||
'viewall' => $viewall,
|
||||
'userid' => $u->{'userid'},
|
||||
'remote' => $remote,
|
||||
'itemshow' => $itemshow,
|
||||
'skip' => $skip,
|
||||
'tagids' => $opts->{tagids},
|
||||
'itemids' => \@itemids,
|
||||
'dateformat' => 'S2',
|
||||
'order' => ($u->{'journaltype'} eq "C" || $u->{'journaltype'} eq "Y") # community or syndicated
|
||||
? "logtime" : "",
|
||||
'err' => \$err,
|
||||
});
|
||||
|
||||
die $err if $err;
|
||||
|
||||
### load the log properties
|
||||
my %logprops = ();
|
||||
my $logtext;
|
||||
LJ::load_log_props2($u->{'userid'}, \@itemids, \%logprops);
|
||||
$logtext = LJ::get_logtext2($u, @itemids);
|
||||
|
||||
my $lastdate = "";
|
||||
my $itemnum = 0;
|
||||
my $lastentry = undef;
|
||||
|
||||
my (%apu, %apu_lite); # alt poster users; UserLite objects
|
||||
foreach (@items) {
|
||||
next unless $_->{'posterid'} != $u->{'userid'};
|
||||
$apu{$_->{'posterid'}} = undef;
|
||||
}
|
||||
if (%apu) {
|
||||
LJ::load_userids_multiple([map { $_, \$apu{$_} } keys %apu], [$u]);
|
||||
$apu_lite{$_} = UserLite($apu{$_}) foreach keys %apu;
|
||||
}
|
||||
|
||||
# load tags
|
||||
my $idsbyc = { $u->{clusterid} => [ ] };
|
||||
push @{$idsbyc->{$u->{clusterid}}}, [ $u->{userid}, $_->{itemid} ]
|
||||
foreach @items;
|
||||
my $tags = LJ::Tags::get_logtagsmulti($idsbyc);
|
||||
|
||||
my $userlite_journal = UserLite($u);
|
||||
|
||||
ENTRY:
|
||||
foreach my $item (@items)
|
||||
{
|
||||
my ($posterid, $itemid, $security, $alldatepart) =
|
||||
map { $item->{$_} } qw(posterid itemid security alldatepart);
|
||||
|
||||
my $replycount = $logprops{$itemid}->{'replycount'};
|
||||
my $subject = $logtext->{$itemid}->[0];
|
||||
my $text = $logtext->{$itemid}->[1];
|
||||
if ($get->{'nohtml'}) {
|
||||
# quote all non-LJ tags
|
||||
$subject =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
$text =~ s{<(?!/?lj)(.*?)>} {<$1>}gi;
|
||||
}
|
||||
|
||||
# don't show posts from suspended users unless the user doing the viewing says to (and is allowed)
|
||||
next ENTRY if $apu{$posterid} && $apu{$posterid}->{'statusvis'} eq 'S' && !$viewsome;
|
||||
|
||||
if ($LJ::UNICODE && $logprops{$itemid}->{'unknown8bit'}) {
|
||||
LJ::item_toutf8($u, \$subject, \$text, $logprops{$itemid});
|
||||
}
|
||||
|
||||
my $date = substr($alldatepart, 0, 10);
|
||||
my $new_day = 0;
|
||||
if ($date ne $lastdate) {
|
||||
$new_day = 1;
|
||||
$lastdate = $date;
|
||||
$lastentry->{'end_day'} = 1 if $lastentry;
|
||||
}
|
||||
|
||||
$itemnum++;
|
||||
LJ::CleanHTML::clean_subject(\$subject) if $subject;
|
||||
|
||||
my $ditemid = $itemid * 256 + $item->{'anum'};
|
||||
LJ::CleanHTML::clean_event(\$text, { 'preformatted' => $logprops{$itemid}->{'opt_preformatted'},
|
||||
'cuturl' => LJ::item_link($u, $itemid, $item->{'anum'}),
|
||||
'ljcut_disable' => $remote->{"opt_ljcut_disable_lastn"}, });
|
||||
LJ::expand_embedded($u, $ditemid, $remote, \$text);
|
||||
|
||||
my @taglist;
|
||||
while (my ($kwid, $kw) = each %{$tags->{"$u->{userid} $itemid"} || {}}) {
|
||||
push @taglist, Tag($u, $kwid => $kw);
|
||||
}
|
||||
@taglist = sort { $a->{name} cmp $b->{name} } @taglist;
|
||||
|
||||
if ($opts->{enable_tags_compatibility} && @taglist) {
|
||||
$text .= LJ::S2::get_tags_text($opts->{ctx}, \@taglist);
|
||||
}
|
||||
|
||||
my $nc = "";
|
||||
$nc .= "nc=$replycount" if $replycount && $remote && $remote->{'opt_nctalklinks'};
|
||||
|
||||
my $permalink = "$journalbase/$ditemid.html";
|
||||
my $readurl = $permalink;
|
||||
$readurl .= "?$nc" if $nc;
|
||||
my $posturl = $permalink . "?mode=reply";
|
||||
|
||||
my $comments = CommentInfo({
|
||||
'read_url' => $readurl,
|
||||
'post_url' => $posturl,
|
||||
'count' => $replycount,
|
||||
'maxcomments' => ($replycount >= LJ::get_cap($u, 'maxcomments')) ? 1 : 0,
|
||||
'enabled' => ($u->{'opt_showtalklinks'} eq "Y" && ! $logprops{$itemid}->{'opt_nocomments'}) ? 1 : 0,
|
||||
'screened' => ($logprops{$itemid}->{'hasscreened'} && ($remote->{'user'} eq $u->{'user'}|| LJ::can_manage($remote, $u))) ? 1 : 0,
|
||||
});
|
||||
|
||||
my $userlite_poster = $userlite_journal;
|
||||
my $pu = $u;
|
||||
if ($u->{'userid'} != $posterid) {
|
||||
$userlite_poster = $apu_lite{$posterid} or die "No apu_lite for posterid=$posterid";
|
||||
$pu = $apu{$posterid};
|
||||
}
|
||||
my $userpic = Image_userpic($pu, 0, $logprops{$itemid}->{'picture_keyword'});
|
||||
|
||||
my $entry = $lastentry = Entry($u, {
|
||||
'subject' => $subject,
|
||||
'text' => $text,
|
||||
'dateparts' => $alldatepart,
|
||||
'security' => $security,
|
||||
'props' => $logprops{$itemid},
|
||||
'itemid' => $ditemid,
|
||||
'journal' => $userlite_journal,
|
||||
'poster' => $userlite_poster,
|
||||
'comments' => $comments,
|
||||
'new_day' => $new_day,
|
||||
'end_day' => 0, # if true, set later
|
||||
'tags' => \@taglist,
|
||||
'userpic' => $userpic,
|
||||
'permalink_url' => $permalink,
|
||||
});
|
||||
|
||||
push @{$p->{'entries'}}, $entry;
|
||||
|
||||
} # end huge while loop
|
||||
|
||||
# mark last entry as closing.
|
||||
$p->{'entries'}->[-1]->{'end_day'} = 1 if $itemnum;
|
||||
|
||||
#### make the skip links
|
||||
my $nav = {
|
||||
'_type' => 'RecentNav',
|
||||
'version' => 1,
|
||||
'skip' => $skip,
|
||||
'count' => $itemnum,
|
||||
};
|
||||
|
||||
# if we've skipped down, then we can skip back up
|
||||
if ($skip) {
|
||||
my $newskip = $skip - $itemshow;
|
||||
$newskip = 0 if $newskip <= 0;
|
||||
$nav->{'forward_skip'} = $newskip;
|
||||
$nav->{'forward_url'} = LJ::make_link("$p->{base_url}/", { skip => ($newskip || ""), tag => (LJ::eurl($get->{tag}) || "") });
|
||||
$nav->{'forward_count'} = $itemshow;
|
||||
}
|
||||
|
||||
# unless we didn't even load as many as we were expecting on this
|
||||
# page, then there are more (unless there are exactly the number shown
|
||||
# on the page, but who cares about that)
|
||||
unless ($itemnum != $itemshow) {
|
||||
$nav->{'backward_count'} = $itemshow;
|
||||
if ($skip == $maxskip) {
|
||||
my $date_slashes = $lastdate; # "yyyy mm dd";
|
||||
$date_slashes =~ s! !/!g;
|
||||
$nav->{'backward_url'} = "$p->{'base_url'}/day/$date_slashes";
|
||||
} else {
|
||||
my $newskip = $skip + $itemshow;
|
||||
$nav->{'backward_url'} = LJ::make_link("$p->{'base_url'}/", { skip => ($newskip || ""), tag => (LJ::eurl($get->{tag}) || "") });
|
||||
$nav->{'backward_skip'} = $newskip;
|
||||
}
|
||||
}
|
||||
|
||||
$p->{'nav'} = $nav;
|
||||
return $p;
|
||||
}
|
||||
|
||||
1;
|
||||
139
livejournal/cgi-bin/LJ/S2/ReplyPage.pm
Executable file
139
livejournal/cgi-bin/LJ/S2/ReplyPage.pm
Executable file
@@ -0,0 +1,139 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub ReplyPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "ReplyPage";
|
||||
$p->{'view'} = "reply";
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my ($entry, $s2entry) = EntryPage_entry($u, $remote, $opts);
|
||||
return if $opts->{'suspendeduser'};
|
||||
return if $opts->{'handler_return'};
|
||||
my $ditemid = $entry->{'itemid'}*256 + $entry->{'anum'};
|
||||
$p->{'head_content'} .= $LJ::COMMON_CODE{'chalresp_js'};
|
||||
|
||||
if ($u->{'opt_blockrobots'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
|
||||
$p->{'entry'} = $s2entry;
|
||||
|
||||
# setup the replying item
|
||||
my $replyto = $s2entry;
|
||||
my $parpost;
|
||||
if ($get->{'replyto'}) {
|
||||
my $re_talkid = int($get->{'replyto'} >> 8);
|
||||
my $re_anum = $get->{'replyto'} % 256;
|
||||
unless ($re_anum == $entry->{'anum'}) {
|
||||
$opts->{'handler_return'} = 404;
|
||||
return;
|
||||
}
|
||||
|
||||
my $sql = "SELECT jtalkid, posterid, state, datepost FROM talk2 ".
|
||||
"WHERE journalid=$u->{'userid'} AND jtalkid=$re_talkid ".
|
||||
"AND nodetype='L' AND nodeid=$entry->{'jitemid'}";
|
||||
foreach my $pass (1, 2) {
|
||||
my $db = $pass == 1 ? LJ::get_cluster_reader($u) : LJ::get_cluster_def_reader($u);
|
||||
$parpost = $db->selectrow_hashref($sql);
|
||||
last if $parpost;
|
||||
}
|
||||
unless ($parpost and $parpost->{'state'} ne 'D') {
|
||||
$opts->{'handler_return'} = 404;
|
||||
return;
|
||||
}
|
||||
if ($parpost->{'state'} eq 'S' && !LJ::Talk::can_unscreen($remote, $u, $s2entry->{'poster'}->{'username'}, undef)) {
|
||||
$opts->{'handler_return'} = 403;
|
||||
return;
|
||||
}
|
||||
if ($parpost->{'state'} eq 'F') {
|
||||
# frozen comment, no replies allowed
|
||||
|
||||
# FIXME: eventually have S2 ErrorPage to handle this and similar
|
||||
# For now, this hack will work; this error is pretty uncommon anyway.
|
||||
$opts->{status} = "403 Forbidden";
|
||||
return "<p>This thread has been frozen; no more replies are allowed.</p>";
|
||||
}
|
||||
|
||||
my $tt = LJ::get_talktext2($u, $re_talkid);
|
||||
$parpost->{'subject'} = $tt->{$re_talkid}->[0];
|
||||
$parpost->{'body'} = $tt->{$re_talkid}->[1];
|
||||
$parpost->{'props'} =
|
||||
LJ::load_talk_props2($u, [ $re_talkid ])->{$re_talkid} || {};
|
||||
|
||||
if($LJ::UNICODE && $parpost->{'props'}->{'unknown8bit'}) {
|
||||
LJ::item_toutf8($u, \$parpost->{'subject'}, \$parpost->{'body'}, {});
|
||||
}
|
||||
|
||||
LJ::CleanHTML::clean_comment(\$parpost->{'body'},
|
||||
{ 'preformatted' => $parpost->{'props'}->{'opt_preformatted'},
|
||||
'anon_comment' => !$parpost->{posterid} });
|
||||
|
||||
my $datetime = DateTime_unix(LJ::mysqldate_to_time($parpost->{'datepost'}));
|
||||
|
||||
my ($s2poster, $pu);
|
||||
my $comment_userpic;
|
||||
if ($parpost->{'posterid'}) {
|
||||
$pu = LJ::load_userid($parpost->{'posterid'});
|
||||
return $opts->{handler_return} = 403 if $pu->{statusvis} eq 'S'; # do not show comments by suspended users
|
||||
$s2poster = UserLite($pu);
|
||||
|
||||
# FIXME: this is a little heavy:
|
||||
$comment_userpic = Image_userpic($pu, 0, $parpost->{'props'}->{'picture_keyword'});
|
||||
}
|
||||
|
||||
my $dtalkid = $re_talkid * 256 + $entry->{'anum'};
|
||||
$replyto = {
|
||||
'_type' => 'EntryLite',
|
||||
'subject' => LJ::ehtml($parpost->{'subject'}),
|
||||
'text' => $parpost->{'body'},
|
||||
'userpic' => $comment_userpic,
|
||||
'poster' => $s2poster,
|
||||
'journal' => $s2entry->{'journal'},
|
||||
'metadata' => {},
|
||||
'permalink_url' => $u->{'_journalbase'} . "/$ditemid.html?view=$dtalkid#t$dtalkid",
|
||||
'depth' => 1,
|
||||
'time' => $datetime,
|
||||
};
|
||||
}
|
||||
|
||||
$p->{'replyto'} = $replyto;
|
||||
|
||||
$p->{'form'} = {
|
||||
'_type' => "ReplyForm",
|
||||
'_remote' => $remote,
|
||||
'_u' => $u,
|
||||
'_ditemid' => $ditemid,
|
||||
'_parpost' => $parpost,
|
||||
};
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
package S2::Builtin::LJ;
|
||||
|
||||
sub ReplyForm__print
|
||||
{
|
||||
my ($ctx, $form) = @_;
|
||||
my $remote = $form->{'_remote'};
|
||||
my $u = $form->{'_u'};
|
||||
my $parpost = $form->{'_parpost'};
|
||||
my $parent = $parpost ? $parpost->{'jtalkid'} : 0;
|
||||
|
||||
$S2::pout->(LJ::Talk::talkform({ 'remote' => $remote,
|
||||
'journalu' => $u,
|
||||
'parpost' => $parpost,
|
||||
'replyto' => $parent,
|
||||
'ditemid' => $form->{'_ditemid'},
|
||||
'form' => $form }));
|
||||
|
||||
}
|
||||
|
||||
1;
|
||||
181
livejournal/cgi-bin/LJ/S2/YearPage.pm
Executable file
181
livejournal/cgi-bin/LJ/S2/YearPage.pm
Executable file
@@ -0,0 +1,181 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::S2;
|
||||
|
||||
sub YearPage
|
||||
{
|
||||
my ($u, $remote, $opts) = @_;
|
||||
|
||||
my $p = Page($u, $opts);
|
||||
$p->{'_type'} = "YearPage";
|
||||
$p->{'view'} = "archive";
|
||||
|
||||
my $user = $u->{'user'};
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) .
|
||||
"/calendar" . $opts->{'pathextra'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($u->{'opt_blockrobots'}) {
|
||||
$p->{'head_content'} .= LJ::robot_meta_tags();
|
||||
}
|
||||
if ($LJ::UNICODE) {
|
||||
$p->{'head_content'} .= '<meta http-equiv="Content-Type" content="text/html; charset='.$opts->{'saycharset'}."\" />\n";
|
||||
}
|
||||
|
||||
my $get = $opts->{'getargs'};
|
||||
|
||||
my $count = LJ::S2::get_journal_day_counts($p);
|
||||
my @years = sort { $a <=> $b } keys %$count;
|
||||
my $maxyear = @years ? $years[-1] : undef;
|
||||
my $year = $get->{'year'}; # old form was /users/<user>/calendar?year=1999
|
||||
|
||||
# but the new form is purtier: */calendar/2001
|
||||
if (! $year && $opts->{'pathextra'} =~ m!^/(\d\d\d\d)/?\b!) {
|
||||
$year = $1;
|
||||
}
|
||||
|
||||
# else... default to the year they last posted.
|
||||
$year ||= $maxyear;
|
||||
|
||||
$p->{'year'} = $year;
|
||||
$p->{'years'} = [];
|
||||
foreach (@years) {
|
||||
push @{$p->{'years'}}, YearYear($_, "$p->{'base_url'}/$_/", $_ == $p->{'year'});
|
||||
}
|
||||
|
||||
$p->{'months'} = [];
|
||||
|
||||
for my $month (1..12) {
|
||||
push @{$p->{'months'}}, YearMonth($p, {
|
||||
'month' => $month,
|
||||
'year' => $year,
|
||||
});
|
||||
}
|
||||
|
||||
return $p;
|
||||
}
|
||||
|
||||
sub YearMonth {
|
||||
my ($p, $calmon) = @_;
|
||||
|
||||
my ($month, $year) = ($calmon->{'month'}, $calmon->{'year'});
|
||||
$calmon->{'_type'} = 'YearMonth';
|
||||
$calmon->{'weeks'} = [];
|
||||
$calmon->{'url'} = sprintf("$p->{'_u'}->{'_journalbase'}/$year/%02d/", $month);
|
||||
|
||||
my $count = LJ::S2::get_journal_day_counts($p);
|
||||
my $has_entries = $count->{$year} && $count->{$year}->{$month} ? 1 : 0;
|
||||
$calmon->{'has_entries'} = $has_entries;
|
||||
|
||||
my $start_monday = 0; # FIXME: check some property to see if weeks start on monday
|
||||
my $week = undef;
|
||||
|
||||
my $flush_week = sub {
|
||||
my $end_month = shift;
|
||||
return unless $week;
|
||||
push @{$calmon->{'weeks'}}, $week;
|
||||
if ($end_month) {
|
||||
$week->{'post_empty'} =
|
||||
7 - $week->{'pre_empty'} - @{$week->{'days'}};
|
||||
}
|
||||
$week = undef;
|
||||
};
|
||||
|
||||
my $push_day = sub {
|
||||
my $d = shift;
|
||||
unless ($week) {
|
||||
my $leading = $d->{'date'}->{'_dayofweek'}-1;
|
||||
if ($start_monday) {
|
||||
$leading = 6 if --$leading < 0;
|
||||
}
|
||||
$week = {
|
||||
'_type' => 'YearWeek',
|
||||
'days' => [],
|
||||
'pre_empty' => $leading,
|
||||
'post_empty' => 0,
|
||||
};
|
||||
}
|
||||
push @{$week->{'days'}}, $d;
|
||||
if ($week->{'pre_empty'} + @{$week->{'days'}} == 7) {
|
||||
$flush_week->();
|
||||
my $size = scalar @{$calmon->{'weeks'}};
|
||||
}
|
||||
};
|
||||
|
||||
my $day_of_week = LJ::day_of_week($year, $month, 1);
|
||||
|
||||
my $daysinmonth = LJ::days_in_month($month, $year);
|
||||
|
||||
for my $day (1..$daysinmonth) {
|
||||
# so we don't auto-vivify years/months
|
||||
my $daycount = $has_entries ? $count->{$year}->{$month}->{$day} : 0;
|
||||
my $d = YearDay($p->{'_u'}, $year, $month, $day,
|
||||
$daycount, $day_of_week+1);
|
||||
$push_day->($d);
|
||||
$day_of_week = ($day_of_week + 1) % 7;
|
||||
}
|
||||
$flush_week->(1); # end of month flag
|
||||
|
||||
my $nowval = $year * 12 + $month;
|
||||
|
||||
# determine the most recent month with posts that is older than
|
||||
# the current time $month/$year. gives calendars the ability to
|
||||
# provide smart next/previous links.
|
||||
my $maxbefore;
|
||||
while (my ($iy, $h) = each %$count) {
|
||||
next if $iy > $year;
|
||||
while (my $im = each %$h) {
|
||||
next if $im >= $month;
|
||||
my $val = $iy * 12 + $im;
|
||||
if ($val < $nowval && $val > $maxbefore) {
|
||||
$maxbefore = $val;
|
||||
$calmon->{'prev_url'} = $p->{'_u'}->{'_journalbase'} . sprintf("/%04d/%02d/", $iy, $im);
|
||||
$calmon->{'prev_date'} = Date($iy, $im, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# same, except inverse: next month after current time with posts
|
||||
my $minafter;
|
||||
while (my ($iy, $h) = each %$count) {
|
||||
next if $iy < $year;
|
||||
while (my $im = each %$h) {
|
||||
next if $im <= $month;
|
||||
my $val = $iy * 12 + $im;
|
||||
if ($val > $nowval && (!$minafter || $val < $minafter)) {
|
||||
$minafter = $val;
|
||||
$calmon->{'next_url'} = $p->{'_u'}->{'_journalbase'} . sprintf("/%04d/%02d/", $iy, $im);
|
||||
$calmon->{'next_date'} = Date($iy, $im, 0);
|
||||
}
|
||||
}
|
||||
}
|
||||
return $calmon;
|
||||
}
|
||||
|
||||
sub YearYear {
|
||||
my ($year, $url, $displayed) = @_;
|
||||
return { '_type' => "YearYear",
|
||||
'year' => $year, 'url' => $url, 'displayed' => $displayed };
|
||||
}
|
||||
|
||||
sub YearDay {
|
||||
my ($u, $year, $month, $day, $count, $dow) = @_;
|
||||
my $d = {
|
||||
'_type' => 'YearDay',
|
||||
'day' => $day,
|
||||
'date' => Date($year, $month, $day, $dow),
|
||||
'num_entries' => $count
|
||||
};
|
||||
if ($count) {
|
||||
$d->{'url'} = sprintf("$u->{'_journalbase'}/$year/%02d/%02d/",
|
||||
$month, $day);
|
||||
}
|
||||
return $d;
|
||||
}
|
||||
|
||||
1;
|
||||
207
livejournal/cgi-bin/LJ/SixDegrees.pm
Executable file
207
livejournal/cgi-bin/LJ/SixDegrees.pm
Executable file
@@ -0,0 +1,207 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
require 'ljlib.pl';
|
||||
|
||||
package LJ::SixDegrees;
|
||||
|
||||
sub find_path
|
||||
{
|
||||
my ($fu, $tu, $timeout) = @_;
|
||||
return () unless $fu && $tu;
|
||||
return () unless $fu->{journaltype} eq "P" && $tu->{journaltype} eq "P";
|
||||
|
||||
$LJ::SixDegrees::MEMC_EXPIRE ||= 86400;
|
||||
|
||||
my $cache = {}; # keys for links in/out -> listrefs, userids -> $u's, "notes" -> why pass/fail
|
||||
$cache->{$fu->{userid}} = $fu;
|
||||
$cache->{$tu->{userid}} = $tu;
|
||||
|
||||
my $memkey = [ $fu->{'userid'}, "6dpath:$fu->{userid}:$tu->{userid}" ];
|
||||
my $exp = 3600;
|
||||
my $path = LJ::MemCache::get($memkey);
|
||||
unless ($path) {
|
||||
$path = _find_path_helper($fu, $tu, $timeout, $cache);
|
||||
LJ::MemCache::set($memkey, $path, $exp) if $path;
|
||||
}
|
||||
|
||||
return () unless $path;
|
||||
return map { $cache->{$_} || LJ::load_userid($_) } @$path;
|
||||
}
|
||||
|
||||
# returns arrayref of userids in path on success (even if empty), or undef on timeout
|
||||
sub _find_path_helper
|
||||
{
|
||||
my ($fu, $tu, $timeout, $cache) = @_;
|
||||
|
||||
my $time_start = time();
|
||||
|
||||
# user is themselves (one element in path)
|
||||
return [$fu->{userid}] if $fu->{'userid'} == $tu->{'userid'};
|
||||
|
||||
# from user befriends to user (two elements in path
|
||||
my $fu_friends = links_out($fu, $cache);
|
||||
if (intersect($fu_friends, [ $tu->{'userid'} ])) {
|
||||
$cache->{'note'} = "2 way path";
|
||||
return [$fu->{userid}, $tu->{userid}];
|
||||
}
|
||||
|
||||
# try to find a three-way path (fu has a friend who lists tu as a friend)
|
||||
my $tu_friendofs = links_in($tu, $cache);
|
||||
if (my $via = intersect($fu_friends, $tu_friendofs)) {
|
||||
$cache->{'note'} = "3 way path";
|
||||
return [$fu->{userid}, $via, $tu->{userid}];
|
||||
}
|
||||
|
||||
# try to find four-way path by expanding fu's friends' friends,
|
||||
# one at a time, looking for intersections. along the way,
|
||||
# keep track of all friendsfriends, then we can walk along
|
||||
# tu's friendofs-friendofs looking for intersections there later
|
||||
# if necessary.
|
||||
my %friendsfriends = (); # uid -> 1
|
||||
my %friends = (); # uid -> 1
|
||||
my $tried = 0;
|
||||
foreach my $fid (@$fu_friends) {
|
||||
$friends{$fid} = 1;
|
||||
next if ++$tried > 100;
|
||||
if (time() > $time_start + $timeout) {
|
||||
$cache->{'note'} = "timeout";
|
||||
return undef;
|
||||
}
|
||||
|
||||
# a group of one friend's ($fid's) friends
|
||||
my $ffset = links_out($fid, $cache);
|
||||
|
||||
# see if $fid's friends intersect $tu's friendofs
|
||||
if (intersect($ffset, [ $tu->{userid} ])) {
|
||||
$cache->{'note'} = "returning via fid's friends to tu";
|
||||
return [$fu->{userid}, $fid, $tu->{userid}];
|
||||
}
|
||||
|
||||
# see if $fid's friends intersect $tu's friendofs
|
||||
if (my $via = intersect($ffset, $tu_friendofs)) {
|
||||
$cache->{'note'} = "returning via fid's friends to tu's friendofs";
|
||||
return [$fu->{userid}, $fid, $via, $tu->{userid}];
|
||||
}
|
||||
|
||||
# otherwise, track who's a friends-of-friend, and the friend we're on
|
||||
# so we don't try doing the same search later
|
||||
foreach (@$ffset) {
|
||||
$friendsfriends{$_} ||= $fid;
|
||||
}
|
||||
}
|
||||
|
||||
# try to find a path by looking at tu's friendof-friendofs
|
||||
$tried = 0;
|
||||
foreach my $foid (@$tu_friendofs) {
|
||||
last if ++$tried > 100;
|
||||
if (time() > $time_start + $timeout) {
|
||||
$cache->{'note'} = "timeout";
|
||||
return undef;
|
||||
}
|
||||
|
||||
if (my $fid = $friendsfriends{$foid}) {
|
||||
$cache->{'note'} = "returning via friend-of-friend is friend of target";
|
||||
return [$fu->{userid}, $fid, $foid, $tu->{userid}];
|
||||
}
|
||||
|
||||
my $foset = links_in($foid, $cache);
|
||||
|
||||
# see if we can go from $tu to $foid's friends. (now, this shouldn't normally
|
||||
# happen, but we limit the links_in/out to 1000, so there's a possibility
|
||||
# we stopped during the friend-of-friend search above)
|
||||
if (intersect([ $fu->{userid} ], $foset)) {
|
||||
$cache->{'note'} = "returning via friend-of-friend but discovered backwards";
|
||||
return [$fu->{userid}, $foid, $tu->{userid}];
|
||||
}
|
||||
|
||||
# otherwise, see if any of this group of friendof-friendofs are a friend-friend
|
||||
foreach my $uid (@$foset) {
|
||||
if (my $fid = $friends{$uid}) {
|
||||
$cache->{'note'} = "returning via friend intersection with friendof-friendof";
|
||||
return [$fu->{userid}, $fid, $foid, $tu->{userid}];
|
||||
}
|
||||
if (my $fid = $friendsfriends{$uid}) {
|
||||
$cache->{'note'} = "returning via friend-of-friend intersection with friendof-friendof";
|
||||
return [$fu->{userid}, $fid, $uid, $foid, $tu->{userid}];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return []; # no path, but not a timeout (as opposed to undef above)
|
||||
}
|
||||
|
||||
sub intersect
|
||||
{
|
||||
my ($list_a, $list_b) = @_;
|
||||
return 0 unless ref $list_a && ref $list_b;
|
||||
my %temp;
|
||||
$temp{$_} = 1 foreach @$list_a;
|
||||
foreach (@$list_b) {
|
||||
return $_ if $temp{$_};
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub link_fetch
|
||||
{
|
||||
my ($uid, $key, $sql, $cache) = @_;
|
||||
|
||||
# first try from the pre-load/already-done per-process cache
|
||||
return $cache->{$key} if defined $cache->{$key};
|
||||
|
||||
# then try memcache
|
||||
my $memkey = [$uid, $key];
|
||||
my $listref = LJ::MemCache::get($memkey);
|
||||
if (ref $listref eq "ARRAY") {
|
||||
$cache->{$key} = $listref;
|
||||
return $listref;
|
||||
}
|
||||
|
||||
# finally fall back to the database.
|
||||
my $dbr = LJ::get_db_reader();
|
||||
$listref = $dbr->selectcol_arrayref($sql, undef, $uid) || [];
|
||||
|
||||
# get the $u's for everybody (bleh, since we need to know if they're a community
|
||||
# or not)
|
||||
my @need_load; # userids necessary to load
|
||||
foreach my $uid (@$listref) {
|
||||
push @need_load, $uid unless $cache->{$uid};
|
||||
}
|
||||
if (@need_load) {
|
||||
LJ::load_userids_multiple([ map { $_, \$cache->{$_} } @need_load ]);
|
||||
}
|
||||
|
||||
# filter out communities/deleted/suspended/etc
|
||||
my @clean_list; # visible users, not communities
|
||||
foreach my $uid (@$listref) {
|
||||
my $u = $cache->{$uid};
|
||||
next unless $u && $u->{'statusvis'} eq "V" && $u->{'journaltype'} eq "P";
|
||||
push @clean_list, $uid;
|
||||
}
|
||||
|
||||
$listref = \@clean_list;
|
||||
LJ::MemCache::set($memkey, $listref, $LJ::SixDegrees::MEMC_EXPIRE);
|
||||
$cache->{$key} = $listref;
|
||||
return $listref;
|
||||
}
|
||||
|
||||
sub links_out
|
||||
{
|
||||
my $uid = LJ::want_userid($_[0]);
|
||||
return link_fetch($uid, "6dlo:$uid",
|
||||
"SELECT friendid FROM friends WHERE userid=? LIMIT 1000",
|
||||
$_[1]);
|
||||
}
|
||||
|
||||
sub links_in
|
||||
{
|
||||
my $uid = LJ::want_userid($_[0]);
|
||||
return link_fetch($uid, "6dli:$uid",
|
||||
"SELECT userid FROM friends WHERE friendid=? LIMIT 1000",
|
||||
$_[1]);
|
||||
}
|
||||
|
||||
1;
|
||||
158
livejournal/cgi-bin/LJ/SpellCheck.pm
Executable file
158
livejournal/cgi-bin/LJ/SpellCheck.pm
Executable file
@@ -0,0 +1,158 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# LJ::SpellCheck class
|
||||
# See perldoc documentation at the end of this file.
|
||||
#
|
||||
# -------------------------------------------------------------------------
|
||||
#
|
||||
# This package is released under the LGPL (GNU Library General Public License)
|
||||
#
|
||||
# A copy of the license has been included with the software as LGPL.txt.
|
||||
# If not, the license is available at:
|
||||
# http://www.gnu.org/copyleft/library.txt
|
||||
#
|
||||
# -------------------------------------------------------------------------
|
||||
|
||||
|
||||
package LJ::SpellCheck;
|
||||
|
||||
use strict;
|
||||
use FileHandle;
|
||||
use IPC::Open2;
|
||||
use POSIX ":sys_wait_h";
|
||||
|
||||
use vars qw($VERSION);
|
||||
$VERSION = '1.0';
|
||||
|
||||
# Good spellcommand values:
|
||||
# ispell -a -h (default)
|
||||
# /usr/local/bin/aspell pipe -H --sug-mode=fast --ignore-case
|
||||
|
||||
sub new {
|
||||
my ($class, $args) = @_;
|
||||
my $self = {};
|
||||
bless $self, ref $class || $class;
|
||||
|
||||
$self->{'command'} = $args->{'spellcommand'} || "ispell -a -h";
|
||||
$self->{'color'} = $args->{'color'} || "#FF0000";
|
||||
return $self;
|
||||
}
|
||||
|
||||
# This function takes a block of text to spell-check and returns HTML
|
||||
# to show suggesting correction, if any. If the return from this
|
||||
# function is empty, then there were no misspellings found.
|
||||
|
||||
sub check_html {
|
||||
my $self = shift;
|
||||
my $journal = shift;
|
||||
|
||||
my $iread = new FileHandle;
|
||||
my $iwrite = new FileHandle;
|
||||
my $ierr = new FileHandle;
|
||||
my $pid;
|
||||
|
||||
# work-around for mod_perl
|
||||
my $tie_stdin = tied *STDIN;
|
||||
untie *STDIN if $tie_stdin;
|
||||
|
||||
$iwrite->autoflush(1);
|
||||
|
||||
$pid = open2($iread, $iwrite, $self->{'command'}) || die "spell process failed";
|
||||
die "Couldn't find spell checker\n" unless $pid;
|
||||
my $banner = <$iread>;
|
||||
die "banner=$banner\n" unless ($banner =~ /^@\(\#\)/);
|
||||
print $iwrite "!\n";
|
||||
|
||||
my $output = "";
|
||||
my $footnotes = "";
|
||||
|
||||
my ($srcidx, $lineidx, $mscnt, $other_bad);
|
||||
$lineidx = 1;
|
||||
$mscnt = 0;
|
||||
foreach my $inline (split(/\n/, $$journal)) {
|
||||
$srcidx = 0;
|
||||
chomp($inline);
|
||||
print $iwrite "^$inline\n";
|
||||
|
||||
my $idata;
|
||||
do {
|
||||
$idata = <$iread>;
|
||||
chomp($idata);
|
||||
|
||||
if ($idata =~ /^& /) {
|
||||
$idata =~ s/^& (\S+) (\d+) (\d+): //;
|
||||
$mscnt++;
|
||||
my ($word, $sugcount, $ofs) = ($1, $2, $3);
|
||||
$ofs -= 1; # because ispell reports "1" for first character
|
||||
|
||||
$output .= substr($inline, $srcidx, $ofs-$srcidx);
|
||||
$output .= "<font color=\"$self->{'color'}\">$word</font>";
|
||||
|
||||
$footnotes .= "<tr valign=top><td align=right><font color=$self->{'color'}>$word</font></td><td>$idata</td></tr>";
|
||||
|
||||
$srcidx = $ofs + length($word);
|
||||
} elsif ($idata =~ /^\# /) {
|
||||
$other_bad = 1;
|
||||
$idata =~ /^\# (\S+) (\d+)/;
|
||||
my ($word, $ofs) = ($1, $2);
|
||||
$ofs -= 1; # because ispell reports "1" for first character
|
||||
$output .= substr($inline, $srcidx, $ofs-$srcidx);
|
||||
$output .= "<font color=\"$self->{'color'}\">$word</font>";
|
||||
$srcidx = $ofs + length($word);
|
||||
}
|
||||
} while ($idata ne "");
|
||||
$output .= substr($inline, $srcidx, length($inline)-$srcidx) . "<br>\n";
|
||||
$lineidx++;
|
||||
}
|
||||
|
||||
$iread->close;
|
||||
$iwrite->close;
|
||||
|
||||
$pid = waitpid($pid, 0);
|
||||
|
||||
# return mod_perl to previous state, though not necessary?
|
||||
tie *STDIN, $tie_stdin if $tie_stdin;
|
||||
|
||||
return (($mscnt || $other_bad) ? "$output<p><b>Suggestions:</b><table cellpadding=3 border=0>$footnotes</table>" : "");
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
LJ::SpellCheck - let users check spelling on web pages
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use LJ::SpellCheck;
|
||||
my $s = new LJ::SpellCheck { 'spellcommand' => 'ispell -a -h',
|
||||
'color' => '#ff0000',
|
||||
};
|
||||
|
||||
my $text = "Lets mispell thigns!";
|
||||
my $correction = $s->check_html(\$text);
|
||||
if ($correction) {
|
||||
print $correction; # contains a ton of HTML
|
||||
} else {
|
||||
print "No spelling problems.";
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The object constructor takes a 'spellcommand' argument. This has to be some ispell compatible program, like aspell. Optionally, it also takes a color to highlight mispelled words.
|
||||
|
||||
The only method on the object is check_html, which takes a reference to the text to check and returns a bunch of HTML highlighting misspellings and showing suggestions. If it returns nothing, then there no misspellings found.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Sometimes the opened spell process hangs and eats up tons of CPU. Fixed now, though... I think.
|
||||
|
||||
check_html returns HTML we like. You may not. :)
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Evan Martin, evan@livejournal.com
|
||||
Brad Fitzpatrick, bradfitz@livejournal.com
|
||||
|
||||
=cut
|
||||
72
livejournal/cgi-bin/LJ/TagGenerator.pm
Executable file
72
livejournal/cgi-bin/LJ/TagGenerator.pm
Executable file
@@ -0,0 +1,72 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package LJ::TagGenerator;
|
||||
use Carp;
|
||||
|
||||
my %_tag_groups = (
|
||||
":common" => [qw(a b body br code col colgroup dd del div dl dt em
|
||||
font form frame frameset h1 h2 h3 h4 h5 h6 head hr
|
||||
html i img input li nobr ol option p pre table td th
|
||||
tr Tr TR tt title u ul)],
|
||||
":html4" => [qw(a abbr acronym address applet area b base basefont
|
||||
bdo big blockquote body br button caption center cite
|
||||
code col colgroup dd del dfn dir div dl dt em fieldset
|
||||
font form frame frameset h1 h2 h3 h4 h5 h6 head hr html
|
||||
i iframe img input ins isindex kbd label legend li link
|
||||
map menu meta noframes noscript object ol optgroup option
|
||||
p param pre q s samp script select small span strike
|
||||
strong style sub sup table tbody td textarea tfoot th
|
||||
thead title tr Tr TR tt u ul var)],
|
||||
);
|
||||
|
||||
sub import {
|
||||
shift; # ditch the class name
|
||||
my %args = @_;
|
||||
my $tags = $args{tags} || $_tag_groups{":common"};
|
||||
ref $tags and UNIVERSAL::isa($tags, "ARRAY")
|
||||
or croak "Invalid tags argument";
|
||||
my $prefix = $args{prefix} || "";
|
||||
my $suffix = $args{suffix} || "";
|
||||
my $uppercase = $args{uppercase} || 1;
|
||||
my $package = (caller)[0];
|
||||
while (my $tag = shift @$tags) {
|
||||
if (exists $_tag_groups{$tag}) {
|
||||
push @$tags, @{$_tag_groups{$tag}};
|
||||
next;
|
||||
}
|
||||
if ($uppercase) {
|
||||
$tag = uc $tag;
|
||||
}
|
||||
# print "aliasing __$tag to ${package}::$prefix$tag$suffix\n";
|
||||
*{"${package}::$prefix$tag$suffix"} = \&{"__$tag"};
|
||||
}
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
$AUTOLOAD =~ /::__([^:]*)$/ or croak "No such method $AUTOLOAD";
|
||||
my $tagname = lc $1;
|
||||
my $sub = "sub $AUTOLOAD " . q{
|
||||
{
|
||||
my $result = '<__TAGNAME__';
|
||||
if (ref($_[0]) && ref($_[0]) eq 'HASH') {
|
||||
my $attrs = shift;
|
||||
while (my ($key, $value) = each %$attrs) {
|
||||
$key =~ s/^\-//;
|
||||
$key =~ s/_/-/g;
|
||||
$result .= (defined $value ? qq( $key="$value") : qq( $key));
|
||||
}
|
||||
}
|
||||
if (@_) {
|
||||
$result .= ">" . join("", @_) . "</__TAGNAME__>";
|
||||
} else {
|
||||
$result .= " />";
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
};
|
||||
$sub =~ s/__TAGNAME__/$tagname/g;
|
||||
eval $sub;
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
1;
|
||||
2164
livejournal/cgi-bin/LJ/TextMessage.pm
Executable file
2164
livejournal/cgi-bin/LJ/TextMessage.pm
Executable file
File diff suppressed because it is too large
Load Diff
682
livejournal/cgi-bin/LJ/User.pm
Executable file
682
livejournal/cgi-bin/LJ/User.pm
Executable file
@@ -0,0 +1,682 @@
|
||||
#
|
||||
# LiveJournal user object
|
||||
#
|
||||
# 2004-07-21: we're transition from $u hashrefs to $u objects, currently
|
||||
# backed by hashrefs, to ease migration. in the future,
|
||||
# more methods from ljlib.pl and other places will move here,
|
||||
# and the representation of a $u object will change to 'fields'.
|
||||
# at present, the motivation to moving to $u objects is to do
|
||||
# all database access for a given user through his/her $u object
|
||||
# so the queries can be tagged for use by the star replication
|
||||
# daemon.
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ::User;
|
||||
use Carp;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
use LJ::MemCache;
|
||||
|
||||
sub readonly {
|
||||
my $u = shift;
|
||||
return LJ::get_cap($u, "readonly");
|
||||
}
|
||||
|
||||
# returns self (the $u object which can be used for $u->do) if
|
||||
# user is writable, else 0
|
||||
sub writer {
|
||||
my $u = shift;
|
||||
return $u if $u->{'_dbcm'} ||= LJ::get_cluster_master($u);
|
||||
return 0;
|
||||
}
|
||||
|
||||
# returns a true value if the user is underage; or if you give it an argument,
|
||||
# will turn on/off that user's underage status. can also take a second argument
|
||||
# when you're setting the flag to also update the underage_status userprop
|
||||
# which is used to record if a user was ever marked as underage.
|
||||
sub underage {
|
||||
# has no bearing if this isn't on
|
||||
return undef unless $LJ::UNDERAGE_BIT;
|
||||
|
||||
# now get the args and continue
|
||||
my $u = shift;
|
||||
return LJ::get_cap($u, 'underage') unless @_;
|
||||
|
||||
# now set it on or off
|
||||
my $on = shift() ? 1 : 0;
|
||||
if ($on) {
|
||||
LJ::modify_caps($u, [ $LJ::UNDERAGE_BIT ], []);
|
||||
$u->{caps} |= 1 << $LJ::UNDERAGE_BIT;
|
||||
} else {
|
||||
LJ::modify_caps($u, [], [ $LJ::UNDERAGE_BIT ]);
|
||||
$u->{caps} &= !(1 << $LJ::UNDERAGE_BIT);
|
||||
}
|
||||
|
||||
# now set their status flag if one was sent
|
||||
my $status = shift();
|
||||
if ($status || $on) {
|
||||
# by default, just records if user was ever underage ("Y")
|
||||
$u->underage_status($status || 'Y');
|
||||
}
|
||||
|
||||
# add to statushistory
|
||||
if (my $shwhen = shift()) {
|
||||
my $text = $on ? "marked" : "unmarked";
|
||||
my $status = $u->underage_status;
|
||||
LJ::statushistory_add($u, undef, "coppa", "$text; status=$status; when=$shwhen");
|
||||
}
|
||||
|
||||
# now fire off any hooks that are available
|
||||
LJ::run_hooks('set_underage', {
|
||||
u => $u,
|
||||
on => $on,
|
||||
status => $u->underage_status,
|
||||
});
|
||||
|
||||
# return what we set it to
|
||||
return $on;
|
||||
}
|
||||
|
||||
# log a line to our userlog
|
||||
sub log_event {
|
||||
my $u = shift;
|
||||
|
||||
my ($type, $info) = @_;
|
||||
return undef unless $type;
|
||||
$info ||= {};
|
||||
|
||||
# now get variables we need; we use delete to remove them from the hash so when we're
|
||||
# done we can just encode what's left
|
||||
my $ip = delete($info->{ip}) || LJ::get_remote_ip() || undef;
|
||||
my $uniq = delete $info->{uniq};
|
||||
unless ($uniq) {
|
||||
eval {
|
||||
$uniq = Apache->request->notes('uniq');
|
||||
};
|
||||
}
|
||||
my $remote = delete($info->{remote}) || LJ::get_remote() || undef;
|
||||
my $targetid = (delete($info->{actiontarget})+0) || undef;
|
||||
my $extra = %$info ? join('&', map { LJ::eurl($_) . '=' . LJ::eurl($info->{$_}) } keys %$info) : undef;
|
||||
|
||||
# now insert the data we have
|
||||
$u->do("INSERT INTO userlog (userid, logtime, action, actiontarget, remoteid, ip, uniq, extra) " .
|
||||
"VALUES (?, UNIX_TIMESTAMP(), ?, ?, ?, ?, ?, ?)", undef, $u->{userid}, $type,
|
||||
$targetid, $remote ? $remote->{userid} : undef, $ip, $uniq, $extra);
|
||||
return undef if $u->err;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# return or set the underage status userprop
|
||||
sub underage_status {
|
||||
return undef unless $LJ::UNDERAGE_BIT;
|
||||
|
||||
my $u = shift;
|
||||
|
||||
# return if they aren't setting it
|
||||
unless (@_) {
|
||||
LJ::load_user_props($u, 'underage_status');
|
||||
return $u->{underage_status};
|
||||
}
|
||||
|
||||
# set and return what it got set to
|
||||
LJ::set_userprop($u, 'underage_status', shift());
|
||||
return $u->{underage_status};
|
||||
}
|
||||
|
||||
# returns a true value if user has a reserved 'ext' name.
|
||||
sub external {
|
||||
my $u = shift;
|
||||
return $u->{user} =~ /^ext_/;
|
||||
}
|
||||
|
||||
# this is for debugging/special uses where you need to instruct
|
||||
# a user object on what database handle to use. returns the
|
||||
# handle that you gave it.
|
||||
sub set_dbcm {
|
||||
my $u = shift;
|
||||
return $u->{'_dbcm'} = shift;
|
||||
}
|
||||
|
||||
sub begin_work {
|
||||
my $u = shift;
|
||||
return 1 unless $LJ::INNODB_DB{$u->{clusterid}};
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
my $rv = $dbcm->begin_work;
|
||||
if ($u->{_dberr} = $dbcm->err) {
|
||||
$u->{_dberrstr} = $dbcm->errstr;
|
||||
}
|
||||
return $rv;
|
||||
}
|
||||
|
||||
sub commit {
|
||||
my $u = shift;
|
||||
return 1 unless $LJ::INNODB_DB{$u->{clusterid}};
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
my $rv = $dbcm->commit;
|
||||
if ($u->{_dberr} = $dbcm->err) {
|
||||
$u->{_dberrstr} = $dbcm->errstr;
|
||||
}
|
||||
return $rv;
|
||||
}
|
||||
|
||||
sub rollback {
|
||||
my $u = shift;
|
||||
return 0 unless $LJ::INNODB_DB{$u->{clusterid}};
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
my $rv = $dbcm->rollback;
|
||||
if ($u->{_dberr} = $dbcm->err) {
|
||||
$u->{_dberrstr} = $dbcm->errstr;
|
||||
}
|
||||
return $rv;
|
||||
}
|
||||
|
||||
# get an $sth from the writer
|
||||
sub prepare {
|
||||
my $u = shift;
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
my $rv = $dbcm->prepare(@_);
|
||||
if ($u->{_dberr} = $dbcm->err) {
|
||||
$u->{_dberrstr} = $dbcm->errstr;
|
||||
}
|
||||
return $rv;
|
||||
}
|
||||
|
||||
# $u->do("UPDATE foo SET key=?", undef, $val);
|
||||
sub do {
|
||||
my $u = shift;
|
||||
my $query = shift;
|
||||
|
||||
my $uid = $u->{userid}+0
|
||||
or croak "Database update called on null user object";
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
$query =~ s!^(\s*\w+\s+)!$1/* uid=$uid */ !;
|
||||
|
||||
my $rv = $dbcm->do($query, @_);
|
||||
if ($u->{_dberr} = $dbcm->err) {
|
||||
$u->{_dberrstr} = $dbcm->errstr;
|
||||
}
|
||||
|
||||
$u->{_mysql_insertid} = $dbcm->{'mysql_insertid'} if $dbcm->{'mysql_insertid'};
|
||||
|
||||
return $rv;
|
||||
}
|
||||
|
||||
sub selectrow_array {
|
||||
my $u = shift;
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
return $dbcm->selectrow_array(@_);
|
||||
}
|
||||
|
||||
sub selectrow_hashref {
|
||||
my $u = shift;
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
return $dbcm->selectrow_hashref(@_);
|
||||
}
|
||||
|
||||
sub err {
|
||||
my $u = shift;
|
||||
return $u->{_dberr};
|
||||
}
|
||||
|
||||
sub errstr {
|
||||
my $u = shift;
|
||||
return $u->{_dberrstr};
|
||||
}
|
||||
|
||||
sub quote {
|
||||
my $u = shift;
|
||||
my $text = shift;
|
||||
|
||||
my $dbcm = $u->{'_dbcm'} ||= LJ::get_cluster_master($u)
|
||||
or croak "Database handle unavailable";
|
||||
|
||||
return $dbcm->quote($text);
|
||||
}
|
||||
|
||||
sub mysql_insertid {
|
||||
my $u = shift;
|
||||
if ($u->isa("LJ::User")) {
|
||||
return $u->{_mysql_insertid};
|
||||
} elsif (LJ::isdb($u)) {
|
||||
my $db = $u;
|
||||
return $db->{'mysql_insertid'};
|
||||
} else {
|
||||
die "Unknown object '$u' being passed to LJ::User::mysql_insertid.";
|
||||
}
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::User::dudata_set
|
||||
# class: logging
|
||||
# des: Record or delete disk usage data for a journal
|
||||
# args: u, area, areaid, bytes
|
||||
# area: One character: "L" for log, "T" for talk, "B" for bio, "P" for pic.
|
||||
# areaid: Unique ID within $area, or '0' if area has no ids (like bio)
|
||||
# bytes: Number of bytes item takes up. Or 0 to delete record.
|
||||
# returns: 1.
|
||||
# </LJFUNC>
|
||||
sub dudata_set {
|
||||
my ($u, $area, $areaid, $bytes) = @_;
|
||||
$bytes += 0; $areaid += 0;
|
||||
if ($bytes) {
|
||||
$u->do("REPLACE INTO dudata (userid, area, areaid, bytes) ".
|
||||
"VALUES (?, ?, $areaid, $bytes)", undef,
|
||||
$u->{userid}, $area);
|
||||
} else {
|
||||
$u->do("DELETE FROM dudata WHERE userid=? AND ".
|
||||
"area=? AND areaid=$areaid", undef,
|
||||
$u->{userid}, $area);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub generate_session
|
||||
{
|
||||
my ($u, $opts) = @_;
|
||||
my $udbh = LJ::get_cluster_master($u);
|
||||
return undef unless $udbh;
|
||||
|
||||
# clean up any old, expired sessions they might have (lazy clean)
|
||||
$u->do("DELETE FROM sessions WHERE userid=? AND timeexpire < UNIX_TIMESTAMP()",
|
||||
undef, $u->{userid});
|
||||
|
||||
my $sess = {};
|
||||
$opts->{'exptype'} = "short" unless $opts->{'exptype'} eq "long" ||
|
||||
$opts->{'exptype'} eq "once";
|
||||
$sess->{'auth'} = LJ::rand_chars(10);
|
||||
my $expsec = $opts->{'expsec'}+0 || {
|
||||
'short' => 60*60*24*1.5, # 36 hours
|
||||
'long' => 60*60*24*60, # 60 days
|
||||
'once' => 60*60*24*1.5, # same as short; just doesn't renew
|
||||
}->{$opts->{'exptype'}};
|
||||
my $id = LJ::alloc_user_counter($u, 'S');
|
||||
return undef unless $id;
|
||||
$u->do("REPLACE INTO sessions (userid, sessid, auth, exptype, ".
|
||||
"timecreate, timeexpire, ipfixed) VALUES (?,?,?,?,UNIX_TIMESTAMP(),".
|
||||
"UNIX_TIMESTAMP()+$expsec,?)", undef,
|
||||
$u->{'userid'}, $id, $sess->{'auth'}, $opts->{'exptype'}, $opts->{'ipfixed'});
|
||||
return undef if $u->err;
|
||||
$sess->{'sessid'} = $id;
|
||||
$sess->{'userid'} = $u->{'userid'};
|
||||
$sess->{'ipfixed'} = $opts->{'ipfixed'};
|
||||
$sess->{'exptype'} = $opts->{'exptype'};
|
||||
|
||||
# clean up old sessions
|
||||
my $old = $udbh->selectcol_arrayref("SELECT sessid FROM sessions WHERE ".
|
||||
"userid=$u->{'userid'} AND ".
|
||||
"timeexpire < UNIX_TIMESTAMP()");
|
||||
$u->kill_sessions(@$old) if $old;
|
||||
|
||||
# mark account as being used
|
||||
LJ::mark_user_active($u, 'login');
|
||||
|
||||
return $sess;
|
||||
}
|
||||
|
||||
sub make_login_session {
|
||||
my ($u, $exptype, $ipfixed) = @_;
|
||||
$exptype ||= 'short';
|
||||
return 0 unless $u;
|
||||
|
||||
my $etime = 0;
|
||||
eval { Apache->request->notes('ljuser' => $u->{'user'}); };
|
||||
|
||||
my $sess = $u->generate_session({
|
||||
'exptype' => $exptype,
|
||||
'ipfixed' => $ipfixed,
|
||||
});
|
||||
$BML::COOKIE{'ljsession'} = [ "ws:$u->{'user'}:$sess->{'sessid'}:$sess->{'auth'}", $etime, 1 ];
|
||||
LJ::set_remote($u);
|
||||
|
||||
LJ::load_user_props($u, "browselang", "schemepref" );
|
||||
my $bl = LJ::Lang::get_lang($u->{'browselang'});
|
||||
if ($bl) {
|
||||
BML::set_cookie("langpref", $bl->{'lncode'} . "/" . time(), 0, $LJ::COOKIE_PATH, $LJ::COOKIE_DOMAIN);
|
||||
BML::set_language($bl->{'lncode'});
|
||||
}
|
||||
|
||||
# restore default scheme
|
||||
if ($u->{'schemepref'} ne "") {
|
||||
BML::set_cookie("BMLschemepref", $u->{'schemepref'}, 0, $LJ::COOKIE_PATH, $LJ::COOKIE_DOMAIN);
|
||||
BML::set_scheme($u->{'schemepref'});
|
||||
}
|
||||
|
||||
LJ::run_hooks("post_login", {
|
||||
"u" => $u,
|
||||
"form" => {},
|
||||
"expiretime" => $etime,
|
||||
});
|
||||
|
||||
LJ::mark_user_active($u, 'login');
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub tosagree_set
|
||||
{
|
||||
my ($u, $err) = @_;
|
||||
return undef unless $u;
|
||||
|
||||
unless (-f "$LJ::HOME/htdocs/inc/legal-tos") {
|
||||
$$err = "TOS include file could not be found";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $rev;
|
||||
open (TOS, "$LJ::HOME/htdocs/inc/legal-tos");
|
||||
while ((!$rev) && (my $line = <TOS>)) {
|
||||
my $rcstag = "Revision";
|
||||
if ($line =~ /\$$rcstag:\s*(\S+)\s*\$/) {
|
||||
$rev = $1;
|
||||
}
|
||||
}
|
||||
close TOS;
|
||||
|
||||
# if the required version of the tos is not available, error!
|
||||
my $rev_req = $LJ::REQUIRED_TOS{rev};
|
||||
if ($rev_req > 0 && $rev ne $rev_req) {
|
||||
$$err = "Required Terms of Service revision is $rev_req, but system version is $rev.";
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $newval = join(', ', time(), $rev);
|
||||
my $rv = LJ::set_userprop($u, "legal_tosagree", $newval);
|
||||
|
||||
# set in $u object for callers later
|
||||
$u->{legal_tosagree} = $newval if $rv;
|
||||
|
||||
return $rv;
|
||||
}
|
||||
|
||||
sub tosagree_verify {
|
||||
my $u = shift;
|
||||
|
||||
return 1 unless $LJ::TOS_CHECK;
|
||||
|
||||
my $rev_req = $LJ::REQUIRED_TOS{rev};
|
||||
return 1 unless $rev_req > 0;
|
||||
|
||||
LJ::load_user_props($u, 'legal_tosagree')
|
||||
unless $u->{legal_tosagree};
|
||||
|
||||
my $rev_cur = (split(/\s*,\s*/, $u->{legal_tosagree}))[1];
|
||||
|
||||
return $rev_cur eq $rev_req;
|
||||
}
|
||||
|
||||
sub kill_sessions {
|
||||
my $u = shift;
|
||||
my (@sessids) = @_;
|
||||
my $in = join(',', map { $_+0 } @sessids);
|
||||
return 1 unless $in;
|
||||
my $userid = $u->{'userid'};
|
||||
foreach (qw(sessions sessions_data)) {
|
||||
$u->do("DELETE FROM $_ WHERE userid=? AND ".
|
||||
"sessid IN ($in)", undef, $userid);
|
||||
}
|
||||
foreach my $id (@sessids) {
|
||||
$id += 0;
|
||||
my $memkey = [$userid,"sess:$userid:$id"];
|
||||
LJ::MemCache::delete($memkey);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub kill_all_sessions {
|
||||
my $u = shift;
|
||||
return 0 unless $u;
|
||||
my $udbh = LJ::get_cluster_master($u);
|
||||
my $sessions = $udbh->selectcol_arrayref("SELECT sessid FROM sessions WHERE ".
|
||||
"userid=$u->{'userid'}");
|
||||
$u->kill_sessions(@$sessions) if @$sessions;
|
||||
|
||||
# forget this user, if we knew they were logged in
|
||||
delete $BML::COOKIE{'ljsession'};
|
||||
LJ::set_remote(undef) if
|
||||
$LJ::CACHE_REMOTE &&
|
||||
$LJ::CACHE_REMOTE->{userid} == $u->{userid};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub kill_session {
|
||||
my $u = shift;
|
||||
return 0 unless $u;
|
||||
return 0 unless exists $u->{'_session'};
|
||||
$u->kill_sessions($u->{'_session'}->{'sessid'});
|
||||
|
||||
# forget this user, if we knew they were logged in
|
||||
delete $BML::COOKIE{'ljsession'};
|
||||
LJ::set_remote(undef) if
|
||||
$LJ::CACHE_REMOTE &&
|
||||
$LJ::CACHE_REMOTE->{userid} == $u->{userid};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::User::mogfs_userpic_key
|
||||
# class: mogilefs
|
||||
# des: Make a mogilefs key for the given pic for the user
|
||||
# args: pic
|
||||
# pic: Either the userpic hash or the picid of the userpic.
|
||||
# returns: 1.
|
||||
# </LJFUNC>
|
||||
sub mogfs_userpic_key {
|
||||
my $self = shift or return undef;
|
||||
my $pic = shift or croak "missing required arg: userpic";
|
||||
|
||||
my $picid = ref $pic ? $pic->{picid} : $pic+0;
|
||||
return "up:$self->{userid}:$picid";
|
||||
}
|
||||
|
||||
# all reads/writes to talk2 must be done inside a lock, so there's
|
||||
# no race conditions between reading from db and putting in memcache.
|
||||
# can't do a db write in between those 2 steps. the talk2 -> memcache
|
||||
# is elsewhere (talklib.pl), but this $dbh->do wrapper is provided
|
||||
# here because non-talklib things modify the talk2 table, and it's
|
||||
# nice to centralize the locking rules.
|
||||
#
|
||||
# return value is return of $dbh->do. $errref scalar ref is optional, and
|
||||
# if set, gets value of $dbh->errstr
|
||||
#
|
||||
# write: (LJ::talk2_do)
|
||||
# GET_LOCK
|
||||
# update/insert into talk2
|
||||
# RELEASE_LOCK
|
||||
# delete memcache
|
||||
#
|
||||
# read: (LJ::Talk::get_talk_data)
|
||||
# try memcache
|
||||
# GET_LOCk
|
||||
# read db
|
||||
# update memcache
|
||||
# RELEASE_LOCK
|
||||
|
||||
sub talk2_do {
|
||||
my ($u, $nodetype, $nodeid, $errref, $sql, @args) = @_;
|
||||
return undef unless $nodetype =~ /^\w$/;
|
||||
return undef unless $nodeid =~ /^\d+$/;
|
||||
return undef unless $u->writer;
|
||||
|
||||
my $dbcm = $u->{_dbcm};
|
||||
|
||||
my $memkey = [$u->{'userid'}, "talk2:$u->{'userid'}:$nodetype:$nodeid"];
|
||||
my $lockkey = $memkey->[1];
|
||||
|
||||
$dbcm->selectrow_array("SELECT GET_LOCK(?,10)", undef, $lockkey);
|
||||
my $ret = $u->do($sql, undef, @args);
|
||||
$$errref = $u->errstr if ref $errref && $u->err;
|
||||
$dbcm->selectrow_array("SELECT RELEASE_LOCK(?)", undef, $lockkey);
|
||||
|
||||
LJ::MemCache::delete($memkey, 0) if int($ret);
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# log2_do
|
||||
# see comments for talk2_do
|
||||
|
||||
sub log2_do {
|
||||
my ($u, $errref, $sql, @args) = @_;
|
||||
return undef unless $u->writer;
|
||||
|
||||
my $dbcm = $u->{_dbcm};
|
||||
|
||||
my $memkey = [$u->{'userid'}, "log2lt:$u->{'userid'}"];
|
||||
my $lockkey = $memkey->[1];
|
||||
|
||||
$dbcm->selectrow_array("SELECT GET_LOCK(?,10)", undef, $lockkey);
|
||||
my $ret = $u->do($sql, undef, @args);
|
||||
$$errref = $u->errstr if ref $errref && $u->err;
|
||||
$dbcm->selectrow_array("SELECT RELEASE_LOCK(?)", undef, $lockkey);
|
||||
|
||||
LJ::MemCache::delete($memkey, 0) if int($ret);
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub url {
|
||||
my $u = shift;
|
||||
LJ::load_user_props($u, "url");
|
||||
if ($u->{'journaltype'} eq "I" && ! $u->{url}) {
|
||||
my $id = $u->identity;
|
||||
if ($id && $id->[0] eq "O") {
|
||||
LJ::set_userprop($u, "url", $id->[1]) if $id->[1];
|
||||
return $id->[1];
|
||||
}
|
||||
}
|
||||
return $u->{url};
|
||||
}
|
||||
|
||||
# returns arrayref of [idtype, identity]
|
||||
sub identity {
|
||||
my $u = shift;
|
||||
return $u->{_identity} if $u->{_identity};
|
||||
return undef unless $u->{'journaltype'} eq "I";
|
||||
my $memkey = [$u->{userid}, "ident:$u->{userid}"];
|
||||
my $ident = LJ::MemCache::get($memkey);
|
||||
if ($ident) {
|
||||
return $u->{_identity} = $ident;
|
||||
}
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$ident = $dbh->selectrow_arrayref("SELECT idtype, identity FROM identitymap ".
|
||||
"WHERE userid=? LIMIT 1", undef, $u->{userid});
|
||||
if ($ident) {
|
||||
LJ::MemCache::set($memkey, $ident);
|
||||
return $ident;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
# returns a URL iff account is an OpenID identity. undef otherwise.
|
||||
sub openid_identity {
|
||||
my $u = shift;
|
||||
my $ident = $u->identity;
|
||||
return undef unless $ident && $ident->[0] == 0;
|
||||
return $ident->[1];
|
||||
}
|
||||
|
||||
# returns username or identity display name, not escaped
|
||||
sub display_name {
|
||||
my $u = shift;
|
||||
return $u->{'user'} unless $u->{'journaltype'} eq "I";
|
||||
|
||||
my $id = $u->identity;
|
||||
return "[ERR:unknown_identity]" unless $id;
|
||||
|
||||
my ($url, $name);
|
||||
if ($id->[0] eq "O") {
|
||||
require Net::OpenID::Consumer;
|
||||
$url = $id->[1];
|
||||
$name = Net::OpenID::VerifiedIdentity::DisplayOfURL($url, $LJ::IS_DEV_SERVER);
|
||||
# FIXME: make a good out of this
|
||||
$name =~ s/\[(live|dead)journal\.com/\[${1}journal/;
|
||||
}
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub ljuser_display {
|
||||
my $u = shift;
|
||||
my $opts = shift;
|
||||
|
||||
return LJ::ljuser($u, $opts) unless $u->{'journaltype'} eq "I";
|
||||
|
||||
my $id = $u->identity;
|
||||
return "<b>????</b>" unless $id;
|
||||
|
||||
my $andfull = $opts->{'full'} ? "&mode=full" : "";
|
||||
my $img = $opts->{'imgroot'} || $LJ::IMGPREFIX;
|
||||
my $strike = $opts->{'del'} ? ' text-decoration: line-through;' : '';
|
||||
|
||||
my ($url, $name);
|
||||
|
||||
if ($id->[0] eq "O") {
|
||||
$url = $id->[1];
|
||||
$name = $u->display_name;
|
||||
|
||||
$url ||= "about:blank";
|
||||
$name ||= "[no_name]";
|
||||
|
||||
$url = LJ::ehtml($url);
|
||||
$name = LJ::ehtml($name);
|
||||
|
||||
return "<span class='ljuser' style='white-space: nowrap;'><a href='$LJ::SITEROOT/userinfo.bml?userid=$u->{userid}&t=I$andfull'><img src='$img/openid-profile.gif' alt='[info]' width='16' height='16' style='vertical-align: bottom; border: 0;' /></a><a href='$url' rel='nofollow'><b>$name</b></a></span>";
|
||||
|
||||
} else {
|
||||
return "<b>????</b>";
|
||||
}
|
||||
}
|
||||
|
||||
sub load_identity_user {
|
||||
my ($type, $ident, $vident) = @_;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $uid = $dbh->selectrow_array("SELECT userid FROM identitymap WHERE idtype=? AND identity=?",
|
||||
undef, $type, $ident);
|
||||
return LJ::load_userid($uid) if $uid;
|
||||
|
||||
# increment ext_ counter until we successfully create an LJ
|
||||
# account. hard cap it at 10 tries. (arbitrary, but we really
|
||||
# shouldn't have *any* failures here, let alone 10 in a row)
|
||||
|
||||
for (1..10) {
|
||||
my $extuser = 'ext_' . LJ::alloc_global_counter('E');
|
||||
|
||||
my $name = $extuser;
|
||||
if ($type eq "O" && ref $vident) {
|
||||
$name = $vident->display;
|
||||
}
|
||||
|
||||
$uid = LJ::create_account({
|
||||
caps => undef,
|
||||
user => $extuser,
|
||||
name => $name,
|
||||
journaltype => 'I',
|
||||
});
|
||||
last if $uid;
|
||||
select undef, undef, undef, .10; # lets not thrash over this
|
||||
}
|
||||
return undef unless $uid &&
|
||||
$dbh->do("INSERT INTO identitymap (idtype, identity, userid) VALUES (?,?,?)",
|
||||
undef, $type, $ident, $uid);
|
||||
return LJ::load_userid($uid);
|
||||
}
|
||||
|
||||
1;
|
||||
122
livejournal/cgi-bin/PaletteModify.pm
Executable file
122
livejournal/cgi-bin/PaletteModify.pm
Executable file
@@ -0,0 +1,122 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
BEGIN {
|
||||
$PaletteModify::HAVE_CRC = eval "use String::CRC32 (); 1;";
|
||||
}
|
||||
|
||||
package PaletteModify;
|
||||
|
||||
sub common_alter
|
||||
{
|
||||
my ($palref, $table) = @_;
|
||||
my $length = length $table;
|
||||
|
||||
my $pal_size = $length / 3;
|
||||
|
||||
# tinting image? if so, we're remaking the whole palette
|
||||
if (my $tint = $palref->{'tint'}) {
|
||||
my $dark = $palref->{'tint_dark'};
|
||||
my $diff = [ map { $tint->[$_] - $dark->[$_] } (0..2) ];
|
||||
$palref = {};
|
||||
for (my $idx=0; $idx<$pal_size; $idx++) {
|
||||
for my $c (0..2) {
|
||||
my $curr = ord(substr($table, $idx*3+$c));
|
||||
my $p = \$palref->{$idx}->[$c];
|
||||
$$p = int($dark->[$c] + $diff->[$c] * $curr / 255);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
while (my ($idx, $c) = each %$palref) {
|
||||
next if $idx >= $pal_size;
|
||||
substr($table, $idx*3+$_, 1) = chr($c->[$_]) for (0..2);
|
||||
}
|
||||
|
||||
return $table;
|
||||
}
|
||||
|
||||
sub new_gif_palette
|
||||
{
|
||||
my ($fh, $palref) = @_;
|
||||
my $header;
|
||||
|
||||
# 13 bytes for magic + image info (size, color depth, etc)
|
||||
# and then the global palette table (3*256)
|
||||
read($fh, $header, 13+3*256);
|
||||
|
||||
# figure out how big global color table is (don't want to overwrite it)
|
||||
my $pf = ord substr($header, 10, 1);
|
||||
my $gct = 2 ** (($pf & 7) + 1); # last 3 bits of packaged fields
|
||||
|
||||
substr($header, 13, 3*$gct) = common_alter($palref, substr($header, 13, 3*$gct));
|
||||
return $header;
|
||||
}
|
||||
|
||||
sub new_png_palette
|
||||
{
|
||||
my ($fh, $palref) = @_;
|
||||
|
||||
# without this module, we can't proceed.
|
||||
return undef unless $PaletteModify::HAVE_CRC;
|
||||
|
||||
my $imgdata;
|
||||
|
||||
# Validate PNG signature
|
||||
my $png_sig = pack("H16", "89504E470D0A1A0A");
|
||||
my $sig;
|
||||
read($fh, $sig, 8);
|
||||
return undef unless $sig eq $png_sig;
|
||||
$imgdata .= $sig;
|
||||
|
||||
# Start reading in chunks
|
||||
my ($length, $type) = (0, '');
|
||||
while (read($fh, $length, 4)) {
|
||||
|
||||
$imgdata .= $length;
|
||||
$length = unpack("N", $length);
|
||||
return undef unless read($fh, $type, 4) == 4;
|
||||
$imgdata .= $type;
|
||||
|
||||
if ($type eq 'IHDR') {
|
||||
my $header;
|
||||
read($fh, $header, $length+4);
|
||||
my ($width,$height,$depth,$color,$compression,
|
||||
$filter,$interlace, $CRC)
|
||||
= unpack("NNCCCCCN", $header);
|
||||
return undef unless $color == 3; # unpaletted image
|
||||
$imgdata .= $header;
|
||||
} elsif ($type eq 'PLTE') {
|
||||
# Finally, we can go to work
|
||||
my $palettedata;
|
||||
read($fh, $palettedata, $length);
|
||||
$palettedata = common_alter($palref, $palettedata);
|
||||
$imgdata .= $palettedata;
|
||||
|
||||
# Skip old CRC
|
||||
my $skip;
|
||||
read($fh, $skip, 4);
|
||||
|
||||
# Generate new CRC
|
||||
my $crc = String::CRC32::crc32($type . $palettedata);
|
||||
$crc = pack("N", $crc);
|
||||
|
||||
$imgdata .= $crc;
|
||||
return $imgdata;
|
||||
} else {
|
||||
my $skip;
|
||||
# Skip rest of chunk and add to imgdata
|
||||
# Number of bytes is +4 becauses of CRC
|
||||
#
|
||||
for (my $count=0; $count < $length + 4; $count++) {
|
||||
read($fh, $skip, 1);
|
||||
$imgdata .= $skip;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
75
livejournal/cgi-bin/XML/Atom.pm
Executable file
75
livejournal/cgi-bin/XML/Atom.pm
Executable file
@@ -0,0 +1,75 @@
|
||||
# $Id: Atom.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom;
|
||||
use strict;
|
||||
|
||||
BEGIN {
|
||||
@XML::Atom::EXPORT = qw( LIBXML );
|
||||
if (eval { require XML::LibXML }) {
|
||||
*{XML::Atom::LIBXML} = sub() {1};
|
||||
} else {
|
||||
require XML::XPath;
|
||||
*{XML::Atom::LIBXML} = sub() {0};
|
||||
}
|
||||
local $^W = 0;
|
||||
*XML::XPath::Function::namespace_uri = sub {
|
||||
my $self = shift;
|
||||
my($node, @params) = @_;
|
||||
my $ns = $node->getNamespace($node->getPrefix);
|
||||
if (!$ns) {
|
||||
$ns = ($node->getNamespaces)[0];
|
||||
}
|
||||
XML::XPath::Literal->new($ns ? $ns->getExpanded : '');
|
||||
};
|
||||
}
|
||||
|
||||
use base qw( XML::Atom::ErrorHandler Exporter );
|
||||
|
||||
our $VERSION = '0.11';
|
||||
|
||||
package XML::Atom::Namespace;
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my($prefix, $uri) = @_;
|
||||
bless { prefix => $prefix, uri => $uri }, $class;
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
use vars qw( $AUTOLOAD );
|
||||
sub AUTOLOAD {
|
||||
(my $var = $AUTOLOAD) =~ s!.+::!!;
|
||||
no strict 'refs';
|
||||
($_[0], $var);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom - Atom feed and API implementation
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::Atom;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Atom is a syndication, API, and archiving format for weblogs and other
|
||||
data. I<XML::Atom> implements the feed format as well as a client for the
|
||||
API.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
I<XML::Atom> is free software; you may redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Except where otherwise noted, I<XML::Atom> is Copyright 2003 Benjamin
|
||||
Trott, cpan@stupidfool.org. All rights reserved.
|
||||
|
||||
=cut
|
||||
348
livejournal/cgi-bin/XML/Atom/Client.pm
Executable file
348
livejournal/cgi-bin/XML/Atom/Client.pm
Executable file
@@ -0,0 +1,348 @@
|
||||
# $Id: Client.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Client;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
use LWP::UserAgent;
|
||||
use XML::Atom::Entry;
|
||||
use XML::Atom::Feed;
|
||||
use XML::Atom::Util qw( first textValue );
|
||||
use Digest::SHA1 qw( sha1 );
|
||||
use MIME::Base64 qw( encode_base64 );
|
||||
use DateTime;
|
||||
|
||||
use constant NS_ATOM => 'http://purl.org/atom/ns#';
|
||||
use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $client = bless { }, $class;
|
||||
$client->init(@_) or return $class->error($client->errstr);
|
||||
$client;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $client = shift;
|
||||
my %param = @_;
|
||||
$client->{ua} = LWP::UserAgent::AtomClient->new($client);
|
||||
$client->{ua}->agent('XML::Atom/' . XML::Atom->VERSION);
|
||||
$client;
|
||||
}
|
||||
|
||||
sub username {
|
||||
my $client = shift;
|
||||
$client->{username} = shift if @_;
|
||||
$client->{username};
|
||||
}
|
||||
|
||||
sub password {
|
||||
my $client = shift;
|
||||
$client->{password} = shift if @_;
|
||||
$client->{password};
|
||||
}
|
||||
|
||||
sub use_soap {
|
||||
my $client = shift;
|
||||
$client->{use_soap} = shift if @_;
|
||||
$client->{use_soap};
|
||||
}
|
||||
|
||||
sub auth_digest {
|
||||
my $client = shift;
|
||||
$client->{auth_digest} = shift if @_;
|
||||
$client->{auth_digest};
|
||||
}
|
||||
|
||||
sub getEntry {
|
||||
my $client = shift;
|
||||
my($url) = @_;
|
||||
my $req = HTTP::Request->new(GET => $url);
|
||||
my $res = $client->make_request($req);
|
||||
return $client->error("Error on GET $url: " . $res->status_line)
|
||||
unless $res->code == 200;
|
||||
XML::Atom::Entry->new(Stream => \$res->content);
|
||||
}
|
||||
|
||||
sub createEntry {
|
||||
my $client = shift;
|
||||
my($uri, $entry) = @_;
|
||||
return $client->error("Must pass a PostURI before posting")
|
||||
unless $uri;
|
||||
my $req = HTTP::Request->new(POST => $uri);
|
||||
$req->content_type('application/x.atom+xml');
|
||||
my $xml = $entry->as_xml;
|
||||
_utf8_off($xml);
|
||||
$req->content_length(length $xml);
|
||||
$req->content($xml);
|
||||
my $res = $client->make_request($req);
|
||||
return $client->error("Error on POST $uri: " . $res->status_line)
|
||||
unless $res->code == 201;
|
||||
$res->header('Location') || 1;
|
||||
}
|
||||
|
||||
sub updateEntry {
|
||||
my $client = shift;
|
||||
my($url, $entry) = @_;
|
||||
my $req = HTTP::Request->new(PUT => $url);
|
||||
$req->content_type('application/x.atom+xml');
|
||||
my $xml = $entry->as_xml;
|
||||
_utf8_off($xml);
|
||||
$req->content_length(length $xml);
|
||||
$req->content($xml);
|
||||
my $res = $client->make_request($req);
|
||||
return $client->error("Error on PUT $url: " . $res->status_line)
|
||||
unless $res->code == 200;
|
||||
1;
|
||||
}
|
||||
|
||||
sub deleteEntry {
|
||||
my $client = shift;
|
||||
my($url) = @_;
|
||||
my $req = HTTP::Request->new(DELETE => $url);
|
||||
my $res = $client->make_request($req);
|
||||
return $client->error("Error on DELETE $url: " . $res->status_line)
|
||||
unless $res->code == 200;
|
||||
1;
|
||||
}
|
||||
|
||||
sub getFeed {
|
||||
my $client = shift;
|
||||
my($uri) = @_;
|
||||
return $client->error("Must pass a FeedURI before retrieving feed")
|
||||
unless $uri;
|
||||
my $req = HTTP::Request->new(GET => $uri);
|
||||
my $res = $client->make_request($req);
|
||||
return $client->error("Error on GET $uri: " . $res->status_line)
|
||||
unless $res->code == 200;
|
||||
my $feed = XML::Atom::Feed->new(Stream => \$res->content)
|
||||
or return $client->error(XML::Atom::Feed->errstr);
|
||||
$feed;
|
||||
}
|
||||
|
||||
sub make_request {
|
||||
my $client = shift;
|
||||
my($req) = @_;
|
||||
$client->munge_request($req);
|
||||
my $res = $client->{ua}->request($req);
|
||||
$client->munge_response($res);
|
||||
$res;
|
||||
}
|
||||
|
||||
sub munge_request {
|
||||
my $client = shift;
|
||||
my($req) = @_;
|
||||
$req->header(
|
||||
Accept => 'application/x.atom+xml, application/xml, text/xml, */*',
|
||||
);
|
||||
my $nonce = $client->make_nonce;
|
||||
my $nonce_enc = encode_base64($nonce, '');
|
||||
my $now = DateTime->now->iso8601 . 'Z';
|
||||
my $digest = encode_base64(sha1($nonce . $now . ($client->password || '')), '');
|
||||
if ($client->use_soap) {
|
||||
my $xml = $req->content || '';
|
||||
$xml =~ s!^(<\?xml.*?\?>)!!;
|
||||
my $method = $req->method;
|
||||
$xml = ($1 || '') . <<SOAP;
|
||||
<soap:Envelope
|
||||
xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/"
|
||||
xmlns:wsu="http://schemas.xmlsoap.org/ws/2002/07/utility"
|
||||
xmlns:wsse="http://schemas.xmlsoap.org/ws/2002/07/secext">
|
||||
<soap:Header>
|
||||
<wsse:Security>
|
||||
<wsse:UsernameToken>
|
||||
<wsse:Username>@{[ $client->username || '' ]}</wsse:Username>
|
||||
<wsse:Password Type="wsse:PasswordDigest">$digest</wsse:Password>
|
||||
<wsse:Nonce>$nonce_enc</wsse:Nonce>
|
||||
<wsu:Created>$now</wsu:Created>
|
||||
</wsse:UsernameToken>
|
||||
</wsse:Security>
|
||||
</soap:Header>
|
||||
<soap:Body>
|
||||
<$method xmlns="http://schemas.xmlsoap.org/wsdl/http/">
|
||||
$xml
|
||||
</$method>
|
||||
</soap:Body>
|
||||
</soap:Envelope>
|
||||
SOAP
|
||||
$req->content($xml);
|
||||
$req->content_length(length $xml);
|
||||
$req->header('SOAPAction', 'http://schemas.xmlsoap.org/wsdl/http/' . $method);
|
||||
$req->method('POST');
|
||||
$req->content_type('text/xml');
|
||||
} else {
|
||||
$req->header('X-WSSE', sprintf
|
||||
qq(UsernameToken Username="%s", PasswordDigest="%s", Nonce="%s", Created="%s"),
|
||||
$client->username || '', $digest, $nonce_enc, $now);
|
||||
$req->header('Authorization', 'WSSE profile="UsernameToken"');
|
||||
}
|
||||
}
|
||||
|
||||
sub munge_response {
|
||||
my $client = shift;
|
||||
my($res) = @_;
|
||||
if ($client->use_soap && (my $xml = $res->content)) {
|
||||
my $doc;
|
||||
if (LIBXML) {
|
||||
my $parser = XML::LibXML->new;
|
||||
$doc = $parser->parse_string($xml);
|
||||
} else {
|
||||
my $xp = XML::XPath->new(xml => $xml);
|
||||
$doc = ($xp->find('/')->get_nodelist)[0];
|
||||
}
|
||||
my $body = first($doc, NS_SOAP, 'Body');
|
||||
if (my $fault = first($body, NS_SOAP, 'Fault')) {
|
||||
$res->code(textValue($fault, undef, 'faultcode'));
|
||||
$res->message(textValue($fault, undef, 'faultstring'));
|
||||
$res->content('');
|
||||
$res->content_length(0);
|
||||
} else {
|
||||
$xml = join '', map $_->toString(LIBXML ? 1 : 0),
|
||||
LIBXML ? $body->childNodes : $body->getChildNodes;
|
||||
$res->content($xml);
|
||||
$res->content_length(1);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub make_nonce { sha1(sha1(time() . {} . rand() . $$)) }
|
||||
|
||||
sub _utf8_off {
|
||||
my $val = shift;
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($val);
|
||||
}
|
||||
}
|
||||
|
||||
package LWP::UserAgent::AtomClient;
|
||||
use strict;
|
||||
|
||||
use base qw( LWP::UserAgent );
|
||||
|
||||
my %ClientOf;
|
||||
sub new {
|
||||
my($class, $client) = @_;
|
||||
my $ua = $class->SUPER::new;
|
||||
$ClientOf{$ua} = $client;
|
||||
$ua;
|
||||
}
|
||||
|
||||
sub get_basic_credentials {
|
||||
my($ua, $realm, $url, $proxy) = @_;
|
||||
my $client = $ClientOf{$ua} or die "Cannot find $ua";
|
||||
return $client->username, $client->password;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
delete $ClientOf{$self};
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Client - A client for the Atom API
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::Atom::Client;
|
||||
use XML::Atom::Entry;
|
||||
my $api = XML::Atom::Client->new;
|
||||
$api->username('Melody');
|
||||
$api->password('Nelson');
|
||||
|
||||
my $entry = XML::Atom::Entry->new;
|
||||
$entry->title('New Post');
|
||||
$entry->content('Content of my post.');
|
||||
my $EditURI = $api->createEntry($PostURI, $entry);
|
||||
|
||||
my $feed = $api->getFeed($FeedURI);
|
||||
my @entries = $feed->entries;
|
||||
|
||||
my $entry = $api->getEntry($EditURI);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<XML::Atom::Client> implements a client for the Atom API described at
|
||||
I<http://bitworking.org/projects/atom/draft-gregorio-09.html>, with the
|
||||
authentication scheme described at
|
||||
I<http://www.intertwingly.net/wiki/pie/DifferentlyAbledClients>.
|
||||
|
||||
B<NOTE:> the API, and particularly the authentication scheme, are still
|
||||
in flux.
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 XML::Atom::Client->new(%param)
|
||||
|
||||
=head2 $api->use_soap([ 0 | 1 ])
|
||||
|
||||
I<XML::Atom::Client> supports both the REST and SOAP-wrapper versions of the
|
||||
Atom API. By default, the REST version of the API will be used, but you can
|
||||
turn on the SOAP wrapper--for example, if you need to connect to a server
|
||||
that supports only the SOAP wrapper--by calling I<use_soap> with a value of
|
||||
C<1>:
|
||||
|
||||
$api->use_soap(1);
|
||||
|
||||
If called without arguments, returns the current value of the flag.
|
||||
|
||||
=head2 $api->username([ $username ])
|
||||
|
||||
If called with an argument, sets the username for login to I<$username>.
|
||||
|
||||
Returns the current username that will be used when logging in to the
|
||||
Atom server.
|
||||
|
||||
=head2 $api->password([ $password ])
|
||||
|
||||
If called with an argument, sets the password for login to I<$password>.
|
||||
|
||||
Returns the current password that will be used when logging in to the
|
||||
Atom server.
|
||||
|
||||
=head2 $api->createEntry($PostURI, $entry)
|
||||
|
||||
Creates a new entry.
|
||||
|
||||
I<$entry> must be an I<XML::Atom::Entry> object.
|
||||
|
||||
=head2 $api->getEntry($EditURI)
|
||||
|
||||
Retrieves the entry with the given URL I<$EditURI>.
|
||||
|
||||
Returns an I<XML::Atom::Entry> object.
|
||||
|
||||
=head2 $api->updateEntry($EditURI, $entry)
|
||||
|
||||
Updates the entry at URL I<$EditURI> with the entry I<$entry>, which must be
|
||||
an I<XML::Atom::Entry> object.
|
||||
|
||||
Returns true on success, false otherwise.
|
||||
|
||||
=head2 $api->deleteEntry($EditURI)
|
||||
|
||||
Deletes the entry at URL I<$EditURI>.
|
||||
|
||||
=head2 $api->getFeed($FeedURI)
|
||||
|
||||
Retrieves the feed at I<$FeedURI>.
|
||||
|
||||
Returns an I<XML::Atom::Feed> object representing the feed returned
|
||||
from the server.
|
||||
|
||||
=head2 ERROR HANDLING
|
||||
|
||||
Methods return C<undef> on error, and the error message can be retrieved
|
||||
using the I<errstr> method.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Please see the I<XML::Atom> manpage for author, copyright, and license
|
||||
information.
|
||||
|
||||
=cut
|
||||
157
livejournal/cgi-bin/XML/Atom/Content.pm
Executable file
157
livejournal/cgi-bin/XML/Atom/Content.pm
Executable file
@@ -0,0 +1,157 @@
|
||||
# $Id: Content.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Content;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
use XML::Atom::Util qw( remove_default_ns );
|
||||
use MIME::Base64 qw( encode_base64 decode_base64 );
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $content = bless {}, $class;
|
||||
$content->init(@_) or return $class->error($content->errstr);
|
||||
$content;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $content = shift;
|
||||
my %param = @_ == 1 ? (Body => $_[0]) : @_;
|
||||
my $elem;
|
||||
unless ($elem = $param{Elem}) {
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
|
||||
$elem = $doc->createElementNS(NS, 'content');
|
||||
$doc->setDocumentElement($elem);
|
||||
} else {
|
||||
$elem = XML::XPath::Node::Element->new('content');
|
||||
}
|
||||
}
|
||||
$content->{elem} = $elem;
|
||||
if ($param{Body}) {
|
||||
$content->body($param{Body});
|
||||
}
|
||||
if ($param{Type}) {
|
||||
$content->type($param{Type});
|
||||
}
|
||||
$content;
|
||||
}
|
||||
|
||||
sub elem { $_[0]->{elem} }
|
||||
|
||||
sub type {
|
||||
my $content = shift;
|
||||
if (@_) {
|
||||
$content->elem->setAttribute('type', shift);
|
||||
}
|
||||
$content->elem->getAttribute('type');
|
||||
}
|
||||
|
||||
sub mode {
|
||||
my $content = shift;
|
||||
$content->elem->getAttribute('mode');
|
||||
}
|
||||
|
||||
sub body {
|
||||
my $content = shift;
|
||||
my $elem = $content->elem;
|
||||
if (@_) {
|
||||
my $data = shift;
|
||||
if (LIBXML) {
|
||||
$elem->removeChildNodes;
|
||||
} else {
|
||||
$elem->removeChild($_) for $elem->getChildNodes;
|
||||
}
|
||||
if (!_is_printable($data)) {
|
||||
if (LIBXML) {
|
||||
$elem->appendChild(XML::LibXML::Text->new(encode_base64($data, '')));
|
||||
} else {
|
||||
$elem->appendChild(XML::XPath::Node::Text->new(encode_base64($data, '')));
|
||||
}
|
||||
$elem->setAttribute('mode', 'base64');
|
||||
} else {
|
||||
my $copy = '<div xmlns="http://www.w3.org/1999/xhtml">' .
|
||||
$data .
|
||||
'</div>';
|
||||
my $node;
|
||||
eval {
|
||||
if (LIBXML) {
|
||||
my $parser = XML::LibXML->new;
|
||||
my $tree = $parser->parse_string($copy);
|
||||
$node = $tree->getDocumentElement;
|
||||
} else {
|
||||
my $xp = XML::XPath->new(xml => $copy);
|
||||
$node = (($xp->find('/')->get_nodelist)[0]->getChildNodes)[0]
|
||||
if $xp;
|
||||
}
|
||||
};
|
||||
if (!$@ && $node) {
|
||||
$elem->appendChild($node);
|
||||
$elem->setAttribute('mode', 'xml');
|
||||
} else {
|
||||
if (LIBXML) {
|
||||
$elem->appendChild(XML::LibXML::Text->new($data));
|
||||
} else {
|
||||
$elem->appendChild(XML::XPath::Node::Text->new($data));
|
||||
}
|
||||
$elem->setAttribute('mode', 'escaped');
|
||||
}
|
||||
}
|
||||
} else {
|
||||
unless (exists $content->{__body}) {
|
||||
my $mode = $elem->getAttribute('mode') || 'xml';
|
||||
if ($mode eq 'xml') {
|
||||
my @children = grep ref($_) =~ /Element/,
|
||||
LIBXML ? $elem->childNodes : $elem->getChildNodes;
|
||||
if (@children) {
|
||||
if (@children == 1 && $children[0]->getLocalName eq 'div') {
|
||||
@children =
|
||||
LIBXML ? $children[0]->childNodes :
|
||||
$children[0]->getChildNodes
|
||||
}
|
||||
$content->{__body} = '';
|
||||
for my $n (@children) {
|
||||
remove_default_ns($n) if LIBXML;
|
||||
$content->{__body} .= $n->toString(LIBXML ? 1 : 0);
|
||||
}
|
||||
} else {
|
||||
$content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
|
||||
}
|
||||
} elsif ($mode eq 'base64') {
|
||||
$content->{__body} = decode_base64(LIBXML ? $elem->textContent : $elem->string_value);
|
||||
} elsif ($mode eq 'escaped') {
|
||||
$content->{__body} = LIBXML ? $elem->textContent : $elem->string_value;
|
||||
} else {
|
||||
$content->{__body} = undef;
|
||||
}
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($content->{__body});
|
||||
}
|
||||
}
|
||||
}
|
||||
$content->{__body};
|
||||
}
|
||||
|
||||
sub _is_printable {
|
||||
my $data = shift;
|
||||
|
||||
# printable ASCII or UTF-8 bytes
|
||||
$data =~ /^(?:[\x09\x0a\x0d\x20-\x7f]|[\xc0-\xdf][\x80-\xbf]|[\xe0-\xef][\x80-\xbf][\x80-\xbf])*$/;
|
||||
}
|
||||
|
||||
sub as_xml {
|
||||
my $content = shift;
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
|
||||
$doc->setDocumentElement($content->elem);
|
||||
return $doc->toString(1);
|
||||
} else {
|
||||
return $content->elem->toString;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
131
livejournal/cgi-bin/XML/Atom/Entry.pm
Executable file
131
livejournal/cgi-bin/XML/Atom/Entry.pm
Executable file
@@ -0,0 +1,131 @@
|
||||
# $Id: Entry.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Entry;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::Thing );
|
||||
use MIME::Base64 qw( encode_base64 decode_base64 );
|
||||
use XML::Atom::Person;
|
||||
use XML::Atom::Content;
|
||||
use XML::Atom::Util qw( first );
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub element_name { 'entry' }
|
||||
|
||||
sub content {
|
||||
my $entry = shift;
|
||||
my @arg = @_;
|
||||
if (@arg && ref($arg[0]) ne 'XML::Atom::Content') {
|
||||
$arg[0] = XML::Atom::Content->new($arg[0]);
|
||||
}
|
||||
$entry->_element('XML::Atom::Content', 'content', @arg);
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Entry - Atom entry
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::Atom::Entry;
|
||||
my $entry = XML::Atom::Entry->new;
|
||||
$entry->title('My Post');
|
||||
$entry->content('The content of my post.');
|
||||
my $xml = $entry->as_xml;
|
||||
my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/');
|
||||
$entry->set($dc, 'subject', 'Food & Drink');
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 XML::Atom::Entry->new([ $stream ])
|
||||
|
||||
Creates a new entry object, and if I<$stream> is supplied, fills it with the
|
||||
data specified by I<$stream>.
|
||||
|
||||
Automatically handles autodiscovery if I<$stream> is a URI (see below).
|
||||
|
||||
Returns the new I<XML::Atom::Entry> object. On failure, returns C<undef>.
|
||||
|
||||
I<$stream> can be any one of the following:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Reference to a scalar
|
||||
|
||||
This is treated as the XML body of the entry.
|
||||
|
||||
=item * Scalar
|
||||
|
||||
This is treated as the name of a file containing the entry XML.
|
||||
|
||||
=item * Filehandle
|
||||
|
||||
This is treated as an open filehandle from which the entry XML can be read.
|
||||
|
||||
=back
|
||||
|
||||
=head2 $entry->content([ $content ])
|
||||
|
||||
Returns the content of the entry. If I<$content> is given, sets the content
|
||||
of the entry. Automatically handles all necessary escaping.
|
||||
|
||||
=head2 $entry->author([ $author ])
|
||||
|
||||
Returns an I<XML::Atom::Person> object representing the author of the entry,
|
||||
or C<undef> if there is no author information present.
|
||||
|
||||
If I<$author> is supplied, it should be an I<XML::Atom::Person> object
|
||||
representing the author. For example:
|
||||
|
||||
my $author = XML::Atom::Person->new;
|
||||
$author->name('Foo Bar');
|
||||
$author->email('foo@bar.com');
|
||||
$entry->author($author);
|
||||
|
||||
=head2 $entry->link
|
||||
|
||||
If called in scalar context, returns an I<XML::Atom::Link> object
|
||||
corresponding to the first I<E<lt>linkE<gt>> tag found in the entry.
|
||||
|
||||
If called in list context, returns a list of I<XML::Atom::Link> objects
|
||||
corresponding to all of the I<E<lt>linkE<gt>> tags found in the entry.
|
||||
|
||||
=head2 $entry->add_link($link)
|
||||
|
||||
Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
|
||||
the entry as a new I<E<lt>linkE<gt>> tag. For example:
|
||||
|
||||
my $link = XML::Atom::Link->new;
|
||||
$link->type('text/html');
|
||||
$link->rel('alternate');
|
||||
$link->href('http://www.example.com/2003/12/post.html');
|
||||
$entry->add_link($link);
|
||||
|
||||
=head2 $entry->get($ns, $element)
|
||||
|
||||
Given an I<XML::Atom::Namespace> element I<$ns> and an element name
|
||||
I<$element>, retrieves the value for the element in that namespace.
|
||||
|
||||
This is useful for retrieving the value of elements not in the main Atom
|
||||
namespace, like categories. For example:
|
||||
|
||||
my $dc = XML::Atom::Namespace->new(dc => 'http://purl.org/dc/elements/1.1/');
|
||||
my $subj = $entry->get($dc, 'subject');
|
||||
|
||||
=head2 $entry->getlist($ns, $element)
|
||||
|
||||
Just like I<$entry-E<gt>get>, but if there are multiple instances of the
|
||||
element I<$element> in the namespace I<$ns>, returns all of them. I<get>
|
||||
will return only the first.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Please see the I<XML::Atom> manpage for author, copyright, and license
|
||||
information.
|
||||
|
||||
=cut
|
||||
21
livejournal/cgi-bin/XML/Atom/ErrorHandler.pm
Executable file
21
livejournal/cgi-bin/XML/Atom/ErrorHandler.pm
Executable file
@@ -0,0 +1,21 @@
|
||||
# $Id: ErrorHandler.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::ErrorHandler;
|
||||
use strict;
|
||||
|
||||
use vars qw( $ERROR );
|
||||
|
||||
sub new { bless {}, shift }
|
||||
sub error {
|
||||
my $msg = $_[1] || '';
|
||||
$msg .= "\n" unless $msg =~ /\n$/;
|
||||
if (ref($_[0])) {
|
||||
$_[0]->{_errstr} = $msg;
|
||||
} else {
|
||||
$ERROR = $msg;
|
||||
}
|
||||
return;
|
||||
}
|
||||
sub errstr { ref($_[0]) ? $_[0]->{_errstr} : $ERROR }
|
||||
|
||||
1;
|
||||
256
livejournal/cgi-bin/XML/Atom/Feed.pm
Executable file
256
livejournal/cgi-bin/XML/Atom/Feed.pm
Executable file
@@ -0,0 +1,256 @@
|
||||
# $Id: Feed.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Feed;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::Thing );
|
||||
use XML::Atom::Entry;
|
||||
BEGIN {
|
||||
if (LIBXML) {
|
||||
*entries = \&entries_libxml;
|
||||
*add_entry = \&add_entry_libxml;
|
||||
} else {
|
||||
*entries = \&entries_xpath;
|
||||
*add_entry = \&add_entry_xpath;
|
||||
}
|
||||
}
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub init {
|
||||
my $atom = shift;
|
||||
my %param = @_ == 1 ? (Stream => $_[0]) : @_;
|
||||
if (UNIVERSAL::isa($param{Stream}, 'URI')) {
|
||||
my @feeds = __PACKAGE__->find_feeds($param{Stream});
|
||||
return $atom->error("Can't find Atom file") unless @feeds;
|
||||
my $ua = LWP::UserAgent->new;
|
||||
my $req = HTTP::Request->new(GET => $feeds[0]);
|
||||
my $res = $ua->request($req);
|
||||
if ($res->is_success) {
|
||||
$param{Stream} = \$res->content;
|
||||
}
|
||||
}
|
||||
$atom->SUPER::init(%param);
|
||||
}
|
||||
|
||||
sub find_feeds {
|
||||
my $class = shift;
|
||||
my($uri) = @_;
|
||||
my $ua = LWP::UserAgent->new;
|
||||
my $req = HTTP::Request->new(GET => $uri);
|
||||
my $res = $ua->request($req);
|
||||
return unless $res->is_success;
|
||||
my @feeds;
|
||||
if ($res->content_type eq 'text/html' || $res->content_type eq 'application/xhtml+xml') {
|
||||
my $base_uri = $uri;
|
||||
my $find_links = sub {
|
||||
my($tag, $attr) = @_;
|
||||
if ($tag eq 'link') {
|
||||
return unless $attr->{rel};
|
||||
my %rel = map { $_ => 1 } split /\s+/, lc($attr->{rel});
|
||||
(my $type = lc $attr->{type}) =~ s/^\s*//;
|
||||
$type =~ s/\s*$//;
|
||||
push @feeds, URI->new_abs($attr->{href}, $base_uri)->as_string
|
||||
if $rel{alternate} &&
|
||||
$type eq 'application/atom+xml';
|
||||
} elsif ($tag eq 'base') {
|
||||
$base_uri = $attr->{href};
|
||||
}
|
||||
};
|
||||
require HTML::Parser;
|
||||
my $p = HTML::Parser->new(api_version => 3,
|
||||
start_h => [ $find_links, "tagname, attr" ]);
|
||||
$p->parse($res->content);
|
||||
} else {
|
||||
@feeds = ($uri);
|
||||
}
|
||||
@feeds;
|
||||
}
|
||||
|
||||
sub element_name { 'feed' }
|
||||
|
||||
sub language {
|
||||
my $feed = shift;
|
||||
if (LIBXML) {
|
||||
my $elem = $feed->{doc}->getDocumentElement;
|
||||
if (@_) {
|
||||
$elem->setAttributeNS('http://www.w3.org/XML/1998/namespace',
|
||||
'lang', $_[0]);
|
||||
}
|
||||
return $elem->getAttribute('lang');
|
||||
} else {
|
||||
if (@_) {
|
||||
$feed->{doc}->setAttribute('xml:lang', $_[0]);
|
||||
}
|
||||
return $feed->{doc}->getAttribute('xml:lang');
|
||||
}
|
||||
}
|
||||
|
||||
sub version {
|
||||
my $feed = shift;
|
||||
my $elem = LIBXML ? $feed->{doc}->getDocumentElement : $feed->{doc};
|
||||
if (@_) {
|
||||
$elem->setAttribute('version', $_[0]);
|
||||
}
|
||||
$elem->getAttribute('version');
|
||||
}
|
||||
|
||||
sub entries_libxml {
|
||||
my $feed = shift;
|
||||
my @res = $feed->{doc}->getElementsByTagNameNS(NS, 'entry') or return;
|
||||
my @entries;
|
||||
for my $res (@res) {
|
||||
my $entry = XML::Atom::Entry->new(Elem => $res->cloneNode(1));
|
||||
push @entries, $entry;
|
||||
}
|
||||
@entries;
|
||||
}
|
||||
|
||||
sub entries_xpath {
|
||||
my $feed = shift;
|
||||
my $set = $feed->{doc}->find("descendant-or-self::*[local-name()='entry' and namespace-uri()='" . NS . "']");
|
||||
my @entries;
|
||||
for my $elem ($set->get_nodelist) {
|
||||
## Delete the link to the parent (feed) element, and append
|
||||
## the default Atom namespace.
|
||||
$elem->del_parent_link;
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$elem->appendNamespace($ns);
|
||||
my $entry = XML::Atom::Entry->new(Elem => $elem);
|
||||
push @entries, $entry;
|
||||
}
|
||||
@entries;
|
||||
}
|
||||
|
||||
sub add_entry_libxml {
|
||||
my $feed = shift;
|
||||
my($entry) = @_;
|
||||
$feed->{doc}->getDocumentElement->appendChild($entry->{doc}->getDocumentElement);
|
||||
}
|
||||
|
||||
sub add_entry_xpath {
|
||||
my $feed = shift;
|
||||
my($entry) = @_;
|
||||
$feed->{doc}->appendChild($entry->{doc});
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Feed - Atom feed
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::Atom::Feed;
|
||||
use XML::Atom::Entry;
|
||||
my $feed = XML::Atom::Feed->new;
|
||||
$feed->title('My Weblog');
|
||||
my $entry = XML::Atom::Entry->new;
|
||||
$entry->title('First Post');
|
||||
$entry->content('Post Body');
|
||||
$feed->add_entry($entry);
|
||||
my @entries = $feed->entries;
|
||||
my $xml = $feed->as_xml;
|
||||
|
||||
## Get a list of the <link rel="..." /> tags in the feed.
|
||||
my $links = $feed->link;
|
||||
|
||||
## Find all of the Atom feeds on a given page, using auto-discovery.
|
||||
my @uris = XML::Atom::Feed->find_feeds('http://www.example.com/');
|
||||
|
||||
## Use auto-discovery to load the first Atom feed on a given page.
|
||||
my $feed = XML::Atom::Feed->new(URI->new('http://www.example.com/'));
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 XML::Atom::Feed->new([ $stream ])
|
||||
|
||||
Creates a new feed object, and if I<$stream> is supplied, fills it with the
|
||||
data specified by I<$stream>.
|
||||
|
||||
Automatically handles autodiscovery if I<$stream> is a URI (see below).
|
||||
|
||||
Returns the new I<XML::Atom::Feed> object. On failure, returns C<undef>.
|
||||
|
||||
I<$stream> can be any one of the following:
|
||||
|
||||
=over 4
|
||||
|
||||
=item * Reference to a scalar
|
||||
|
||||
This is treated as the XML body of the feed.
|
||||
|
||||
=item * Scalar
|
||||
|
||||
This is treated as the name of a file containing the feed XML.
|
||||
|
||||
=item * Filehandle
|
||||
|
||||
This is treated as an open filehandle from which the feed XML can be read.
|
||||
|
||||
=item * URI object
|
||||
|
||||
This is treated as a URI, and the feed XML will be retrieved from the URI.
|
||||
|
||||
If the content type returned from fetching the content at URI is
|
||||
I<text/html>, this method will automatically try to perform auto-discovery
|
||||
by looking for a I<E<lt>linkE<gt>> tag describing the feed URL. If such
|
||||
a URL is found, the feed XML will be automatically retrieved.
|
||||
|
||||
If the URI is already of a feed, no auto-discovery is necessary, and the
|
||||
feed XML will be retrieved and parsed as normal.
|
||||
|
||||
=back
|
||||
|
||||
=head2 XML::Atom::Feed->find_feeds($uri)
|
||||
|
||||
Given a URI I<$uri>, use auto-discovery to find all of the Atom feeds linked
|
||||
from that page (using I<E<lt>linkE<gt>> tags).
|
||||
|
||||
Returns a list of feed URIs.
|
||||
|
||||
=head2 $feed->link
|
||||
|
||||
If called in scalar context, returns an I<XML::Atom::Link> object
|
||||
corresponding to the first I<E<lt>linkE<gt>> tag found in the feed.
|
||||
|
||||
If called in list context, returns a list of I<XML::Atom::Link> objects
|
||||
corresponding to all of the I<E<lt>linkE<gt>> tags found in the feed.
|
||||
|
||||
=head2 $feed->add_link($link)
|
||||
|
||||
Adds the link I<$link>, which must be an I<XML::Atom::Link> object, to
|
||||
the feed as a new I<E<lt>linkE<gt>> tag. For example:
|
||||
|
||||
my $link = XML::Atom::Link->new;
|
||||
$link->type('text/html');
|
||||
$link->rel('alternate');
|
||||
$link->href('http://www.example.com/');
|
||||
$feed->add_link($link);
|
||||
|
||||
=head2 $feed->language
|
||||
|
||||
Returns the language of the feed, from I<xml:lang>.
|
||||
|
||||
=head2 $feed->author([ $author ])
|
||||
|
||||
Returns an I<XML::Atom::Person> object representing the author of the entry,
|
||||
or C<undef> if there is no author information present.
|
||||
|
||||
If I<$author> is supplied, it should be an I<XML::Atom::Person> object
|
||||
representing the author. For example:
|
||||
|
||||
my $author = XML::Atom::Person->new;
|
||||
$author->name('Foo Bar');
|
||||
$author->email('foo@bar.com');
|
||||
$feed->author($author);
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Please see the I<XML::Atom> manpage for author, copyright, and license
|
||||
information.
|
||||
|
||||
=cut
|
||||
92
livejournal/cgi-bin/XML/Atom/Link.pm
Executable file
92
livejournal/cgi-bin/XML/Atom/Link.pm
Executable file
@@ -0,0 +1,92 @@
|
||||
# $Id: Link.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Link;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $link = bless {}, $class;
|
||||
$link->init(@_) or return $class->error($link->errstr);
|
||||
$link;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $link = shift;
|
||||
my %param = @_ == 1 ? (Body => $_[0]) : @_;
|
||||
my $elem;
|
||||
unless ($elem = $param{Elem}) {
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
|
||||
$elem = $doc->createElementNS(NS, 'link');
|
||||
$doc->setDocumentElement($elem);
|
||||
} else {
|
||||
$elem = XML::XPath::Node::Element->new('link');
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$elem->appendNamespace($ns);
|
||||
}
|
||||
}
|
||||
$link->{elem} = $elem;
|
||||
$link;
|
||||
}
|
||||
|
||||
sub elem { $_[0]->{elem} }
|
||||
|
||||
sub get {
|
||||
my $link = shift;
|
||||
my($attr) = @_;
|
||||
my $val = $link->elem->getAttribute($attr);
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($val);
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub set {
|
||||
my $link = shift;
|
||||
if (@_ == 2) {
|
||||
my($attr, $val) = @_;
|
||||
$link->elem->setAttribute($attr, $val);
|
||||
} elsif (@_ == 3) {
|
||||
my($ns, $attr, $val) = @_;
|
||||
my $attribute = "$ns->{prefix}:$attr";
|
||||
if (LIBXML) {
|
||||
$link->elem->setAttributeNS($ns->{uri}, $attribute, $val);
|
||||
} else {
|
||||
my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
|
||||
$link->elem->appendNamespace($ns);
|
||||
$link->elem->setAttribute($attribute => $val);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub as_xml {
|
||||
my $link = shift;
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
|
||||
$doc->setDocumentElement($link->elem);
|
||||
return $doc->toString(1);
|
||||
} else {
|
||||
return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
|
||||
$link->elem->toString;
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
use vars qw( $AUTOLOAD );
|
||||
sub AUTOLOAD {
|
||||
(my $var = $AUTOLOAD) =~ s!.+::!!;
|
||||
no strict 'refs';
|
||||
*$AUTOLOAD = sub {
|
||||
@_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
1;
|
||||
120
livejournal/cgi-bin/XML/Atom/Person.pm
Executable file
120
livejournal/cgi-bin/XML/Atom/Person.pm
Executable file
@@ -0,0 +1,120 @@
|
||||
# $Id: Person.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Person;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
use XML::Atom::Util qw( first );
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $person = bless {}, $class;
|
||||
$person->init(@_) or return $class->error($person->errstr);
|
||||
$person;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $person = shift;
|
||||
my %param = @_;
|
||||
my $elem;
|
||||
unless ($elem = $param{Elem}) {
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->createDocument('1.0', 'utf-8');
|
||||
$elem = $doc->createElementNS(NS, 'author'); ## xxx
|
||||
$doc->setDocumentElement($elem);
|
||||
} else {
|
||||
$elem = XML::XPath::Node::Element->new('author'); ## xxx
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$elem->appendNamespace($ns);
|
||||
}
|
||||
}
|
||||
$person->{elem} = $elem;
|
||||
$person;
|
||||
}
|
||||
|
||||
sub elem { $_[0]->{elem} }
|
||||
|
||||
sub get {
|
||||
my $person = shift;
|
||||
my($name) = @_;
|
||||
my $node = first($person->elem, NS, $name) or return;
|
||||
my $val = LIBXML ? $node->textContent : $node->string_value;
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($val);
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub set {
|
||||
my $person = shift;
|
||||
my($name, $val) = @_;
|
||||
my $elem;
|
||||
unless ($elem = first($person->elem, NS, $name)) {
|
||||
if (LIBXML) {
|
||||
$elem = XML::LibXML::Element->new($name);
|
||||
$elem->setNamespace(NS);
|
||||
} else {
|
||||
$elem = XML::XPath::Node::Element->new($name);
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$elem->appendNamespace($ns);
|
||||
}
|
||||
$person->elem->appendChild($elem);
|
||||
}
|
||||
if (LIBXML) {
|
||||
$elem->removeChildNodes;
|
||||
$elem->appendChild(XML::LibXML::Text->new($val));
|
||||
} else {
|
||||
$elem->removeChild($_) for $elem->getChildNodes;
|
||||
$elem->appendChild(XML::XPath::Node::Text->new($val));
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub as_xml {
|
||||
my $person = shift;
|
||||
if (LIBXML) {
|
||||
my $doc = XML::LibXML::Document->new('1.0', 'utf-8');
|
||||
$doc->setDocumentElement($person->elem);
|
||||
return $doc->toString(1);
|
||||
} else {
|
||||
return '<?xml version="1.0" encoding="utf-8"?>' . "\n" .
|
||||
$person->elem->toString;
|
||||
}
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
use vars qw( $AUTOLOAD );
|
||||
sub AUTOLOAD {
|
||||
(my $var = $AUTOLOAD) =~ s!.+::!!;
|
||||
no strict 'refs';
|
||||
*$AUTOLOAD = sub {
|
||||
@_ > 1 ? $_[0]->set($var, @_[1..$#_]) : $_[0]->get($var)
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Person - Author or contributor object
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $author = XML::Atom::Person->new;
|
||||
$author->email('foo@example.com');
|
||||
$author->name('Foo Bar');
|
||||
$entry->author($author);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<XML::Atom::Person> represents an author or contributor element in an
|
||||
Atom feed or entry.
|
||||
|
||||
=cut
|
||||
538
livejournal/cgi-bin/XML/Atom/Server.pm
Executable file
538
livejournal/cgi-bin/XML/Atom/Server.pm
Executable file
@@ -0,0 +1,538 @@
|
||||
# $Id: Server.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Server;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
use MIME::Base64 qw( encode_base64 decode_base64 );
|
||||
use Digest::SHA1 qw( sha1 );
|
||||
use XML::Atom::Util qw( first encode_xml textValue );
|
||||
use XML::Atom::Entry;
|
||||
|
||||
use constant NS_SOAP => 'http://schemas.xmlsoap.org/soap/envelope/';
|
||||
use constant NS_WSSE => 'http://schemas.xmlsoap.org/ws/2002/07/secext';
|
||||
use constant NS_WSU => 'http://schemas.xmlsoap.org/ws/2002/07/utility';
|
||||
|
||||
sub handler ($$) {
|
||||
my $class = shift;
|
||||
my($r) = @_;
|
||||
require Apache::Constants;
|
||||
if (lc($r->dir_config('Filter') || '') eq 'on') {
|
||||
$r = $r->filter_register;
|
||||
}
|
||||
my $server = $class->new or die $class->errstr;
|
||||
$server->{apache} = $r;
|
||||
$server->run;
|
||||
return Apache::Constants::OK();
|
||||
}
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $server = bless { }, $class;
|
||||
$server->init(@_) or return $class->error($server->errstr);
|
||||
$server;
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $server = shift;
|
||||
$server->{param} = {};
|
||||
unless ($ENV{MOD_PERL}) {
|
||||
require CGI;
|
||||
$server->{cgi} = CGI->new();
|
||||
}
|
||||
$server;
|
||||
}
|
||||
|
||||
sub run {
|
||||
my $server = shift;
|
||||
(my $pi = $server->path_info) =~ s!^/!!;
|
||||
my @args = split /\//, $pi;
|
||||
for my $arg (@args) {
|
||||
my($k, $v) = split /=/, $arg, 2;
|
||||
$server->request_param($k, $v);
|
||||
}
|
||||
if (my $action = $server->request_header('SOAPAction')) {
|
||||
$server->{is_soap} = 1;
|
||||
$action =~ s/"//g;
|
||||
my($method) = $action =~ m!/([^/]+)$!;
|
||||
$server->request_method($method);
|
||||
}
|
||||
my $out;
|
||||
eval {
|
||||
defined($out = $server->handle_request) or die $server->errstr;
|
||||
if (defined $out && $server->{is_soap}) {
|
||||
$out =~ s!^(<\?xml.*?\?>)!!;
|
||||
$out = <<SOAP;
|
||||
$1
|
||||
<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
|
||||
<soap:Body>$out</soap:Body>
|
||||
</soap:Envelope>
|
||||
SOAP
|
||||
}
|
||||
};
|
||||
if ($@) {
|
||||
$out = $server->show_error($@);
|
||||
}
|
||||
$server->send_http_header;
|
||||
$server->print($out);
|
||||
1;
|
||||
}
|
||||
|
||||
sub handle_request;
|
||||
sub password_for_user;
|
||||
|
||||
sub uri {
|
||||
my $server = shift;
|
||||
$ENV{MOD_PERL} ? $server->{apache}->uri : $server->{cgi}->url;
|
||||
}
|
||||
|
||||
sub path_info {
|
||||
my $server = shift;
|
||||
return $server->{__path_info} if exists $server->{__path_info};
|
||||
my $path_info;
|
||||
if ($ENV{MOD_PERL}) {
|
||||
## mod_perl often leaves part of the script name (Location)
|
||||
## in the path info, for some reason. This should remove it.
|
||||
$path_info = $server->{apache}->path_info;
|
||||
if ($path_info) {
|
||||
my($script_last) = $server->{apache}->location =~ m!/([^/]+)$!;
|
||||
$path_info =~ s!^/$script_last!!;
|
||||
}
|
||||
} else {
|
||||
$path_info = $server->{cgi}->path_info;
|
||||
}
|
||||
$server->{__path_info} = $path_info;
|
||||
}
|
||||
|
||||
sub request_header {
|
||||
my $server = shift;
|
||||
my($key) = @_;
|
||||
if ($ENV{MOD_PERL}) {
|
||||
return $server->{apache}->header_in($key);
|
||||
} else {
|
||||
($key = uc($key)) =~ tr/-/_/;
|
||||
return $ENV{'HTTP_' . $key};
|
||||
}
|
||||
}
|
||||
|
||||
sub request_method {
|
||||
my $server = shift;
|
||||
if (@_) {
|
||||
$server->{request_method} = shift;
|
||||
} elsif (!exists $server->{request_method}) {
|
||||
$server->{request_method} =
|
||||
$ENV{MOD_PERL} ? $server->{apache}->method : $ENV{REQUEST_METHOD};
|
||||
}
|
||||
$server->{request_method};
|
||||
}
|
||||
|
||||
sub request_content {
|
||||
my $server = shift;
|
||||
unless (exists $server->{request_content}) {
|
||||
if ($ENV{MOD_PERL}) {
|
||||
## Read from $server->{apache}
|
||||
my $r = $server->{apache};
|
||||
my $len = $server->request_header('Content-length');
|
||||
$r->read($server->{request_content}, $len);
|
||||
} else {
|
||||
## Read from STDIN
|
||||
my $len = $ENV{CONTENT_LENGTH} || 0;
|
||||
read STDIN, $server->{request_content}, $len;
|
||||
}
|
||||
}
|
||||
$server->{request_content};
|
||||
}
|
||||
|
||||
sub request_param {
|
||||
my $server = shift;
|
||||
my $k = shift;
|
||||
$server->{param}{$k} = shift if @_;
|
||||
$server->{param}{$k};
|
||||
}
|
||||
|
||||
sub response_header {
|
||||
my $server = shift;
|
||||
my($key, $val) = @_;
|
||||
if ($ENV{MOD_PERL}) {
|
||||
$server->{apache}->header_out($key, $val);
|
||||
} else {
|
||||
unless ($key =~ /^-/) {
|
||||
($key = lc($key)) =~ tr/-/_/;
|
||||
$key = '-' . $key;
|
||||
}
|
||||
$server->{cgi_headers}{$key} = $val;
|
||||
}
|
||||
}
|
||||
|
||||
sub response_code {
|
||||
my $server = shift;
|
||||
$server->{response_code} = shift if @_;
|
||||
$server->{response_code};
|
||||
}
|
||||
|
||||
sub response_content_type {
|
||||
my $server = shift;
|
||||
$server->{response_content_type} = shift if @_;
|
||||
$server->{response_content_type};
|
||||
}
|
||||
|
||||
sub send_http_header {
|
||||
my $server = shift;
|
||||
my $type = $server->response_content_type || 'application/x.atom+xml';
|
||||
if ($ENV{MOD_PERL}) {
|
||||
$server->{apache}->status($server->response_code || 200);
|
||||
$server->{apache}->send_http_header($type);
|
||||
} else {
|
||||
$server->{cgi_headers}{-status} = $server->response_code || 200;
|
||||
$server->{cgi_headers}{-type} = $type;
|
||||
print $server->{cgi}->header(%{ $server->{cgi_headers} });
|
||||
}
|
||||
}
|
||||
|
||||
sub print {
|
||||
my $server = shift;
|
||||
if ($ENV{MOD_PERL}) {
|
||||
$server->{apache}->print(@_);
|
||||
} else {
|
||||
CORE::print(@_);
|
||||
}
|
||||
}
|
||||
|
||||
sub error {
|
||||
my $server = shift;
|
||||
my($code, $msg) = @_;
|
||||
$server->response_code($code) if ref($server);
|
||||
return $server->SUPER::error($msg);
|
||||
}
|
||||
|
||||
sub show_error {
|
||||
my $server = shift;
|
||||
my($err) = @_;
|
||||
chomp($err = encode_xml($err));
|
||||
if ($server->{is_soap}) {
|
||||
my $code = $server->response_code;
|
||||
if ($code >= 400) {
|
||||
$server->response_code(500);
|
||||
}
|
||||
return <<FAULT;
|
||||
<soap:Envelope xmlns:soap="http://schemas.xmlsoap.org/soap/envelope/">
|
||||
<soap:Body>
|
||||
<soap:Fault>
|
||||
<faultcode>$code</faultcode>
|
||||
<faultstring>$err</faultstring>
|
||||
</soap:Fault>
|
||||
</soap:Body>
|
||||
</soap:Envelope>
|
||||
FAULT
|
||||
} else {
|
||||
return <<ERR;
|
||||
<?xml version="1.0" encoding="utf-8"?>
|
||||
<error>$err</error>
|
||||
ERR
|
||||
}
|
||||
}
|
||||
|
||||
sub get_auth_info {
|
||||
my $server = shift;
|
||||
my %param;
|
||||
if ($server->{is_soap}) {
|
||||
my $xml = $server->xml_body;
|
||||
my $auth = first($xml, NS_WSSE, 'UsernameToken');
|
||||
$param{Username} = textValue($auth, NS_WSSE, 'Username');
|
||||
$param{PasswordDigest} = textValue($auth, NS_WSSE, 'Password');
|
||||
$param{Nonce} = textValue($auth, NS_WSSE, 'Nonce');
|
||||
$param{Created} = textValue($auth, NS_WSSE, 'Created');
|
||||
} else {
|
||||
my $req = $server->request_header('X-WSSE')
|
||||
or return $server->auth_failure(401, 'X-WSSE authentication required');
|
||||
$req =~ s/^(?:WSSE|UsernameToken) //;
|
||||
for my $i (split /,\s*/, $req) {
|
||||
my($k, $v) = split /=/, $i, 2;
|
||||
$v =~ s/^"//;
|
||||
$v =~ s/"$//;
|
||||
$param{$k} = $v;
|
||||
}
|
||||
}
|
||||
\%param;
|
||||
}
|
||||
|
||||
sub authenticate {
|
||||
my $server = shift;
|
||||
my $auth = $server->get_auth_info or return;
|
||||
for my $f (qw( Username PasswordDigest Nonce Created )) {
|
||||
return $server->auth_failure(400, "X-WSSE requires $f")
|
||||
unless $auth->{$f};
|
||||
}
|
||||
my $password = $server->password_for_user($auth->{Username});
|
||||
defined($password) or return $server->auth_failure(403, 'Invalid login');
|
||||
my $expected = encode_base64(sha1(
|
||||
decode_base64($auth->{Nonce}) . $auth->{Created} . $password
|
||||
), '');
|
||||
return $server->auth_failure(403, 'Invalid login')
|
||||
unless $expected eq $auth->{PasswordDigest};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_failure {
|
||||
my $server = shift;
|
||||
$server->response_header('WWW-Authenticate', 'WSSE profile="UsernameToken"');
|
||||
return $server->error(@_);
|
||||
}
|
||||
|
||||
sub xml_body {
|
||||
my $server = shift;
|
||||
unless (exists $server->{xml_body}) {
|
||||
if (LIBXML) {
|
||||
my $parser = XML::LibXML->new;
|
||||
$server->{xml_body} =
|
||||
$parser->parse_string($server->request_content);
|
||||
} else {
|
||||
$server->{xml_body} =
|
||||
XML::XPath->new(xml => $server->request_content);
|
||||
}
|
||||
}
|
||||
$server->{xml_body};
|
||||
}
|
||||
|
||||
sub atom_body {
|
||||
my $server = shift;
|
||||
my $atom;
|
||||
if ($server->{is_soap}) {
|
||||
my $xml = $server->xml_body;
|
||||
$atom = XML::Atom::Entry->new(Doc => first($xml, NS_SOAP, 'Body'))
|
||||
or return $server->error(500, XML::Atom::Entry->errstr);
|
||||
} else {
|
||||
$atom = XML::Atom::Entry->new(Stream => \$server->request_content)
|
||||
or return $server->error(500, XML::Atom::Entry->errstr);
|
||||
}
|
||||
$atom;
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Server - A server for the Atom API
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package My::Server;
|
||||
use base qw( XML::Atom::Server );
|
||||
sub handle_request {
|
||||
my $server = shift;
|
||||
$server->authenticate or return;
|
||||
my $method = $app->request_method;
|
||||
if ($method eq 'POST') {
|
||||
return $server->new_post;
|
||||
}
|
||||
...
|
||||
}
|
||||
|
||||
my %Passwords;
|
||||
sub password_for_user {
|
||||
my $server = shift;
|
||||
my($username) = @_;
|
||||
$Passwords{$username};
|
||||
}
|
||||
|
||||
sub new_post {
|
||||
my $server = shift;
|
||||
my $entry = $server->atom_body or return;
|
||||
## $entry is an XML::Atom::Entry object.
|
||||
## ... Save the new entry ...
|
||||
}
|
||||
|
||||
package main;
|
||||
my $server = My::Server->new;
|
||||
$server->run;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
I<XML::Atom::Server> provides a base class for Atom API servers. It handles
|
||||
all core server processing, both the SOAP and REST formats of the protocol,
|
||||
and WSSE authentication. It can also run as either a mod_perl handler or as
|
||||
part of a CGI program.
|
||||
|
||||
It does not provide functions specific to any particular implementation,
|
||||
such as posting an entry, retrieving a list of entries, deleting an entry, etc.
|
||||
Implementations should subclass I<XML::Atom::Server>, overriding the
|
||||
I<handle_request> method, and handle all functions such as this themselves.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
=head2 Request Handling
|
||||
|
||||
Subclasses of I<XML::Atom::Server> must override the I<handle_request>
|
||||
method to perform all request processing. The implementation must set all
|
||||
response headers, including the response code and any relevant HTTP headers,
|
||||
and should return a scalar representing the response body to be sent back
|
||||
to the client.
|
||||
|
||||
For example:
|
||||
|
||||
sub handle_request {
|
||||
my $server = shift;
|
||||
my $method = $server->request_method;
|
||||
if ($method eq 'POST') {
|
||||
return $server->new_post;
|
||||
}
|
||||
## ... handle GET, PUT, etc
|
||||
}
|
||||
|
||||
sub new_post {
|
||||
my $server = shift;
|
||||
my $entry = $server->atom_body or return;
|
||||
my $id = save_this_entry($entry); ## Implementation-specific
|
||||
$server->response_header(Location => $app->uri . '/entry_id=' . $id);
|
||||
$server->response_code(201);
|
||||
$server->response_content_type('application/x.atom+xml');
|
||||
return serialize_entry($entry); ## Implementation-specific
|
||||
}
|
||||
|
||||
=head2 Authentication
|
||||
|
||||
Servers that require authentication for posting or retrieving entries or
|
||||
feeds should override the I<password_for_user> method. Given a username
|
||||
(from the WSSE header), I<password_for_user> should return that user's
|
||||
password in plaintext. This will then be combined with the nonce and the
|
||||
creation time to generate the digest, which will be compared with the
|
||||
digest sent in the WSSE header. If the supplied username doesn't exist in
|
||||
your user database or alike, just return C<undef>.
|
||||
|
||||
For example:
|
||||
|
||||
my %Passwords = ( foo => 'bar' ); ## The password for "foo" is "bar".
|
||||
sub password_for_user {
|
||||
my $server = shift;
|
||||
my($username) = @_;
|
||||
$Passwords{$username};
|
||||
}
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
I<XML::Atom::Server> provides a variety of methods to be used by subclasses
|
||||
for retrieving headers, content, and other request information, and for
|
||||
setting the same on the response.
|
||||
|
||||
=head2 Client Request Parameters
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $server->uri
|
||||
|
||||
Returns the URI of the Atom server implementation.
|
||||
|
||||
=item * $server->request_method
|
||||
|
||||
Returns the name of the request method sent to the server from the client
|
||||
(for example, C<GET>, C<POST>, etc). Note that if the client sent the
|
||||
request in a SOAP envelope, the method is obtained from the I<SOAPAction>
|
||||
HTTP header.
|
||||
|
||||
=item * $server->request_header($header)
|
||||
|
||||
Retrieves the value of the HTTP request header I<$header>.
|
||||
|
||||
=item * $server->request_content
|
||||
|
||||
Returns a scalar containing the contents of a POST or PUT request from the
|
||||
client.
|
||||
|
||||
=item * $server->request_param($param)
|
||||
|
||||
I<XML::Atom::Server> automatically parses the PATH_INFO sent in the request
|
||||
and breaks it up into key-value pairs. This can be used to pass parameters.
|
||||
For example, in the URI
|
||||
|
||||
http://localhost/atom-server/entry_id=1
|
||||
|
||||
the I<entry_id> parameter would be set to C<1>.
|
||||
|
||||
I<request_param> returns the value of the value of the parameter I<$param>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Setting up the Response
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $server->response_header($header, $value)
|
||||
|
||||
Sets the value of the HTTP response header I<$header> to I<$value>.
|
||||
|
||||
=item * $server->response_code([ $code ])
|
||||
|
||||
Returns the current response code to be sent back to the client, and if
|
||||
I<$code> is given, sets the response code.
|
||||
|
||||
=item * $server->response_content_type([ $type ])
|
||||
|
||||
Returns the current I<Content-Type> header to be sent back to the client, and
|
||||
I<$type> is given, sets the value for that header.
|
||||
|
||||
=back
|
||||
|
||||
=head2 Processing the Request
|
||||
|
||||
=over 4
|
||||
|
||||
=item * $server->authenticate
|
||||
|
||||
Attempts to authenticate the request based on the authentication
|
||||
information present in the request (currently just WSSE). This will call
|
||||
the I<password_for_user> method in the subclass to obtain the cleartext
|
||||
password for the username given in the request.
|
||||
|
||||
=item * $server->atom_body
|
||||
|
||||
Returns an I<XML::Atom::Entry> object containing the entry sent in the
|
||||
request.
|
||||
|
||||
=back
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
Once you have defined your server subclass, you can set it up either as a
|
||||
CGI program or as a mod_perl handler.
|
||||
|
||||
A simple CGI program would look something like this:
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
use strict;
|
||||
|
||||
use My::Server;
|
||||
my $server = My::Server->new;
|
||||
$server->run;
|
||||
|
||||
A simple mod_perl handler configuration would look something like this:
|
||||
|
||||
PerlModule My::Server
|
||||
<Location /atom-server>
|
||||
SetHandler perl-script
|
||||
PerlHandler My::Server
|
||||
</Location>
|
||||
|
||||
=head1 ERROR HANDLING
|
||||
|
||||
If you wish to return an error from I<handle_request>, you can use the
|
||||
built-in I<error> method:
|
||||
|
||||
sub handle_request {
|
||||
my $server = shift;
|
||||
...
|
||||
return $server->error(500, "Something went wrong");
|
||||
}
|
||||
|
||||
This will be returned to the client with a response code of 500 and an
|
||||
error string of C<Something went wrong>. Errors are automatically
|
||||
serialized into SOAP faults if the incoming request is enclosed in a SOAP
|
||||
envelope.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Please see the I<XML::Atom> manpage for author, copyright, and license
|
||||
information.
|
||||
|
||||
=cut
|
||||
322
livejournal/cgi-bin/XML/Atom/Thing.pm
Executable file
322
livejournal/cgi-bin/XML/Atom/Thing.pm
Executable file
@@ -0,0 +1,322 @@
|
||||
# $Id: Thing.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Thing;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use base qw( XML::Atom::ErrorHandler );
|
||||
use XML::Atom::Util qw( first nodelist remove_default_ns );
|
||||
use XML::Atom::Link;
|
||||
use LWP::UserAgent;
|
||||
BEGIN {
|
||||
if (LIBXML) {
|
||||
*init = \&init_libxml;
|
||||
*set = \&set_libxml;
|
||||
*link = \&link_libxml;
|
||||
} else {
|
||||
*init = \&init_xpath;
|
||||
*set = \&set_xpath;
|
||||
*link = \&link_xpath;
|
||||
}
|
||||
}
|
||||
|
||||
use constant NS => 'http://purl.org/atom/ns#';
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
my $atom = bless {}, $class;
|
||||
$atom->init(@_) or return $class->error($atom->errstr);
|
||||
$atom;
|
||||
}
|
||||
|
||||
sub init_libxml {
|
||||
my $atom = shift;
|
||||
my %param = @_ == 1 ? (Stream => $_[0]) : @_;
|
||||
if (%param) {
|
||||
if (my $stream = $param{Stream}) {
|
||||
my $parser = XML::LibXML->new;
|
||||
if (ref($stream) eq 'SCALAR') {
|
||||
$atom->{doc} = $parser->parse_string($$stream);
|
||||
} elsif (ref($stream)) {
|
||||
$atom->{doc} = $parser->parse_fh($stream);
|
||||
} else {
|
||||
$atom->{doc} = $parser->parse_file($stream);
|
||||
}
|
||||
} elsif (my $doc = $param{Doc}) {
|
||||
$atom->{doc} = $doc;
|
||||
} elsif (my $elem = $param{Elem}) {
|
||||
$atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
|
||||
$atom->{doc}->setDocumentElement($elem);
|
||||
}
|
||||
} else {
|
||||
my $doc = $atom->{doc} = XML::LibXML::Document->createDocument('1.0', 'utf-8');
|
||||
my $root = $doc->createElementNS(NS, $atom->element_name);
|
||||
$doc->setDocumentElement($root);
|
||||
}
|
||||
$atom;
|
||||
}
|
||||
|
||||
sub init_xpath {
|
||||
my $atom = shift;
|
||||
my %param = @_ == 1 ? (Stream => $_[0]) : @_;
|
||||
my $elem_name = $atom->element_name;
|
||||
if (%param) {
|
||||
if (my $stream = $param{Stream}) {
|
||||
my $xp;
|
||||
if (ref($stream) eq 'SCALAR') {
|
||||
$xp = XML::XPath->new(xml => $$stream);
|
||||
} elsif (ref($stream)) {
|
||||
$xp = XML::XPath->new(ioref => $stream);
|
||||
} else {
|
||||
$xp = XML::XPath->new(filename => $stream);
|
||||
}
|
||||
my $set = $xp->find('/' . $elem_name);
|
||||
unless ($set && $set->size) {
|
||||
$set = $xp->find('/');
|
||||
}
|
||||
$atom->{doc} = ($set->get_nodelist)[0];
|
||||
} elsif (my $doc = $param{Doc}) {
|
||||
$atom->{doc} = $doc;
|
||||
} elsif (my $elem = $param{Elem}) {
|
||||
my $xp = XML::XPath->new(context => $elem);
|
||||
my $set = $xp->find('/' . $elem_name);
|
||||
unless ($set && $set->size) {
|
||||
$set = $xp->find('/');
|
||||
}
|
||||
$atom->{doc} = ($set->get_nodelist)[0];
|
||||
}
|
||||
} else {
|
||||
my $xp = XML::XPath->new;
|
||||
$xp->set_namespace(atom => NS);
|
||||
$atom->{doc} = XML::XPath::Node::Element->new($atom->element_name);
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$atom->{doc}->appendNamespace($ns);
|
||||
}
|
||||
$atom;
|
||||
}
|
||||
|
||||
sub get {
|
||||
my $atom = shift;
|
||||
my($ns, $name) = @_;
|
||||
my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
|
||||
my $node = first($atom->{doc}, $ns_uri, $name);
|
||||
return unless $node;
|
||||
my $val = LIBXML ? $node->textContent : $node->string_value;
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($val);
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub getlist {
|
||||
my $atom = shift;
|
||||
my($ns, $name) = @_;
|
||||
my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
|
||||
my @node = nodelist($atom->{doc}, $ns_uri, $name);
|
||||
map {
|
||||
my $val = LIBXML ? $_->textContent : $_->string_value;
|
||||
if ($] >= 5.008) {
|
||||
require Encode;
|
||||
Encode::_utf8_off($val);
|
||||
}
|
||||
$val;
|
||||
} @node;
|
||||
}
|
||||
|
||||
sub set_libxml {
|
||||
my $atom = shift;
|
||||
my($ns, $name, $val, $attr) = @_;
|
||||
my $elem;
|
||||
my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
|
||||
unless ($elem = first($atom->{doc}, $ns_uri, $name)) {
|
||||
$elem = $atom->{doc}->createElementNS($ns_uri, $name);
|
||||
$atom->{doc}->getDocumentElement->appendChild($elem);
|
||||
}
|
||||
if ($ns ne NS) {
|
||||
$atom->{doc}->getDocumentElement->setNamespace($ns->{uri}, $ns->{prefix}, 0);
|
||||
}
|
||||
if (ref($val) =~ /Element$/) {
|
||||
$elem->appendChild($val);
|
||||
} elsif (defined $val) {
|
||||
$elem->removeChildNodes;
|
||||
my $text = XML::LibXML::Text->new($val);
|
||||
$elem->appendChild($text);
|
||||
}
|
||||
if ($attr) {
|
||||
while (my($k, $v) = each %$attr) {
|
||||
$elem->setAttribute($k, $v);
|
||||
}
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub set_xpath {
|
||||
my $atom = shift;
|
||||
my($ns, $name, $val, $attr) = @_;
|
||||
my $elem;
|
||||
my $ns_uri = ref($ns) eq 'XML::Atom::Namespace' ? $ns->{uri} : $ns;
|
||||
unless ($elem = first($atom->{doc}, $ns_uri, $name)) {
|
||||
$elem = XML::XPath::Node::Element->new($name);
|
||||
if ($ns ne NS) {
|
||||
my $ns = XML::XPath::Node::Namespace->new($ns->{prefix} => $ns->{uri});
|
||||
$elem->appendNamespace($ns);
|
||||
}
|
||||
$atom->{doc}->appendChild($elem);
|
||||
}
|
||||
if (ref($val) =~ /Element$/) {
|
||||
$elem->appendChild($val);
|
||||
} elsif (defined $val) {
|
||||
$elem->removeChild($_) for $elem->getChildNodes;
|
||||
my $text = XML::XPath::Node::Text->new($val);
|
||||
$elem->appendChild($text);
|
||||
}
|
||||
if ($attr) {
|
||||
while (my($k, $v) = each %$attr) {
|
||||
$elem->setAttribute($k, $v);
|
||||
}
|
||||
}
|
||||
$val;
|
||||
}
|
||||
|
||||
sub add_link {
|
||||
my $thing = shift;
|
||||
my($link) = @_;
|
||||
my $elem;
|
||||
if (ref($link) eq 'XML::Atom::Link') {
|
||||
if (LIBXML) {
|
||||
$thing->{doc}->getDocumentElement->appendChild($link->elem);
|
||||
} else {
|
||||
$thing->{doc}->appendChild($link->elem);
|
||||
}
|
||||
} else {
|
||||
if (LIBXML) {
|
||||
$elem = $thing->{doc}->createElementNS(NS, 'link');
|
||||
$thing->{doc}->getDocumentElement->appendChild($elem);
|
||||
} else {
|
||||
$elem = XML::XPath::Node::Element->new('link');
|
||||
my $ns = XML::XPath::Node::Namespace->new('#default' => NS);
|
||||
$elem->appendNamespace($ns);
|
||||
$thing->{doc}->appendChild($elem);
|
||||
}
|
||||
}
|
||||
if (ref($link) eq 'HASH') {
|
||||
for my $k (qw( type rel href title )) {
|
||||
my $v = $link->{$k} or next;
|
||||
$elem->setAttribute($k, $v);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub link_libxml {
|
||||
my $thing = shift;
|
||||
if (wantarray) {
|
||||
my @res = $thing->{doc}->getDocumentElement->getChildrenByTagNameNS(NS, 'link');
|
||||
my @links;
|
||||
for my $elem (@res) {
|
||||
push @links, XML::Atom::Link->new(Elem => $elem);
|
||||
}
|
||||
return @links;
|
||||
} else {
|
||||
my $elem = first($thing->{doc}, NS, 'link') or return;
|
||||
return XML::Atom::Link->new(Elem => $elem);
|
||||
}
|
||||
}
|
||||
|
||||
sub link_xpath {
|
||||
my $thing = shift;
|
||||
if (wantarray) {
|
||||
my $set = $thing->{doc}->find("*[local-name()='link' and namespace-uri()='" . NS . "']");
|
||||
my @links;
|
||||
for my $elem ($set->get_nodelist) {
|
||||
push @links, XML::Atom::Link->new(Elem => $elem);
|
||||
}
|
||||
return @links;
|
||||
} else {
|
||||
my $elem = first($thing->{doc}, NS, 'link') or return;
|
||||
return XML::Atom::Link->new(Elem => $elem);
|
||||
}
|
||||
}
|
||||
|
||||
sub author {
|
||||
my $thing = shift;
|
||||
$thing->_element('XML::Atom::Person', 'author', @_);
|
||||
}
|
||||
|
||||
sub as_xml {
|
||||
my $doc = $_[0]->{doc};
|
||||
if (eval { require XML::LibXSLT }) {
|
||||
my $parser = XML::LibXML->new;
|
||||
my $xslt = XML::LibXSLT->new;
|
||||
my $style_doc = $parser->parse_string(<<'EOX');
|
||||
<?xml version="1.0"?>
|
||||
<xsl:stylesheet version="1.0" xmlns:xsl="http://www.w3.org/1999/XSL/Transform">
|
||||
<xsl:template match="@*|node()">
|
||||
<xsl:copy>
|
||||
<xsl:apply-templates select="@*|node()"/>
|
||||
</xsl:copy>
|
||||
</xsl:template>
|
||||
</xsl:stylesheet>
|
||||
EOX
|
||||
my $sheet = $xslt->parse_stylesheet($style_doc);
|
||||
my $results = $sheet->transform($doc);
|
||||
return $sheet->output_string($results);
|
||||
} else {
|
||||
remove_default_ns($doc->getDocumentElement);
|
||||
return $doc->toString(LIBXML ? 1 : 0);
|
||||
}
|
||||
}
|
||||
|
||||
sub _element {
|
||||
my $thing = shift;
|
||||
my($class, $name) = (shift, shift);
|
||||
my $root = LIBXML ? $thing->{doc}->getDocumentElement : $thing->{doc};
|
||||
if (@_) {
|
||||
my $obj = shift;
|
||||
if (my $node = first($thing->{doc}, NS, $name)) {
|
||||
$root->removeChild($node);
|
||||
}
|
||||
my $elem = LIBXML ?
|
||||
$thing->{doc}->createElementNS(NS, $name) :
|
||||
XML::XPath::Node::Element->new($name);
|
||||
$root->appendChild($elem);
|
||||
if (LIBXML) {
|
||||
for my $child ($obj->elem->childNodes) {
|
||||
$elem->appendChild($child->cloneNode(1));
|
||||
}
|
||||
for my $attr ($obj->elem->attributes) {
|
||||
next unless ref($attr) eq 'XML::LibXML::Attr';
|
||||
$elem->setAttribute($attr->getName, $attr->getValue);
|
||||
}
|
||||
} else {
|
||||
for my $child ($obj->elem->getChildNodes) {
|
||||
$elem->appendChild($child);
|
||||
}
|
||||
for my $attr ($obj->elem->getAttributes) {
|
||||
$elem->appendAttribute($attr);
|
||||
}
|
||||
}
|
||||
$obj->{elem} = $elem;
|
||||
$thing->{'__' . $name} = $obj;
|
||||
} else {
|
||||
unless (exists $thing->{'__' . $name}) {
|
||||
my $elem = first($thing->{doc}, NS, $name) or return;
|
||||
$thing->{'__' . $name} = $class->new(Elem => $elem);
|
||||
}
|
||||
}
|
||||
$thing->{'__' . $name};
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
use vars qw( $AUTOLOAD );
|
||||
sub AUTOLOAD {
|
||||
(my $var = $AUTOLOAD) =~ s!.+::!!;
|
||||
no strict 'refs';
|
||||
*$AUTOLOAD = sub {
|
||||
@_ > 1 ? $_[0]->set(NS, $var, @_[1..$#_]) : $_[0]->get(NS, $var)
|
||||
};
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
1;
|
||||
106
livejournal/cgi-bin/XML/Atom/Util.pm
Executable file
106
livejournal/cgi-bin/XML/Atom/Util.pm
Executable file
@@ -0,0 +1,106 @@
|
||||
# $Id: Util.pm,v 1.1 2005/04/15 17:37:32 bradfitz Exp $
|
||||
|
||||
package XML::Atom::Util;
|
||||
use strict;
|
||||
|
||||
use XML::Atom;
|
||||
use vars qw( @EXPORT_OK @ISA );
|
||||
use Exporter;
|
||||
@EXPORT_OK = qw( first nodelist textValue iso2dt encode_xml remove_default_ns );
|
||||
@ISA = qw( Exporter );
|
||||
|
||||
sub first {
|
||||
my @nodes = nodelist(@_);
|
||||
return unless @nodes;
|
||||
return $nodes[0];
|
||||
}
|
||||
|
||||
sub nodelist {
|
||||
if (LIBXML) {
|
||||
return $_[1] ? $_[0]->getElementsByTagNameNS($_[1], $_[2]) :
|
||||
$_[0]->getElementsByTagName($_[2]);
|
||||
} else {
|
||||
my $set = $_[1] ?
|
||||
$_[0]->find("descendant::*[local-name()='$_[2]' and namespace-uri()='$_[1]']") :
|
||||
$_[0]->find("descendant::$_[2]");
|
||||
return unless $set && $set->isa('XML::XPath::NodeSet');
|
||||
return $set->get_nodelist;
|
||||
}
|
||||
}
|
||||
|
||||
sub textValue {
|
||||
my $node = first(@_) or return;
|
||||
LIBXML ? $node->textContent : $node->string_value;
|
||||
}
|
||||
|
||||
sub iso2dt {
|
||||
my($iso) = @_;
|
||||
return unless $iso =~ /^(\d{4})(?:-?(\d{2})(?:-?(\d\d?)(?:T(\d{2}):(\d{2}):(\d{2})(?:\.\d+)?(?:Z|([+-]\d{2}:\d{2}))?)?)?)?/;
|
||||
my($y, $mo, $d, $h, $m, $s, $zone) =
|
||||
($1, $2 || 1, $3 || 1, $4 || 0, $5 || 0, $6 || 0, $7);
|
||||
require DateTime;
|
||||
my $dt = DateTime->new(
|
||||
year => $y,
|
||||
month => $mo,
|
||||
day => $d,
|
||||
hour => $h,
|
||||
minute => $m,
|
||||
second => $s,
|
||||
time_zone => 'UTC',
|
||||
);
|
||||
if ($zone && $zone ne 'Z') {
|
||||
my $seconds = DateTime::TimeZone::offset_as_seconds($zone);
|
||||
$dt->subtract(seconds => $seconds);
|
||||
}
|
||||
$dt;
|
||||
}
|
||||
|
||||
my %Map = ('&' => '&', '"' => '"', '<' => '<', '>' => '>',
|
||||
'\'' => ''');
|
||||
my $RE = join '|', keys %Map;
|
||||
|
||||
sub encode_xml {
|
||||
my($str) = @_;
|
||||
$str =~ s!($RE)!$Map{$1}!g;
|
||||
$str;
|
||||
}
|
||||
|
||||
sub remove_default_ns {
|
||||
my($node) = @_;
|
||||
$node->setNamespace('http://www.w3.org/1999/xhtml', '')
|
||||
if $node->nodeName =~ /^default:/ && ref($node) =~ /Element$/;
|
||||
for my $n ($node->childNodes) {
|
||||
remove_default_ns($n);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
XML::Atom::Util - Utility functions
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use XML::Atom::Util qw( iso2dt );
|
||||
my $dt = iso2dt($entry->issued);
|
||||
|
||||
=head1 USAGE
|
||||
|
||||
=head2 iso2dt($iso)
|
||||
|
||||
Transforms the ISO-8601 date I<$iso> into a I<DateTime> object and returns
|
||||
the I<DateTime> object.
|
||||
|
||||
=head2 encode_xml($str)
|
||||
|
||||
Encodes characters with special meaning in XML into entities and returns
|
||||
the encoded string.
|
||||
|
||||
=head1 AUTHOR & COPYRIGHT
|
||||
|
||||
Please see the I<XML::Atom> manpage for author, copyright, and license
|
||||
information.
|
||||
|
||||
=cut
|
||||
BIN
livejournal/cgi-bin/XML/Parser/Encodings/koi8-r.enc
Executable file
BIN
livejournal/cgi-bin/XML/Parser/Encodings/koi8-r.enc
Executable file
Binary file not shown.
75
livejournal/cgi-bin/XML/Parser/Encodings/koi8-r.xml
Executable file
75
livejournal/cgi-bin/XML/Parser/Encodings/koi8-r.xml
Executable file
@@ -0,0 +1,75 @@
|
||||
<encmap name='koi8-r' expat='yes'>
|
||||
<ch byte='x80' uni='x2500'/>
|
||||
<ch byte='x81' uni='x2502'/>
|
||||
<ch byte='x82' uni='x250c'/>
|
||||
<ch byte='x83' uni='x2510'/>
|
||||
<ch byte='x84' uni='x2514'/>
|
||||
<ch byte='x85' uni='x2518'/>
|
||||
<ch byte='x86' uni='x251c'/>
|
||||
<ch byte='x87' uni='x2524'/>
|
||||
<ch byte='x88' uni='x252c'/>
|
||||
<ch byte='x89' uni='x2534'/>
|
||||
<ch byte='x8a' uni='x253c'/>
|
||||
<ch byte='x8b' uni='x2580'/>
|
||||
<ch byte='x8c' uni='x2584'/>
|
||||
<ch byte='x8d' uni='x2588'/>
|
||||
<ch byte='x8e' uni='x258c'/>
|
||||
<range byte='x8f' len='4' uni='x2590'/>
|
||||
<ch byte='x93' uni='x2320'/>
|
||||
<ch byte='x94' uni='x25a0'/>
|
||||
<range byte='x95' len='2' uni='x2219'/>
|
||||
<ch byte='x97' uni='x2248'/>
|
||||
<range byte='x98' len='2' uni='x2264'/>
|
||||
<ch byte='x9a' uni='x00a0'/>
|
||||
<ch byte='x9b' uni='x2321'/>
|
||||
<ch byte='x9c' uni='x00b0'/>
|
||||
<ch byte='x9d' uni='x00b2'/>
|
||||
<ch byte='x9e' uni='x00b7'/>
|
||||
<ch byte='x9f' uni='x00f7'/>
|
||||
<range byte='xa0' len='3' uni='x2550'/>
|
||||
<ch byte='xa3' uni='x0451'/>
|
||||
<range byte='xa4' len='15' uni='x2553'/>
|
||||
<ch byte='xb3' uni='x0401'/>
|
||||
<range byte='xb4' len='11' uni='x2562'/>
|
||||
<ch byte='xbf' uni='x00a9'/>
|
||||
<ch byte='xc0' uni='x044e'/>
|
||||
<range byte='xc1' len='2' uni='x0430'/>
|
||||
<ch byte='xc3' uni='x0446'/>
|
||||
<range byte='xc4' len='2' uni='x0434'/>
|
||||
<ch byte='xc6' uni='x0444'/>
|
||||
<ch byte='xc7' uni='x0433'/>
|
||||
<ch byte='xc8' uni='x0445'/>
|
||||
<range byte='xc9' len='8' uni='x0438'/>
|
||||
<ch byte='xd1' uni='x044f'/>
|
||||
<range byte='xd2' len='4' uni='x0440'/>
|
||||
<ch byte='xd6' uni='x0436'/>
|
||||
<ch byte='xd7' uni='x0432'/>
|
||||
<ch byte='xd8' uni='x044c'/>
|
||||
<ch byte='xd9' uni='x044b'/>
|
||||
<ch byte='xda' uni='x0437'/>
|
||||
<ch byte='xdb' uni='x0448'/>
|
||||
<ch byte='xdc' uni='x044d'/>
|
||||
<ch byte='xdd' uni='x0449'/>
|
||||
<ch byte='xde' uni='x0447'/>
|
||||
<ch byte='xdf' uni='x044a'/>
|
||||
<ch byte='xe0' uni='x042e'/>
|
||||
<range byte='xe1' len='2' uni='x0410'/>
|
||||
<ch byte='xe3' uni='x0426'/>
|
||||
<range byte='xe4' len='2' uni='x0414'/>
|
||||
<ch byte='xe6' uni='x0424'/>
|
||||
<ch byte='xe7' uni='x0413'/>
|
||||
<ch byte='xe8' uni='x0425'/>
|
||||
<range byte='xe9' len='8' uni='x0418'/>
|
||||
<ch byte='xf1' uni='x042f'/>
|
||||
<range byte='xf2' len='4' uni='x0420'/>
|
||||
<ch byte='xf6' uni='x0416'/>
|
||||
<ch byte='xf7' uni='x0412'/>
|
||||
<ch byte='xf8' uni='x042c'/>
|
||||
<ch byte='xf9' uni='x042b'/>
|
||||
<ch byte='xfa' uni='x0417'/>
|
||||
<ch byte='xfb' uni='x0428'/>
|
||||
<ch byte='xfc' uni='x042d'/>
|
||||
<ch byte='xfd' uni='x0429'/>
|
||||
<ch byte='xfe' uni='x0427'/>
|
||||
<ch byte='xff' uni='x042a'/>
|
||||
</encmap>
|
||||
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1251.enc
Executable file
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1251.enc
Executable file
Binary file not shown.
54
livejournal/cgi-bin/XML/Parser/Encodings/windows-1251.xml
Executable file
54
livejournal/cgi-bin/XML/Parser/Encodings/windows-1251.xml
Executable file
@@ -0,0 +1,54 @@
|
||||
<encmap name='windows-1251' expat='yes'>
|
||||
<range byte='x80' len='2' uni='x0402'/>
|
||||
<ch byte='x82' uni='x201a'/>
|
||||
<ch byte='x83' uni='x0453'/>
|
||||
<ch byte='x84' uni='x201e'/>
|
||||
<ch byte='x85' uni='x2026'/>
|
||||
<range byte='x86' len='2' uni='x2020'/>
|
||||
<ch byte='x88' uni='x20ac'/>
|
||||
<ch byte='x89' uni='x2030'/>
|
||||
<ch byte='x8a' uni='x0409'/>
|
||||
<ch byte='x8b' uni='x2039'/>
|
||||
<ch byte='x8c' uni='x040a'/>
|
||||
<ch byte='x8d' uni='x040c'/>
|
||||
<ch byte='x8e' uni='x040b'/>
|
||||
<ch byte='x8f' uni='x040f'/>
|
||||
<ch byte='x90' uni='x0452'/>
|
||||
<range byte='x91' len='2' uni='x2018'/>
|
||||
<range byte='x93' len='2' uni='x201c'/>
|
||||
<ch byte='x95' uni='x2022'/>
|
||||
<range byte='x96' len='2' uni='x2013'/>
|
||||
<ch byte='x99' uni='x2122'/>
|
||||
<ch byte='x9a' uni='x0459'/>
|
||||
<ch byte='x9b' uni='x203a'/>
|
||||
<ch byte='x9c' uni='x045a'/>
|
||||
<ch byte='x9d' uni='x045c'/>
|
||||
<ch byte='x9e' uni='x045b'/>
|
||||
<ch byte='x9f' uni='x045f'/>
|
||||
<ch byte='xa0' uni='x00a0'/>
|
||||
<ch byte='xa1' uni='x040e'/>
|
||||
<ch byte='xa2' uni='x045e'/>
|
||||
<ch byte='xa3' uni='x0408'/>
|
||||
<ch byte='xa4' uni='x00a4'/>
|
||||
<ch byte='xa5' uni='x0490'/>
|
||||
<range byte='xa6' len='2' uni='x00a6'/>
|
||||
<ch byte='xa8' uni='x0401'/>
|
||||
<ch byte='xa9' uni='x00a9'/>
|
||||
<ch byte='xaa' uni='x0404'/>
|
||||
<range byte='xab' len='4' uni='x00ab'/>
|
||||
<ch byte='xaf' uni='x0407'/>
|
||||
<range byte='xb0' len='2' uni='x00b0'/>
|
||||
<ch byte='xb2' uni='x0406'/>
|
||||
<ch byte='xb3' uni='x0456'/>
|
||||
<ch byte='xb4' uni='x0491'/>
|
||||
<range byte='xb5' len='3' uni='x00b5'/>
|
||||
<ch byte='xb8' uni='x0451'/>
|
||||
<ch byte='xb9' uni='x2116'/>
|
||||
<ch byte='xba' uni='x0454'/>
|
||||
<ch byte='xbb' uni='x00bb'/>
|
||||
<ch byte='xbc' uni='x0458'/>
|
||||
<ch byte='xbd' uni='x0405'/>
|
||||
<ch byte='xbe' uni='x0455'/>
|
||||
<ch byte='xbf' uni='x0457'/>
|
||||
<range byte='xc0' len='64' uni='x0410'/>
|
||||
</encmap>
|
||||
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1252.enc
Executable file
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1252.enc
Executable file
Binary file not shown.
26
livejournal/cgi-bin/XML/Parser/Encodings/windows-1252.xml
Executable file
26
livejournal/cgi-bin/XML/Parser/Encodings/windows-1252.xml
Executable file
@@ -0,0 +1,26 @@
|
||||
<encmap name='windows-1252' expat='yes'>
|
||||
<ch byte='x80' uni='x20ac'/>
|
||||
<ch byte='x82' uni='x201a'/>
|
||||
<ch byte='x83' uni='x0192'/>
|
||||
<ch byte='x84' uni='x201e'/>
|
||||
<ch byte='x85' uni='x2026'/>
|
||||
<range byte='x86' len='2' uni='x2020'/>
|
||||
<ch byte='x88' uni='x20c6'/>
|
||||
<ch byte='x89' uni='x2030'/>
|
||||
<ch byte='x8a' uni='x0160'/>
|
||||
<ch byte='x8b' uni='x2039'/>
|
||||
<ch byte='x8c' uni='x0152'/>
|
||||
<ch byte='x8e' uni='x017d'/>
|
||||
<range byte='x91' len='2' uni='x2018'/>
|
||||
<range byte='x93' len='2' uni='x201c'/>
|
||||
<ch byte='x95' uni='x2022'/>
|
||||
<range byte='x96' len='2' uni='x2013'/>
|
||||
<ch byte='x98' uni='x02dc'/>
|
||||
<ch byte='x99' uni='x2122'/>
|
||||
<ch byte='x9a' uni='x0161'/>
|
||||
<ch byte='x9b' uni='x203a'/>
|
||||
<ch byte='x9c' uni='x0153'/>
|
||||
<ch byte='x9e' uni='x017e'/>
|
||||
<ch byte='x9f' uni='x0178'/>
|
||||
<range byte='xa0' len='96' uni='x00a0' />
|
||||
</encmap>
|
||||
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1255.enc
Executable file
BIN
livejournal/cgi-bin/XML/Parser/Encodings/windows-1255.enc
Executable file
Binary file not shown.
4
livejournal/cgi-bin/XML/README.txt
Executable file
4
livejournal/cgi-bin/XML/README.txt
Executable file
@@ -0,0 +1,4 @@
|
||||
XML::Atom is not part of the LiveJournal codebase. It's being
|
||||
sucked in here to avoid library incompatibilities. Long story.
|
||||
|
||||
|
||||
263
livejournal/cgi-bin/bml/scheme/bluewhite.look
Executable file
263
livejournal/cgi-bin/bml/scheme/bluewhite.look
Executable file
@@ -0,0 +1,263 @@
|
||||
#
|
||||
# Welcome to GENERIC.LOOK for the WhiteBlue scheme
|
||||
#
|
||||
# by....
|
||||
# Brad Fitzpatrick
|
||||
# brad@danga.com
|
||||
#
|
||||
|
||||
######################### little stuff
|
||||
|
||||
_parent=>global.look
|
||||
|
||||
AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
|
||||
H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
|
||||
H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
# Banner Header: search results banner, content desriptor, etc...
|
||||
BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
GRIN=><grin>
|
||||
HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
|
||||
|
||||
NEWLINE=>{D}<BR>
|
||||
P=>{D}<BR>%%DATA%%
|
||||
P/FOLLOW_P=>{D}<BR><IMG SRC="/img/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
|
||||
|
||||
STANDOUTO<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
|
||||
BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
|
||||
%%DATA%%
|
||||
|
||||
</TD></TR></TABLE></CENTER>
|
||||
<=STANDOUTO
|
||||
|
||||
STANDOUT<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT>
|
||||
<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
|
||||
<tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="/img/corn_nw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="/img/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="/img/corn_ne.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="/img/dot.gif" alt=""></td>
|
||||
<td valign=top>
|
||||
%%DATA%%
|
||||
|
||||
</td>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="/img/dot.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="/img/corn_sw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="/img/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="/img/corn_se.gif" alt=""></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
</CENTER>
|
||||
<=STANDOUT
|
||||
SOERROR=><div style='background-color:#f3f4fe; color:red; font-weight:bold; text-align:center'>%%data%%</div>
|
||||
EMAILEX=><div style='width: 50%; font-family: courier; background-color: #efefef; border: dotted #cdcdcd 2px; padding: 5px;'>%%data%%</div>
|
||||
|
||||
######################### choices stuff
|
||||
|
||||
CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
|
||||
|
||||
CHOICES<=
|
||||
{F}<P><DIV CLASS="choice"><TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
|
||||
<TR>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMS%%
|
||||
</DL>
|
||||
</TD>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMSB%%
|
||||
</DL>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE></DIV>
|
||||
<=CHOICES
|
||||
|
||||
##################################################################################
|
||||
################################### MAIN PAGE ####################################
|
||||
##################################################################################
|
||||
|
||||
PAGE<=
|
||||
{Fps}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
|
||||
<HTML><?load_page_info?>
|
||||
<HEAD>
|
||||
<TITLE>%%TITLE%%</TITLE>
|
||||
%%head%%
|
||||
<?_code
|
||||
use strict;
|
||||
my $crumb_up;
|
||||
if(LJ::get_active_crumb() ne '')
|
||||
{
|
||||
my $parentcrumb = LJ::get_parent_crumb();
|
||||
$crumb_up = "<link rel='up' title='$parentcrumb->[0]' href='$parentcrumb->[1]' />";
|
||||
}
|
||||
return $crumb_up;
|
||||
_code?>
|
||||
</HEAD>
|
||||
|
||||
<BODY BGCOLOR=#FFFFFF TOPMARGIN="0" LEFTMARGIN="0" MARGINHEIGHT="0" MARGINWIDTH="0" LINK=#0000C0 VLINK=#0000C0 %%bodyopts%%>
|
||||
|
||||
<TABLE WIDTH=100% BORDER=0 CELLPADDING=0 CELLSPACING=0 BACKGROUND="/img/bluewhite/bluefade.jpg">
|
||||
<TR WIDTH=100%>
|
||||
<TD VALIGN=BOTTOM ALIGN=LEFT HEIGHT=100>
|
||||
|
||||
<TABLE BACKGROUND="" HEIGHT=95 WIDTH=100% BORDER=0>
|
||||
<TR>
|
||||
<TD WIDTH=3> </TD>
|
||||
<TD HEIGHT=53 WIDTH=406 VALIGN=BOTTOM>
|
||||
<?_code
|
||||
$is_home = (BML::get_uri() =~ m!^/(index\.bml)?!);
|
||||
if (0 && $is_home)
|
||||
{
|
||||
return '<IMG SRC="/img/bluewhite/title.gif" WIDTH=600 HEIGHT=53><!-- ';
|
||||
}
|
||||
return "";
|
||||
_code?>
|
||||
|
||||
<FONT SIZE=6 COLOR="#000a3f" FACE="Arial, Helvetica"><B>%%TITLE%%</B></FONT>
|
||||
|
||||
<?_code
|
||||
if (0 && $is_home)
|
||||
{
|
||||
return ' -->';
|
||||
}
|
||||
return "";
|
||||
_code?>
|
||||
|
||||
</TD>
|
||||
<TD VALIGN=TOP ALIGN=RIGHT>
|
||||
<?_code
|
||||
unless ($is_home) {
|
||||
return "<A HREF=\"/\"><IMG SRC=\"/img/bluewhite/home.gif\" WIDTH=35 HEIGHT=36 BORDER=0></A> ";
|
||||
}
|
||||
return "";
|
||||
_code?>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
|
||||
</TD></TR>
|
||||
<TR><TD bgcolor="#FFFFFF"><?breadcrumbs?></TD</TR>
|
||||
</TABLE>
|
||||
|
||||
<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0>
|
||||
<TR VALIGN=TOP>
|
||||
<TD WIDTH=133 BGCOLOR=#d7d9e8 NOWRAP><IMG SRC="/img/bluewhite/hline.gif" WIDTH=133 HEIGHT=25 ALT="">
|
||||
|
||||
<TABLE WIDTH=128 BORDER=0 CELLSPACING=0 CELLPADDING=0>
|
||||
<TR><TD>
|
||||
|
||||
<FONT FACE="Arial,Helvetica" SIZE=-1>
|
||||
<?_code
|
||||
|
||||
$ret = "";
|
||||
|
||||
sub dump_entry
|
||||
{
|
||||
my ($ret, $listref, $depth) = @_;
|
||||
|
||||
foreach my $mi (@$listref)
|
||||
{
|
||||
if ($depth==0) {
|
||||
$$ret .= "<P><IMG SRC=\"/img/bluewhite/bullet.gif\" WIDTH=10 HEIGHT=10 HSPACE=2 ALIGN=ABSMIDDLE>";
|
||||
} else {
|
||||
$$ret .= " " x ($depth*3+1);
|
||||
$$ret .= $mi->{'cont'} ? " " : "- ";
|
||||
}
|
||||
|
||||
my $name = $mi->{'name'};
|
||||
$name =~ s/ / /g;
|
||||
if (! defined $mi->{'uri'}) {
|
||||
if ($depth == 0) {
|
||||
$$ret .= "<B>$name</B><BR>";
|
||||
} else {
|
||||
$$ret .= "$name<BR>";
|
||||
}
|
||||
} elsif ($mi->{'match'} ?
|
||||
(BML::get_uri() =~ /$mi->{'match'}/) :
|
||||
(BML::get_uri() eq $mi->{'uri'})
|
||||
){
|
||||
$$ret .= "<B><SPAN style=\"background-color: #FFFFFF\"><FONT COLOR=#0000D0>$name</FONT></SPAN></B><BR>";
|
||||
} else {
|
||||
$$ret .= "<A HREF=\"$mi->{'uri'}\">$name</A><BR>";
|
||||
}
|
||||
|
||||
if ($mi->{'children'} &&
|
||||
($mi->{'recursematch'} ? BML::get_uri() =~ /$mi->{'recursematch'}/ : 1)) {
|
||||
&dump_entry($ret, $mi->{'children'}, $depth+1);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
&dump_entry(\$ret, \@sidebar, 0);
|
||||
|
||||
return $ret;
|
||||
|
||||
_code?>
|
||||
</FONT>
|
||||
|
||||
</TD></TR></TABLE>
|
||||
</TD>
|
||||
<TD ALIGN=LEFT BACKGROUND="/img/bluewhite/vline.gif" WIDTH=25 NOWRAP>
|
||||
<IMG SRC="/img/bluewhite/linetop.gif" WIDTH=25 HEIGHT=25 ALT=""><BR>
|
||||
<IMG SRC="/img/bluewhite/vline.gif" WIDTH=25 HEIGHT=800 ALT="">
|
||||
</TD>
|
||||
<TD>
|
||||
|
||||
<IMG SRC="/img/dot.gif" WIDTH=1 HEIGHT=3><BR>
|
||||
%%BODY%%
|
||||
|
||||
</TD>
|
||||
<TD WIDTH=20> </TD>
|
||||
</TR>
|
||||
|
||||
<!-- table closure row -->
|
||||
<TR>
|
||||
<TD WIDTH=133 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade.gif" WIDTH=133 HEIGHT=25 ALT=""></TD>
|
||||
<TD WIDTH=25 NOWRAP><IMG SRC="/img/bluewhite/sidebarfade_line.gif" WIDTH=25 HEIGHT=25 ALT=""></TD></TD>
|
||||
<TD>
|
||||
|
||||
</TD>
|
||||
<TD WIDTH=20> </TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
<!-- /table closure row -->
|
||||
|
||||
<TABLE WIDTH=100%>
|
||||
<TR>
|
||||
<TD ALIGN=RIGHT>
|
||||
<FONT FACE="Arial, Helvetica" SIZE="-2">
|
||||
<A HREF="/privacy.bml">Privacy Policy</A> -
|
||||
<A HREF="/coppa.bml">COPPA</A><BR>
|
||||
<A HREF="/disclaimer.bml">Legal Disclaimer</A> -
|
||||
<A HREF="/sitemap.bml">Site Map</A><BR>
|
||||
</FONT>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
|
||||
</BODY>
|
||||
</HTML>
|
||||
<=PAGE
|
||||
|
||||
365
livejournal/cgi-bin/bml/scheme/global.look
Executable file
365
livejournal/cgi-bin/bml/scheme/global.look
Executable file
@@ -0,0 +1,365 @@
|
||||
_parent=>../../lj-bml-blocks.pl
|
||||
|
||||
loginboxstyle=>{Ss}background: url(<?imgprefix?>/userinfo.gif) no-repeat; background-color: #fff; background-position: 0px 1px; padding-left: 18px; color: #00C; font-weight: bold;
|
||||
commloginboxstyle=>{Ss}background: url(<?imgprefix?>/community.gif) no-repeat; background-color: #fff; background-position: 0px 2px; padding-left: 19px; color: #00C; font-weight: bold;
|
||||
|
||||
SECURITYPRIVATE=>{Ss}<img src="<?imgprefix?>/icon_private.gif" width=16 height=16 align=absmiddle>
|
||||
SECURITYPROTECTED=>{Ss}<img src="<?imgprefix?>/icon_protected.gif" width=14 height=15 align=absmiddle>
|
||||
LJUSER=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
|
||||
LJCOMM=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%'><img src='<?imgprefix?>/community.gif' alt='userinfo' width='16' height='16' style='vertical-align:bottom;border:0;' /></a><a href='/community/%%data%%/'><b>%%data%%</b></a></span>
|
||||
LJUSERF=>{DRs}<span class='ljuser' style='white-space:nowrap;'><a href='/userinfo.bml?user=%%data%%&mode=full'><img src='<?imgprefix?>/userinfo.gif' alt='userinfo' width='17' height='17' style='vertical-align:bottom;border:0;' /></a><a href='/users/%%data%%/'><b>%%data%%</b></a></span>
|
||||
HELP=>{DR}(<a href="%%data%%"><i>help</i></a>)
|
||||
INERR=>{DR}<font color="#ff0000"><b>%%data%%</b></font>
|
||||
SOERROR=>{DR}<div><b>%%data%%</b></div>
|
||||
EMAILEX=><div style='font-family: courier; border: solid black 1px; padding: 5px;'>%%data%%</div>
|
||||
|
||||
ENTRYFORMCSS<=
|
||||
{Ss}
|
||||
<style type="text/css">
|
||||
#EntryForm #MetaInfo {
|
||||
width: 100%;
|
||||
}
|
||||
#EntryForm th {
|
||||
font-size: 1em;
|
||||
}
|
||||
#EntryForm #SubmitBar {
|
||||
background-color: #dfdfdf;
|
||||
padding: 5px;
|
||||
text-align: center;
|
||||
border: 1px outset #000;
|
||||
margin-left: auto; margin-right: auto;
|
||||
}
|
||||
#MetaInfo tr {
|
||||
padding-bottom: 10px;
|
||||
}
|
||||
#metainfo th {
|
||||
text-align: left;
|
||||
}
|
||||
#mood_preview {
|
||||
display: none;
|
||||
}
|
||||
#datetime_box input, #datetime_box select {
|
||||
margin-right: 2px;
|
||||
}
|
||||
#EntryForm legend {
|
||||
font-weight: bold;
|
||||
}
|
||||
#EntryForm #Options {
|
||||
margin-left: 0; margin-right: 0; padding: 0;
|
||||
background-color: #dfdfdf;
|
||||
border: 1px outset #000;
|
||||
}
|
||||
#EntryForm #Options th {
|
||||
text-align: left;
|
||||
}
|
||||
#EntryForm #infobox {
|
||||
text-align: center;
|
||||
}
|
||||
#EntryForm #infobox table {
|
||||
background-color: #dfdfdf;
|
||||
border: 2px solid <?emcolor?>;
|
||||
}
|
||||
#EntryForm textarea {
|
||||
border: 1px inset #000;
|
||||
padding: 2px;
|
||||
}
|
||||
#EntryForm #Security option {
|
||||
padding-left: 18px;
|
||||
}
|
||||
#EntryForm #security_public {
|
||||
background-image: url("<?imgprefix?>/userinfo.gif");
|
||||
background-repeat: no-repeat;
|
||||
}
|
||||
#EntryForm #security_private {
|
||||
background-image: url("<?imgprefix?>/icon_private.gif");
|
||||
background-repeat: no-repeat;
|
||||
}
|
||||
#EntryForm #security_friends, #EntryForm #security_custom {
|
||||
background-image: url("<?imgprefix?>/icon_protected.gif");
|
||||
background-repeat: no-repeat;
|
||||
}
|
||||
#EntryForm #UserpicPreviewImage {
|
||||
border: 1px solid #000;
|
||||
}
|
||||
#EntryForm {
|
||||
width: 100%;
|
||||
}
|
||||
</style>
|
||||
<=ENTRYFORMCSS
|
||||
|
||||
NEEDLOGIN<=
|
||||
<?h1 <?_ml bml.needlogin.head _ml?> h1?>
|
||||
<?p <?_ml bml.needlogin.body2 _ml?> p?>
|
||||
<=NEEDLOGIN
|
||||
|
||||
BADINPUT<=
|
||||
<?h1 <?_ml bml.badinput.head _ml?> h1?>
|
||||
<?p <?_ml bml.badinput.body _ml?> p?>
|
||||
<=BADINPUT
|
||||
|
||||
REQUIREPOST=><?_ml bml.requirepost _ml?>
|
||||
|
||||
LOAD_PAGE_INFO<=
|
||||
<?_code
|
||||
#line 3
|
||||
@sidebar = ({ 'name' => 'Home',
|
||||
'uri' => '/',
|
||||
'match' => "^/(index\\.bml)?(\\?.*)?\$",
|
||||
'children' => [
|
||||
{ 'name' => 'Create Journal',
|
||||
'uri' => '/create.bml', },
|
||||
{ 'name' => 'Update',
|
||||
'uri' => '/update.bml',
|
||||
# 'children' => [
|
||||
# { 'name' => 'Full Update',
|
||||
# 'uri' => '/update.bml?mode=full', }
|
||||
# ],
|
||||
},
|
||||
{ 'name' => 'Download',
|
||||
'uri' => '/download/', },
|
||||
],
|
||||
},
|
||||
{ 'name' => 'LiveJournal',
|
||||
'children' => [
|
||||
{ 'name' => 'News',
|
||||
'match' => '^/news\\.bml\$',
|
||||
'uri' => '/news.bml', },
|
||||
{ 'name' => 'Paid Accounts',
|
||||
'uri' => '/paidaccounts/',
|
||||
'recursematch' => '^/paidaccounts/',
|
||||
'children' => [
|
||||
{ 'name' => 'Is this safe?',
|
||||
'uri' => '/paidaccounts/whysafe.bml', },
|
||||
{ 'name' => 'Progress',
|
||||
'uri' => '/paidaccounts/progress.bml', },
|
||||
],
|
||||
},
|
||||
# { 'name' => 'To-Do list',
|
||||
# 'uri' => '/todo.bml', },
|
||||
{ 'name' => 'Contributors',
|
||||
'uri' => '/contributors.bml', },
|
||||
],
|
||||
},
|
||||
{ 'name' => 'Customize',
|
||||
'children' => [
|
||||
{ 'name' => 'Modify Journal',
|
||||
'uri' => '/modify.bml', },
|
||||
{ 'name' => 'Create Style',
|
||||
'uri' => '/createstyle.bml', },
|
||||
{ 'name' => 'Edit Style',
|
||||
'uri' => '/editstyle.bml', },
|
||||
],
|
||||
},
|
||||
{ 'name' => 'Find Users',
|
||||
'children' => [
|
||||
{ 'name' => 'Random!',
|
||||
'uri' => '/random.bml', },
|
||||
{ 'name' => 'By Region',
|
||||
'uri' => '/directory.bml', },
|
||||
{ 'name' => 'By Interest',
|
||||
'uri' => '/interests.bml', },
|
||||
{ 'name' => 'Search',
|
||||
'uri' => '/directorysearch.bml', }
|
||||
], },
|
||||
{ 'name' => 'Edit ...',
|
||||
'children' => [
|
||||
{ 'name' => 'Personal Info &',
|
||||
'uri' => '/editinfo.bml', },
|
||||
{ 'name' => 'Settings', cont => 1,
|
||||
'uri' => '/editinfo.bml', },
|
||||
{ 'name' => 'Your Friends',
|
||||
'uri' => '/editfriends.bml', },
|
||||
{ 'name' => 'Old Entries',
|
||||
'uri' => '/editjournal.bml', },
|
||||
{ 'name' => 'Your Pictures',
|
||||
'uri' => '/editpics.bml', },
|
||||
{ 'name' => 'Your Password',
|
||||
'uri' => '/changepassword.bml', },
|
||||
],
|
||||
},
|
||||
{ 'name' => 'Developer Area',
|
||||
'uri' => '/developer/',
|
||||
'match' => "^/developer/\$",
|
||||
'recursematch' => "^/developer/",
|
||||
'children' => [
|
||||
{ 'name' => 'Style System',
|
||||
'uri' => '/developer/styles.bml',
|
||||
'children' => [
|
||||
{ 'name' => 'View Types',
|
||||
'uri' => '/developer/views.bml', },
|
||||
{ 'name' => 'Variable List',
|
||||
'uri' => '/developer/varlist.bml', },
|
||||
],
|
||||
},
|
||||
{ 'name' => 'Embedding',
|
||||
'uri' => '/developer/embedding.bml', },
|
||||
{ 'name' => 'Protocol',
|
||||
'uri' => '/developer/protocol.bml',
|
||||
'children' => [
|
||||
{ 'name' => 'Mode List',
|
||||
'uri' => '/developer/modelist.bml', }
|
||||
],
|
||||
},
|
||||
],
|
||||
},
|
||||
{ 'name' => 'Need Help?',
|
||||
'children' => [
|
||||
{ 'name' => 'Lost Password?',
|
||||
'uri' => '/lostinfo.bml', },
|
||||
{ 'name' => 'Freq. Asked',
|
||||
'uri' => '/support/faq.bml', },
|
||||
{ 'name' => 'Questions',
|
||||
'uri' => '/support/faq.bml', cont => 1, },
|
||||
{ 'name' => 'Support Area',
|
||||
'uri' => '/support/', },
|
||||
],
|
||||
},
|
||||
);
|
||||
|
||||
my $remote = LJ::get_remote();
|
||||
my $remuser = $remote ? $remote->{'user'} : "";
|
||||
my $uri = BML::get_uri();
|
||||
if ($remuser ne "" && $uri ne "/logout.bml")
|
||||
{
|
||||
my $subdomain = $remuser;
|
||||
$subdomain =~ s/_/-/g;
|
||||
unshift @sidebar, { 'name' => "Hello, $remuser!",
|
||||
'children' => [
|
||||
{ 'name' => 'Your Journal',
|
||||
'children' => [
|
||||
{ 'name' => 'Recent',
|
||||
'uri' => "/users/$remuser/", },
|
||||
{ 'name' => 'Calendar',
|
||||
'uri' => "/users/$remuser/calendar", },
|
||||
{ 'name' => 'Friends',
|
||||
'uri' => "/users/$remuser/friends",
|
||||
'extra' => "/friendsfilter.bml",
|
||||
},
|
||||
],
|
||||
},
|
||||
{ 'name' => 'User Info',
|
||||
'uri' => "/userinfo.bml?user=$remuser", },
|
||||
{ 'name' => 'Memories',
|
||||
'uri' => "/memories.bml?user=$remuser", },
|
||||
{ 'name' => 'Logout',
|
||||
'uri' => '/logout.bml', },
|
||||
]
|
||||
};
|
||||
} elsif ($uri ne "/login.bml") {
|
||||
unshift @sidebar, { 'name' => "Log In",
|
||||
'uri' => '/login.bml', }
|
||||
}
|
||||
|
||||
return "";
|
||||
_code?>
|
||||
<=LOAD_PAGE_INFO
|
||||
|
||||
AL=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
|
||||
AWAYLINK=>{P}<i><a href="%%data1%%">%%data2%%</a></i> <img src="/img/external_link.gif" width='16' height='11' align='absmiddle' />
|
||||
|
||||
H1=>{D}<h1>%%data%%</h1>
|
||||
H2=>{D}<h2>%%data%%</h2>
|
||||
|
||||
# Banner Header: search results banner, content desriptor, etc...
|
||||
BH=>{D}<p align='center'><font face="Arial,Helvetica" color="#CC0000" size='-1'><b>%%data%%</b></font>
|
||||
|
||||
GRIN=>{S}<grin>
|
||||
HR=>{S}<hr />
|
||||
|
||||
NEWLINE=>{S}<BR>
|
||||
P=>{D}<P>%%data%%</P>
|
||||
|
||||
STANDOUT<=
|
||||
{D}<blockquote>
|
||||
<hr />
|
||||
%%data%%
|
||||
<hr />
|
||||
</blockquote>
|
||||
<=STANDOUT
|
||||
|
||||
ERRORBAR<=
|
||||
{D}<blockquote>
|
||||
<hr />
|
||||
%%data%%
|
||||
<hr />
|
||||
</blockquote>
|
||||
<=ERRORBAR
|
||||
|
||||
WARNINGBAR<=
|
||||
{D}<blockquote>
|
||||
<hr />
|
||||
%%data%%
|
||||
<hr />
|
||||
</blockquote>
|
||||
<=WARNINGBAR
|
||||
|
||||
BADCONTENT<=
|
||||
<?h1 <?_ml Error _ml?> h1?>
|
||||
<?p <?_ml bml.badcontent.body _ml?> p?>
|
||||
<=BADCONTENT
|
||||
|
||||
DE<=
|
||||
%%data%%
|
||||
<=DE
|
||||
|
||||
EMCOLOR=>{S}#c0c0c0
|
||||
HOTCOLOR=>{S}#ff0000
|
||||
EMCOLORLITE=>{S}#e2e2e2
|
||||
ALTCOLOR1=>{S}#eeeeee
|
||||
ALTCOLOR2=>{S}#dddddd
|
||||
screenedbarcolor=>{S}#d0d0d0
|
||||
|
||||
CHOICE=>{P}<dt><a href="%%data2%%"><font size="+1"><tt><b>%%data1%%</b></tt></font></a><dd><font size="2">%%data3%%</font>
|
||||
|
||||
CHOICES<=
|
||||
{F}<table width="100%" cellpadding="2" cellspacing="5">
|
||||
<tr>
|
||||
<td valign='top' width="50%">
|
||||
<dl>
|
||||
%%items%%
|
||||
</dl>
|
||||
</td>
|
||||
<td valign='top' width="50%">
|
||||
<dl>
|
||||
%%itemsb%%
|
||||
</dl>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
<=CHOICES
|
||||
|
||||
PAGE<=
|
||||
{Fp}<html>
|
||||
<head><title>%%title%%</title>%%head%%</head>
|
||||
<body %%bodyopts%%>
|
||||
%%body%%
|
||||
</body>
|
||||
</html>
|
||||
<=PAGE
|
||||
|
||||
BREADCRUMBS<=
|
||||
{Fp}<?_code
|
||||
# where are we
|
||||
my @crumbs = LJ::get_crumb_path();
|
||||
return unless @crumbs;
|
||||
my @ret;
|
||||
my $count = 0;
|
||||
foreach my $crumb (@crumbs) {
|
||||
# put crumbs together
|
||||
next unless $crumb->[3]; # no blank crumbs
|
||||
if ($crumb->[3] eq 'dynamic') {
|
||||
# dynamic
|
||||
unshift @ret, "<b>$crumb->[0]</b>";
|
||||
$count++;
|
||||
} else {
|
||||
# non-dynamic
|
||||
unshift @ret, $count++ == 0 ?
|
||||
"<b>$ML{'crumb.'.$crumb->[3]}</b>" :
|
||||
$crumb->[1] ne '' ?
|
||||
"<a href=\"$crumb->[1]\">$ML{'crumb.'.$crumb->[3]}</a>" :
|
||||
"$ML{'crumb.'.$crumb->[3]}";
|
||||
}
|
||||
}
|
||||
return "<div id='ljbreadcrumbs'>" . join(" : ", @ret) . "</div>";
|
||||
_code?>
|
||||
<=BREADCRUMBS
|
||||
55
livejournal/cgi-bin/bml/scheme/lynx.look
Executable file
55
livejournal/cgi-bin/bml/scheme/lynx.look
Executable file
@@ -0,0 +1,55 @@
|
||||
###
|
||||
### Lynx Scheme - Very simple for text browsers
|
||||
###
|
||||
|
||||
_parent=>global.look
|
||||
|
||||
h1=>{D}<h1>%%DATA%%</h1>
|
||||
h2=>{D}<h2>%%DATA%%</h2>
|
||||
|
||||
loginboxstyle=>{S}
|
||||
commloginboxstyle=>{S}
|
||||
|
||||
page<=
|
||||
{Fps}<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
|
||||
<html xmlns="http://www.w3.org/1999/xhtml">
|
||||
<head>
|
||||
<link rel="home" title="<?_ml lynx.nav.home _ml?>" href="/" />
|
||||
<link rel="contents" title="<?_ml lynx.nav.sitemap _ml?>" href="/site/" />
|
||||
<link rel="help" title="<?_ml lynx.nav.help _ml?>" href="/support/" />
|
||||
<?_code
|
||||
use strict;
|
||||
my $crumb_up;
|
||||
if(LJ::get_active_crumb() ne '')
|
||||
{
|
||||
my $parentcrumb = LJ::get_parent_crumb();
|
||||
$crumb_up = "<link rel='up' title='$parentcrumb->[0]' href='$parentcrumb->[1]' />";
|
||||
}
|
||||
return $crumb_up;
|
||||
_code?>
|
||||
<style>
|
||||
#Comments q { padding-left: 2.5em; font-style: italic; }
|
||||
</style>
|
||||
<title><?_code {
|
||||
my $elhash = $_[2];
|
||||
return $elhash->{'WINDOWTITLE'} || $elhash->{'TITLE'};
|
||||
} _code?></title>
|
||||
%%HEAD%%
|
||||
</head>
|
||||
|
||||
<body %%bodyopts%%>
|
||||
|
||||
%%BODY%%
|
||||
|
||||
<hr />
|
||||
|
||||
<p>[ <a href='/'><?_ml lynx.nav.home _ml?></a> | <a href='/update.bml'><?_ml lynx.nav.update _ml?></a> | <?_code
|
||||
use strict;
|
||||
if(my $u = LJ::get_remote()) {
|
||||
return "<a href='/users/$u->{'user'}/'>$ML{'lynx.nav.recent'}</a> | <a href='/users/$u->{'user'}/friends/'>$ML{'lynx.nav.friends'}</a> | ";
|
||||
}
|
||||
_code?><a href='/login.bml'><?_ml lynx.nav.login _ml?></a>/<a href='/logout.bml'><?_ml lynx.nav.logout _ml?></a> | <a href='/manage/siteopts.bml'><?_ml lynx.nav.siteopts _ml?></a> | <a href='/site/'><?_ml lynx.nav.sitemap _ml?></a> ]</p>
|
||||
<?breadcrumbs?>
|
||||
</body>
|
||||
</html>
|
||||
<=page
|
||||
225
livejournal/cgi-bin/bml/scheme/opalcat.look
Executable file
225
livejournal/cgi-bin/bml/scheme/opalcat.look
Executable file
@@ -0,0 +1,225 @@
|
||||
_parent=>global.look
|
||||
|
||||
AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="<?imgprefix?>/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="<?imgprefix?>/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
|
||||
H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
|
||||
H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
# Banner Header: search results banner, content desriptor, etc...
|
||||
BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
GRIN=><grin>
|
||||
HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
|
||||
|
||||
DE<=
|
||||
<font size=-1>%%DATA%%</font>
|
||||
<=DE
|
||||
|
||||
NEWLINE=>{D}<BR>
|
||||
P=>{D}<BR>%%DATA%%
|
||||
P/FOLLOW_P=>{D}<BR><IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
|
||||
|
||||
STANDOUTO<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
|
||||
BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
|
||||
%%DATA%%
|
||||
|
||||
</TD></TR></TABLE></CENTER>
|
||||
<=STANDOUTO
|
||||
|
||||
STANDOUT<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT>
|
||||
<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
|
||||
<tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="<?imgprefix?>/corn_nw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="<?imgprefix?>/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="<?imgprefix?>/corn_ne.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="<?imgprefix?>/dot.gif" alt=""></td>
|
||||
<td valign=top>
|
||||
%%DATA%%
|
||||
|
||||
</td>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="<?imgprefix?>/dot.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="<?imgprefix?>/corn_sw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="<?imgprefix?>/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="<?imgprefix?>/corn_se.gif" alt=""></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
</CENTER>
|
||||
<=STANDOUT
|
||||
|
||||
######################### choices stuff
|
||||
|
||||
CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
|
||||
|
||||
CHOICES<=
|
||||
{F}<P><DIV CLASS="choice"><TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
|
||||
<TR>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMS%%
|
||||
</DL>
|
||||
</TD>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMSB%%
|
||||
</DL>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE></DIV>
|
||||
<=CHOICES
|
||||
|
||||
##################################################################################
|
||||
################################### MAIN PAGE ####################################
|
||||
##################################################################################
|
||||
|
||||
PAGE<=
|
||||
{F}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 4.0 Transitional//EN" "http://www.w3.org/TR/REC-html40/loose.dtd">
|
||||
<HTML><?load_page_info?>
|
||||
<HEAD>
|
||||
<LINK REL="SHORTCUT ICON" HREF="http://www.livejournal.com/favicon.ico">
|
||||
<TITLE>%%TITLE%%</TITLE>
|
||||
%%HEAD%%
|
||||
<SCRIPT LANGUAGE="JavaScript">
|
||||
window.onerror = null; // damn javascript.
|
||||
</SCRIPT>
|
||||
</HEAD>
|
||||
<BODY BGCOLOR=#FFFFFF TOPMARGIN="0" LEFTMARGIN="0" RIGHTMARGIN="0" BOTTOMMARGIN="0"
|
||||
MARGINHEIGHT="0" MARGINWIDTH="0" LINK=#0000C0 VLINK=#0000C0
|
||||
BACKGROUND="<?imgprefix?>/opal/spiral2.jpg" %%bodyopts%%>
|
||||
|
||||
<TABLE BORDER=0 CELLPADDING=0 CELLSPACING=0 WIDTH=100% HEIGHT=100%>
|
||||
<TR VALIGN=TOP>
|
||||
<TD WIDTH=128 NOWRAP>
|
||||
|
||||
<IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 HEIGHT=15><BR>
|
||||
|
||||
<FONT FACE="Arial,Helvetica" SIZE=-1>
|
||||
<?_code
|
||||
|
||||
$ret = "";
|
||||
|
||||
sub dump_entry
|
||||
{
|
||||
my ($ret, $listref, $depth) = @_;
|
||||
|
||||
foreach my $mi (@$listref)
|
||||
{
|
||||
if ($depth==0) {
|
||||
$$ret .= "<P><IMG SRC=\"<?imgprefix?>/opal/bullet.gif\" WIDTH=10 HEIGHT=10 HSPACE=2 ALIGN=ABSMIDDLE>";
|
||||
} else {
|
||||
$$ret .= " " x ($depth*3+1);
|
||||
$$ret .= $mi->{'cont'} ? " " : "- ";
|
||||
}
|
||||
|
||||
my $extra = "";
|
||||
if ($mi->{'extra'}) {
|
||||
$extra = " <A HREF=\"$mi->{'extra'}\">...</A>";
|
||||
}
|
||||
|
||||
my $name = $mi->{'name'};
|
||||
$name =~ s/ / /g;
|
||||
if (! defined $mi->{'uri'}) {
|
||||
if ($depth == 0) {
|
||||
$$ret .= "<B>$name</B>$extra<BR>";
|
||||
} else {
|
||||
$$ret .= "$name$extra<BR>";
|
||||
}
|
||||
} elsif ($mi->{'match'} ?
|
||||
(BML::get_uri() =~ /$mi->{'match'}/) :
|
||||
(BML::get_uri() eq $mi->{'uri'})
|
||||
){
|
||||
$$ret .= "<B><SPAN style=\"background-color: #D0D0FF\"><FONT COLOR=#0000D0>$name</FONT></SPAN></B>$extra<BR>";
|
||||
} else {
|
||||
$$ret .= "<A HREF=\"$mi->{'uri'}\">$name</A>$extra<BR>";
|
||||
}
|
||||
|
||||
if ($mi->{'children'} &&
|
||||
($mi->{'recursematch'} ? BML::get_uri() =~ /$mi->{'recursematch'}/ : 1)) {
|
||||
&dump_entry($ret, $mi->{'children'}, $depth+1);
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
&dump_entry(\$ret, \@sidebar, 0);
|
||||
|
||||
return $ret;
|
||||
|
||||
_code?>
|
||||
</FONT>
|
||||
|
||||
</TD>
|
||||
<TD ALIGN=LEFT WIDTH=39 NOWRAP><BR></TD>
|
||||
|
||||
</TD>
|
||||
<TD WIDTH=100%>
|
||||
|
||||
<TABLE HEIGHT=95 WIDTH=100% BORDER=0 cellpadding=0 cellspacing=0>
|
||||
<TR>
|
||||
<TD VALIGN=TOP ALIGN=RIGHT>
|
||||
<?_code
|
||||
$is_home = (BML::get_uri() =~ m!^/(index\.bml)?!);
|
||||
if (! $is_home)
|
||||
{
|
||||
return '<P><A HREF="/"><IMG SRC="<?imgprefix?>/opal/home.gif" WIDTH=87 HEIGHT=51 BORDER=0 HSPACE=0></A></P>';
|
||||
} else {
|
||||
return "<P> </P>";
|
||||
}
|
||||
return "";
|
||||
_code?>
|
||||
|
||||
<P align=left><FONT SIZE=6 COLOR="#000a3f" FACE="Arial, Helvetica"><B>%%TITLE%%</B></FONT>
|
||||
<BR><IMG SRC="<?imgprefix?>/opal/pencil-line.gif" WIDTH=345 HEIGHT=23></P>
|
||||
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
|
||||
|
||||
<IMG SRC="<?imgprefix?>/dot.gif" WIDTH=1 HEIGHT=5><BR>
|
||||
|
||||
<TABLE WIDTH=100%>
|
||||
<TR><TD ALIGN=LEFT>
|
||||
%%BODY%%
|
||||
</TD>
|
||||
<TD WIDTH=20> </TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
|
||||
</TD>
|
||||
</TR>
|
||||
|
||||
<TR ALIGN=RIGHT>
|
||||
<TD> </TD><TD> </TD>
|
||||
<TD>
|
||||
<P> <P>
|
||||
<FONT FACE="Arial, Helvetica" SIZE="-2">
|
||||
<A HREF="/legal/tos.bml">Terms of Service</A><BR>
|
||||
<A HREF="/legal/privacy.bml">Privacy Policy</A> -
|
||||
<A HREF="/legal/coppa.bml">COPPA</A>
|
||||
</FONT>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
|
||||
</BODY>
|
||||
</HTML>
|
||||
<=PAGE
|
||||
|
||||
198
livejournal/cgi-bin/bml/scheme/woais.look
Executable file
198
livejournal/cgi-bin/bml/scheme/woais.look
Executable file
@@ -0,0 +1,198 @@
|
||||
_parent=>global.look
|
||||
|
||||
AL=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
AWAYLINK=>{P}<I><A HREF="%%DATA1%%">%%DATA2%%</A></I> <IMG SRC="/img/external_link.gif" WIDTH=16 HEIGHT=11 ALIGN=ABSMIDDLE>
|
||||
|
||||
H1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
H1/FOLLOW_CHOICES=>{D}<FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
HEAD1=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000"><B>%%DATA%%</B></FONT>
|
||||
|
||||
H2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
HEAD2=>{D}<P><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
# Banner Header: search results banner, content desriptor, etc...
|
||||
BH=>{D}<P ALIGN=CENTER><FONT FACE="Arial,Helvetica" COLOR="#CC0000" SIZE=-1><B>%%DATA%%</B></FONT>
|
||||
|
||||
GRIN=><grin>
|
||||
HR=><P ALIGN="CENTER"><FONT COLOR=BLUE>*</FONT></P>
|
||||
|
||||
NEWLINE=>{D}<BR>
|
||||
P=>{D}<BR>%%DATA%%
|
||||
P/FOLLOW_P=>{D}<BR><IMG SRC="/img/dot.gif" WIDTH=1 VSPACE=6 HEIGHT=1><BR>%%DATA%%
|
||||
|
||||
STANDOUTO<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT><TABLE ALIGN=CENTER CELLPADDING=8 BORDER=1 BGCOLOR=#CCCCFF BORDERCOLORLIGHT=#DDDDFF
|
||||
BORDERCOLORDARK=#BBBBFF><TR><TD VALIGN=CENTER>
|
||||
%%DATA%%
|
||||
|
||||
</TD></TR></TABLE></CENTER>
|
||||
<=STANDOUTO
|
||||
|
||||
STANDOUT<=
|
||||
{D}<CENTER><FONT SIZE=1><BR></FONT>
|
||||
<table cellspacing=0 cellpadding=0 border=0 bgcolor="#ccccff">
|
||||
<tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="/img/corn_nw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="/img/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="/img/corn_ne.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="/img/dot.gif" alt=""></td>
|
||||
<td valign=top>
|
||||
%%DATA%%
|
||||
|
||||
</td>
|
||||
<td width=7>
|
||||
<img width=7 height=1 src="/img/dot.gif" alt=""></td>
|
||||
</tr><tr>
|
||||
<td width=7 align=left valign=top>
|
||||
<img width=7 height=7 src="/img/corn_sw.gif" alt=""></td>
|
||||
<td height=7>
|
||||
<img height=7 src="/img/dot.gif" alt=""></td>
|
||||
<td width=7 valign=top align=right>
|
||||
<img height=7 src="/img/corn_se.gif" alt=""></td>
|
||||
</tr>
|
||||
</table>
|
||||
|
||||
</CENTER>
|
||||
<=STANDOUT
|
||||
|
||||
CHOICE=>{P}<DT><A HREF="%%DATA2%%"><FONT FACE="Arial,Helvetica"><B>%%DATA1%%</B></FONT></A><DD><FONT SIZE="2">%%DATA3%%</FONT>
|
||||
|
||||
CHOICES<=
|
||||
{F}<TABLE WIDTH="100%" CELLPADDING="2" CELLSPACING="5">
|
||||
<TR>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMS%%
|
||||
</DL>
|
||||
</TD>
|
||||
<TD VALIGN=TOP WIDTH="50%">
|
||||
<DL>
|
||||
%%ITEMSB%%
|
||||
</DL>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
<=CHOICES
|
||||
|
||||
PAGE<=
|
||||
{F}<!DOCTYPE HTML PUBLIC "-//W3C//DTD HTML 3.2 Final//EN">
|
||||
<HTML>
|
||||
<HEAD>
|
||||
<TITLE>%%TITLE%% [LiveJournal.com]</TITLE>
|
||||
%%head%%
|
||||
</HEAD>
|
||||
<BODY BGCOLOR="#FFFFFF" %%bodyopts%%>
|
||||
|
||||
<CENTER>
|
||||
|
||||
<!-- BEGIN HEADER TABLE -->
|
||||
<TABLE WIDTH=520 CELLSPACING="0" CELLPADDING="0" BORDER="0">
|
||||
|
||||
<TR ALIGN=LEFT VALIGN=TOP>
|
||||
<TD WIDTH=520>
|
||||
<FONT FACE="Trebuchet MS, Arial, Helvetica" SIZE="+4" COLOR="#000066"><STRONG><EM>%%TITLE%%</EM></STRONG></FONT>
|
||||
</TD>
|
||||
</TR>
|
||||
<TR ALIGN=LEFT VALIGN=TOP>
|
||||
<TD WIDTH="520"><IMG SRC="/img/bluedot.gif" ALT="" WIDTH="520" HEIGHT="4" HSPACE="0" VSPACE="0" BORDER="0"><BR>
|
||||
<TABLE WIDTH="520" CELLSPACING="0" CELLPADDING="0" BORDER="0">
|
||||
<TR ALIGN=CENTER VALIGN=MIDDLE>
|
||||
<?_code
|
||||
@headers = (
|
||||
{ width => 55, href => "/", text => "Home" },
|
||||
{ width => 50, href => "/news.bml", text => "News" },
|
||||
{ width => 105, href => "/create.bml", text => "Create Journal" },
|
||||
{ width => 105, href => "/update.bml", text => "Update Journal" },
|
||||
{ width => 70, href => "/download/", text => "Download" },
|
||||
{ width => 75, href => "/directory.bml", text => "Directory" },
|
||||
{ width => 60, href => "/support.bml", text => "Support" },
|
||||
);
|
||||
|
||||
my $ret = "";
|
||||
my $uri = BML::get_uri();
|
||||
foreach $h (@headers)
|
||||
{
|
||||
if ($uri eq $h->{'href'})
|
||||
{
|
||||
$ret .= "<TD ALIGN=CENTER WIDTH=$h->{'width'} BGCOLOR=#000066><FONT FACE=\"Arial, Helvetica\" SIZE=-1 COLOR=#CCCCCC><STRONG>$h->{'text'}</STRONG></FONT><BR></TD>\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
$ret .= "<TD WIDTH=$h->{'width'} BGCOLOR=#6666CC><A HREF=\"$h->{'href'}\"><FONT FACE=\"Arial, Helvetica\" SIZE=-1 COLOR=#CCCCCC><STRONG>$h->{'text'}</STRONG></FONT></A></TD>\n";
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
_code?>
|
||||
</TR>
|
||||
<TR>
|
||||
<TD COLSPAN=7 ALIGN=RIGHT>
|
||||
<FONT SIZE=2 FACE="Verdana,Arial">
|
||||
<?_code
|
||||
if (BML::get_uri() =~ /^\/log(in|out)/) {
|
||||
return "";
|
||||
}
|
||||
|
||||
my $remote = LJ::get_remote();
|
||||
if ($remote) {
|
||||
return "<B>Logged in:</B> $remote->{'user'}, <A HREF=\"/logout.bml\">Logout</A>";
|
||||
} else {
|
||||
return "<B>Not Logged in.</B> <A HREF=\"/login.bml\">Login</A>";
|
||||
}
|
||||
_code?>
|
||||
</FONT>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
<!-- END HEADER TABLE -->
|
||||
|
||||
<BR>
|
||||
|
||||
<!-- BEGIN BODY TABLE -->
|
||||
<TABLE WIDTH=520 CELLSPACING="0" CELLPADDING="0" BORDER="0">
|
||||
<TR VALIGN=TOP VALIGN=LEFT>
|
||||
<TD WIDTH=520>
|
||||
<!-- BEGIN MAIN CONTENT -->
|
||||
|
||||
%%BODY%%
|
||||
|
||||
|
||||
<!-- END MAIN CONTENT -->
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
<!-- END BODY TABLE -->
|
||||
|
||||
</CENTER>
|
||||
|
||||
<P ALIGN=CENTER><CENTER>
|
||||
<BR>
|
||||
<!-- BEGIN FOOTER TABLE -->
|
||||
<TABLE WIDTH="630" CELLSPACING="0" CELLPADDING="0" BORDER="0">
|
||||
<TR ALIGN=CENTER VALIGN=TOP>
|
||||
<TD ALIGN=CENTER>
|
||||
<IMG SRC="/img/bluedot.gif" ALT="" WIDTH="350" HEIGHT="1" HSPACE="0" VSPACE="2" BORDER="0"><BR>
|
||||
<FONT FACE="Arial, Helvetica" SIZE="-2">
|
||||
<A HREF="/privacy.bml">Privacy Policy</A> -
|
||||
<A HREF="/coppa.bml">COPPA</A><BR>
|
||||
<A HREF="/disclaimer.bml">Legal Disclaimer</A> -
|
||||
<A HREF="/sitemap.bml">Site Map</A><BR>
|
||||
</FONT>
|
||||
</TD>
|
||||
</TR>
|
||||
</TABLE>
|
||||
<!-- END FOOTER TABLE -->
|
||||
|
||||
</CENTER>
|
||||
|
||||
</BODY>
|
||||
</HTML>
|
||||
<=PAGE
|
||||
|
||||
1021
livejournal/cgi-bin/cleanhtml.pl
Executable file
1021
livejournal/cgi-bin/cleanhtml.pl
Executable file
File diff suppressed because it is too large
Load Diff
522
livejournal/cgi-bin/communitylib.pl
Executable file
522
livejournal/cgi-bin/communitylib.pl
Executable file
@@ -0,0 +1,522 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package LJ;
|
||||
|
||||
use strict;
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::get_sent_invites
|
||||
# des: Get a list of sent invitations from the past 30 days.
|
||||
# args: cuserid
|
||||
# des-cuserid: a userid or u object of the community to get sent invitations for
|
||||
# returns: hashref of arrayrefs with keys userid, maintid, recvtime, status, args (itself
|
||||
# a hashref if what abilities the user would be given)
|
||||
# </LJFUNC>
|
||||
sub get_sent_invites {
|
||||
my $cu = shift;
|
||||
$cu = LJ::want_user($cu);
|
||||
return undef unless $cu;
|
||||
|
||||
# now hit the database for their recent invites
|
||||
my $dbcr = LJ::get_cluster_def_reader($cu);
|
||||
return LJ::error('db') unless $dbcr;
|
||||
my $data = $dbcr->selectall_arrayref('SELECT userid, maintid, recvtime, status, args FROM invitesent ' .
|
||||
'WHERE commid = ? AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $cu->{userid});
|
||||
|
||||
# now break data down into usable format for caller
|
||||
my @res;
|
||||
foreach my $row (@{$data || []}) {
|
||||
my $temp = {};
|
||||
LJ::decode_url_string($row->[4], $temp);
|
||||
push @res, {
|
||||
userid => $row->[0]+0,
|
||||
maintid => $row->[1]+0,
|
||||
recvtime => $row->[2],
|
||||
status => $row->[3],
|
||||
args => $temp,
|
||||
};
|
||||
}
|
||||
|
||||
# all done
|
||||
return \@res;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::send_comm_invite
|
||||
# des: Sends an invitation to a user to join a community with the passed abilities.
|
||||
# args: uuserid, cuserid, muserid, attrs
|
||||
# des-uuserid: a userid or u object of the user to invite
|
||||
# des-cuserid: a userid or u object of the community to invite the user to
|
||||
# des-muserid: a userid or u object of the maintainer doing the inviting
|
||||
# des-attrs: a hashref of abilities this user should have (e.g. member, post, unmoderated, ...)
|
||||
# returns: 1 for success, undef if failure
|
||||
# </LJFUNC>
|
||||
sub send_comm_invite {
|
||||
my ($u, $cu, $mu, $attrs) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$cu = LJ::want_user($cu);
|
||||
$mu = LJ::want_user($mu);
|
||||
return undef unless $u && $cu && $mu;
|
||||
|
||||
# step 1: if the user has banned the community, don't accept the invite
|
||||
return LJ::error('comm_user_has_banned') if LJ::is_banned($cu, $u);
|
||||
|
||||
# step 2: outstanding invite?
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
return LJ::error('db') unless $dbcr;
|
||||
my $argstr = $dbcr->selectrow_array('SELECT args FROM inviterecv WHERE userid = ? AND commid = ? ' .
|
||||
'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $u->{userid}, $cu->{userid});
|
||||
|
||||
# step 3: exceeded outstanding invitation limit? only if no outstanding invite
|
||||
unless ($argstr) {
|
||||
my $cdbcr = LJ::get_cluster_def_reader($cu);
|
||||
return LJ::error('db') unless $cdbcr;
|
||||
my $count = $cdbcr->selectrow_array("SELECT COUNT(*) FROM invitesent WHERE commid = ? AND userid <> ? AND status = 'outstanding'",
|
||||
undef, $cu->{userid}, $u->{userid});
|
||||
my $fr = LJ::get_friends($cu) || {};
|
||||
my $max = int(scalar(keys %$fr) / 10); # can invite up to 1/10th of the community
|
||||
$max = 50 if $max < 50; # or 50, whichever is greater
|
||||
return LJ::error('comm_invite_limit') if $count > $max;
|
||||
}
|
||||
|
||||
# step 4: setup arg string as url-encoded string
|
||||
my $newargstr = join('=1&', map { LJ::eurl($_) } @$attrs) . '=1';
|
||||
|
||||
# step 5: delete old stuff (lazy cleaning of invite tables)
|
||||
return LJ::error('db') unless $u->writer;
|
||||
$u->do('DELETE FROM inviterecv WHERE userid = ? AND ' .
|
||||
'recvtime < UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $u->{userid});
|
||||
|
||||
return LJ::error('db') unless $cu->writer;
|
||||
$cu->do('DELETE FROM invitesent WHERE commid = ? AND ' .
|
||||
'recvtime < UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $cu->{userid});
|
||||
|
||||
# step 6: branch here to update or insert
|
||||
if ($argstr) {
|
||||
# merely an update, so just do it quietly
|
||||
$u->do("UPDATE inviterecv SET args = ? WHERE userid = ? AND commid = ?",
|
||||
undef, $newargstr, $u->{userid}, $cu->{userid});
|
||||
|
||||
$cu->do("UPDATE invitesent SET args = ?, status = 'outstanding' WHERE userid = ? AND commid = ?",
|
||||
undef, $newargstr, $cu->{userid}, $u->{userid});
|
||||
} else {
|
||||
# insert new data, as this is a new invite
|
||||
$u->do("INSERT INTO inviterecv VALUES (?, ?, ?, UNIX_TIMESTAMP(), ?)",
|
||||
undef, $u->{userid}, $cu->{userid}, $mu->{userid}, $newargstr);
|
||||
|
||||
$cu->do("REPLACE INTO invitesent VALUES (?, ?, ?, UNIX_TIMESTAMP(), 'outstanding', ?)",
|
||||
undef, $cu->{userid}, $u->{userid}, $mu->{userid}, $newargstr);
|
||||
}
|
||||
|
||||
# step 7: error check database work
|
||||
return LJ::error('db') if $u->err || $cu->err;
|
||||
|
||||
# success
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::accept_comm_invite
|
||||
# des: Accepts an invitation a user has received. This does all the work to make the
|
||||
# user join the community as well as sets up privileges.
|
||||
# args: uuserid, cuserid
|
||||
# des-uuserid: a userid or u object of the user to get pending invites for
|
||||
# des-cuserid: a userid or u object of the community to reject the invitation from
|
||||
# returns: 1 for success, undef if failure
|
||||
# </LJFUNC>
|
||||
sub accept_comm_invite {
|
||||
my ($u, $cu) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$cu = LJ::want_user($cu);
|
||||
return undef unless $u && $cu;
|
||||
|
||||
# get their invite to make sure they have one
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
return LJ::error('db') unless $dbcr;
|
||||
my $argstr = $dbcr->selectrow_array('SELECT args FROM inviterecv WHERE userid = ? AND commid = ? ' .
|
||||
'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $u->{userid}, $cu->{userid});
|
||||
return undef unless $argstr;
|
||||
|
||||
# decode to find out what they get
|
||||
my $args = {};
|
||||
LJ::decode_url_string($argstr, $args);
|
||||
|
||||
# valid invite. let's accept it as far as the community listing us goes.
|
||||
# 0, 0 means don't add comm to user's friends list, and don't auto-add P edge.
|
||||
LJ::join_community($u, $cu, 0, 0) if $args->{member};
|
||||
|
||||
# now grant necessary abilities
|
||||
my %edgelist = (
|
||||
post => 'P',
|
||||
preapprove => 'N',
|
||||
moderate => 'M',
|
||||
admin => 'A',
|
||||
);
|
||||
foreach (keys %edgelist) {
|
||||
LJ::set_rel($cu->{userid}, $u->{userid}, $edgelist{$_}) if $args->{$_};
|
||||
}
|
||||
|
||||
# now we can delete the invite and update the status on the other side
|
||||
return LJ::error('db') unless $u->writer;
|
||||
$u->do("DELETE FROM inviterecv WHERE userid = ? AND commid = ?",
|
||||
undef, $u->{userid}, $cu->{userid});
|
||||
|
||||
return LJ::error('db') unless $cu->writer;
|
||||
$cu->do("UPDATE invitesent SET status = 'accepted' WHERE commid = ? AND userid = ?",
|
||||
undef, $cu->{userid}, $u->{userid});
|
||||
|
||||
# done
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::reject_comm_invite
|
||||
# des: Rejects an invitation a user has received.
|
||||
# args: uuserid, cuserid
|
||||
# des-uuserid: a userid or u object of the user to get pending invites for
|
||||
# des-cuserid: a userid or u object of the community to reject the invitation from
|
||||
# returns: 1 for success, undef if failure
|
||||
# </LJFUNC>
|
||||
sub reject_comm_invite {
|
||||
my ($u, $cu) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$cu = LJ::want_user($cu);
|
||||
return undef unless $u && $cu;
|
||||
|
||||
# get their invite to make sure they have one
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
return LJ::error('db') unless $dbcr;
|
||||
my $test = $dbcr->selectrow_array('SELECT userid FROM inviterecv WHERE userid = ? AND commid = ? ' .
|
||||
'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $u->{userid}, $cu->{userid});
|
||||
return undef unless $test;
|
||||
|
||||
# now just reject it
|
||||
return LJ::error('db') unless $u->writer;
|
||||
$u->do("DELETE FROM inviterecv WHERE userid = ? AND commid = ?",
|
||||
undef, $u->{userid}, $cu->{userid});
|
||||
|
||||
return LJ::error('db') unless $cu->writer;
|
||||
$cu->do("UPDATE invitesent SET status = 'rejected' WHERE commid = ? AND userid = ?",
|
||||
undef, $cu->{userid}, $u->{userid});
|
||||
|
||||
# done
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::get_pending_invites
|
||||
# des: Gets a list of pending invitations for a user to join a community.
|
||||
# args: uuserid
|
||||
# des-uuserid: a userid or u object of the user to get pending invites for
|
||||
# returns: [ [ commid, maintainerid, time, args(url encoded) ], [ ... ], ... ] or
|
||||
# undef if failure
|
||||
# </LJFUNC>
|
||||
sub get_pending_invites {
|
||||
my $u = shift;
|
||||
$u = LJ::want_user($u);
|
||||
return undef unless $u;
|
||||
|
||||
# hit up database for invites and return them
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
return LJ::error('db') unless $dbcr;
|
||||
my $pending = $dbcr->selectall_arrayref('SELECT commid, maintid, recvtime, args FROM inviterecv WHERE userid = ? ' .
|
||||
'AND recvtime > UNIX_TIMESTAMP(DATE_SUB(NOW(), INTERVAL 30 DAY))',
|
||||
undef, $u->{userid});
|
||||
return undef if $dbcr->err;
|
||||
return $pending;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::leave_community
|
||||
# des: Makes a user leave a community. Takes care of all reluser and friend stuff.
|
||||
# args: uuserid, ucommid, defriend
|
||||
# des-uuserid: a userid or u object of the user doing the leaving
|
||||
# des-ucommid: a userid or u object of the community being left
|
||||
# des-defriend: remove comm from user's friends list
|
||||
# returns: 1 if success, undef if error of some sort (ucommid not a comm, uuserid not in
|
||||
# comm, db error, etc)
|
||||
# </LJFUNC>
|
||||
sub leave_community {
|
||||
my ($uuid, $ucid, $defriend) = @_;
|
||||
my $u = LJ::want_user($uuid);
|
||||
my $cu = LJ::want_user($ucid);
|
||||
$defriend = $defriend ? 1 : 0;
|
||||
return LJ::error('comm_not_found') unless $u && $cu;
|
||||
|
||||
# defriend comm -> user
|
||||
return LJ::error('comm_not_comm') unless $cu->{journaltype} =~ /[CS]/;
|
||||
my $ret = LJ::remove_friend($cu->{userid}, $u->{userid});
|
||||
return LJ::error('comm_not_member') unless $ret; # $ret = number of rows deleted, should be 1 if the user was in the comm
|
||||
|
||||
# clear edges that effect this relationship
|
||||
foreach my $edge (qw(P N A M)) {
|
||||
LJ::clear_rel($cu->{userid}, $u->{userid}, $edge);
|
||||
}
|
||||
|
||||
# defriend user -> comm?
|
||||
return 1 unless $defriend;
|
||||
LJ::remove_friend($u, $cu);
|
||||
|
||||
# don't care if we failed the removal of comm from user's friends list...
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::join_community
|
||||
# des: Makes a user join a community. Takes care of all reluser and friend stuff.
|
||||
# args: uuserid, ucommid, friend?, noauto?
|
||||
# des-uuserid: a userid or u object of the user doing the joining
|
||||
# des-ucommid: a userid or u object of the community being joined
|
||||
# des-friend: 1 to add this comm to user's friends list, else not
|
||||
# des-noauto: if defined, 1 adds P edge, 0 does not; else, base on community postlevel
|
||||
# returns: 1 if success, undef if error of some sort (ucommid not a comm, uuserid already in
|
||||
# comm, db error, etc)
|
||||
# </LJFUNC>
|
||||
sub join_community {
|
||||
my ($uuid, $ucid, $friend, $canpost) = @_;
|
||||
my $u = LJ::want_user($uuid);
|
||||
my $cu = LJ::want_user($ucid);
|
||||
$friend = $friend ? 1 : 0;
|
||||
return LJ::error('comm_not_found') unless $u && $cu;
|
||||
return LJ::error('comm_not_comm') unless $cu->{journaltype} eq 'C';
|
||||
|
||||
# friend comm -> user
|
||||
LJ::add_friend($cu->{userid}, $u->{userid});
|
||||
|
||||
# add edges that effect this relationship... if the user sent a fourth
|
||||
# argument, use that as a bool. else, load commrow and use the postlevel.
|
||||
my $addpostacc = 0;
|
||||
if (defined $canpost) {
|
||||
$addpostacc = $canpost ? 1 : 0;
|
||||
} else {
|
||||
my $crow = LJ::get_community_row($cu);
|
||||
$addpostacc = $crow->{postlevel} eq 'members' ? 1 : 0;
|
||||
}
|
||||
LJ::set_rel($cu->{userid}, $u->{userid}, 'P') if $addpostacc;
|
||||
|
||||
# friend user -> comm?
|
||||
return 1 unless $friend;
|
||||
LJ::add_friend($u->{userid}, $cu->{userid}, { defaultview => 1 });
|
||||
|
||||
# done
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::get_community_row
|
||||
# des: Gets data relevant to a community such as their membership level and posting access.
|
||||
# args: ucommid
|
||||
# des-ucommid: a userid or u object of the community
|
||||
# returns: a hashref with user, userid, name, membership, and postlevel data from the
|
||||
# user and community tables; undef if error
|
||||
# </LJFUNC>
|
||||
sub get_community_row {
|
||||
my $ucid = shift;
|
||||
my $cu = LJ::want_user($ucid);
|
||||
return unless $cu;
|
||||
|
||||
# hit up database
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my ($membership, $postlevel) =
|
||||
$dbr->selectrow_array('SELECT membership, postlevel FROM community WHERE userid=?',
|
||||
undef, $cu->{userid});
|
||||
return if $dbr->err;
|
||||
return unless $membership && $postlevel;
|
||||
|
||||
# return result hashref
|
||||
my $row = {
|
||||
user => $cu->{user},
|
||||
userid => $cu->{userid},
|
||||
name => $cu->{name},
|
||||
membership => $membership,
|
||||
postlevel => $postlevel,
|
||||
};
|
||||
return $row;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::get_pending_members
|
||||
# des: Gets a list of userids for people that have requested to be added to a community
|
||||
# but haven't yet actually been approved or rejected.
|
||||
# args: comm
|
||||
# des-comm: a userid or u object of the community to get pending members of
|
||||
# returns: an arrayref of userids of people with pending membership requests
|
||||
# </LJFUNC>
|
||||
sub get_pending_members {
|
||||
my $comm = shift;
|
||||
my $cu = LJ::want_user($comm);
|
||||
|
||||
# database request
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $args = $dbr->selectcol_arrayref('SELECT arg1 FROM authactions WHERE userid = ? ' .
|
||||
"AND action = 'comm_join_request' AND used = 'N'",
|
||||
undef, $cu->{userid}) || [];
|
||||
|
||||
# parse out the args
|
||||
my @list;
|
||||
foreach (@$args) {
|
||||
push @list, $1+0 if $_ =~ /^targetid=(\d+)$/;
|
||||
}
|
||||
return \@list;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::approve_pending_member
|
||||
# des: Approves someone's request to join a community. This updates the authactions table
|
||||
# as appropriate as well as does the regular join logic. This also generates an email to
|
||||
# be sent to the user notifying them of the acceptance.
|
||||
# args: commid, userid
|
||||
# des-commid: userid of the community
|
||||
# des-userid: userid of the user doing the join
|
||||
# returns: 1 on success, 0/undef on error
|
||||
# </LJFUNC>
|
||||
sub approve_pending_member {
|
||||
my ($commid, $userid) = @_;
|
||||
my $cu = LJ::want_user($commid);
|
||||
my $u = LJ::want_user($userid);
|
||||
return unless $cu && $u;
|
||||
|
||||
# step 1, update authactions table
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $count = $dbh->do("UPDATE authactions SET used = 'Y' WHERE userid = ? AND arg1 = ?",
|
||||
undef, $cu->{userid}, "targetid=$u->{userid}");
|
||||
return unless $count;
|
||||
|
||||
# step 2, make user join the community
|
||||
return unless LJ::join_community($u->{userid}, $cu->{userid});
|
||||
|
||||
# step 3, email the user
|
||||
my $email = "Dear $u->{name},\n\n" .
|
||||
"Your request to join the \"$cu->{user}\" community has been approved. If you " .
|
||||
"wish to add this community to your friends page reading list, click the link below.\n\n" .
|
||||
"\t$LJ::SITEROOT/friends/add.bml?user=$cu->{user}\n\n" .
|
||||
"Regards,\n$LJ::SITENAME Team";
|
||||
LJ::send_mail({
|
||||
to => $u->{email},
|
||||
from => $LJ::COMMUNITY_EMAIL,
|
||||
fromname => $LJ::SITENAME,
|
||||
charset => 'utf-8',
|
||||
subject => "Your Request to Join $cu->{user}",
|
||||
body => $email,
|
||||
});
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::reject_pending_member
|
||||
# des: Rejects someone's request to join a community. Updates authactions and generates
|
||||
# an email to the user.
|
||||
# args: commid, userid
|
||||
# des-commid: userid of the community
|
||||
# des-userid: userid of the user doing the join
|
||||
# returns: 1 on success, 0/undef on error
|
||||
# </LJFUNC>
|
||||
sub reject_pending_member {
|
||||
my ($commid, $userid) = @_;
|
||||
my $cu = LJ::want_user($commid);
|
||||
my $u = LJ::want_user($userid);
|
||||
return unless $cu && $u;
|
||||
|
||||
# step 1, update authactions table
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $count = $dbh->do("UPDATE authactions SET used = 'Y' WHERE userid = ? AND arg1 = ?",
|
||||
undef, $cu->{userid}, "targetid=$u->{userid}");
|
||||
return unless $count;
|
||||
|
||||
# step 2, email the user
|
||||
my $email = "Dear $u->{name},\n\n" .
|
||||
"Your request to join the \"$cu->{user}\" community has been declined. You " .
|
||||
"may wish to contact the maintainer(s) of this community if you are still " .
|
||||
"interested in joining.\n\n" .
|
||||
"Regards,\n$LJ::SITENAME Team";
|
||||
LJ::send_mail({
|
||||
to => $u->{email},
|
||||
from => $LJ::COMMUNITY_EMAIL,
|
||||
fromname => $LJ::SITENAME,
|
||||
charset => 'utf-8',
|
||||
subject => "Your Request to Join $cu->{user}",
|
||||
body => $email,
|
||||
});
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::comm_join_request
|
||||
# des: Registers an authaction to add a user to a
|
||||
# community and sends an approval email to the maintainers
|
||||
# returns: Hashref; output of LJ::register_authaction()
|
||||
# includes datecreate of old row if no new row was created
|
||||
# args: comm, u
|
||||
# des-comm: Community user object
|
||||
# des-u: User object to add to community
|
||||
# </LJFUNC>
|
||||
sub comm_join_request {
|
||||
my ($comm, $u) = @_;
|
||||
return undef unless ref $comm && ref $u;
|
||||
|
||||
my $arg = "targetid=$u->{userid}";
|
||||
my $dbh = LJ::get_db_writer();
|
||||
|
||||
# check for duplicates within the same hour (to prevent spamming)
|
||||
my $oldaa = $dbh->selectrow_hashref("SELECT aaid, authcode, datecreate FROM authactions " .
|
||||
"WHERE userid=? AND arg1=? " .
|
||||
"AND action='comm_join_request' AND used='N' " .
|
||||
"AND NOW() < datecreate + INTERVAL 1 HOUR " .
|
||||
"ORDER BY 1 DESC LIMIT 1",
|
||||
undef, $comm->{'userid'}, $arg);
|
||||
return $oldaa if $oldaa;
|
||||
|
||||
# insert authactions row
|
||||
my $aa = LJ::register_authaction($comm->{'userid'}, 'comm_join_request', $arg);
|
||||
return undef unless $aa;
|
||||
|
||||
# if there are older duplicates, invalidate any existing unused authactions of this type
|
||||
$dbh->do("UPDATE authactions SET used='Y' WHERE userid=? AND aaid<>? AND arg1=? " .
|
||||
"AND action='comm_invite' AND used='N'",
|
||||
undef, $comm->{'userid'}, $aa->{'aaid'}, $arg);
|
||||
|
||||
# get maintainers of community
|
||||
my $adminids = LJ::load_rel_user($comm->{userid}, 'A') || [];
|
||||
my $admins = LJ::load_userids(@$adminids);
|
||||
|
||||
# now prepare the emails
|
||||
my %dests;
|
||||
my $cuser = $comm->{user};
|
||||
foreach my $au (values %$admins) {
|
||||
next if $dests{$au->{email}}++;
|
||||
LJ::load_user_props($au, 'opt_communityjoinemail');
|
||||
next if $au->{opt_communityjoinemail} =~ /[DN]/; # Daily, None
|
||||
|
||||
my $body = "Dear $au->{name},\n\n" .
|
||||
"The user \"$u->{user}\" has requested to join the \"$cuser\" community. If you wish " .
|
||||
"to add this user to your community, please click this link:\n\n" .
|
||||
"\t$LJ::SITEROOT/approve/$aa->{aaid}.$aa->{authcode}\n\n" .
|
||||
"Alternately, to approve or reject all outstanding membership requests at the same time, " .
|
||||
"visit the community member management page:\n\n" .
|
||||
"\t$LJ::SITEROOT/community/pending.bml?comm=$cuser\n\n" .
|
||||
"You may also ignore this e-mail. The request to join will expire after a period of 30 days.\n\n" .
|
||||
"If you wish to no longer receive these e-mails, visit the community management page and " .
|
||||
"set the relevant options:\n\n\t$LJ::SITEROOT/community/manage.bml\n\n" .
|
||||
"Regards,\n$LJ::SITENAME Team\n";
|
||||
|
||||
LJ::send_mail({
|
||||
to => $au->{email},
|
||||
from => $LJ::COMMUNITY_EMAIL,
|
||||
fromname => $LJ::SITENAME,
|
||||
charset => 'utf-8',
|
||||
subject => "$cuser Membership Request by $u->{user}",
|
||||
body => $body,
|
||||
wrap => 76,
|
||||
});
|
||||
}
|
||||
|
||||
return $aa;
|
||||
}
|
||||
|
||||
1;
|
||||
146
livejournal/cgi-bin/conban.pl
Executable file
146
livejournal/cgi-bin/conban.pl
Executable file
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Con;
|
||||
|
||||
$cmd{'ban_set'}->{'handler'} = \&ban_set_unset;
|
||||
$cmd{'ban_unset'}->{'handler'} = \&ban_set_unset;
|
||||
$cmd{'ban_list'}->{'handler'} = \&ban_list;
|
||||
|
||||
sub ban_list
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless ($remote) {
|
||||
push @$out, [ "error", "You must be logged in to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# journal to list from
|
||||
my $j = $remote;
|
||||
|
||||
unless ($remote->{'journaltype'} eq "P") {
|
||||
push @$out, [ "error", "Only people can list banned users, not communities (you're not logged in as a person account)." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (scalar(@$args) == 3) {
|
||||
unless ($args->[1] eq "from") {
|
||||
push @$out, [ "error", "First argument not 'from'." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
$j = LJ::load_user($args->[2]);
|
||||
if (!$j) {
|
||||
push @$out, [ "error", "Unknown account." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless (LJ::check_priv($remote, "finduser")) {
|
||||
if ($j->{journaltype} ne 'C') {
|
||||
push @$out, [ "error", "Account is not a community." ];
|
||||
return 0;
|
||||
} elsif (!LJ::can_manage($remote, $j)) {
|
||||
push @$out, [ "error", "Not maintainer of this community." ];
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my $banids = LJ::load_rel_user($j->{userid}, 'B') || [];
|
||||
my $us = LJ::load_userids(@$banids);
|
||||
my @userlist = map { $us->{$_}{user} } keys %$us;
|
||||
|
||||
foreach my $username (@userlist) {
|
||||
push @$out, [ 'info', $username ];
|
||||
}
|
||||
push @$out, [ "info", "$j->{user} has not banned any other users." ] unless @userlist;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub ban_set_unset
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
my $error = 0;
|
||||
|
||||
unless ($remote) {
|
||||
push @$out, [ "error", "You must be logged in to use this command" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# journal to ban from:
|
||||
my $j;
|
||||
|
||||
unless ($remote->{'journaltype'} eq "P") {
|
||||
push @$out, [ "error", "Only people can ban other users, not communities (you're not logged in as a person account)." ],
|
||||
return 0;
|
||||
}
|
||||
|
||||
if (scalar(@$args) == 4) {
|
||||
unless ($args->[2] eq "from") {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "2nd argument not 'from'" ];
|
||||
}
|
||||
|
||||
$j = LJ::load_user($args->[3]);
|
||||
if (! $j) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Unknown community." ],
|
||||
} elsif (! LJ::can_manage_other($remote, $j)) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Not maintainer of this community." ],
|
||||
}
|
||||
|
||||
} else {
|
||||
if (scalar(@$args) == 2) {
|
||||
# banning from the remote user's journal
|
||||
$j = $remote;
|
||||
} else {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "This form of the command takes exactly 1 argument. Consult the reference." ];
|
||||
}
|
||||
}
|
||||
|
||||
return 0 if ($error);
|
||||
|
||||
my $user = $args->[1];
|
||||
my $banid = LJ::get_userid($dbh, $user);
|
||||
|
||||
unless ($banid) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid user \"$user\"" ];
|
||||
}
|
||||
|
||||
return 0 if ($error);
|
||||
|
||||
my $qbanid = $banid+0;
|
||||
my $quserid = $j->{'userid'}+0;
|
||||
|
||||
# exceeded ban limit?
|
||||
if ($args->[0] eq 'ban_set') {
|
||||
my $banlist = LJ::load_rel_user($quserid, 'B') || [];
|
||||
if (scalar(@$banlist) >= ($LJ::MAX_BANS || 5000)) {
|
||||
push @$out, [ "error", "You have reached the maximum number of bans. Unban someone and try again." ];
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
if ($args->[0] eq "ban_set") {
|
||||
LJ::set_rel($quserid, $qbanid, 'B');
|
||||
$j->log_event('ban_set', { actiontarget => $banid, remote => $remote });
|
||||
push @$out, [ "info", "User $user ($banid) banned from $j->{'user'}." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($args->[0] eq "ban_unset") {
|
||||
LJ::clear_rel($quserid, $qbanid, 'B');
|
||||
$j->log_event('ban_unset', { actiontarget => $banid, remote => $remote });
|
||||
push @$out, [ "info", "User $user ($banid) un-banned from $j->{'user'}." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
164
livejournal/cgi-bin/confaq.pl
Executable file
164
livejournal/cgi-bin/confaq.pl
Executable file
@@ -0,0 +1,164 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Con;
|
||||
|
||||
$cmd{'faqcat'}->{'handler'} = \&faqcat;
|
||||
|
||||
sub faqcat
|
||||
{
|
||||
# add <catkey> <catname> <catorder>
|
||||
# REPLACE INTO faqcat (faqcat, faqcatname, catorder) VALUES ($catkey, $catname, $catorder)
|
||||
# delete <catkey>
|
||||
# DELETE FROM faqcat WHERE faqcat = $catkey
|
||||
# list
|
||||
# SELECT * FROM faqcat ORDER BY sortorder
|
||||
# move <faqcat> {"up"|"down"}
|
||||
# two UPDATEs faqcat SET catorder$catorder WHERE faqcat = $catkey
|
||||
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
my $command = $args->[1];
|
||||
|
||||
## the following commands doesn't require any priv.
|
||||
|
||||
if ($command eq "list") {
|
||||
my %catdefined;
|
||||
my $sth = $dbh->prepare("SELECT faqcat, faqcatname, catorder FROM faqcat ORDER BY catorder");
|
||||
$sth->execute;
|
||||
push @$out, [ "", sprintf("%-20s %-45s %s", "catkey", "catname", "order" ) ];
|
||||
push @$out, [ "", "-"x76 ];
|
||||
while (my ($faqcat, $faqcatname, $catorder) = $sth->fetchrow_array)
|
||||
{
|
||||
$catdefined{$faqcat} = 1;
|
||||
push @$out, [ "", sprintf("%-20s %-45s %5d",
|
||||
$faqcat,
|
||||
$faqcatname,
|
||||
$catorder ) ];
|
||||
}
|
||||
$sth->finish;
|
||||
|
||||
push @$out, [ "", "" ];
|
||||
push @$out, [ "", "catkeys currently in use:" ];
|
||||
push @$out, [ "", "-------------------------" ];
|
||||
|
||||
$sth = $dbh->prepare("SELECT faqcat, COUNT(*) FROM faq GROUP BY 1");
|
||||
$sth->execute;
|
||||
while (my ($faqcat, $count) = $sth->fetchrow_array)
|
||||
{
|
||||
my $state = $catdefined{$faqcat} ? "" : "error";
|
||||
push @$out, [ $state, sprintf("%-15s by %5d", $faqcat, $count) ];
|
||||
}
|
||||
$sth->finish;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($command eq "showused") {
|
||||
my $sth = $dbh->prepare("SELECT faqcat, faqcatname, catorder FROM faqcat ORDER BY catorder");
|
||||
$sth->execute;
|
||||
push @$out, [ "", sprintf("%-20s %-45s %3d", "catkey", "catname", "order" ) ];
|
||||
push @$out, [ "", "-"x76 ];
|
||||
while (my ($faqcat, $faqcatname, $catorder) = $sth->fetchrow_array)
|
||||
{
|
||||
push @$out, [ "", sprintf("%-20s %-45s %3d",
|
||||
$faqcat,
|
||||
$faqcatname,
|
||||
$catorder ) ];
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
### everything from here on down requires the "faqcat" priv.
|
||||
|
||||
unless ($remote->{'priv'}->{'faqcat'})
|
||||
{
|
||||
push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
if ($command eq "delete") {
|
||||
my $catkey = $dbh->quote($args->[2]);
|
||||
my $sth = $dbh->prepare("DELETE FROM faqcat WHERE faqcat=$catkey");
|
||||
$sth->execute;
|
||||
if ($sth->rows) {
|
||||
push @$out, [ "info", "Category Deleted" ];
|
||||
} else {
|
||||
push @$out, [ "info", "Category didn't exist to be deleted." ];
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($command eq "add") {
|
||||
my $catkey = $dbh->quote($args->[2]);
|
||||
my $catname = $dbh->quote($args->[3]);
|
||||
my $catorder = ($args->[4])+0;
|
||||
|
||||
my $faqd = LJ::Lang::get_dom("faq");
|
||||
my $rlang = LJ::Lang::get_root_lang($faqd);
|
||||
unless ($rlang) { undef $faqd; }
|
||||
if ($faqd) {
|
||||
LJ::Lang::set_text($dbh, $faqd->{'dmid'}, $rlang->{'lncode'},
|
||||
"cat.$args->[2]", $args->[3], { 'changeseverity' => 1 });
|
||||
}
|
||||
|
||||
my $sth = $dbh->prepare("REPLACE INTO faqcat (faqcat, faqcatname, catorder) ".
|
||||
"VALUES ($catkey, $catname, $catorder)");
|
||||
$sth->execute;
|
||||
push @$out, [ "info", "Catagory added/changed." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
if ($command eq "move") {
|
||||
my $catkey = $args->[2];
|
||||
my $dir = $args->[3];
|
||||
unless ($dir eq "up" || $dir eq "down") {
|
||||
push @$out, [ "error", "Direction argument must be up or down." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my %pre; # catkey -> key before
|
||||
my %post; # catkey -> key after
|
||||
my %catorder; # catkey -> order
|
||||
|
||||
my $sth = $dbh->prepare("SELECT faqcat, catorder FROM faqcat ORDER BY catorder");
|
||||
$sth->execute;
|
||||
my $last;
|
||||
while (my ($key, $order) = $sth->fetchrow_array) {
|
||||
push @cats, $key;
|
||||
$catorder{$key} = $order;
|
||||
$post{$last} = $key;
|
||||
$pre{$key} = $last;
|
||||
$last = $key;
|
||||
}
|
||||
|
||||
my %new; # catkey -> new order
|
||||
if ($dir eq "up" && $pre{$catkey}) {
|
||||
$new{$catkey} = $catorder{$pre{$catkey}};
|
||||
$new{$pre{$catkey}} = $catorder{$catkey};
|
||||
}
|
||||
if ($dir eq "down" && $post{$catkey}) {
|
||||
$new{$catkey} = $catorder{$post{$catkey}};
|
||||
$new{$post{$catkey}} = $catorder{$catkey};
|
||||
}
|
||||
if (%new) {
|
||||
foreach my $n (keys %new) {
|
||||
my $qk = $dbh->quote($n);
|
||||
my $co = $new{$n}+0;
|
||||
$dbh->do("UPDATE faqcat SET catorder=$co WHERE faqcat=$qk");
|
||||
}
|
||||
push @$out, [ "info", "Category order changed" ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
push @$out, [ "info", "Category can't move $dir anymore." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
push @$out, [ "error", "No Such option \'$command\'" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
182
livejournal/cgi-bin/conmoodtheme.pl
Executable file
182
livejournal/cgi-bin/conmoodtheme.pl
Executable file
@@ -0,0 +1,182 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Con;
|
||||
|
||||
$cmd{'moodtheme_create'}->{'handler'} = \&moodtheme_create;
|
||||
$cmd{'moodtheme_public'}->{'handler'} = \&moodtheme_public;
|
||||
$cmd{'moodtheme_setpic'}->{'handler'} = \&moodtheme_setpic;
|
||||
$cmd{'moodtheme_list'}->{'handler'} = \&moodtheme_list;
|
||||
|
||||
sub moodtheme_list
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
if (scalar(@$args) > 2) {
|
||||
push @$out, [ "error", "This command takes only 1 optional argument. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($id) = ($args->[1]+0);
|
||||
my $sth;
|
||||
|
||||
if ($id) {
|
||||
|
||||
$sth = $dbh->prepare("SELECT m.mood, md.moodid, md.picurl, md.width, md.height FROM moodthemedata md, moods m WHERE md.moodid=m.moodid AND md.moodthemeid=$id ORDER BY m.mood");
|
||||
$sth->execute;
|
||||
while (my ($mood, $moodid, $picurl, $w, $h) = $sth->fetchrow_array) {
|
||||
push @$out, [ "", sprintf("%-20s %2dx%2d %s", "$mood ($moodid)", $w, $h, $picurl) ];
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
push @$out, [ "", sprintf("%3s %4s %-15s %-25s %s", "pub", "id# ", "owner", "theme name", "des") ];
|
||||
push @$out, [ "", "-"x80 ];
|
||||
my $passes = 1;
|
||||
if ($remote) { $passes=2; }
|
||||
for (my $pass=1; $pass<=$passes ; $pass++) {
|
||||
if ($pass==1) {
|
||||
push @$out, [ "info", "Public themes:" ];
|
||||
$sth = $dbh->prepare("SELECT mt.moodthemeid, u.user, mt.is_public, mt.name, mt.des FROM moodthemes mt, user u WHERE mt.ownerid=u.userid AND mt.is_public='Y' ORDER BY mt.moodthemeid");
|
||||
} else {
|
||||
push @$out, [ "info", "Your themes:" ];
|
||||
$sth = $dbh->prepare("SELECT mt.moodthemeid, u.user, mt.is_public, mt.name, mt.des FROM moodthemes mt, user u WHERE mt.ownerid=u.userid AND mt.ownerid=$remote->{'userid'} ORDER BY mt.moodthemeid");
|
||||
}
|
||||
$sth->execute;
|
||||
if ($dbh->err) { push @$out, [ "error", $dbh->errstr ]; };
|
||||
while (my ($id, $user, $pub, $name, $des) = $sth->fetchrow_array) {
|
||||
push @$out, [ "", sprintf("%3s %4s %-15s %-25s %s", $pub ? " X " : "", $id, $user, $name, $des) ];
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub moodtheme_create
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless (scalar(@$args) == 3) {
|
||||
push @$out, [ "error", "This command takes exactly 2 arguments. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($remote) {
|
||||
push @$out, [ "error", "You have to be logged in to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $u = LJ::load_userid($remote->{'userid'});
|
||||
unless (LJ::get_cap($u, "moodthemecreate")) {
|
||||
push @$out, [ "error", "Sorry, your account type doesn't let you create new mood themes." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($name, $des) = ($args->[1], $args->[2]);
|
||||
my $qname = $dbh->quote($name);
|
||||
my $qdes = $dbh->quote($des);
|
||||
|
||||
$sth = $dbh->prepare("INSERT INTO moodthemes (ownerid, name, des, is_public) VALUES ($remote->{'userid'}, $qname, $qdes, 'N')");
|
||||
$sth->execute;
|
||||
my $mtid = $dbh->{'mysql_insertid'};
|
||||
push @$out, [ "info", "Success. Your new moodthemeid = $mtid" ];
|
||||
}
|
||||
|
||||
sub moodtheme_public
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless ($remote->{'priv'}->{'moodthememanager'}) {
|
||||
push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless (scalar(@$args) == 3) {
|
||||
push @$out, [ "error", "This command takes exactly 2 arguments. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($themeid, $setting) = ($args->[1], $args->[2]);
|
||||
|
||||
unless ($setting eq 'Y' || $setting eq 'N') {
|
||||
push @$out, [ "error", "Setting must be either 'Y' or 'N'." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
$themeid += 0;
|
||||
|
||||
my $sth;
|
||||
$sth = $dbh->prepare("SELECT is_public FROM moodthemes WHERE moodthemeid=$themeid");
|
||||
$sth->execute;
|
||||
my ($old_value) = $sth->fetchrow_array;
|
||||
unless ($old_value) {
|
||||
push @$out, [ "error", "This theme doesn't seem to exist." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($old_value eq $setting) {
|
||||
push @$out, [ "info", "Public setting not changed (already set to '$setting')" ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $qsetting = $dbh->quote($setting);
|
||||
$dbh->do("UPDATE moodthemes SET is_public=$qsetting WHERE moodthemeid=$themeid");
|
||||
|
||||
push @$out, [ "info", "Public setting changed." ];
|
||||
}
|
||||
|
||||
sub moodtheme_setpic
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless (scalar(@$args) == 6) {
|
||||
push @$out, [ "error", "This command takes exactly 5 arguments. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($remote) {
|
||||
push @$out, [ "error", "You have to be logged in to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $u = LJ::load_userid($remote->{'userid'});
|
||||
unless (LJ::get_cap($u, "moodthemecreate")) {
|
||||
push @$out, [ "error", "Sorry, your account type doesn't let you modify mood themes." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($themeid, $moodid, $picurl, $width, $height) =
|
||||
($args->[1], $args->[2], $args->[3], $args->[4], $args->[5]);
|
||||
|
||||
$themeid += 0;
|
||||
|
||||
my $sth;
|
||||
$sth = $dbh->prepare("SELECT ownerid FROM moodthemes WHERE moodthemeid=$themeid");
|
||||
$sth->execute;
|
||||
my ($owner) = $sth->fetchrow_array;
|
||||
if ($owner != $remote->{'userid'}) {
|
||||
push @$out, [ "error", "You do not own this theme." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
$width += 0;
|
||||
$height += 0;
|
||||
$moodid += 0;
|
||||
if (!$picurl || $width==0 || $height==0) {
|
||||
$dbh->do("DELETE FROM moodthemedata WHERE moodthemeid=$themeid AND moodid=$moodid");
|
||||
LJ::MemCache::delete([$themeid, "moodthemedata:$themeid"]);
|
||||
push @$out, [ "info", "Data deleted for theme=$themeid, moodid=$moodid." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $qpicurl = $dbh->quote($picurl);
|
||||
$dbh->do("REPLACE INTO moodthemedata (moodthemeid, moodid, picurl, width, height) VALUES ($themeid, $moodid, $qpicurl, $width, $height)");
|
||||
LJ::MemCache::delete([$themeid, "moodthemedata:$themeid"]);
|
||||
if ($dbh->err) { push @$out, [ "error", $dbh->errstr ]; }
|
||||
|
||||
push @$out, [ "", "Data inserted for theme=$themeid, moodid=$moodid." ];
|
||||
return 1;
|
||||
|
||||
}
|
||||
|
||||
|
||||
222
livejournal/cgi-bin/conshared.pl
Executable file
222
livejournal/cgi-bin/conshared.pl
Executable file
@@ -0,0 +1,222 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::Con;
|
||||
|
||||
use vars qw(%cmd);
|
||||
|
||||
$cmd{'shared'}->{'handler'} = \&shared;
|
||||
$cmd{'community'}->{'handler'} = \&community;
|
||||
$cmd{'change_community_admin'}->{'handler'} = \&change_community_admin;
|
||||
|
||||
sub change_community_admin
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
my $sth;
|
||||
my $err = sub { push @$out, [ "error", $_[0] ]; return 0; };
|
||||
|
||||
return $err->("This command takes exactly 2 arguments. Consult the reference.")
|
||||
unless scalar(@$args) == 3;
|
||||
|
||||
my ($comm_name, $newowner_name) = ($args->[1], $args->[2]);
|
||||
my $ucomm = LJ::load_user($comm_name);
|
||||
my $unew = LJ::load_user($newowner_name);
|
||||
|
||||
return $err->("Given community doesn't exist or isn't a community.")
|
||||
unless ($ucomm && $ucomm->{'journaltype'} eq "C");
|
||||
|
||||
return $err->("New owner doesn't exist or isn't a person account.")
|
||||
unless ($unew && $unew->{'journaltype'} eq "P");
|
||||
|
||||
return $err->("You do not have access to transfer ownership of this community.")
|
||||
unless $remote->{'priv'}->{'communityxfer'};
|
||||
|
||||
return $err->("New owner's email address isn't validated.")
|
||||
unless ($unew->{'status'} eq "A");
|
||||
|
||||
my $commid = $ucomm->{'userid'};
|
||||
my $newid = $unew->{'userid'};
|
||||
|
||||
# remove old maintainers' power over it
|
||||
LJ::clear_rel($ucomm, '*', 'A');
|
||||
|
||||
# add a new sole maintainer
|
||||
LJ::set_rel($ucomm, $newid, 'A');
|
||||
|
||||
# so old maintainers can't regain access:
|
||||
$dbh->do("DELETE FROM infohistory WHERE userid=$commid");
|
||||
|
||||
# change password to blank & set email of community to new maintainer's email
|
||||
LJ::update_user($ucomm, { password => '', email => $unew->{'email'} });
|
||||
|
||||
## log to status history
|
||||
LJ::statushistory_add($commid, $remote->{'userid'}, "communityxfer", "Changed maintainer to '$unew->{'user'}'($newid)");
|
||||
LJ::statushistory_add($newid, $remote->{'userid'}, "communityxfer", "Control of '$ucomm->{'user'}'($commid) given.");
|
||||
|
||||
push @$out, [ "info", "Transferred ownership of \"$ucomm->{'user'}\" to \"$unew->{'user'}\"." ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub shared
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
my $error = 0;
|
||||
|
||||
unless (scalar(@$args) == 4) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "This command takes exactly 3 arguments. Consult the reference." ];
|
||||
}
|
||||
|
||||
return 0 if $error;
|
||||
|
||||
my ($shared_user, $action, $target_user) = ($args->[1], $args->[2], $args->[3]);
|
||||
my $shared = LJ::load_user($shared_user);
|
||||
my $shared_id = $shared->{'userid'};
|
||||
my $target = LJ::load_user($target_user);
|
||||
my $target_id = $target->{'userid'};
|
||||
|
||||
unless ($action eq "add" || $action eq "remove") {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid action \"$action\" ... expected 'add' or 'remove'" ];
|
||||
}
|
||||
unless ($shared_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid shared journal \"$shared_user\"" ];
|
||||
}
|
||||
unless ($shared->{'journaltype'} eq 'S') {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "\"$shared_user\" is not a shared journal" ];
|
||||
}
|
||||
unless ($target_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid user \"$target_user\" to add/remove" ];
|
||||
} elsif ($target_id == $shared_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Target user can't be shared journal user." ];
|
||||
}
|
||||
|
||||
unless (LJ::can_manage($remote, $shared_id) ||
|
||||
$remote->{'privarg'}->{'sharedjournal'}->{'*'})
|
||||
{
|
||||
$error = 1;
|
||||
push @$out, [ "error", "You don't have access to add/remove users to this shared journal." ];
|
||||
}
|
||||
|
||||
return 0 if ($error);
|
||||
|
||||
if ($action eq "add") {
|
||||
if (LJ::check_rel($shared_id, $target_id, 'P')) {
|
||||
push @$out, [ "error", "User \"$target->{'user'}\" already has posting access to this shared journal." ];
|
||||
return 0;
|
||||
}
|
||||
# don't send request if the admin is giving themselves posting access
|
||||
if ($target->{'user'} eq $remote->{'user'}) {
|
||||
LJ::set_rel($shared, $target, 'P');
|
||||
push @$out, [ "info", "User \"$target_user\" has been given posting access to \"$shared_user\"." ];
|
||||
} else {
|
||||
my $res = LJ::shared_member_request($shared, $target);
|
||||
unless ($res) {
|
||||
push @$out, [ 'error', "Could not add user." ];
|
||||
return 0;
|
||||
}
|
||||
if ($res->{'datecreate'}) {
|
||||
push @$out, [ 'error', "User \"$target->{'user'}\" already mailed on: $res->{'datecreate'}" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
push @$out, [ "info", "User \"$target_user\" has been sent a confirmation email and will be able to post in \"$shared_user\" once they confirm this action." ];
|
||||
}
|
||||
}
|
||||
if ($action eq "remove") {
|
||||
LJ::clear_rel($shared_id, $target_id, 'P');
|
||||
push @$out, [ "info", "User \"$target_user\" can no longer post in \"$shared_user\"." ];
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub community
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
my $error = 0;
|
||||
my $sth;
|
||||
|
||||
unless (scalar(@$args) == 4) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "This command takes exactly 3 arguments. Consult the reference." ];
|
||||
}
|
||||
|
||||
return 0 if ($error);
|
||||
|
||||
my ($com_user, $action, $target_user) = ($args->[1], $args->[2], $args->[3]);
|
||||
my $comm = LJ::load_user($com_user);
|
||||
my $com_id = $comm->{'userid'};
|
||||
my $target = LJ::load_user($target_user);
|
||||
my $target_id = $target->{'userid'};
|
||||
|
||||
my $ci;
|
||||
|
||||
unless ($action eq "add" || $action eq "remove") {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid action \"$action\" ... expected 'add' or 'remove'" ];
|
||||
}
|
||||
unless ($com_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid community \"$com_user\"" ];
|
||||
}
|
||||
else
|
||||
{
|
||||
$ci = $dbh->selectrow_hashref("SELECT userid, membership, postlevel FROM community WHERE userid=$com_id");
|
||||
|
||||
unless ($ci) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "\"$com_user\" isn't a registered community." ];
|
||||
}
|
||||
}
|
||||
|
||||
unless ($target_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Invalid user \"$target_user\" to add/remove" ];
|
||||
} elsif ($target_id == $com_id) {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "User \"$target_user\" can't be shared journal user." ];
|
||||
} elsif ($target->{'journaltype'} ne 'P') {
|
||||
$error = 1;
|
||||
push @$out, [ "error", "Cannot add community/syndicated account to community." ];
|
||||
}
|
||||
|
||||
|
||||
# user doesn't need admin priv to remove themselves from community
|
||||
|
||||
unless (LJ::can_manage_other($remote, $com_id) ||
|
||||
$remote->{'privarg'}->{'sharedjournal'}->{'*'} ||
|
||||
($remote->{'user'} eq $target_user && $action eq "remove"))
|
||||
{
|
||||
my $modifier = $action eq "add" ? "to" : "from";
|
||||
$error = 1;
|
||||
push @$out, [ "error", "You don't have access to $action users $modifier this shared journal." ];
|
||||
}
|
||||
|
||||
return 0 if ($error);
|
||||
|
||||
if ($action eq "add")
|
||||
{
|
||||
push @$out, [ 'error', 'The ability to add users to a community through the console has been removed.' ];
|
||||
push @$out, [ 'error', 'Users must now request to be added to a community by visiting the community\'s' ];
|
||||
push @$out, [ 'error', 'profile page and clicking the link to join.' ];
|
||||
}
|
||||
|
||||
if ($action eq "remove") {
|
||||
LJ::remove_friend($com_id, $target_id);
|
||||
push @$out, [ "info", "User \"$target_user\" is no longer a member of \"$com_user\"." ];
|
||||
|
||||
LJ::clear_rel($com_id, $target_id, 'P');
|
||||
LJ::clear_rel($com_id, $target_id, 'N');
|
||||
push @$out, [ "info", "User \"$target_user\" can no longer post in \"$com_user\"." ];
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
1665
livejournal/cgi-bin/console.pl
Executable file
1665
livejournal/cgi-bin/console.pl
Executable file
File diff suppressed because it is too large
Load Diff
421
livejournal/cgi-bin/consuspend.pl
Executable file
421
livejournal/cgi-bin/consuspend.pl
Executable file
@@ -0,0 +1,421 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Con;
|
||||
|
||||
use strict;
|
||||
use vars qw(%cmd);
|
||||
|
||||
$cmd{'expunge_userpic'}->{'handler'} = \&expunge_userpic;
|
||||
$cmd{'suspend'}->{'handler'} = \&suspend;
|
||||
$cmd{'unsuspend'}->{'handler'} = \&suspend;
|
||||
$cmd{'getemail'}->{'handler'} = \&getemail;
|
||||
$cmd{'get_maintainer'}->{'handler'} = \&get_maintainer;
|
||||
$cmd{'get_moderator'}->{'handler'} = \&get_moderator;
|
||||
$cmd{'finduser'}->{'handler'} = \&finduser;
|
||||
$cmd{'infohistory'}->{'handler'} = \&infohistory;
|
||||
$cmd{'change_journal_status'}->{'handler'} = \&change_journal_status;
|
||||
$cmd{'set_underage'}->{'handler'} = \&set_underage;
|
||||
|
||||
sub set_underage {
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
my $err = sub { push @$out, [ "error", shift ]; 0; };
|
||||
my $info = sub { push @$out, [ "info", shift ]; 1; };
|
||||
|
||||
return $err->("This command takes three arguments. Consult the reference for details.")
|
||||
unless scalar(@$args) == 4;
|
||||
return $err->("You don't have the necessary privilege (siteadmin:underage) to change an account's underage flag.")
|
||||
unless LJ::check_priv($remote, 'siteadmin', 'underage') || LJ::check_priv($remote, 'siteadmin', '*');
|
||||
|
||||
my $u = LJ::load_user($args->[1]);
|
||||
return $err->("Invalid user.")
|
||||
unless $u;
|
||||
return $err->("Account is not a person type account.")
|
||||
unless $u->{journaltype} eq 'P';
|
||||
|
||||
return $err->("Second argument must be 'on' or 'off'.")
|
||||
unless $args->[2] =~ /^(?:on|off)$/;
|
||||
my $on = $args->[2] eq 'on' ? 1 : 0;
|
||||
|
||||
my $note = $args->[3];
|
||||
return $err->("You must provide a reason for this change as the third argument.")
|
||||
unless $note;
|
||||
|
||||
# can't set state to what it is already
|
||||
return $err->("User is already of the requested underage state.")
|
||||
unless $on ^ $u->underage;
|
||||
|
||||
my ($res, $sh, $status);
|
||||
if ($on) {
|
||||
$status = 'M'; # "M"anually turned on
|
||||
$res = "User marked as underage.";
|
||||
$sh = "marked; $note";
|
||||
} else {
|
||||
$status = undef; # no status change
|
||||
$res = "User no longer marked as underaged.";
|
||||
$sh = "unmarked; $note";
|
||||
}
|
||||
|
||||
# now record this change (yes we log it twice)
|
||||
LJ::statushistory_add($u->{userid}, $remote->{userid}, "set_underage", $sh);
|
||||
$u->underage($on, $status, "manual");
|
||||
return $info->($res);
|
||||
}
|
||||
|
||||
sub change_journal_status {
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
my $err = sub { push @$out, [ "error", shift ]; 0; };
|
||||
my $info = sub { push @$out, [ "info", shift ]; 1; };
|
||||
|
||||
return $err->("This command takes two arguments. Consult the reference for details.")
|
||||
unless scalar(@$args) == 3;
|
||||
return $err->("You don't have the necessary privilege (siteadmin:users) to change account status.")
|
||||
unless LJ::check_priv($remote, 'siteadmin', 'users') || LJ::check_priv($remote, 'siteadmin', '*');
|
||||
|
||||
my $u = LJ::load_user($args->[1]);
|
||||
return $err->("Invalid user.")
|
||||
unless $u;
|
||||
|
||||
# figure out the new status
|
||||
my $status = $args->[2];
|
||||
my $opts = {
|
||||
#name => [ 'status-to', 'valid-statuses-from', 'error-message-if-from-fails', 'success-message' ]
|
||||
normal => [ 'V', 'ML', 'The user must be in memorial or locked status first.', 'User status set back to normal.' ],
|
||||
memorial => [ 'M', 'V', 'The user must be in normal status first.', 'User account set as memorial.' ],
|
||||
locked => [ 'L', 'V', 'The user must be in normal status first.', 'User account has been locked.' ],
|
||||
}->{$status};
|
||||
|
||||
# make sure we got a valid $opts arrayref
|
||||
return $err->("Invalid status. Consult the reference for more information.")
|
||||
unless defined $opts && ref $opts eq 'ARRAY';
|
||||
|
||||
# verify user's from-statusvis is okay (it's contained in $opts->[1])
|
||||
return $err->($opts->[2]) unless $opts->[1] =~ /$u->{statusvis}/;
|
||||
|
||||
# okay, so we need to update the user now and update statushistory
|
||||
LJ::statushistory_add($u->{userid}, $remote->{userid}, "journal_status", "Changed status to $status from $u->{statusvis}.");
|
||||
LJ::update_user($u->{'userid'}, { statusvis => $opts->[0], raw => 'statusvisdate=NOW()' });
|
||||
return $info->($opts->[3]);
|
||||
}
|
||||
|
||||
sub expunge_userpic {
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless (scalar(@$args) == 3) {
|
||||
push @$out, [ "error", "This command takes exactly two arguments, username and picid. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $user = $args->[1];
|
||||
my $picid = $args->[2]+0;
|
||||
|
||||
unless (LJ::check_priv($remote, 'siteadmin', 'userpics') || LJ::check_priv($remote, 'siteadmin', '*')) {
|
||||
push @$out, [ "error", "You don't have access to expunge user picture icons." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $u = LJ::load_user($user);
|
||||
|
||||
# the actual expunging happens in ljlib
|
||||
my ($rval, $hookval) = LJ::expunge_userpic($u, $picid);
|
||||
push @$out, $hookval if @{$hookval || []};
|
||||
|
||||
# now load up from the return value we got
|
||||
unless ($rval && $u) {
|
||||
push @$out, [ "error", "Error expunging user picture icon." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# but make sure to log it
|
||||
LJ::statushistory_add($u->{userid}, $remote->{userid}, 'expunge_userpic', "expunged userpic; id=$picid");
|
||||
push @$out, [ "info", "User picture icon $picid for $u->{user} expunged from $LJ::SITENAMESHORT." ];
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub suspend
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
my $confirmed = 0;
|
||||
if (scalar(@$args) == 4 && $args->[3] eq 'confirm') {
|
||||
pop @$args;
|
||||
$confirmed = 1;
|
||||
}
|
||||
|
||||
unless (scalar(@$args) == 3) {
|
||||
push @$out, [ "error", "This command takes exactly 2 arguments. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $cmd = $args->[0];
|
||||
my ($user, $reason) = ($args->[1], $args->[2]);
|
||||
|
||||
if ($cmd eq "suspend" && $reason eq "off") {
|
||||
push @$out, [ "error", "The second argument to the 'suspend' command is no longer 'off' to unsuspend. Use the 'unsuspend' command instead." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($remote->{'priv'}->{'suspend'}) {
|
||||
push @$out, [ "error", "You don't have access to $cmd users." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# if the user argument is an email address...
|
||||
my @users;
|
||||
if ($user =~ /@/) {
|
||||
push @$out, [ "info", "Acting on users matching email $user..." ];
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $names = $dbr->selectcol_arrayref('SELECT user FROM user WHERE email = ?', undef, $user);
|
||||
if ($dbr->err) {
|
||||
push @$out, [ "error", "Database error: " . $dbr->errstr ];
|
||||
return 0;
|
||||
}
|
||||
unless ($names && @$names) {
|
||||
push @$out, [ "error", "No users found matching the email address $user." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# bail unless they've confirmed this mass action
|
||||
unless ($confirmed) {
|
||||
push @$out, [ "info", " $_" ] foreach @$names;
|
||||
push @$out, [ "info", "To actually confirm this action, please do this again:" ];
|
||||
push @$out, [ "info", " $cmd $user \"$reason\" confirm" ];
|
||||
return 1;
|
||||
}
|
||||
|
||||
push @users, $_ foreach @$names;
|
||||
} else {
|
||||
push @users, $user;
|
||||
}
|
||||
|
||||
foreach my $username (@users) {
|
||||
my $u = LJ::load_user($username);
|
||||
unless ($u) {
|
||||
push @$out, [ "error", "$username invalid/unable to load." ];
|
||||
next;
|
||||
}
|
||||
|
||||
my $status = ($cmd eq "unsuspend") ? "V" : "S";
|
||||
if ($u->{'statusvis'} eq $status) {
|
||||
push @$out, [ "error", "$username was already in that state ($status)" ];
|
||||
next;
|
||||
}
|
||||
|
||||
LJ::update_user($u->{'userid'}, { statusvis => $status, raw => 'statusvisdate=NOW()' });
|
||||
$u->{statusvis} = $status;
|
||||
|
||||
LJ::statushistory_add($u->{'userid'}, $remote->{'userid'}, $cmd, $reason);
|
||||
|
||||
LJ::Con::fb_push( $u );
|
||||
|
||||
push @$out, [ "info", "User '$username' ${cmd}ed." ];
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub getemail
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless (scalar(@$args) == 2) {
|
||||
push @$out, [ "error", "This command takes exactly 1 argument. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($user) = ($args->[1]);
|
||||
my $userid = &LJ::get_userid($user);
|
||||
|
||||
unless ($remote->{'priv'}->{'suspend'}) {
|
||||
push @$out, [ "error", "You don't have access to see email addresses." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($userid) {
|
||||
push @$out, [ "error", "Invalid user \"$user\"" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $sth = $dbh->prepare("SELECT email, status FROM user WHERE userid=$userid");
|
||||
$sth->execute;
|
||||
my ($email, $status) = $sth->fetchrow_array;
|
||||
|
||||
push @$out, [ "info", "User: $user" ];
|
||||
push @$out, [ "info", "Email: $email" ];
|
||||
push @$out, [ "info", "Status: $status (A=approved, N=new, T=transferring)" ];
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub finduser
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless ($remote->{'priv'}->{'finduser'}) {
|
||||
push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($crit, $data);
|
||||
if (scalar(@$args) == 2) {
|
||||
# new form; we can auto-detect emails easy enough
|
||||
$data = $args->[1];
|
||||
if ($data =~ /@/) {
|
||||
$crit = 'email';
|
||||
} else {
|
||||
$crit = 'user';
|
||||
}
|
||||
} else {
|
||||
# old format...but new variation
|
||||
$crit = $args->[1];
|
||||
$data = $args->[2];
|
||||
|
||||
# if they gave us a username and want to search by email, instead find
|
||||
# all users with that email address
|
||||
if ($crit eq 'email' && $data !~ /@/) {
|
||||
my $u = LJ::load_user($data);
|
||||
unless ($u) {
|
||||
push @$out, [ "error", "User doesn't exist." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
$data = $u->{email};
|
||||
}
|
||||
}
|
||||
|
||||
my $qd = $dbh->quote($data);
|
||||
|
||||
my $where;
|
||||
if ($crit eq "email") {
|
||||
$where = "email=$qd";
|
||||
} elsif ($crit eq "userid") {
|
||||
$where = "userid=$qd";
|
||||
} elsif ($crit eq "user") {
|
||||
$where = "user=$qd";
|
||||
}
|
||||
|
||||
unless ($where) {
|
||||
push @$out, [ "error", "Invalid search criteria. See reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $userids = $dbh->selectcol_arrayref("SELECT userid FROM user WHERE $where");
|
||||
if ($dbh->err) {
|
||||
push @$out, [ "error", "Error in database query: " . $dbh->errstr ];
|
||||
return 0;
|
||||
}
|
||||
unless ($userids && @$userids) {
|
||||
push @$out, [ "error", "No matches." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $us = LJ::load_userids(@$userids);
|
||||
foreach my $u (sort { $a->{userid} <=> $b->{userid} } values %$us) {
|
||||
push @$out, [ "info", "User: $u->{'user'} ".
|
||||
"($u->{'userid'}), journaltype: $u->{'journaltype'}, statusvis: $u->{'statusvis'}, email: ($u->{'status'}) $u->{'email'}" ];
|
||||
if ($u->underage) {
|
||||
my $reason;
|
||||
if ($u->underage_status eq 'M') {
|
||||
$reason = "manual set (see statushistory type set_underage)";
|
||||
} elsif ($u->underage_status eq 'Y') {
|
||||
$reason = "provided birthdate";
|
||||
} elsif ($u->underage_status eq 'O') {
|
||||
$reason = "unique cookie";
|
||||
}
|
||||
push @$out, [ "info", " User is marked underage due to $reason." ];
|
||||
}
|
||||
foreach (LJ::run_hooks("finduser_extrainfo", { 'dbh' => $dbh, 'u' => $u })) {
|
||||
next unless $_->[0];
|
||||
foreach (split(/\n/, $_->[0])) {
|
||||
push @$out, [ "info", $_ ];
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_maintainer
|
||||
{
|
||||
my ($dbh, $remote, $args, $out, $edge) = @_;
|
||||
$edge ||= 'A';
|
||||
|
||||
unless (scalar(@$args) == 2) {
|
||||
push @$out, [ "error", "This command takes exactly 1 argument. Consult the reference." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless ($remote->{'priv'}->{'finduser'}) {
|
||||
push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $user = $args->[1];
|
||||
my $u = LJ::load_user($user);
|
||||
|
||||
unless ($u) {
|
||||
push @$out, [ "error", "Invalid user \"$user\"" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
# journaltype eq 'P' means we're calling get_maintainer on a
|
||||
# plain user and we should get a list of what they maintain instead of
|
||||
# getting a list of what maintains them
|
||||
my $ids = $u->{journaltype} eq 'P' ?
|
||||
LJ::load_rel_target($u->{userid}, $edge) :
|
||||
LJ::load_rel_user($u->{userid}, $edge);
|
||||
$ids ||= [];
|
||||
|
||||
# finduser loop
|
||||
finduser($dbh, $remote, ['finduser', 'userid', $_], $out) foreach @$ids;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_moderator
|
||||
{
|
||||
# simple pass through, but specify to use the 'M' edge
|
||||
return get_maintainer(@_, 'M');
|
||||
}
|
||||
|
||||
sub infohistory
|
||||
{
|
||||
my ($dbh, $remote, $args, $out) = @_;
|
||||
|
||||
unless ($remote->{'privarg'}->{'finduser'}->{'infohistory'}) {
|
||||
push @$out, [ "error", "$remote->{'user'}, you are not authorized to use this command." ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $user = $args->[1];
|
||||
my $userid = LJ::get_userid($user);
|
||||
|
||||
unless ($userid) {
|
||||
push @$out, [ "error", "Invalid user $user" ];
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $sth = $dbh->prepare("SELECT * FROM infohistory WHERE userid='$userid'");
|
||||
$sth->execute;
|
||||
if (! $sth->rows) {
|
||||
push @$out, [ "error", "No matches." ];
|
||||
} else {
|
||||
push @$out, ["info", "Infohistory of user: $user"];
|
||||
while (my $info = $sth->fetchrow_hashref) {
|
||||
$info->{'oldvalue'} ||= '(none)';
|
||||
push @$out, [ "info",
|
||||
"Changed $info->{'what'} at $info->{'timechange'}.\n".
|
||||
"Old value of $info->{'what'} was $info->{'oldvalue'}.".
|
||||
($info->{'other'} ?
|
||||
"\nOther information recorded: $info->{'other'}" : "") ];
|
||||
}
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
90
livejournal/cgi-bin/crumbs.pl
Executable file
90
livejournal/cgi-bin/crumbs.pl
Executable file
@@ -0,0 +1,90 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# Stores all global crumbs and builds the crumbs hash
|
||||
|
||||
%LJ::CRUMBS = (
|
||||
'acctstatus' => ['Account Status', '/accountstatus.bml', 'manage'],
|
||||
'addfriend' => ['Add Friend', '', 'userinfo'],
|
||||
'addtodo' => ['Add To-Do Item', '', 'todo'],
|
||||
'advcustomize' => ['Customize Advanced S2 Settings', '/customize/advanced/index.bml', 'manage'],
|
||||
'advsearch' => ['Advanced Search', '/directorysearch.bml', 'search'],
|
||||
'birthdays' => ['Birthdays', '/birthdays.bml', 'friends'],
|
||||
'changepass' => ['Change Password', '/changepassword.bml', 'manage'],
|
||||
'comminvites' => ['Community Invitations', '/manage/invites.bml', 'manage'],
|
||||
'commmembers' => ['Community Membership', '', 'managecommunity'],
|
||||
'commpending' => ['Pending Memberships', '', 'managecommunity'],
|
||||
'commsearch' => ['Community Search', '/community/search.bml', 'community'],
|
||||
'commsentinvites' => ['Sent Invitations', '/community/sentinvites.bml', 'managecommunity'],
|
||||
'commsettings' => ['Community Settings', '/community/settings.bml', 'managecommunity'],
|
||||
'community' => ['Community Center', '/community/', 'home'],
|
||||
'createcommunity' => ['Create Community', '/community/create.bml', 'managecommunity'],
|
||||
'createjournal' => ['Create Journal', '/create.bml', 'home'],
|
||||
'createstyle' => ['Create Style', '/styles/create.bml', 'modify'],
|
||||
'customize' => ['Customize S2 Settings', '/customize/index.bml', 'manage'],
|
||||
'delcomment' => ['Delete Comment', '/delcomment.bml', 'home'],
|
||||
'editentries' => ['Edit Entries', '/editjournal.bml', 'manage'],
|
||||
'editentries_do' => ['Edit Entry', '/editjournal_do.bml', 'editentries'],
|
||||
'editfriends' => ['Edit Friends', '/friends/edit.bml', 'friends'],
|
||||
'editfriendgrps' => ['Edit Friends Groups', '/friends/editgroups.bml', 'friends'],
|
||||
'editinfo' => ['Personal Info', '/editinfo.bml', 'manage'],
|
||||
'editpics' => ['User Pictures', '/editpics.bml', 'manage'],
|
||||
'editstyle' => ['Edit Style', '/styles/edit.bml', 'modify'],
|
||||
'emailgateway' => ['Email Gateway', '/manage/emailpost.bml', 'manage'],
|
||||
'emailmanage' => ['Email Management', '/tools/emailmanage.bml', 'manage'],
|
||||
'encodings' => ['About Encodings', '/support/encodings.bml', 'support'],
|
||||
'export' => ['Export Journal', '/export.bml', 'home'],
|
||||
'faq' => ['Frequently Asked Questions', '/support/faq.bml', 'support'],
|
||||
'feedstersearch' => ['Search a Journal', '/tools/search.bml', 'home'],
|
||||
'friends' => ['Friends Tools', '/friends/index.bml', 'manage'],
|
||||
'friendsfilter' => ['Friends Filter', '/friends/filter.bml', 'friends'],
|
||||
'home' => ['Home', '/', ''],
|
||||
'joincomm' => ['Join Community', '', 'community'],
|
||||
'latestposts' => ['Latest Posts', '/stats/latest.bml', 'stats'],
|
||||
'layerbrowse' => ['Public Layer Browser', '/customize/advanced/layerbrowse.bml', 'advcustomize'],
|
||||
'leavecomm' => ['Leave Community', '', 'community'],
|
||||
'linkslist' => ['Your Links', '/manage/links.bml', 'manage'],
|
||||
'login' => ['Login', '/login.bml', 'home'],
|
||||
'logout' => ['Logout', '/logout.bml', 'home'],
|
||||
'lostinfo' => ['Lost Info', '/lostinfo.bml', 'manage'],
|
||||
'manage' => ['Manage Accounts', '/manage/', 'home'],
|
||||
'managecommunity' => ['Community Management', '/community/manage.bml', 'manage'],
|
||||
'meme' => ['Meme Tracker', '/meme.bml', 'home'],
|
||||
'memories' => ['Memorable Posts', '/tools/memories.bml', 'manage'],
|
||||
'moderate' => ['Community Moderation', '/community/moderate.bml', 'community'],
|
||||
'modify' => ['Journal Settings', '/modify.bml', 'manage'],
|
||||
'moodlist' => ['Mood Viewer', '/moodlist.bml', 'manage'],
|
||||
'news' => ['News', '/news.bml', 'home'],
|
||||
'phonepostsettings' => ['Phone Post', '/manage/phonepost.bml', 'manage'],
|
||||
'popfaq' => ['Popular FAQs', '/support/popfaq.bml', 'faq'],
|
||||
'preview' => ['Layout Previews', '/customize/preview.bml', 'customize'],
|
||||
'register' => ['Validate Email', '/register.bml', 'home'],
|
||||
'searchinterests' => ['Search By Interest', '/interests.bml', 'search'],
|
||||
'searchregion' => ['Search By Region', '/directory.bml', 'search'],
|
||||
'seeoverrides' => ['View User Overrides', '', 'support'],
|
||||
'setpgpkey' => ['Public Key', '/manage/pubkey.bml', 'manage'],
|
||||
'siteopts' => ['Browse Preferences', '/manage/siteopts.bml', 'manage'],
|
||||
'stats' => ['Statistics', '/stats.bml', 'about'],
|
||||
'styles' => ['Styles', '/styles/index.bml', 'modify'],
|
||||
'support' => ['Support', '/support/index.bml', 'home'],
|
||||
'supportact' => ['Request Action', '', 'support'],
|
||||
'supportappend' => ['Append to Request', '', 'support'],
|
||||
'supporthelp' => ['Request Board', '/support/help.bml', 'support'],
|
||||
'supportnotify' => ['Notification Settings', '/support/changenotify.bml', 'support'],
|
||||
'supportscores' => ['High Scores', '/support/highscores.bml', 'support'],
|
||||
'supportsubmit' => ['Submit Request', '/support/submit.bml', 'support'],
|
||||
'textmessage' => ['Send Text Message', '/tools/textmessage.bml', 'home'],
|
||||
'themes' => ['Theme Previews', '/customize/themes.bml', 'customize'],
|
||||
'todo' => ['Todo List', '/todo', 'home'],
|
||||
'transfercomm' => ['Transfer Community', '/community/transfer.bml', 'managecommunity'],
|
||||
'unsubscribe' => ['Unsubscribe', '/unsubscribe.bml', 'home'],
|
||||
'update' => ['Update Journal', '/update.bml', 'home'],
|
||||
'utf8convert' => ['UTF-8 Converter', '/utf8convert.bml', 'manage'],
|
||||
'yourlayers' => ['Your Layers', '/customize/advanced/layers.bml', 'advcustomize'],
|
||||
'yourstyles' => ['Your Styles', '/customize/advanced/styles.bml', 'advcustomize'],
|
||||
);
|
||||
|
||||
# include the local crumbs info
|
||||
require "$ENV{'LJHOME'}/cgi-bin/crumbs-local.pl"
|
||||
if -e "$ENV{'LJHOME'}/cgi-bin/crumbs-local.pl";
|
||||
|
||||
1;
|
||||
649
livejournal/cgi-bin/directorylib.pl
Executable file
649
livejournal/cgi-bin/directorylib.pl
Executable file
@@ -0,0 +1,649 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# Directory search code.
|
||||
#
|
||||
############################################################
|
||||
#
|
||||
# Misc Notes...
|
||||
#
|
||||
# directory handle can only touch:
|
||||
# community
|
||||
# friends
|
||||
# payments
|
||||
# userinterests
|
||||
# userprop
|
||||
# userusage
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::Dir;
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
|
||||
my $MAX_RETURN_RESULT = 1000;
|
||||
|
||||
my %filters = (
|
||||
'int' => { 'searcher' => \&search_int,
|
||||
'validate' => \&validate_int, },
|
||||
'fr' => { 'searcher' => \&search_fr,
|
||||
'validate' => \&validate_fr, },
|
||||
'fro' => { 'searcher' => \&search_fro,
|
||||
'validate' => \&validate_fro, },
|
||||
'loc' => { 'validate' => \&validate_loc,
|
||||
'searcher' => \&search_loc, },
|
||||
#'gen' => { 'validate' => \&validate_gen,
|
||||
# 'searcher' => \&search_gen, },
|
||||
'age' => { 'validate' => \&validate_age,
|
||||
'searcher' => \&search_age, },
|
||||
'ut' => { 'validate' => \&validate_ut,
|
||||
'searcher' => \&search_ut, },
|
||||
'com' => { 'searcher' => \&search_com,
|
||||
'validate' => \&validate_com, },
|
||||
);
|
||||
|
||||
# validate all filter options
|
||||
#
|
||||
sub validate
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
my @filters;
|
||||
foreach my $f (sort keys %filters) {
|
||||
next unless $filters{$f}->{'validate'};
|
||||
if ($filters{$f}->{'validate'}->($req, $errors)) {
|
||||
push @filters, $f;
|
||||
}
|
||||
}
|
||||
return sort @filters;
|
||||
}
|
||||
|
||||
# entry point to do a search: give it
|
||||
# a db-read handle
|
||||
# directory master (must be able to write to dirsearchres2)
|
||||
# hashref of the request,
|
||||
# a listref of where to put the user hashrefs returned,
|
||||
# hashref of where to return results of the query
|
||||
sub do_search
|
||||
{
|
||||
my ($dbr, $dbdir, $req, $users, $info) = @_;
|
||||
my $sth;
|
||||
|
||||
# clear return buffers
|
||||
@{$users} = ();
|
||||
%{$info} = ();
|
||||
|
||||
my @crits;
|
||||
foreach my $f (sort keys %filters)
|
||||
{
|
||||
next unless $filters{$f}->{'validate'}->($req, []);
|
||||
|
||||
my @criteria = $filters{$f}->{'searcher'}->($dbr, $req, $info);
|
||||
if (@criteria) {
|
||||
push @crits, @criteria;
|
||||
} else {
|
||||
# filters return nothing to signal an error, and should have set $info->{'errmsg'}
|
||||
$info->{'errmsg'} = "[Filter $f failed] $info->{'errmsg'}";
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
unless (scalar(@crits)) {
|
||||
$info->{'errmsg'} = "You did not enter any search criteria.";
|
||||
return 0;
|
||||
}
|
||||
|
||||
########## time to build us some huge SQL statement. yee haw.
|
||||
|
||||
my $orderby;
|
||||
my %only_one_copy = qw(community c user u userusage uu);
|
||||
|
||||
## keep track of what table aliases we've used
|
||||
my %alias_used;
|
||||
$alias_used{'u'} = "?"; # only used by dbr, not dbdir
|
||||
$alias_used{'c'} = "?"; # might be used later, if opt_format eq "com"
|
||||
$alias_used{'uu'} = "?"; # might be used later, if opt_sort is by time
|
||||
|
||||
my %conds; # where condition -> 1
|
||||
my %useridcol; # all keys here equal each other (up.userid == uu.userid == ..)
|
||||
|
||||
## foreach each critera, build up the query
|
||||
foreach my $crit (@crits)
|
||||
{
|
||||
### each search criteria has its own table aliases. make those unique.
|
||||
my %map_alias = (); # keep track of local -> global table alias mapping
|
||||
|
||||
foreach my $localalias (keys %{$crit->{'tables'}})
|
||||
{
|
||||
my $table = $crit->{'tables'}->{$localalias};
|
||||
my $newalias;
|
||||
|
||||
# some tables might be used multiple times but they're
|
||||
# setup such that opening them multiple times is useless.
|
||||
if ($only_one_copy{$table}) {
|
||||
$newalias = $only_one_copy{$table};
|
||||
$alias_used{$newalias} = $table;
|
||||
} else {
|
||||
my $ct = 1;
|
||||
$newalias = $localalias;
|
||||
while ($alias_used{$newalias}) {
|
||||
$ct++;
|
||||
$newalias = "$localalias$ct";
|
||||
}
|
||||
$alias_used{$newalias} = $table;
|
||||
}
|
||||
|
||||
$map_alias{$localalias} = $newalias;
|
||||
}
|
||||
|
||||
## add each condition to the where clause, after fixing up aliases
|
||||
foreach my $cond (@{$crit->{'conds'}}) {
|
||||
$cond =~ s/\{(\w+?)\}/$map_alias{$1}/g;
|
||||
$conds{$cond} = 1;
|
||||
}
|
||||
|
||||
## add join to u.userid table
|
||||
my $cond = $crit->{'userid'};
|
||||
if ($cond) {
|
||||
$cond =~ s/\{(\w+?)\}/$map_alias{$1}/g;
|
||||
$useridcol{$cond} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my $pagesize = $req->{'opt_pagesize'}+0 || 100;
|
||||
if ($pagesize > 200) { $pagesize = 200; }
|
||||
if ($pagesize < 5) { $pagesize = 5; }
|
||||
|
||||
$req->{'opt_format'} ||= "pics";
|
||||
if ($req->{'opt_format'} eq "com") {
|
||||
$alias_used{'c'} = "community";
|
||||
$useridcol{"c.userid"} = 1;
|
||||
}
|
||||
|
||||
$req->{'opt_sort'} ||= "ut";
|
||||
if ($req->{'opt_sort'} eq "ut") {
|
||||
$alias_used{'uu'} = 'userusage';
|
||||
$useridcol{"uu.userid"} = 1;
|
||||
$orderby = "ORDER BY uu.timeupdate DESC";
|
||||
} elsif ($req->{'opt_sort'} eq "user") {
|
||||
$alias_used{'u'} = 'user';
|
||||
$useridcol{"u.userid"} = 1;
|
||||
$orderby = "ORDER BY u.user";
|
||||
} elsif ($req->{'opt_sort'} eq "name") {
|
||||
$alias_used{'u'} = 'user';
|
||||
$useridcol{"u.userid"} = 1;
|
||||
$orderby = "ORDER BY u.name";
|
||||
}
|
||||
|
||||
# delete reserved table aliases the didn't end up being used
|
||||
foreach (keys %alias_used) {
|
||||
delete $alias_used{$_} if $alias_used{$_} eq "?";
|
||||
}
|
||||
|
||||
# add clauses to make all userid cols equal each other
|
||||
my $useridcol; # any one
|
||||
foreach my $ca (keys %useridcol) {
|
||||
foreach my $cb (keys %useridcol) {
|
||||
next if $ca eq $cb;
|
||||
$conds{"$ca=$cb"} = 1;
|
||||
}
|
||||
$useridcol = $ca;
|
||||
}
|
||||
|
||||
my $fromwhat = join(", ", map { "$alias_used{$_} $_" } keys %alias_used);
|
||||
my $conds = join(" AND ", keys %conds);
|
||||
|
||||
my $sql = "SELECT $useridcol FROM $fromwhat WHERE $conds $orderby LIMIT $MAX_RETURN_RESULT";
|
||||
|
||||
if ($req->{'sql'}) {
|
||||
$info->{'errmsg'} = "SQL: $sql";
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $qdig = $dbr->quote(md5_hex($sql));
|
||||
my $hit_cache = 0;
|
||||
my $count = 0;
|
||||
my @ids;
|
||||
|
||||
# delete any stale results
|
||||
$dbdir->do("DELETE FROM dirsearchres2 WHERE qdigest=$qdig AND ".
|
||||
"dateins < DATE_SUB(NOW(), INTERVAL 15 MINUTE)");
|
||||
# mark query as in progress.
|
||||
$dbdir->do("INSERT INTO dirsearchres2 (qdigest, dateins, userids) ".
|
||||
"VALUES ($qdig, NOW(), '[searching]')");
|
||||
if ($dbdir->err)
|
||||
{
|
||||
# if there's an error inserting that, we know something's there.
|
||||
# let's see what!
|
||||
my $ids = $dbdir->selectrow_array("SELECT userids FROM dirsearchres2 ".
|
||||
"WHERE qdigest=$qdig");
|
||||
if (defined $ids) {
|
||||
if ($ids eq "[searching]") {
|
||||
# somebody else (or same user before) is still searching
|
||||
$info->{'searching'} = 1;
|
||||
return 1;
|
||||
}
|
||||
@ids = split(/,/, $ids);
|
||||
$count = scalar(@ids);
|
||||
$hit_cache = 1;
|
||||
}
|
||||
}
|
||||
|
||||
## guess we'll have to query it.
|
||||
if (! $hit_cache)
|
||||
{
|
||||
BML::do_later(sub {
|
||||
$sth = $dbdir->prepare($sql);
|
||||
$sth->execute;
|
||||
while (my ($id) = $sth->fetchrow_array) {
|
||||
push @ids, $id;
|
||||
}
|
||||
my $ids = $dbdir->quote(join(",", @ids));
|
||||
$dbdir->do("REPLACE INTO dirsearchres2 (qdigest, dateins, userids) ".
|
||||
"VALUES ($qdig, NOW(), $ids)");
|
||||
});
|
||||
$info->{'searching'} = 1;
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $page = $req->{'page'} || 1;
|
||||
my $skip = ($page-1)*$pagesize;
|
||||
my $pages = int($count / $pagesize) + (($count % $pagesize) ? 1 : 0);
|
||||
$pages ||= 1;
|
||||
if ($page > $pages) { $page = $pages; }
|
||||
$info->{'pages'} = $pages;
|
||||
$info->{'page'} = $page;
|
||||
$info->{'first'} = ($page-1)*$pagesize+1;
|
||||
$info->{'last'} = $page * $pagesize;
|
||||
$info->{'count'} = $count;
|
||||
if ($count == $MAX_RETURN_RESULT) {
|
||||
$info->{'overflow'} = 1;
|
||||
}
|
||||
if ($page == $pages) { $info->{'last'} = $count; }
|
||||
|
||||
## now, get info on the ones we want.
|
||||
@ids = grep{ $_+0 } @ids[($info->{'first'}-1)..($info->{'last'}-1)];
|
||||
return 1 unless @ids;
|
||||
|
||||
my %u;
|
||||
LJ::load_userids_multiple([ map { $_ => \$u{$_} } @ids ]);
|
||||
my $tu = LJ::get_timeupdate_multi(@ids);
|
||||
my $now = time();
|
||||
|
||||
# need to get community info
|
||||
if ($req->{'opt_format'} eq "com") {
|
||||
my $in = join(',', @ids);
|
||||
my $sth = $dbr->prepare("SELECT userid, membership, postlevel ".
|
||||
"FROM community ".
|
||||
"WHERE userid IN ($in)");
|
||||
$sth->execute;
|
||||
while (my ($uid, $mem, $postlev) = $sth->fetchrow_array) {
|
||||
next unless $u{$uid};
|
||||
$u{$uid}->{'membership'} = $mem;
|
||||
$u{$uid}->{'postlevel'} = $postlev;
|
||||
}
|
||||
foreach (@ids) {
|
||||
delete $u{$_} unless $u{$_}->{'membership'};
|
||||
}
|
||||
}
|
||||
|
||||
foreach my $id (@ids) {
|
||||
next unless $u{$id} && $u{$id}->{'statusvis'} eq "V";
|
||||
$u{$id}->{'secondsold'} = $tu->{$id} ? $now - $tu->{$id} : undef;
|
||||
push @$users, $u{$id} if $u{$id};
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub ago_text
|
||||
{
|
||||
my $secondsold = shift;
|
||||
return "Never." unless ($secondsold);
|
||||
my $num;
|
||||
my $unit;
|
||||
if ($secondsold > 60*60*24*7) {
|
||||
$num = int($secondsold / (60*60*24*7));
|
||||
$unit = "week";
|
||||
} elsif ($secondsold > 60*60*24) {
|
||||
$num = int($secondsold / (60*60*24));
|
||||
$unit = "day";
|
||||
} elsif ($secondsold > 60*60) {
|
||||
$num = int($secondsold / (60*60));
|
||||
$unit = "hour";
|
||||
} elsif ($secondsold > 60) {
|
||||
$num = int($secondsold / (60));
|
||||
$unit = "minute";
|
||||
} else {
|
||||
$num = $secondsold;
|
||||
$unit = "second";
|
||||
}
|
||||
return "$num $unit" . ($num==1?"":"s") . " ago";
|
||||
}
|
||||
|
||||
########## INTEREST ############
|
||||
|
||||
sub validate_int
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
|
||||
my $int = lc($req->{'int_like'});
|
||||
$int =~ s/^\s+//;
|
||||
$int =~ s/\s+$//;
|
||||
return 0 unless $int;
|
||||
|
||||
$req->{'int_like'} = $int;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_int
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
my $arg = $req->{'int_like'};
|
||||
push @{$info->{'english'}}, "are interested in \"$arg\"";
|
||||
|
||||
## find interest id, if one doth exist.
|
||||
my $qint = $dbr->quote($req->{'int_like'});
|
||||
my $intid = $dbr->selectrow_array("SELECT intid FROM interests ".
|
||||
"WHERE interest=$qint");
|
||||
unless ($intid) {
|
||||
$info->{'errmsg'} = "The interest you have entered is not valid.";
|
||||
return;
|
||||
}
|
||||
|
||||
my $UI_TABLE = $req->{'com_do'} ? "comminterests" : "userinterests";
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'ui' => $UI_TABLE,
|
||||
},
|
||||
'conds' => [ "{ui}.intid=$intid" ],
|
||||
'userid' => "{ui}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
######## HAS FRIEND ##############
|
||||
|
||||
sub validate_fr
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'fr_user'} =~ /\S/;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_fr
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
|
||||
my $user = lc($req->{'fr_user'});
|
||||
my $arg = $user;
|
||||
|
||||
push @{$info->{'english'}}, "consider \"$arg\" a friend";
|
||||
|
||||
my $friendid = LJ::get_userid($user);
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'f' => 'friends',
|
||||
},
|
||||
'conds' => [ "{f}.friendid=$friendid" ],
|
||||
'userid' => "{f}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
######## FRIEND OF ##############
|
||||
|
||||
sub validate_fro
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'fro_user'} =~ /\S/;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_fro
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
|
||||
my $user = lc($req->{'fro_user'});
|
||||
my $arg = $user;
|
||||
|
||||
push @{$info->{'english'}}, "are considered a friend by \"$arg\"";
|
||||
|
||||
my $userid = LJ::get_userid($user);
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'f' => 'friends',
|
||||
},
|
||||
'conds' => [ "{f}.userid=$userid" ],
|
||||
'userid' => "{f}.friendid",
|
||||
};
|
||||
}
|
||||
|
||||
|
||||
########### LOCATION ###############
|
||||
|
||||
sub validate_loc
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'loc_cn'};
|
||||
|
||||
unless ($req->{'loc_cn'} =~ /^[A-Z]{2}$/ || # ISO code
|
||||
$req->{'loc_cn'} =~ /^LJ/) # site-local country/region code
|
||||
{
|
||||
push @$errors, "Invalid country for location search.";
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_loc
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
my ($sth);
|
||||
|
||||
my ($longcountry, $longstate, $longcity);
|
||||
my $qcode = $dbr->quote(uc($req->{'loc_cn'}));
|
||||
$sth = $dbr->prepare("SELECT item FROM codes WHERE type='country' AND code=$qcode");
|
||||
$sth->execute;
|
||||
($longcountry) = $sth->fetchrow_array;
|
||||
|
||||
$longstate = lc($req->{'loc_st'});
|
||||
$longstate =~ s/(\w+)/\u$1/g;
|
||||
$longcity = lc($req->{'loc_ci'});
|
||||
$longcity =~ s/(\w+)/\u$1/g;
|
||||
|
||||
$req->{'loc_st'} = lc($req->{'loc_st'});
|
||||
$req->{'loc_ci'} = lc($req->{'loc_ci'});
|
||||
|
||||
if ($req->{'loc_cn'} eq "US") {
|
||||
my $qstate = $dbr->quote($req->{'loc_st'});
|
||||
if (length($req->{'loc_st'}) > 2) {
|
||||
## convert long state name into state code
|
||||
$sth = $dbr->prepare("SELECT code FROM codes WHERE type='state' AND item=$qstate");
|
||||
$sth->execute;
|
||||
my ($code) = $sth->fetchrow_array;
|
||||
if ($code) {
|
||||
$req->{'loc_st'} = lc($code);
|
||||
}
|
||||
} else {
|
||||
$sth = $dbr->prepare("SELECT item FROM codes WHERE type='state' AND code=$qstate");
|
||||
$sth->execute;
|
||||
($longstate) = $sth->fetchrow_array;
|
||||
}
|
||||
}
|
||||
|
||||
push @{$info->{'english'}}, "live in " . join(", ", grep { $_; } ($longcity, $longstate, $longcountry));
|
||||
|
||||
my $p = LJ::get_prop("user", "sidx_loc");
|
||||
unless ($p) {
|
||||
$info->{'errmsg'} = "Userprop sidx_loc doesn't exist. Run update-db.pl?";
|
||||
return;
|
||||
}
|
||||
|
||||
my $prefix = join("-", $req->{'loc_cn'}, $req->{'loc_st'}, $req->{'loc_ci'});
|
||||
$prefix =~ s/\-+$//; # remove trailing hyphens
|
||||
$prefix =~ s![\_\%\"\']!\\$&!g;
|
||||
|
||||
#### do the sub requests.
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'up' => 'userprop',
|
||||
},
|
||||
'conds' => [ "{up}.upropid=$p->{'id'}",
|
||||
"{up}.value LIKE '$prefix%'",
|
||||
],
|
||||
'userid' => "{up}.userid",
|
||||
};
|
||||
|
||||
}
|
||||
|
||||
########### GENDER ###################
|
||||
|
||||
sub validate_gen
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'gen_sel'};
|
||||
unless ($req->{'gen_sel'} eq "M" ||
|
||||
$req->{'gen_sel'} eq "F")
|
||||
{
|
||||
push @$errors, "You must select either Male or Female when searching by gender.\n";
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_gen
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
my $args = $req->{'gen_sel'};
|
||||
|
||||
push @{$info->{'english'}}, "are " . ($args eq "M" ? "male" : "female");
|
||||
my $qgen = $dbr->quote($args);
|
||||
|
||||
my $p = LJ::get_prop("user", "gender");
|
||||
unless ($p) {
|
||||
$info->{'errmsg'} = "Userprop gender doesn't exist. Run update-db.pl?";
|
||||
return;
|
||||
}
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'up' => 'userprop',
|
||||
},
|
||||
'conds' => [ "{up}.upropid=$p->{'id'}",
|
||||
"{up}.value=$qgen",
|
||||
],
|
||||
'userid' => "{up}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
########### AGE ###################
|
||||
|
||||
sub validate_age
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 if $req->{'age_min'} eq "" && $req->{'age_max'} eq "";
|
||||
|
||||
for (qw(age_min age_max)) {
|
||||
unless ($req->{$_} =~ /^\d+$/) {
|
||||
push @$errors, "Both min and max age must be specified for an age query.";
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
if ($req->{'age_min'} > $req->{'age_max'}) {
|
||||
push @$errors, "Minimum age must be less than maximum age.";
|
||||
return 0;
|
||||
}
|
||||
if ($req->{'age_min'} < 14) {
|
||||
push @$errors, "You cannot search for users under 14 years of age.";
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_age
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
my $qagemin = $dbr->quote($req->{'age_min'});
|
||||
my $qagemax = $dbr->quote($req->{'age_max'});
|
||||
my $args = "$req->{'age_min'}-$req->{'age_max'}";
|
||||
|
||||
if ($req->{'age_min'} == $req->{'age_max'}) {
|
||||
push @{$info->{'english'}}, "are $req->{'age_min'} years old";
|
||||
} else {
|
||||
push @{$info->{'english'}}, "are between $req->{'age_min'} and $req->{'age_max'} years old";
|
||||
}
|
||||
|
||||
my $p = LJ::get_prop("user", "sidx_bdate");
|
||||
unless ($p) {
|
||||
$info->{'errmsg'} = "Userprop sidx_bdate doesn't exist. Run update-db.pl?";
|
||||
return;
|
||||
}
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'up' => 'userprop',
|
||||
},
|
||||
'conds' => [ "{up}.upropid=$p->{'id'}",
|
||||
"{up}.value BETWEEN DATE_SUB(NOW(), INTERVAL $qagemax YEAR) AND DATE_SUB(NOW(), INTERVAL $qagemin YEAR)",
|
||||
],
|
||||
'userid' => "{up}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
########### UPDATE TIME ###################
|
||||
|
||||
sub validate_ut
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'ut_days'};
|
||||
unless ($req->{'ut_days'} =~ /^\d+$/) {
|
||||
push @$errors, "Days since last updated must be a postive, whole number.";
|
||||
return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_ut
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
my $qdays = $req->{'ut_days'}+0;
|
||||
|
||||
if ($qdays == 1) {
|
||||
push @{$info->{'english'}}, "have updated their journal in the past day";
|
||||
} else {
|
||||
push @{$info->{'english'}}, "have updated their journal in the past $qdays days";
|
||||
}
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'uu' => 'userusage',
|
||||
},
|
||||
'conds' => [ "{uu}.timeupdate > DATE_SUB(NOW(), INTERVAL $qdays DAY)", ],
|
||||
'userid' => "{uu}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
######### community
|
||||
|
||||
sub validate_com
|
||||
{
|
||||
my ($req, $errors) = @_;
|
||||
return 0 unless $req->{'com_do'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub search_com
|
||||
{
|
||||
my ($dbr, $req, $info) = @_;
|
||||
$info->{'allwhat'} = "communities";
|
||||
|
||||
return {
|
||||
'tables' => {
|
||||
'c' => 'community',
|
||||
},
|
||||
'userid' => "{c}.userid",
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
82
livejournal/cgi-bin/emailcheck.pl
Executable file
82
livejournal/cgi-bin/emailcheck.pl
Executable file
@@ -0,0 +1,82 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# Function to reject bogus email addresses
|
||||
#
|
||||
|
||||
package LJ;
|
||||
|
||||
sub check_email
|
||||
{
|
||||
my ($email, $errors) = @_;
|
||||
|
||||
# Trim off whitespace and force to lowercase.
|
||||
$email =~ s/^\s+//;
|
||||
$email =~ s/\s+$//;
|
||||
$email = lc $email;
|
||||
|
||||
my $reject = sub {
|
||||
my $errcode = shift;
|
||||
my $errmsg = shift;
|
||||
# TODO: add $opts to end of check_email and make option
|
||||
# to either return error codes, or let caller supply
|
||||
# a subref to resolve error codes into native language
|
||||
# error messages (probably via BML::ML hash, or something)
|
||||
push @$errors, $errmsg;
|
||||
return;
|
||||
};
|
||||
|
||||
# Empty email addresses are not good.
|
||||
unless ($email) {
|
||||
return $reject->("empty",
|
||||
"Your email address cannot be blank.");
|
||||
}
|
||||
|
||||
# Check that the address is of the form username@some.domain.
|
||||
my ($username, $domain);
|
||||
if ($email =~ /^([^@]+)@([^@]+)/) {
|
||||
$username = $1;
|
||||
$domain = $2;
|
||||
} else {
|
||||
return $reject->("bad_form",
|
||||
"You did not give a valid email address. An email address looks like username\@some.domain");
|
||||
}
|
||||
|
||||
# Check the username for invalid characters.
|
||||
unless ($username =~ /^[^\s\",;\(\)\[\]\{\}\<\>]+$/) {
|
||||
return $reject->("bad_username",
|
||||
"You have invalid characters in your email address username.");
|
||||
}
|
||||
|
||||
# Check the domain name.
|
||||
unless ($domain =~ /^[\w-]+(\.[\w-]+)*\.(ac|ad|ae|aero|af|ag|ai|al|am|an|ao|aq|ar|arpa|as|at|au|aw|az|ba|bb|bd|be|bf|bg|bh|bi|biz|bj|bm|bn|bo|br|bs|bt|bv|bw|by|bz|ca|cc|cd|cf|cg|ch|ci|ck|cl|cm|cn|co|com|coop|cr|cu|cv|cx|cy|cz|de|dj|dk|dm|do|dz|ec|edu|ee|eg|er|es|et|fi|fj|fk|fm|fo|fr|ga|gb|gd|ge|gf|gg|gh|gi|gl|gm|gn|gov|gp|gq|gr|gs|gt|gu|gw|gy|hk|hm|hn|hr|ht|hu|id|ie|il|im|in|info|int|io|iq|ir|is|it|je|jm|jo|jp|ke|kg|kh|ki|km|kn|kr|kw|ky|kz|la|lb|lc|li|lk|lr|ls|lt|lu|lv|ly|ma|mc|md|mg|mh|mil|mk|ml|mm|mn|mo|mp|mq|mr|ms|mt|mu|museum|mv|mw|mx|my|mz|na|name|nc|ne|net|nf|ng|ni|nl|no|np|nr|nu|nz|om|org|pa|pe|pf|pg|ph|pk|pl|pm|pn|pr|pro|ps|pt|pw|py|qa|re|ro|ru|rw|sa|sb|sc|sd|se|sg|sh|si|sj|sk|sl|sm|sn|so|sr|st|su|sv|sy|sz|tc|td|tf|tg|th|tj|tk|tm|tn|to|tp|tr|tt|tv|tw|tz|ua|ug|uk|um|us|uy|uz|va|vc|ve|vg|vi|vn|vu|wf|ws|ye|yt|yu|za|zm|zw)$/)
|
||||
{
|
||||
return $reject->("bad_domain",
|
||||
"Your email address domain is invalid.");
|
||||
}
|
||||
|
||||
# Catch misspellings of hotmail.com
|
||||
if ($domain =~ /^(otmail|hotmial|hotmil|hotamail|hotmaul|hoatmail|hatmail|htomail)\.(cm|co|com|cmo|om)$/ or
|
||||
$domain =~ /^hotmail\.(cm|co|om|cmo)$/)
|
||||
{
|
||||
return $reject->("bad_hotmail_spelling",
|
||||
"You gave $email as your email address. Are you sure you didn't mean hotmail.com?");
|
||||
}
|
||||
|
||||
# Catch misspellings of aol.com
|
||||
elsif ($domain =~ /^(ol|aoll)\.(cm|co|com|cmo|om)$/ or
|
||||
$domain =~ /^aol\.(cm|co|om|cmo)$/)
|
||||
{
|
||||
return $reject->("bad_aol_spelling",
|
||||
"You gave $email as your email address. Are you sure you didn't mean aol.com?");
|
||||
}
|
||||
|
||||
# Catch web addresses (two or more w's followed by a dot)
|
||||
elsif ($username =~ /^www*\./)
|
||||
{
|
||||
return $reject->("web_address",
|
||||
"You gave $email as your email address, but it looks more like a web address to me.");
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
225
livejournal/cgi-bin/fbupload.pl
Executable file
225
livejournal/cgi-bin/fbupload.pl
Executable file
@@ -0,0 +1,225 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package LJ::FBUpload;
|
||||
use strict;
|
||||
|
||||
require "$ENV{LJHOME}/cgi-bin/ljconfig.pl";
|
||||
require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
|
||||
use MIME::Words ();
|
||||
use XML::Simple;
|
||||
use IO::Handle;
|
||||
use LWP::UserAgent;
|
||||
use URI::Escape;
|
||||
use Digest::MD5 ();
|
||||
use File::Basename ();
|
||||
|
||||
*hash = \&Digest::MD5::md5_hex;
|
||||
|
||||
# This has bitten us one too many times.
|
||||
# Don't let startup continue unless LWP is ok.
|
||||
die "* Installed version of LWP is too old! *" if LWP->VERSION < 5.803;
|
||||
|
||||
sub make_auth
|
||||
{
|
||||
my ($chal, $password) = @_;
|
||||
return unless $chal && $password;
|
||||
return "crp:$chal:" . hash($chal . hash($password));
|
||||
}
|
||||
|
||||
sub get_challenge
|
||||
{
|
||||
my ($u, $ua, $err) = @_;
|
||||
return unless $u && $ua;
|
||||
|
||||
my $req = HTTP::Request->new(GET => "$LJ::FB_SITEROOT/interface/simple");
|
||||
$req->push_header("X-FB-Mode" => "GetChallenge");
|
||||
$req->push_header("X-FB-User" => $u->{'user'});
|
||||
|
||||
my $res = $$ua->request($req);
|
||||
if ($res->is_success()) {
|
||||
|
||||
my $xmlres = XML::Simple::XMLin($res->content);
|
||||
my $methres = $xmlres->{GetChallengeResponse};
|
||||
return $methres->{Challenge};
|
||||
|
||||
} else {
|
||||
$$err = $res->content();
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# returns FB protocol data structure, regardless of FB
|
||||
# success or failure. it's the callers responsibility
|
||||
# to check the structure for FB return values.
|
||||
#
|
||||
# on http failure, returns numeric http error code,
|
||||
# and sets $rv reference with errorstring.
|
||||
#
|
||||
# returns undef on unrecoverable failure.
|
||||
#
|
||||
# opts: { path => path to image on disk,
|
||||
# or title to use if 'rawdata' isn't on disk.
|
||||
# rawdata => optional image data scalar ref
|
||||
# imgsec => bitmask for image security
|
||||
# caption => optional image description
|
||||
# galname => gallery to upload image to }
|
||||
sub do_upload
|
||||
{
|
||||
my ($u, $rv, $opts) = @_;
|
||||
unless ($u && $opts->{'path'}) {
|
||||
$$rv = "Invalid parameters to do_upload()";
|
||||
return;
|
||||
}
|
||||
|
||||
my $ua = LWP::UserAgent->new;
|
||||
$ua->agent("LiveJournal_FBUpload/0.2");
|
||||
|
||||
my $err;
|
||||
my $chal = get_challenge($u, \$ua, \$err);
|
||||
unless ($chal) {
|
||||
$$rv = "Error getting challenge from FB server: $err";
|
||||
return;
|
||||
}
|
||||
|
||||
my $rawdata = $opts->{'rawdata'};
|
||||
unless ($rawdata) {
|
||||
# no rawdata was passed, so slurp it in ourselves
|
||||
unless (open (F, $opts->{'path'})) {
|
||||
$$rv = "Couldn't read image file: $!\n";
|
||||
return;
|
||||
}
|
||||
binmode(F);
|
||||
my $data;
|
||||
{ local $/ = undef; $data = <F>; }
|
||||
$rawdata = \$data;
|
||||
close F;
|
||||
}
|
||||
|
||||
# convert strings to security masks/
|
||||
# default to private on unknown strings.
|
||||
# lack of an imgsec opt means public.
|
||||
$opts->{imgsec} ||= 255;
|
||||
unless ($opts->{imgsec} =~ /^\d+$/) {
|
||||
my %groupmap = (
|
||||
private => 0, regusers => 253,
|
||||
friends => 254, public => 255
|
||||
);
|
||||
$opts->{imgsec} = 'private' unless $groupmap{ $opts->{imgsec} };
|
||||
$opts->{imgsec} = $groupmap{ $opts->{imgsec} };
|
||||
}
|
||||
|
||||
my $basename = File::Basename::basename($opts->{'path'});
|
||||
my $length = length $$rawdata;
|
||||
|
||||
my $req = HTTP::Request->new(PUT => "$LJ::FB_SITEROOT/interface/simple");
|
||||
my %headers = (
|
||||
'X-FB-Mode' => 'UploadPic',
|
||||
'X-FB-UploadPic.ImageLength' => $length,
|
||||
'Content-Length' => $length,
|
||||
'X-FB-UploadPic.Meta.Filename' => $basename,
|
||||
'X-FB-UploadPic.MD5' => hash($$rawdata),
|
||||
'X-FB-User' => $u->{'user'},
|
||||
'X-FB-Auth' => make_auth( $chal, $u->{'password'} ),
|
||||
':X-FB-UploadPic.Gallery._size'=> 1,
|
||||
'X-FB-UploadPic.PicSec' => $opts->{'imgsec'},
|
||||
'X-FB-UploadPic.Gallery.0.GalName' => $opts->{'galname'} || 'LJ_emailpost',
|
||||
'X-FB-UploadPic.Gallery.0.GalSec' => 255
|
||||
);
|
||||
|
||||
$headers{'X-FB-UploadPic.Meta.Description'} = $opts->{caption}
|
||||
if $opts->{caption};
|
||||
|
||||
$req->push_header($_, $headers{$_}) foreach keys %headers;
|
||||
|
||||
$req->content($$rawdata);
|
||||
my $res = $ua->request($req);
|
||||
|
||||
my $res_code = $1 if $res->status_line =~ /^(\d+)/;
|
||||
unless ($res->is_success) {
|
||||
$$rv = "HTTP error uploading pict: " . $res->content();
|
||||
return $res_code;
|
||||
}
|
||||
|
||||
my $xmlres;
|
||||
eval { $xmlres = XML::Simple::XMLin($res->content); };
|
||||
if ($@) {
|
||||
$$rv = "Error parsing XML: $@";
|
||||
return;
|
||||
}
|
||||
my $methres = $xmlres->{UploadPicResponse};
|
||||
$methres->{Title} = $basename;
|
||||
|
||||
return $methres;
|
||||
}
|
||||
|
||||
# args:
|
||||
# $u,
|
||||
# arrayref of { title, url, width, height, caption }
|
||||
# optional opts overrides hashref.
|
||||
# (if not supplied, userprops are used.)
|
||||
# returns: html string suitable for entry post body
|
||||
# TODO: Hook this like the Fotobilder "post to journal"
|
||||
# caption posting page. More pretty. (layout keywords?)
|
||||
sub make_html
|
||||
{
|
||||
my ($u, $images, $opts) = @_;
|
||||
my ($icount, $html);
|
||||
|
||||
$icount = scalar @$images;
|
||||
return "" unless $icount;
|
||||
|
||||
# Merge overrides with userprops that might
|
||||
# have been passed in.
|
||||
$opts = {} unless $opts && ref $opts;
|
||||
my @props = qw/ emailpost_imgsize emailpost_imglayout emailpost_imgcut /;
|
||||
|
||||
LJ::load_user_props( $u, @props );
|
||||
foreach (@props) {
|
||||
my $prop = $_;
|
||||
$prop =~ s/emailpost_//;
|
||||
$opts->{$prop} = lc($opts->{$prop}) || $u->{$_};
|
||||
}
|
||||
|
||||
$opts->{imgcut} ||= 'totals';
|
||||
$html .= "\n";
|
||||
|
||||
# set journal image display size
|
||||
my @valid_sizes = qw/ 100x100 320x240 640x480 /;
|
||||
$opts->{imgsize} = '320x240' unless grep { $opts->{imgsize} eq $_; } @valid_sizes;
|
||||
my ($width, $height) = split 'x', $opts->{imgsize};
|
||||
my $size = '/s' . $opts->{imgsize};
|
||||
|
||||
# force lj-cut on images larger than 320 in either direction
|
||||
$opts->{imgcut} = 'totals' if $width > 320 || $height > 320;
|
||||
|
||||
# insert image links into post body
|
||||
my $horiz = $opts->{imglayout} =~ /^horiz/i;
|
||||
$html .=
|
||||
"<lj-cut text='$icount "
|
||||
. ( ( $icount == 1 ) ? 'image' : 'images' ) . "'>"
|
||||
if $opts->{imgcut} eq 'totals';
|
||||
$html .= "<table border='0'><tr>"
|
||||
if $horiz;
|
||||
|
||||
foreach my $i (@$images) {
|
||||
my $title = LJ::ehtml($i->{'title'});
|
||||
|
||||
# don't set a size on images smaller than the requested width/height
|
||||
# (we never scale larger, just smaller)
|
||||
undef $size if $i->{width} <= $width || $i->{height} <= $height;
|
||||
|
||||
$html .= "<td>" if $horiz;
|
||||
$html .= "<lj-cut text=\"$title\">" if $opts->{imgcut} eq 'titles';
|
||||
$html .= "<a href=\"$i->{url}/\">";
|
||||
$html .= "<img src=\"$i->{url}$size\" alt=\"$title\" border=\"0\"></a><br />";
|
||||
$html .= "$i->{caption}<br />" if $i->{caption};
|
||||
$html .= $horiz ? '</td>' : '<br />';
|
||||
$html .= "</lj-cut> " if $opts->{imgcut} eq 'titles';
|
||||
}
|
||||
$html .= "</tr></table>" if $horiz;
|
||||
$html .= "</lj-cut>\n" if $opts->{imgcut} eq 'totals';
|
||||
|
||||
return $html;
|
||||
}
|
||||
|
||||
1;
|
||||
365
livejournal/cgi-bin/htmlcontrols.pl
Executable file
365
livejournal/cgi-bin/htmlcontrols.pl
Executable file
@@ -0,0 +1,365 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_datetime
|
||||
# class: component
|
||||
# des:
|
||||
# info: Parse output later with [func[html_datetime_decode]].
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_datetime
|
||||
{
|
||||
my $opts = shift;
|
||||
my $lang = $opts->{'lang'} || "EN";
|
||||
my ($yyyy, $mm, $dd, $hh, $nn, $ss);
|
||||
my $ret;
|
||||
my $name = $opts->{'name'};
|
||||
my $disabled = $opts->{'disabled'} ? 1 : 0;
|
||||
if ($opts->{'default'} =~ /^(\d\d\d\d)-(\d\d)-(\d\d)(?: (\d\d):(\d\d):(\d\d))?/) {
|
||||
($yyyy, $mm, $dd, $hh, $nn, $ss) = ($1 > 0 ? $1 : "",
|
||||
$2+0,
|
||||
$3 > 0 ? $3+0 : "",
|
||||
$4 > 0 ? $4 : "",
|
||||
$5 > 0 ? $5 : "",
|
||||
$6 > 0 ? $6 : "");
|
||||
}
|
||||
$ret .= html_select({ 'name' => "${name}_mm", 'selected' => $mm, 'disabled' => $disabled },
|
||||
map { $_, LJ::Lang::month_long($_) } (1..12));
|
||||
$ret .= html_text({ 'name' => "${name}_dd", 'size' => '2', 'maxlength' => '2', 'value' => $dd,
|
||||
'disabled' => $disabled }) . ", ";
|
||||
$ret .= html_text({ 'name' => "${name}_yyyy", 'size' => '4', 'maxlength' => '4', 'value' => $yyyy,
|
||||
'disabled' => $disabled });
|
||||
unless ($opts->{'notime'}) {
|
||||
$ret .= ' ';
|
||||
$ret .= html_text({ 'name' => "${name}_hh", 'size' => '2', 'maxlength' => '2', 'value' => $hh,
|
||||
'disabled' => $disabled }) . ':';
|
||||
$ret .= html_text({ 'name' => "${name}_nn", 'size' => '2', 'maxlength' => '2', 'value' => $nn,
|
||||
'disabled' => $disabled });
|
||||
if ($opts->{'seconds'}) {
|
||||
$ret .= ':';
|
||||
$ret .= html_text({ 'name' => "${name}_ss", 'size' => '2', 'maxlength' => '2', 'value' => $ss,
|
||||
'disabled' => $disabled });
|
||||
}
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_datetime_decode
|
||||
# class: component
|
||||
# des:
|
||||
# info: Generate the form controls with [func[html_datetime]].
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_datetime_decode
|
||||
{
|
||||
my $opts = shift;
|
||||
my $hash = shift;
|
||||
my $name = $opts->{'name'};
|
||||
return sprintf("%04d-%02d-%02d %02d:%02d:%02d",
|
||||
$hash->{"${name}_yyyy"},
|
||||
$hash->{"${name}_mm"},
|
||||
$hash->{"${name}_dd"},
|
||||
$hash->{"${name}_hh"},
|
||||
$hash->{"${name}_nn"},
|
||||
$hash->{"${name}_ss"});
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_select
|
||||
# class: component
|
||||
# des: Creates a drop-down box or listbox HTML form element (the <select> tag).
|
||||
# info:
|
||||
# args: opts
|
||||
# des-opts: A hashref of options. Special options are:
|
||||
# raw: inserts value unescaped into select tag;
|
||||
# noescape: won't escape key values if set to 1
|
||||
# disabled: disables the element;
|
||||
# multiple: creates a drop-down if 0, a multi-select listbox if 1;
|
||||
# selected: if multiple, an arrayref of selected values; otherwise, a scalar equalling the selected value;
|
||||
# All other options will be treated as html attribute/value pairs
|
||||
# returns: the generated HTML.
|
||||
# </WCMFUNC>
|
||||
sub html_select
|
||||
{
|
||||
my $opts = shift;
|
||||
my @items = @_;
|
||||
my $ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
my $ret;
|
||||
$ret .= "<select";
|
||||
$ret .= " $opts->{'raw'}" if $opts->{'raw'};
|
||||
$ret .= " disabled='disabled'" if $opts->{'disabled'};
|
||||
$ret .= " multiple='multiple'" if $opts->{'multiple'};
|
||||
foreach (grep { ! /^(raw|disabled|selected|noescape|multiple)$/ } keys %$opts) {
|
||||
$ret .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
$ret .= ">";
|
||||
|
||||
# build hashref from arrayref if multiple selected
|
||||
my $selref = { map { $_, 1 } @{$opts->{'selected'}} }
|
||||
if $opts->{'multiple'} && ref $opts->{'selected'} eq 'ARRAY';
|
||||
|
||||
my $did_sel = 0;
|
||||
while (defined (my $value = shift @items)) {
|
||||
|
||||
# items can be either pairs of $value, $text or a list of $it hashrefs (or a mix)
|
||||
my $it = {};
|
||||
my $text;
|
||||
if (ref $value) {
|
||||
$it = $value;
|
||||
$value = $it->{value};
|
||||
$text = $it->{text};
|
||||
} else {
|
||||
$text = shift @items;
|
||||
}
|
||||
|
||||
my $sel = "";
|
||||
# multiple-mode or single-mode?
|
||||
if (ref $selref eq 'HASH' && $selref->{$value} ||
|
||||
$opts->{'selected'} eq $value && !$did_sel++) {
|
||||
|
||||
$sel = " selected='selected'";
|
||||
}
|
||||
$value = $ehtml ? ehtml($value) : $value;
|
||||
|
||||
my $id;
|
||||
if ($opts->{'name'} ne "" && $value ne "") {
|
||||
$id = " id='$opts->{'name'}_$value'";
|
||||
}
|
||||
|
||||
# is this individual option disabled?
|
||||
my $dis = $it->{'disabled'} ? " disabled='disabled'" : '';
|
||||
|
||||
$ret .= "<option value=\"$value\"$id$sel$dis>" .
|
||||
($ehtml ? ehtml($text) : $text) . "</option>";
|
||||
}
|
||||
$ret .= "</select>";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_check
|
||||
# class: component
|
||||
# des:
|
||||
# info:
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_check
|
||||
{
|
||||
my $opts = shift;
|
||||
|
||||
my $disabled = $opts->{'disabled'} ? " disabled='disabled'" : "";
|
||||
my $ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
my $ret;
|
||||
if ($opts->{'type'} eq "radio") {
|
||||
$ret .= "<input type='radio'";
|
||||
} else {
|
||||
$ret .= "<input type='checkbox'";
|
||||
}
|
||||
if ($opts->{'selected'}) { $ret .= " checked='checked'"; }
|
||||
if ($opts->{'raw'}) { $ret .= " $opts->{'raw'}"; }
|
||||
foreach (grep { ! /^(disabled|type|selected|raw|noescape)$/ } keys %$opts) {
|
||||
$ret .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
$ret .= "$disabled />";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_text
|
||||
# class: component
|
||||
# des:
|
||||
# info:
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_text
|
||||
{
|
||||
my $opts = shift;
|
||||
|
||||
my $disabled = $opts->{'disabled'} ? " disabled='disabled'" : "";
|
||||
my $ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
my $type = $opts->{'type'} eq 'password' ? 'password' : 'text';
|
||||
my $ret;
|
||||
$ret .= "<input type=\"$type\"";
|
||||
foreach (grep { ! /^(type|disabled|raw|noescape)$/ } keys %$opts) {
|
||||
$ret .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
if ($opts->{'raw'}) { $ret .= " $opts->{'raw'}"; }
|
||||
$ret .= "$disabled />";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_textarea
|
||||
# class: component
|
||||
# des:
|
||||
# info:
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_textarea
|
||||
{
|
||||
my $opts = shift;
|
||||
|
||||
my $disabled = $opts->{'disabled'} ? " disabled='disabled'" : "";
|
||||
my $ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
my $ret;
|
||||
$ret .= "<textarea";
|
||||
foreach (grep { ! /^(disabled|raw|value|noescape)$/ } keys %$opts) {
|
||||
$ret .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
if ($opts->{'raw'}) { $ret .= " $opts->{'raw'}"; }
|
||||
$ret .= "$disabled>" . ($ehtml ? ehtml($opts->{'value'}) : $opts->{'value'}) . "</textarea>";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_color
|
||||
# class: component
|
||||
# des: A text field with attached color preview and button to choose a color
|
||||
# info: Depends on the client-side Color Picker
|
||||
# args:
|
||||
# des-:
|
||||
# returns:
|
||||
# </WCMFUNC>
|
||||
sub html_color
|
||||
{
|
||||
my $opts = shift;
|
||||
|
||||
my $htmlname = ehtml($opts->{'name'});
|
||||
my $des = ehtml($opts->{'des'}) || "Pick a Color";
|
||||
my $ret;
|
||||
|
||||
## Output the preview box and picker button with script so that
|
||||
## they don't appear when JavaScript is unavailable.
|
||||
$ret .= "<script language=\"JavaScript\"><!--\n".
|
||||
"document.write('<span style=\"border: 1px solid #000000; ".
|
||||
"padding-left: 2em; background-color: " . ehtml($opts->{'default'}) . ";\" ".
|
||||
"id=\"${htmlname}_disp\"> </span>'); ".
|
||||
"\n--></script>\n";
|
||||
|
||||
# 'onchange' argument happens when color picker button is clicked,
|
||||
# or when focus is changed to text box
|
||||
|
||||
$ret .= html_text({ 'size' => 8, 'maxlength' => 7, 'name' => $htmlname, 'id' => $htmlname,
|
||||
'onchange' => "setBGColor(findel('${htmlname}_disp'),${htmlname}.value);",
|
||||
'onfocus' => $opts->{'onchange'},
|
||||
'disabled' => $opts->{'disabled'}, 'value' => $opts->{'default'},
|
||||
'noescape' => 1, 'raw' => $opts->{'raw'},
|
||||
});
|
||||
|
||||
my $disabled = $opts->{'disabled'} ? "disabled=\'disabled\'" : '';
|
||||
$ret .= "<script language=\"JavaScript\"><!--\n".
|
||||
"document.write('<button ".
|
||||
"onclick=\"spawnPicker(findel(\\'${htmlname}\\')," .
|
||||
"findel(\\'${htmlname}_disp\\'),\\'$des\\'); " .
|
||||
LJ::ejs($opts->{'onchange'}) .
|
||||
" return false;\"$disabled>Choose...</button>'); ".
|
||||
"\n--></script>\n";
|
||||
|
||||
# A little help for the non-JavaScript folks
|
||||
$ret .= "<noscript> (#<var>rr</var><var>gg</var><var>bb</var>)</noscript>";
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_hidden
|
||||
# class: component
|
||||
# des: Makes the HTML for a hidden form element
|
||||
# args: name, val
|
||||
# des-name: Name of form element (will be HTML escaped)
|
||||
# des-val: Value of form element (will be HTML escaped)
|
||||
# returns: HTML
|
||||
# </WCMFUNC>
|
||||
sub html_hidden
|
||||
{
|
||||
my $ret;
|
||||
|
||||
while (@_) {
|
||||
my $name = shift;
|
||||
my $val;
|
||||
my $ehtml = 1;
|
||||
my $extra;
|
||||
if (ref $name eq 'HASH') {
|
||||
my $opts = $name;
|
||||
|
||||
$val = $opts->{value};
|
||||
$name = $opts->{name};
|
||||
|
||||
$ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
foreach (grep { ! /^(name|value|raw|noescape)$/ } keys %$opts) {
|
||||
$extra .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
|
||||
$extra .= " $opts->{'raw'}" if $opts->{'raw'};
|
||||
|
||||
} else {
|
||||
$val = shift;
|
||||
}
|
||||
|
||||
$ret .= "<input type='hidden'";
|
||||
# allow override of these in 'raw'
|
||||
$ret .= " name=\"" . ($ehtml ? ehtml($name) : $name) . "\"" if $name;
|
||||
$ret .= " value=\"" . ($ehtml ? ehtml($val) : $val) . "\"" if defined $val;
|
||||
$ret .= "$extra />";
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <WCMFUNC>
|
||||
# name: html_submit
|
||||
# class: component
|
||||
# des: Makes the HTML for a submit button
|
||||
# args: name, val, opts?
|
||||
# des-name: Name of form element (will be HTML escaped)
|
||||
# des-val: Value of form element, and label of button (will be HTML escaped)
|
||||
# des-opts: Optional hashref of additional tag attributes
|
||||
# returns: HTML
|
||||
# </WCMFUNC>
|
||||
sub html_submit
|
||||
{
|
||||
my ($name, $val, $opts) = @_;
|
||||
|
||||
# if one argument, assume (undef, $val)
|
||||
if (@_ == 1) {
|
||||
$val = $name;
|
||||
$name = undef;
|
||||
}
|
||||
|
||||
my ($eopts, $disabled, $raw);
|
||||
my $type = 'submit';
|
||||
|
||||
my $ehtml;
|
||||
if ($opts && ref $opts eq 'HASH') {
|
||||
$disabled = " disabled='disabled'" if $opts->{'disabled'};
|
||||
$raw = " $opts->{'raw'}" if $opts->{'raw'};
|
||||
$type = 'reset' if $opts->{'type'} eq 'reset';
|
||||
|
||||
$ehtml = $opts->{'noescape'} ? 0 : 1;
|
||||
foreach (grep { ! /^(raw|disabled|noescape|type)$/ } keys %$opts) {
|
||||
$eopts .= " $_=\"" . ($ehtml ? ehtml($opts->{$_}) : $opts->{$_}) . "\"";
|
||||
}
|
||||
}
|
||||
my $ret = "<input type='$type'";
|
||||
# allow override of these in 'raw'
|
||||
$ret .= " name=\"" . ($ehtml ? ehtml($name) : $name) . "\"" if $name;
|
||||
$ret .= " value=\"" . ($ehtml ? ehtml($val) : $val) . "\"" if defined $val;
|
||||
$ret .= "$eopts$raw$disabled />";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
119
livejournal/cgi-bin/imageconf.pl
Executable file
119
livejournal/cgi-bin/imageconf.pl
Executable file
@@ -0,0 +1,119 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
package LJ::Img;
|
||||
use vars qw(%img);
|
||||
|
||||
$img{'btn_up'} = {
|
||||
'src' => '/btn_up.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Up',
|
||||
};
|
||||
|
||||
$img{'btn_down'} = {
|
||||
'src' => '/btn_dn.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Down',
|
||||
};
|
||||
|
||||
$img{'btn_del'} = {
|
||||
'src' => '/btn_del.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Delete',
|
||||
};
|
||||
|
||||
$img{'btn_freeze'} = {
|
||||
'src' => '/btn_freeze.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Freeze',
|
||||
};
|
||||
|
||||
$img{'btn_unfreeze'} = {
|
||||
'src' => '/btn_unfreeze.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Unfreeze',
|
||||
};
|
||||
|
||||
$img{'btn_scr'} = {
|
||||
'src' => '/btn_scr.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Screen',
|
||||
};
|
||||
|
||||
$img{'btn_unscr'} = {
|
||||
'src' => '/btn_unscr.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Unscreen',
|
||||
};
|
||||
|
||||
$img{'prev_entry'} = {
|
||||
'src' => '/btn_prev.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Previous Entry',
|
||||
};
|
||||
|
||||
$img{'next_entry'} = {
|
||||
'src' => '/btn_next.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Next Entry',
|
||||
};
|
||||
|
||||
$img{'memadd'} = {
|
||||
'src' => '/memadd.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Add to memories!',
|
||||
};
|
||||
|
||||
$img{'editentry'} = {
|
||||
'src' => '/btn_edit.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Edit Entry',
|
||||
};
|
||||
|
||||
$img{'edittags'} = {
|
||||
'src' => '/btn_edittags.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Edit Tags',
|
||||
};
|
||||
|
||||
$img{'tellfriend'} = {
|
||||
'src' => '/btn_tellfriend.gif',
|
||||
'width' => 22,
|
||||
'height' => 20,
|
||||
'alt' => 'Tell a Friend!',
|
||||
};
|
||||
|
||||
$img{'placeholder'} = {
|
||||
'src' => '/imageplaceholder2.png',
|
||||
'width' => 35,
|
||||
'height' => 35,
|
||||
'alt' => 'Image',
|
||||
};
|
||||
|
||||
$img{'xml'} = {
|
||||
'src' => '/xml.gif',
|
||||
'width' => 36,
|
||||
'height' => 14,
|
||||
'alt' => 'XML Source',
|
||||
};
|
||||
|
||||
# load the site-local version, if it's around.
|
||||
if (-e "$LJ::HOME/cgi-bin/imageconf-local.pl") {
|
||||
require "$LJ::HOME/cgi-bin/imageconf-local.pl";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
30
livejournal/cgi-bin/lj-bml-blocks.pl
Executable file
30
livejournal/cgi-bin/lj-bml-blocks.pl
Executable file
@@ -0,0 +1,30 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
|
||||
|
||||
BML::register_block("DOMAIN", "S", $LJ::DOMAIN);
|
||||
BML::register_block("IMGPREFIX", "S", $LJ::IMGPREFIX);
|
||||
BML::register_block("STATPREFIX", "S", $LJ::STATPREFIX);
|
||||
BML::register_block("SITEROOT", "S", $LJ::SITEROOT);
|
||||
BML::register_block("SITENAME", "S", $LJ::SITENAME);
|
||||
BML::register_block("ADMIN_EMAIL", "S", $LJ::ADMIN_EMAIL);
|
||||
BML::register_block("SUPPORT_EMAIL", "S", $LJ::SUPPORT_EMAIL);
|
||||
BML::register_block("CHALRESPJS", "", $LJ::COMMON_CODE{'chalresp_js'});
|
||||
|
||||
{
|
||||
my $dl = "<a href=\"$LJ::SITEROOT/files/%%DATA%%\">HTTP</a>";
|
||||
if ($LJ::FTPPREFIX) {
|
||||
$dl .= " - <a href=\"$LJ::FTPPREFIX/%%DATA%%\">FTP</a>";
|
||||
}
|
||||
BML::register_block("DL", "DR", $dl);
|
||||
}
|
||||
|
||||
if ($LJ::UNICODE) {
|
||||
BML::register_block("METACTYPE", "S", '<meta http-equiv="Content-Type" content="text/html; charset=utf-8">')
|
||||
} else {
|
||||
BML::register_block("METACTYPE", "S", '<meta http-equiv="Content-Type" content="text/html">')
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
53
livejournal/cgi-bin/lj-bml-init.pl
Executable file
53
livejournal/cgi-bin/lj-bml-init.pl
Executable file
@@ -0,0 +1,53 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljconfig.pl";
|
||||
|
||||
foreach (@LJ::LANGS, @LJ::LANGS_IN_PROGRESS) {
|
||||
BML::register_isocode(substr($_, 0, 2), $_);
|
||||
BML::register_language($_);
|
||||
}
|
||||
|
||||
# set default path/domain for cookies
|
||||
BML::set_config("CookieDomain" => $LJ::COOKIE_DOMAIN);
|
||||
BML::set_config("CookiePath" => $LJ::COOKIE_PATH);
|
||||
|
||||
BML::register_hook("startup", sub {
|
||||
my $r = Apache->request;
|
||||
my $uri = "bml" . $r->uri;
|
||||
unless ($uri =~ s/\.bml$//) {
|
||||
$uri .= ".index";
|
||||
}
|
||||
$uri =~ s!/!.!g;
|
||||
$r->notes("codepath" => $uri);
|
||||
});
|
||||
|
||||
BML::register_hook("codeerror", sub {
|
||||
my $msg = shift;
|
||||
if ($msg =~ /Can\'t call method.*on an undefined value/) {
|
||||
return $LJ::MSG_DB_UNAVAILABLE ||
|
||||
"Sorry, database temporarily unavailable.";
|
||||
}
|
||||
chomp $msg;
|
||||
$msg .= " \@ $LJ::SERVER_NAME" if $LJ::SERVER_NAME;
|
||||
warn "$msg\n";
|
||||
return "<b>[Error: $msg]</b>";
|
||||
}) unless $LJ::IS_DEV_SERVER;
|
||||
|
||||
if ($LJ::UNICODE) {
|
||||
BML::set_config("DefaultContentType", "text/html; charset=utf-8");
|
||||
}
|
||||
|
||||
# register BML multi-language hook
|
||||
BML::register_hook("ml_getter", \&LJ::Lang::get_text);
|
||||
|
||||
# include file handling
|
||||
BML::register_hook('include_getter', sub {
|
||||
# simply call LJ::load_include, as it does all the work of hitting up
|
||||
# memcache/db for us and falling back to disk if necessary...
|
||||
my ($file, $source) = @_;
|
||||
$$source = LJ::load_include($file);
|
||||
return 1;
|
||||
});
|
||||
|
||||
1;
|
||||
322
livejournal/cgi-bin/ljcmdbuffer.pl
Executable file
322
livejournal/cgi-bin/ljcmdbuffer.pl
Executable file
@@ -0,0 +1,322 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
|
||||
require "$ENV{LJHOME}/cgi-bin/supportlib.pl";
|
||||
require "$ENV{LJHOME}/cgi-bin/ljmail.pl";
|
||||
|
||||
package LJ::Cmdbuffer;
|
||||
|
||||
# built-in commands
|
||||
%LJ::Cmdbuffer::cmds =
|
||||
(
|
||||
|
||||
# delete journal entries
|
||||
delitem => {
|
||||
run => \&LJ::Cmdbuffer::_delitem,
|
||||
},
|
||||
|
||||
# ping weblogs.com with updates? takes a $u argument
|
||||
weblogscom => {
|
||||
too_old => 60*60*2, # 2 hours old = qbufferd not running?
|
||||
once_per_user => 1,
|
||||
run => \&LJ::Cmdbuffer::_weblogscom,
|
||||
},
|
||||
|
||||
# emails that previously failed to send
|
||||
send_mail => {
|
||||
arg_format => 'raw',
|
||||
run => \&LJ::Cmdbuffer::_send_mail,
|
||||
},
|
||||
|
||||
# notify fotobilder of dirty friends
|
||||
dirty => {
|
||||
once_per_user => 1,
|
||||
kill_mem_size => 50_000, # bytes
|
||||
kill_job_ct => 250, # calls to LJ::Cmdbuffer::flush
|
||||
run => \&LJ::Cmdbuffer::_dirty,
|
||||
},
|
||||
|
||||
# send notifications for support requests
|
||||
support_notify => {
|
||||
too_old => 60*60*2, # after two hours, notification seems kinda pointless
|
||||
run => \&LJ::Cmdbuffer::_support_notify,
|
||||
},
|
||||
|
||||
);
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Cmdbuffer::flush
|
||||
# des: flush up to 500 rows of a given command type from the cmdbuffer table
|
||||
# args: dbh, db, cmd, userid?
|
||||
# des-dbh: master database handle
|
||||
# des-db: database cluster master
|
||||
# des-cmd: a command type registered in %LJ::Cmdbuffer::cmds
|
||||
# des-userid: optional userid to which flush should be constrained
|
||||
# returns: 1 on success, 0 on failure
|
||||
# </LJFUNC>
|
||||
sub LJ::Cmdbuffer::flush
|
||||
{
|
||||
my ($dbh, $db, $cmd, $userid) = @_;
|
||||
return 0 unless $cmd;
|
||||
|
||||
my $mode = "run";
|
||||
if ($cmd =~ s/:(\w+)//) {
|
||||
$mode = $1;
|
||||
}
|
||||
|
||||
my $code = $LJ::Cmdbuffer::cmds{$cmd} ?
|
||||
$LJ::Cmdbuffer::cmds{$cmd}->{$mode} : $LJ::HOOKS{"cmdbuf:$cmd:$mode"}->[0];
|
||||
return 0 unless $code;
|
||||
|
||||
# start/finish modes
|
||||
if ($mode ne "run") {
|
||||
$code->($dbh);
|
||||
return 1;
|
||||
}
|
||||
|
||||
# 0 = never too old
|
||||
my $too_old = LJ::Cmdbuffer::get_property($cmd, 'too_old') || 0;
|
||||
|
||||
# 0 == okay to run more than once per user
|
||||
my $once_per_user = LJ::Cmdbuffer::get_property($cmd, 'once_per_user') || 0;
|
||||
|
||||
# 'url' = urlencode, 'raw' = don't urlencode
|
||||
my $arg_format = LJ::Cmdbuffer::get_property($cmd, 'arg_format') || 'url';
|
||||
|
||||
my $clist;
|
||||
my $loop = 1;
|
||||
|
||||
my $where = "cmd=" . $dbh->quote($cmd);
|
||||
if ($userid) {
|
||||
$where .= " AND journalid=" . $dbh->quote($userid);
|
||||
}
|
||||
|
||||
my $LIMIT = 500;
|
||||
|
||||
while ($loop &&
|
||||
($clist = $db->selectall_arrayref("SELECT cbid, UNIX_TIMESTAMP() - UNIX_TIMESTAMP(instime), journalid ".
|
||||
"FROM cmdbuffer ".
|
||||
"WHERE $where ORDER BY cbid LIMIT $LIMIT")) &&
|
||||
$clist && @$clist)
|
||||
{
|
||||
my @too_old;
|
||||
my @cbids;
|
||||
|
||||
# citem: [ cbid, age, journalid ]
|
||||
foreach my $citem (@$clist) {
|
||||
if ($too_old && $citem->[1] > $too_old) {
|
||||
push @too_old, $citem->[0];
|
||||
} else {
|
||||
push @cbids, $citem->[0];
|
||||
}
|
||||
}
|
||||
if (@too_old) {
|
||||
local $" = ",";
|
||||
$db->do("DELETE FROM cmdbuffer WHERE cbid IN (@too_old)");
|
||||
}
|
||||
|
||||
foreach my $cbid (@cbids) {
|
||||
my $got_lock = $db->selectrow_array("SELECT GET_LOCK('cbid-$cbid',10)");
|
||||
return 0 unless $got_lock;
|
||||
# sadly, we have to do another query here to verify the job hasn't been
|
||||
# done by another thread. (otherwise we could've done it above, instead
|
||||
# of just getting the id)
|
||||
|
||||
my $c = $db->selectrow_hashref("SELECT cbid, journalid, cmd, instime, args " .
|
||||
"FROM cmdbuffer WHERE cbid=?", undef, $cbid);
|
||||
next unless $c;
|
||||
|
||||
if ($arg_format eq "url") {
|
||||
my $a = {};
|
||||
LJ::decode_url_string($c->{'args'}, $a);
|
||||
$c->{'args'} = $a;
|
||||
}
|
||||
# otherwise, arg_format eq "raw"
|
||||
|
||||
# run handler
|
||||
$code->($dbh, $db, $c);
|
||||
|
||||
# if this task is to be run once per user, go ahead and delete any jobs
|
||||
# for this user of this type and remove them from the queue
|
||||
my $wh = "cbid=$cbid";
|
||||
if ($once_per_user) {
|
||||
$wh = "cmd=" . $db->quote($cmd) . " AND journalid=" . $db->quote($c->{journalid});
|
||||
@$clist = grep { $_->[2] != $c->{journalid} } @$clist;
|
||||
}
|
||||
|
||||
$db->do("DELETE FROM cmdbuffer WHERE $wh");
|
||||
$db->do("SELECT RELEASE_LOCK('cbid-$cbid')");
|
||||
}
|
||||
$loop = 0 unless scalar(@$clist) == $LIMIT;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Cmdbuffer::get_property
|
||||
# des: get a property of an async job type, either built-in or site-specific
|
||||
# args: cmd, prop
|
||||
# des-cmd: a registered async job type
|
||||
# des-prop: the property name to look up
|
||||
# returns: value of property (whatever it may be) on success, undef on failure
|
||||
# </LJFUNC>
|
||||
sub get_property {
|
||||
my ($cmd, $prop) = @_;
|
||||
return undef unless $cmd && $prop;
|
||||
|
||||
if (my $c = $LJ::Cmdbuffer::cmds{$cmd}) {
|
||||
return $c->{$prop};
|
||||
}
|
||||
|
||||
if (LJ::are_hooks("cmdbuf:$cmd:$prop")) {
|
||||
return LJ::run_hook("cmdbuf:$cmd:$prop");
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub _delitem {
|
||||
my ($dbh, $db, $c) = @_;
|
||||
my $a = $c->{'args'};
|
||||
return LJ::delete_entry($c->{'journalid'}, $a->{'itemid'},
|
||||
0, $a->{'anum'});
|
||||
}
|
||||
|
||||
sub _weblogscom {
|
||||
# user, title, url
|
||||
my ($dbh, $db, $c) = @_;
|
||||
my $a = $c->{'args'};
|
||||
eval {
|
||||
eval "use XMLRPC::Lite;";
|
||||
unless ($@) {
|
||||
XMLRPC::Lite
|
||||
->new( proxy => "http://rpc.weblogs.com/RPC2",
|
||||
timeout => 5 )
|
||||
->call('weblogUpdates.ping', # xml-rpc method call
|
||||
LJ::ehtml($a->{'title'}) . " \@ $LJ::SITENAMESHORT",
|
||||
$a->{'url'},
|
||||
"$LJ::SITEROOT/misc/weblogs-change.bml?user=$a->{'user'}");
|
||||
}
|
||||
};
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _send_mail {
|
||||
my ($dbh, $db, $c) = @_;
|
||||
|
||||
my $msg = Storable::thaw($c->{'args'});
|
||||
return LJ::send_mail($msg, "async");
|
||||
}
|
||||
|
||||
sub _dirty {
|
||||
my ($dbh, $db, $c) = @_;
|
||||
|
||||
my $a = $c->{args};
|
||||
my $what = $a->{what};
|
||||
|
||||
if ($what eq 'friends') {
|
||||
eval {
|
||||
eval qq{
|
||||
use RPC::XML;
|
||||
use RPC::XML::Client;
|
||||
};
|
||||
unless ($@) {
|
||||
my $u = LJ::load_userid($c->{journalid});
|
||||
my %req = ( user => $u->{user} );
|
||||
|
||||
# fill in groups info
|
||||
LJ::fill_groups_xmlrpc($u, \%req);
|
||||
|
||||
my $res = RPC::XML::Client
|
||||
->new("$LJ::FB_SITEROOT/interface/xmlrpc")
|
||||
->send_request('FB.XMLRPC.groups_push',
|
||||
# FIXME: don't be lazy with the smart_encode
|
||||
# FIXME: log useful errors from outcome
|
||||
RPC::XML::smart_encode(\%req));
|
||||
}
|
||||
};
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _support_notify {
|
||||
my ($dbh, $db, $c) = @_;
|
||||
|
||||
# load basic stuff common to both paths
|
||||
my $a = $c->{args};
|
||||
my $type = $a->{type};
|
||||
my $spid = $a->{spid}+0;
|
||||
my $sp = LJ::Support::load_request($spid, $type eq 'new' ? 1 : 0); # 1 means load body
|
||||
my $dbr = LJ::get_db_reader();
|
||||
|
||||
# now branch a bit to select the right user information
|
||||
my ($select, $level) = $type eq 'new' ?
|
||||
('u.email', "'new', 'all'") :
|
||||
('u.email, u.userid, u.user', "'all'");
|
||||
|
||||
my $data = $dbr->selectall_arrayref("SELECT $select FROM supportnotify sn, user u " .
|
||||
"WHERE sn.userid=u.userid AND sn.spcatid=? " .
|
||||
"AND sn.level IN ($level)", undef, $sp->{_cat}{spcatid});
|
||||
|
||||
# prepare the email
|
||||
my $body;
|
||||
my @emails;
|
||||
if ($type eq 'new') {
|
||||
$body = "A $LJ::SITENAME support request has been submitted regarding the following:\n\n";
|
||||
$body .= "Category: $sp->{_cat}{catname}\n";
|
||||
$body .= "Subject: $sp->{subject}\n\n";
|
||||
$body .= "You can track its progress or add information here:\n\n";
|
||||
$body .= "$LJ::SITEROOT/support/see_request.bml?id=$spid";
|
||||
$body .= "\n\nIf you do not wish to receive notifications of incoming support requests, you may change your notification settings here:\n\n";
|
||||
$body .= "$LJ::SITEROOT/support/changenotify.bml";
|
||||
$body .= "\n\n" . "="x70 . "\n\n";
|
||||
$body .= $sp->{body};
|
||||
|
||||
# just copy this out
|
||||
push @emails, $_->[0] foreach @$data;
|
||||
} elsif ($type eq 'update') {
|
||||
# load the response we want to stuff in the email
|
||||
my ($resp, $rtype, $posterid) =
|
||||
$dbr->selectrow_array("SELECT message, type, userid FROM supportlog WHERE spid = ? AND splid = ?",
|
||||
undef, $sp->{spid}, $a->{splid}+0);
|
||||
|
||||
# build body
|
||||
$body = "A follow-up to the request regarding \"$sp->{subject}\" has ";
|
||||
$body .= "been submitted. You can track its progress or add ";
|
||||
$body .= "information here:\n\n ";
|
||||
$body .= "$LJ::SITEROOT/support/see_request.bml?id=$spid";
|
||||
$body .= "\n\n" . "="x70 . "\n\n";
|
||||
$body .= $resp;
|
||||
|
||||
# now see who this should be sent to
|
||||
foreach my $erow (@$data) {
|
||||
next if $posterid == $erow->[1];
|
||||
next if $rtype eq 'screened' &&
|
||||
!LJ::Support::can_read_screened($sp, LJ::make_remote($erow->[2], $erow->[1]));
|
||||
next if $rtype eq 'internal' &&
|
||||
!LJ::Support::can_read_internal($sp, LJ::make_remote($erow->[2], $erow->[1]));
|
||||
push @emails, $erow->[0];
|
||||
}
|
||||
}
|
||||
|
||||
# send the email
|
||||
LJ::send_mail({
|
||||
bcc => join(', ', @emails),
|
||||
from => $LJ::BOGUS_EMAIL,
|
||||
fromname => "$LJ::SITENAME Support",
|
||||
charset => 'utf-8',
|
||||
subject => ($type eq 'update' ? 'Re: ' : '') . "Support Request \#$spid",
|
||||
body => $body,
|
||||
wrap => 1,
|
||||
}) if @emails;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
55
livejournal/cgi-bin/ljdb.pl
Executable file
55
livejournal/cgi-bin/ljdb.pl
Executable file
@@ -0,0 +1,55 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
use lib "$ENV{LJHOME}/cgi-bin";
|
||||
use DBI::Role;
|
||||
use DBI;
|
||||
|
||||
require "$ENV{LJHOME}/cgi-bin/ljconfig.pl";
|
||||
|
||||
package LJ::DB;
|
||||
|
||||
our $DBIRole = new DBI::Role {
|
||||
'timeout' => 2,
|
||||
'sources' => \%LJ::DBINFO,
|
||||
'default_db' => "livejournal",
|
||||
'time_check' => 60,
|
||||
};
|
||||
|
||||
sub dbh_by_role {
|
||||
return $DBIRole->get_dbh( @_ );
|
||||
}
|
||||
|
||||
sub dbh_by_name {
|
||||
my $name = shift;
|
||||
my $dbh = dbh_by_role("master")
|
||||
or die "Couldn't contact master to find name of '$name'\n";
|
||||
|
||||
my $fdsn = $dbh->selectrow_array("SELECT fdsn FROM dbinfo WHERE name=?", undef, $name);
|
||||
die "No fdsn found for db name '$name'\n" unless $fdsn;
|
||||
|
||||
return $DBIRole->get_dbh_conn($fdsn);
|
||||
|
||||
}
|
||||
|
||||
sub dbh_by_fdsn {
|
||||
my $fdsn = shift;
|
||||
return $DBIRole->get_dbh_conn($fdsn);
|
||||
}
|
||||
|
||||
sub root_dbh_by_name {
|
||||
my $name = shift;
|
||||
my $dbh = dbh_by_role("master")
|
||||
or die "Couldn't contact master to find name of '$name'";
|
||||
|
||||
my $fdsn = $dbh->selectrow_array("SELECT rootfdsn FROM dbinfo WHERE name=?", undef, $name);
|
||||
die "No rootfdsn found for db name '$name'\n" unless $fdsn;
|
||||
|
||||
return $DBIRole->get_dbh_conn($fdsn);
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
|
||||
245
livejournal/cgi-bin/ljdefaults.pl
Executable file
245
livejournal/cgi-bin/ljdefaults.pl
Executable file
@@ -0,0 +1,245 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# Do not edit this file. You should edit ljconfig.pl, which you should have at
|
||||
# cgi-bin/ljconfig.pl. If you don't, copy it from doc/ljconfig.pl.txt to cgi-bin
|
||||
# and edit it there. This file only provides backup default values for upgrading.
|
||||
#
|
||||
|
||||
{
|
||||
package LJ;
|
||||
use Sys::Hostname ();
|
||||
|
||||
$DEFAULT_STYLE ||= {
|
||||
'core' => 'core1',
|
||||
'layout' => 'generator/layout',
|
||||
'i18n' => 'generator/en',
|
||||
};
|
||||
|
||||
# cluster 0 is no longer supported
|
||||
$DEFAULT_CLUSTER ||= 1;
|
||||
@CLUSTERS = (1) unless @CLUSTERS;
|
||||
|
||||
$HOME = $ENV{'LJHOME'};
|
||||
$HTDOCS = "$HOME/htdocs";
|
||||
$BIN = "$HOME/bin";
|
||||
|
||||
$SERVER_NAME ||= Sys::Hostname::hostname();
|
||||
|
||||
$UNICODE = 1 unless defined $UNICODE;
|
||||
|
||||
@LANGS = ("en") unless @LANGS;
|
||||
$DEFAULT_LANG ||= $LANGS[0];
|
||||
|
||||
$SITENAME ||= "NameNotConfigured.com";
|
||||
unless ($SITENAMESHORT) {
|
||||
$SITENAMESHORT = $SITENAME;
|
||||
$SITENAMESHORT =~ s/\..*//; # remove .net/.com/etc
|
||||
}
|
||||
$SITENAMEABBREV ||= "[??]";
|
||||
|
||||
$NODB_MSG ||= "Database temporarily unavailable. Try again shortly.";
|
||||
$MSG_READONLY_USER ||= "Database temporarily in read-only mode during maintenance.";
|
||||
|
||||
$SITEROOT ||= "http://www.$DOMAIN:8011";
|
||||
$IMGPREFIX ||= "$SITEROOT/img";
|
||||
$STATPREFIX ||= "$SITEROOT/stc";
|
||||
$JSPREFIX ||= "$SITEROOT/js";
|
||||
$USERPIC_ROOT ||= "$LJ::SITEROOT/userpic";
|
||||
$PALIMGROOT ||= "$LJ::SITEROOT/palimg";
|
||||
|
||||
if ($LJ::DB_USERIDMAP ||= "") {
|
||||
$LJ::DB_USERIDMAP .= "." unless $LJ::DB_USERIDMAP =~ /\.$/;
|
||||
}
|
||||
|
||||
# path to sendmail and any necessary options
|
||||
$SENDMAIL ||= "/usr/sbin/sendmail -t -oi";
|
||||
|
||||
# protocol, mailserver hostname, and preferential weight.
|
||||
# qmtp, smtp, dmtp, and sendmail are the currently supported protocols.
|
||||
@MAIL_TRANSPORTS = ( [ 'sendmail', $SENDMAIL, 1 ] ) unless @MAIL_TRANSPORTS;
|
||||
|
||||
# where we set the cookies (note the period before the domain)
|
||||
$COOKIE_DOMAIN ||= ".$DOMAIN";
|
||||
$COOKIE_PATH ||= "/";
|
||||
@COOKIE_DOMAIN_RESET = ("", "$DOMAIN", ".$DOMAIN") unless @COOKIE_DOMAIN_RESET;
|
||||
|
||||
## default portal options
|
||||
@PORTAL_COLS = qw(main right moz) unless (@PORTAL_COLS);
|
||||
|
||||
$PORTAL_URI ||= "/portal/"; # either "/" or "/portal/"
|
||||
|
||||
$PORTAL_LOGGED_IN ||= {'main' => [
|
||||
[ 'update', 'mode=full'],
|
||||
],
|
||||
'right' => [
|
||||
[ 'stats', '', ],
|
||||
[ 'bdays', '', ],
|
||||
[ 'popfaq', '', ],
|
||||
] };
|
||||
$PORTAL_LOGGED_OUT ||= {'main' => [
|
||||
[ 'update', 'mode='],
|
||||
],
|
||||
'right' => [
|
||||
[ 'login', '', ],
|
||||
[ 'stats', '', ],
|
||||
[ 'randuser', '', ],
|
||||
[ 'popfaq', '', ],
|
||||
],
|
||||
'moz' => [
|
||||
[ 'login', '', ],
|
||||
],
|
||||
};
|
||||
|
||||
$MAX_HINTS_LASTN ||= 100;
|
||||
$MAX_SCROLLBACK_FRIENDS ||= 1000;
|
||||
$MAX_USERPIC_KEYWORDS ||= 10;
|
||||
|
||||
# this option can be a boolean or a URL, but internally we want a URL
|
||||
# (which can also be a boolean)
|
||||
if ($LJ::OPENID_SERVER && $LJ::OPENID_SERVER == 1) {
|
||||
$LJ::OPENID_SERVER = "$LJ::SITEROOT/openid/server.bml";
|
||||
}
|
||||
|
||||
# set default capability limits if the site maintainer hasn't.
|
||||
{
|
||||
my %defcap = (
|
||||
'checkfriends' => 1,
|
||||
'checkfriends_interval' => 60,
|
||||
'friendsviewupdate' => 30,
|
||||
'makepoll' => 1,
|
||||
'maxfriends' => 500,
|
||||
'moodthemecreate' => 1,
|
||||
'styles' => 1,
|
||||
's2styles' => 1,
|
||||
's2viewentry' => 1,
|
||||
's2viewreply' => 1,
|
||||
's2stylesmax' => 10,
|
||||
's2layersmax' => 50,
|
||||
'textmessage' => 1,
|
||||
'todomax' => 100,
|
||||
'todosec' => 1,
|
||||
'userdomain' => 0,
|
||||
'useremail' => 0,
|
||||
'userpics' => 5,
|
||||
'findsim' => 1,
|
||||
'full_rss' => 1,
|
||||
'can_post' => 1,
|
||||
'get_comments' => 1,
|
||||
'leave_comments' => 1,
|
||||
'mod_queue' => 50,
|
||||
'mod_queue_per_poster' => 1,
|
||||
'weblogscom' => 0,
|
||||
'hide_email_after' => 0,
|
||||
'userlinks' => 5,
|
||||
'maxcomments' => 5000,
|
||||
'rateperiod-lostinfo' => 24*60, # 24 hours
|
||||
'rateallowed-lostinfo' => 5,
|
||||
'tools_recent_comments_display' => 50,
|
||||
);
|
||||
foreach my $k (keys %defcap) {
|
||||
next if (defined $LJ::CAP_DEF{$k});
|
||||
$LJ::CAP_DEF{$k} = $defcap{$k};
|
||||
}
|
||||
}
|
||||
|
||||
# FIXME: should forcibly limit userlinks to 255 (tinyint)
|
||||
|
||||
# set default userprop limits if site maintainer hasn't
|
||||
{
|
||||
my %defuser = (
|
||||
's1_lastn_style' => 'lastn/Default LiveJournal',
|
||||
's1_friends_style' => 'friends/Default Friends View',
|
||||
's1_calendar_style' => 'calendar/Default Calendar',
|
||||
's1_day_style' => 'day/Default Day View',
|
||||
);
|
||||
foreach my $k (keys %defuser) {
|
||||
next if (defined $LJ::USERPROP_DEF{$k});
|
||||
$LJ::USERPROP_DEF{$k} = $defuser{$k};
|
||||
}
|
||||
}
|
||||
|
||||
# Send community invites from the admin address unless otherwise specified
|
||||
$COMMUNITY_EMAIL ||= $ADMIN_EMAIL;
|
||||
|
||||
# By default, auto-detect account types for
|
||||
# <lj user> tags only if using memcache
|
||||
unless (defined $LJ::DYNAMIC_LJUSER) {
|
||||
$LJ::DYNAMIC_LJUSER = scalar(@LJ::MEMCACHE_SERVERS) ? 1 : 0;
|
||||
}
|
||||
|
||||
# The list of content types that we consider valid for gzip compression.
|
||||
%GZIP_OKAY = (
|
||||
'text/html' => 1, # regular web pages; XHTML 1.0 "may" be this
|
||||
'text/xml' => 1, # regular XML files
|
||||
'application/xml' => 1, # XHTML 1.1 "may" be this
|
||||
'application/xhtml+xml' => 1, # XHTML 1.1 "should" be this
|
||||
'application/rdf+xml' => 1, # FOAF should be this
|
||||
) unless %GZIP_OKAY;
|
||||
|
||||
# maximum FOAF friends to return (so the server doesn't get overloaded)
|
||||
$MAX_FOAF_FRIENDS ||= 1000;
|
||||
|
||||
# maximum number of friendofs to load/memcache (affects userinfo.bml display)
|
||||
$MAX_FRIENDOF_LOAD ||= 5000;
|
||||
|
||||
# whether to proactively delete any comments associated with an entry when we assign
|
||||
# a new jitemid (see the big comment above LJ::Protocol::new_entry_cleanup_hack)
|
||||
$NEW_ENTRY_CLEANUP_HACK ||= 0;
|
||||
|
||||
# block size is used in stats generation code that gets n rows from the db at a time
|
||||
$STATS_BLOCK_SIZE ||= 10_000;
|
||||
|
||||
# Maximum number of comments to display on Recent Comments page
|
||||
$TOOLS_RECENT_COMMENTS_MAX = 50;
|
||||
|
||||
# setup the mogilefs defaults so we can create the necessary domains
|
||||
# and such. it is not recommended that you change the name of the
|
||||
# classes. you can feel free to add your own or alter the mindevcount
|
||||
# from within ljconfig.pl, but the LiveJournal code uses these class
|
||||
# names elsewhere and depends on them existing if you're using MogileFS
|
||||
# for storage.
|
||||
#
|
||||
# also note that this won't actually do anything unless you have
|
||||
# defined a MOGILEFS_CONFIG hash in ljconfig.pl and you explicitly set
|
||||
# at least the hosts key to be an arrayref of ip:port combinations
|
||||
# indicating where to reach your local MogileFS server.
|
||||
%MOGILEFS_CONFIG = () unless defined %MOGILEFS_CONFIG;
|
||||
$MOGILEFS_CONFIG{domain} ||= 'livejournal';
|
||||
$MOGILEFS_CONFIG{classes} ||= {};
|
||||
$MOGILEFS_CONFIG{classes}->{userpics} ||= 3;
|
||||
$MOGILEFS_CONFIG{classes}->{captcha} ||= 2;
|
||||
|
||||
# Default to allow all reproxying.
|
||||
%REPROXY_DISABLE = () unless %REPROXY_DISABLE;
|
||||
|
||||
# Default error message for age verification needed
|
||||
$UNDERAGE_ERROR ||= "Sorry, your account needs to be <a href='$SITEROOT/agecheck/'>age verified</a> before you can leave any comments.";
|
||||
|
||||
# Terms of Service revision requirements
|
||||
foreach (
|
||||
[ rev => '0.0' ],
|
||||
[ title => 'Terms of Service agreement required' ],
|
||||
[ html => '' ],
|
||||
[ text => '' ]
|
||||
)
|
||||
{
|
||||
$LJ::REQUIRED_TOS{$_->[0]} = $_->[1]
|
||||
unless defined $LJ::REQUIRED_TOS{$_->[0]};
|
||||
}
|
||||
|
||||
# setup default minimal style information
|
||||
$MINIMAL_USERAGENT{$_} ||= 1 foreach qw(Links Lynx w BlackBerry); # w is for w3m
|
||||
$MINIMAL_BML_SCHEME ||= 'lynx';
|
||||
$MINIMAL_STYLE{'core'} ||= 'core1';
|
||||
|
||||
# maximum size to cache s2compiled data
|
||||
$MAX_S2COMPILED_CACHE_SIZE ||= 7500; # bytes
|
||||
$S2COMPILED_MIGRATION_DONE ||= 0; # turn on after s2compiled2 migration
|
||||
|
||||
}
|
||||
|
||||
# no dependencies.
|
||||
# <LJDEP>
|
||||
# </LJDEP>
|
||||
|
||||
return 1;
|
||||
647
livejournal/cgi-bin/ljemailgateway.pl
Executable file
647
livejournal/cgi-bin/ljemailgateway.pl
Executable file
@@ -0,0 +1,647 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package LJ::Emailpost;
|
||||
use strict;
|
||||
use lib "$ENV{LJHOME}/cgi-bin";
|
||||
|
||||
BEGIN {
|
||||
require 'ljconfig.pl';
|
||||
if ($LJ::USE_PGP) {
|
||||
eval 'use GnuPG::Interface';
|
||||
die "Could not load GnuPG::Interface." if $@;
|
||||
}
|
||||
}
|
||||
|
||||
require 'ljlib.pl';
|
||||
require 'ljprotocol.pl';
|
||||
require 'fbupload.pl';
|
||||
use HTML::Entities;
|
||||
use IO::Handle;
|
||||
use LWP::UserAgent;
|
||||
use MIME::Words ();
|
||||
use XML::Simple;
|
||||
|
||||
# $rv - scalar ref from mailgated.
|
||||
# set to 1 to dequeue, 0 to leave for further processing.
|
||||
sub process {
|
||||
my ($entity, $to, $rv) = @_;
|
||||
|
||||
my (
|
||||
# journal vars
|
||||
$head, $user, $journal,
|
||||
$pin, $u, $req, $post_error,
|
||||
|
||||
# email vars
|
||||
$from, $addrlist, $return_path,
|
||||
$body, $subject, $charset,
|
||||
$format, $tent,
|
||||
|
||||
# pict upload vars
|
||||
$fb_upload, $fb_upload_errstr,
|
||||
);
|
||||
|
||||
$head = $entity->head;
|
||||
$head->unfold;
|
||||
|
||||
$$rv = 1; # default dequeue
|
||||
|
||||
# Parse email for lj specific info
|
||||
($user, $pin) = split(/\+/, $to);
|
||||
($user, $journal) = split(/\./, $user) if $user =~ /\./;
|
||||
$u = LJ::load_user($user);
|
||||
return unless $u;
|
||||
LJ::load_user_props($u, 'emailpost_pin') unless (lc($pin) eq 'pgp' && $LJ::USE_PGP);
|
||||
|
||||
# Pick what address to send potential errors to.
|
||||
$addrlist = LJ::Emailpost::get_allowed_senders($u);
|
||||
$from = ${(Mail::Address->parse( $head->get('From:') ))[0] || []}[1];
|
||||
return unless $from;
|
||||
my $err_addr;
|
||||
foreach (keys %$addrlist) {
|
||||
if (lc($from) eq lc &&
|
||||
$addrlist->{$_}->{'get_errors'}) {
|
||||
$err_addr = $from;
|
||||
last;
|
||||
}
|
||||
}
|
||||
$err_addr ||= $u->{email};
|
||||
|
||||
my $err = sub {
|
||||
my ($msg, $opt) = @_;
|
||||
|
||||
# FIXME: Need to log last 10 errors to DB / memcache
|
||||
# and create a page to watch this stuff.
|
||||
|
||||
my $errbody;
|
||||
$errbody .= "There was an error during your email posting:\n\n";
|
||||
$errbody .= $msg;
|
||||
if ($body) {
|
||||
$errbody .= "\n\n\nOriginal posting follows:\n\n";
|
||||
$errbody .= $body;
|
||||
}
|
||||
|
||||
# Rate limit email to 1/5min/address
|
||||
if ($opt->{'sendmail'} && $err_addr &&
|
||||
LJ::MemCache::add("rate_eperr:$err_addr", 5, 300)) {
|
||||
LJ::send_mail({
|
||||
'to' => $err_addr,
|
||||
'from' => $LJ::BOGUS_EMAIL,
|
||||
'fromname' => "$LJ::SITENAME Error",
|
||||
'subject' => "$LJ::SITENAME posting error: $subject",
|
||||
'body' => $errbody
|
||||
});
|
||||
}
|
||||
$$rv = 0 if $opt->{'retry'};
|
||||
return $msg;
|
||||
};
|
||||
|
||||
# The return path should normally not ever be perverted enough to require this,
|
||||
# but some mailers nowadays do some very strange things.
|
||||
$return_path = ${(Mail::Address->parse( $head->get('Return-Path') ))[0] || []}[1];
|
||||
|
||||
# Use text/plain piece first - if it doesn't exist, then fallback to text/html
|
||||
$tent = get_entity( $entity );
|
||||
$tent = get_entity( $entity, 'html' ) unless $tent;
|
||||
|
||||
$body = $tent ? $tent->bodyhandle->as_string : "";
|
||||
$body =~ s/^\s+//;
|
||||
$body =~ s/\s+$//;
|
||||
|
||||
# Snag charset and do utf-8 conversion
|
||||
my $content_type = $head->get('Content-type:');
|
||||
$charset = $1 if $content_type =~ /\bcharset=['"]?(\S+?)['"]?[\s\;]/i;
|
||||
$format = $1 if $content_type =~ /\bformat=['"]?(\S+?)['"]?[\s\;]/i;
|
||||
if (defined($charset) && $charset !~ /^UTF-?8$/i) { # no charset? assume us-ascii
|
||||
return $err->("Unknown charset encoding type.", { sendmail => 1 })
|
||||
unless Unicode::MapUTF8::utf8_supported_charset($charset);
|
||||
$body = Unicode::MapUTF8::to_utf8({-string=>$body, -charset=>$charset});
|
||||
}
|
||||
|
||||
# check subject for rfc-1521 junk
|
||||
$subject ||= $head->get('Subject:');
|
||||
if ($subject =~ /^=\?/) {
|
||||
my @subj_data = MIME::Words::decode_mimewords( $subject );
|
||||
if (@subj_data) {
|
||||
if ($subject =~ /utf-8/i) {
|
||||
$subject = $subj_data[0][0];
|
||||
} else {
|
||||
$subject = Unicode::MapUTF8::to_utf8(
|
||||
{
|
||||
-string => $subj_data[0][0],
|
||||
-charset => $subj_data[0][1]
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Strip (and maybe use) pin data from viewable areas
|
||||
if ($subject =~ s/^\s*\+([a-z0-9]+)\s+//i) {
|
||||
$pin = $1 unless defined $pin;
|
||||
}
|
||||
if ($body =~ s/^\s*\+([a-z0-9]+)\s+//i) {
|
||||
$pin = $1 unless defined $pin;
|
||||
}
|
||||
|
||||
# Validity checks. We only care about these if they aren't using PGP.
|
||||
unless (lc($pin) eq 'pgp' && $LJ::USE_PGP) {
|
||||
return $err->("No allowed senders have been saved for your account.") unless ref $addrlist;
|
||||
|
||||
# don't mail user due to bounce spam
|
||||
return $err->("Unauthorized sender address: $from")
|
||||
unless grep { lc($from) eq lc($_) } keys %$addrlist;
|
||||
|
||||
return $err->("Unable to locate your PIN.", { sendmail => 1 }) unless $pin;
|
||||
return $err->("Invalid PIN.", { sendmail => 1 }) unless lc($pin) eq lc($u->{emailpost_pin});
|
||||
}
|
||||
|
||||
return $err->("Email gateway access denied for your account type.", { sendmail => 1 })
|
||||
unless LJ::get_cap($u, "emailpost");
|
||||
|
||||
# Is this message from a sprint PCS phone? Sprint doesn't support
|
||||
# MMS (yet) - when it does, we should just be able to rip this block
|
||||
# of code completely out.
|
||||
#
|
||||
# Sprint has two methods of non-mms mail sending.
|
||||
# - Normal text messaging just sends a text/plain piece.
|
||||
# - Sprint "PictureMail".
|
||||
# PictureMail sends a text/html piece, that contains XML with
|
||||
# the location of the image on their servers - and a text/plain as well.
|
||||
# (The text/plain used to be blank, now it's really text/plain. We still
|
||||
# can't use it, however, without heavy and fragile parsing.)
|
||||
# We assume the existence of a text/html means this is a PictureMail message,
|
||||
# as there is no other method (headers or otherwise) to tell the difference,
|
||||
# and Sprint tells me that their text messaging never contains text/html.
|
||||
# Currently, PictureMail can only contain one image per message
|
||||
# and the image is always a jpeg. (2/2/05)
|
||||
if ($return_path =~ /(?:messaging|pm)\.sprint(?:pcs)?\.com/ &&
|
||||
$content_type =~ m#^multipart/alternative#i) {
|
||||
|
||||
$tent = get_entity( $entity, 'html' );
|
||||
|
||||
return $err->(
|
||||
"Unable to find Sprint HTML content in PictureMail message.",
|
||||
{ sendmail => 1 }
|
||||
) unless $tent;
|
||||
|
||||
# ok, parse the XML.
|
||||
my $html = $tent->bodyhandle->as_string();
|
||||
my $xml_string = $1 if $html =~ /<!-- lsPictureMail-Share-\w+-comment\n(.+)\n-->/is;
|
||||
return $err->(
|
||||
"Unable to find XML content in PictureMail message.",
|
||||
{ sendmail => 1 }
|
||||
) unless $xml_string;
|
||||
|
||||
HTML::Entities::decode_entities( $xml_string );
|
||||
my $xml = eval { XML::Simple::XMLin( $xml_string ); };
|
||||
return $err->(
|
||||
"Unable to parse XML content in PictureMail message.",
|
||||
{ sendmail => 1 }
|
||||
) if ( ! $xml || $@ );
|
||||
|
||||
return $err->(
|
||||
"Sorry, we currently only support image media.",
|
||||
{ sendmail => 1 }
|
||||
) unless $xml->{messageContents}->{type} eq 'PICTURE';
|
||||
|
||||
my $url =
|
||||
HTML::Entities::decode_entities(
|
||||
$xml->{messageContents}->{mediaItems}->{mediaItem}->{content} );
|
||||
$url = LJ::trim($url);
|
||||
$url =~ s#</?url>##g;
|
||||
|
||||
return $err->(
|
||||
"Invalid remote SprintPCS URL.", { sendmail => 1 }
|
||||
) unless $url =~ m#^http://pictures.sprintpcs.com/#;
|
||||
|
||||
# we've got the url to the full sized image.
|
||||
# fetch!
|
||||
my ($tmpdir, $tempfile);
|
||||
$tmpdir = File::Temp::tempdir( "ljmailgate_" . 'X' x 20, DIR=> $main::workdir );
|
||||
( undef, $tempfile ) = File::Temp::tempfile(
|
||||
'sprintpcs_XXXXX',
|
||||
SUFFIX => '.jpg',
|
||||
OPEN => 0,
|
||||
DIR => $tmpdir
|
||||
);
|
||||
my $ua = LWP::UserAgent->new(
|
||||
timeout => 20,
|
||||
agent => 'Mozilla',
|
||||
);
|
||||
my $ua_rv = $ua->get( $url, ':content_file' => $tempfile );
|
||||
|
||||
$body = $xml->{messageContents}->{messageText};
|
||||
$body = ref $body ? "" : HTML::Entities::decode( $body );
|
||||
|
||||
if ($ua_rv->is_success) {
|
||||
# (re)create a basic mime entity, so the rest of the
|
||||
# emailgateway can function without modifications.
|
||||
# (We don't need anything but Data, the other parts have
|
||||
# already been pulled from $head->unfold)
|
||||
$subject = 'Picture Post';
|
||||
$entity = MIME::Entity->build( Data => $body );
|
||||
$entity->attach(
|
||||
Path => $tempfile,
|
||||
Type => 'image/jpeg'
|
||||
);
|
||||
}
|
||||
else {
|
||||
# Retry if we are unable to connect to the remote server.
|
||||
# Otherwise, the image has probably expired. Dequeue.
|
||||
my $reason = $ua_rv->status_line;
|
||||
return $err->(
|
||||
"Unable to fetch SprintPCS image. ($reason)",
|
||||
{
|
||||
sendmail => 1,
|
||||
retry => $reason =~ /Connection refused/
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
# tmobile hell.
|
||||
# if there is a message, then they send text/plain and text/html,
|
||||
# with a slew of their tmobile specific images. If no message
|
||||
# is attached, there is no text/plain piece, and the journal is
|
||||
# polluted with their advertising. (The tmobile images (both good
|
||||
# and junk) are posted to scrapbook either way.)
|
||||
# gross. do our best to strip out the nasty stuff.
|
||||
if ($return_path && $return_path =~ /tmomail\.net$/ &&
|
||||
$head->get("X-Operator") =~ /^T-Mobile/i) {
|
||||
|
||||
# if we aren't using their text/plain, then it's just
|
||||
# advertising, and nothing else. kill it.
|
||||
$body = "" if $tent->effective_type eq 'text/html';
|
||||
|
||||
# strip all images but tmobile phone dated.
|
||||
# 06-03-05_12394.jpg
|
||||
my @imgs;
|
||||
foreach my $img ( get_entity($entity, 'image') ) {
|
||||
my $path = $img->bodyhandle->path;
|
||||
$path =~ s#.*/##;
|
||||
# intentionally not being explicit with regexp, in case
|
||||
# they go to 4 digit year or whatever.
|
||||
push @imgs, $img if $path =~ /^\d+-\d+-\d+_\d+.\w+$/;
|
||||
}
|
||||
$entity->parts(\@imgs);
|
||||
}
|
||||
|
||||
# PGP signed mail? We'll see about that.
|
||||
if (lc($pin) eq 'pgp' && $LJ::USE_PGP) {
|
||||
my %gpg_errcodes = ( # temp mapping until translation
|
||||
'bad' => "PGP signature found to be invalid.",
|
||||
'no_key' => "You don't have a PGP key uploaded.",
|
||||
'bad_tmpdir' => "Problem generating tempdir: Please try again.",
|
||||
'invalid_key' => "Your PGP key is invalid. Please upload a proper key.",
|
||||
'not_signed' => "You specified PGP verification, but your message isn't PGP signed!");
|
||||
my $gpgerr;
|
||||
my $gpgcode = LJ::Emailpost::check_sig($u, $entity, \$gpgerr);
|
||||
unless ($gpgcode eq 'good') {
|
||||
my $errstr = $gpg_errcodes{$gpgcode};
|
||||
$errstr .= "\nGnuPG error output:\n$gpgerr\n" if $gpgerr;
|
||||
return $err->($errstr, { sendmail => 1 });
|
||||
}
|
||||
|
||||
# Strip pgp clearsigning and any extra text surrounding it
|
||||
# This takes into account pgp 'dash escaping' and a possible lack of Hash: headers
|
||||
$body =~ s/.*?^-----BEGIN PGP SIGNED MESSAGE-----(?:\n[^\n].*?\n\n|\n\n)//ms;
|
||||
$body =~ s/-----BEGIN PGP SIGNATURE-----.+//s;
|
||||
}
|
||||
|
||||
$body =~ s/^(?:\- )?[\-_]{2,}\s*\r?\n.*//ms; # trim sigs
|
||||
$body =~ s/ \n/ /g if lc($format) eq 'flowed'; # respect flowed text
|
||||
|
||||
# trim off excess whitespace (html cleaner converts to breaks)
|
||||
$body =~ s/\n+$/\n/;
|
||||
|
||||
# Find and set entry props.
|
||||
my $props = {};
|
||||
my (%lj_headers, $amask);
|
||||
if ($body =~ s/^(lj-.+?)\n\n//is) {
|
||||
map { $lj_headers{lc($1)} = $2 if /^lj-(\w+):\s*(.+?)\s*$/i } split /\n/, $1;
|
||||
}
|
||||
|
||||
LJ::load_user_props(
|
||||
$u,
|
||||
qw/
|
||||
emailpost_userpic emailpost_security
|
||||
emailpost_comments emailpost_gallery
|
||||
emailpost_imgsecurity /
|
||||
);
|
||||
|
||||
# Get post options, using lj-headers first, and falling back
|
||||
# to user props. If neither exist, the regular journal defaults
|
||||
# are used.
|
||||
$props->{taglist} = $lj_headers{tags};
|
||||
$props->{picture_keyword} = $lj_headers{'userpic'} ||
|
||||
$u->{'emailpost_userpic'};
|
||||
$props->{current_mood} = $lj_headers{'mood'};
|
||||
$props->{current_music} = $lj_headers{'music'};
|
||||
$props->{opt_nocomments} = 1
|
||||
if $lj_headers{comments} =~ /off/i
|
||||
|| $u->{'emailpost_comments'} =~ /off/i;
|
||||
$props->{opt_noemail} = 1
|
||||
if $lj_headers{comments} =~ /noemail/i
|
||||
|| $u->{'emailpost_comments'} =~ /noemail/i;
|
||||
|
||||
$lj_headers{security} = lc($lj_headers{security}) || $u->{'emailpost_security'};
|
||||
if ($lj_headers{security} =~ /^(public|private|friends)$/) {
|
||||
if ($1 eq 'friends') {
|
||||
$lj_headers{security} = 'usemask';
|
||||
$amask = 1;
|
||||
}
|
||||
} elsif ($lj_headers{security}) { # Assume a friendgroup if unknown security mode.
|
||||
# Get the mask for the requested friends group, or default to private.
|
||||
my $group = LJ::get_friend_group($u, { 'name'=>$lj_headers{security} });
|
||||
if ($group) {
|
||||
$amask = (1 << $group->{groupnum});
|
||||
$lj_headers{security} = 'usemask';
|
||||
} else {
|
||||
$err->("Friendgroup \"$lj_headers{security}\" not found. Your journal entry was posted privately.",
|
||||
{ sendmail => 1 });
|
||||
$lj_headers{security} = 'private';
|
||||
}
|
||||
}
|
||||
|
||||
# if they specified a imgsecurity header but it isn't valid, default
|
||||
# to private. Otherwise, set to what they specified.
|
||||
$lj_headers{'imgsecurity'} = lc($lj_headers{'imgsecurity'}) ||
|
||||
$u->{'emailpost_imgsecurity'} || 'public';
|
||||
$lj_headers{'imgsecurity'} = 'private'
|
||||
unless $lj_headers{'imgsecurity'} =~ /^(private|regusers|friends|public)$/;
|
||||
|
||||
# upload picture attachments to fotobilder.
|
||||
# undef return value? retry posting for later.
|
||||
$fb_upload = upload_images(
|
||||
$entity, $u,
|
||||
\$fb_upload_errstr,
|
||||
{
|
||||
imgsec => $lj_headers{'imgsecurity'},
|
||||
galname => $lj_headers{'gallery'} || $u->{'emailpost_gallery'}
|
||||
}
|
||||
) || return $err->( $fb_upload_errstr, { retry => 1 } );
|
||||
|
||||
# if we found and successfully uploaded some images...
|
||||
$body .= LJ::FBUpload::make_html( $u, $fb_upload, \%lj_headers )
|
||||
if ref $fb_upload eq 'ARRAY';
|
||||
|
||||
# at this point, there are either no images in the message ($fb_upload == 1)
|
||||
# or we had some error during upload that we may or may not want to retry
|
||||
# from. $fb_upload contains the http error code.
|
||||
if ( $fb_upload == 400 # bad http request
|
||||
|| $fb_upload == 1401 # user has exceeded the fb quota
|
||||
|| $fb_upload == 1402 # user has exceeded the fb quota
|
||||
) {
|
||||
# don't retry these errors, go ahead and post the body
|
||||
# to the journal, postfixed with the remote error.
|
||||
$body .= "\n";
|
||||
$body .= "(Your picture was not posted: $fb_upload_errstr)";
|
||||
}
|
||||
|
||||
# Fotobilder server error. Retry.
|
||||
return $err->( $fb_upload_errstr, { retry => 1 } ) if $fb_upload == 500;
|
||||
|
||||
# build lj entry
|
||||
$req = {
|
||||
'usejournal' => $journal,
|
||||
'ver' => 1,
|
||||
'username' => $user,
|
||||
'event' => $body,
|
||||
'subject' => $subject,
|
||||
'security' => $lj_headers{security},
|
||||
'allowmask' => $amask,
|
||||
'props' => $props,
|
||||
'tz' => 'guess',
|
||||
};
|
||||
|
||||
# post!
|
||||
LJ::Protocol::do_request("postevent", $req, \$post_error, { noauth=>1 });
|
||||
return $err->(LJ::Protocol::error_message($post_error), { sendmail => 1}) if $post_error;
|
||||
|
||||
return "Email post success";
|
||||
}
|
||||
|
||||
# By default, returns first plain text entity from email message.
|
||||
# Specifying a type will return an array of MIME::Entity handles
|
||||
# of that type. (image, application, etc)
|
||||
# Specifying a type of 'all' will return all MIME::Entities,
|
||||
# regardless of type.
|
||||
sub get_entity
|
||||
{
|
||||
my ($entity, $type) = @_;
|
||||
|
||||
# old arguments were a hashref
|
||||
$type = $type->{'type'} if ref $type eq "HASH";
|
||||
|
||||
# default to text
|
||||
$type ||= 'text';
|
||||
|
||||
my $head = $entity->head;
|
||||
my $mime_type = $head->mime_type;
|
||||
|
||||
return $entity if $type eq 'text' && $mime_type eq "text/plain";
|
||||
return $entity if $type eq 'html' && $mime_type eq "text/html";
|
||||
my @entities;
|
||||
|
||||
# Only bother looking in messages that advertise attachments
|
||||
my $mimeattach_re = qr{ m|^multipart/(?:alternative|signed|mixed|related)$| };
|
||||
if ($mime_type =~ $mimeattach_re) {
|
||||
my $partcount = $entity->parts;
|
||||
for (my $i=0; $i<$partcount; $i++) {
|
||||
my $alte = $entity->parts($i);
|
||||
|
||||
return $alte if $type eq 'text' && $alte->mime_type eq "text/plain";
|
||||
return $alte if $type eq 'html' && $alte->mime_type eq "text/html";
|
||||
push @entities, $alte if $type eq 'all';
|
||||
|
||||
if ($type eq 'image' &&
|
||||
$alte->mime_type =~ m#^application/octet-stream#) {
|
||||
my $alte_head = $alte->head;
|
||||
my $filename = $alte_head->recommended_filename;
|
||||
push @entities, $alte if $filename =~ /\.(?:gif|png|tiff?|jpe?g)$/;
|
||||
}
|
||||
push @entities, $alte if $alte->mime_type =~ /^$type/ &&
|
||||
$type ne 'all';
|
||||
|
||||
# Recursively search through nested MIME for various pieces
|
||||
if ($alte->mime_type =~ $mimeattach_re) {
|
||||
if ($type =~ /^(?:text|html)$/) {
|
||||
my $text_entity = get_entity($entity->parts($i), $type);
|
||||
return $text_entity if $text_entity;
|
||||
} else {
|
||||
push @entities, get_entity($entity->parts($i), $type);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return @entities if $type ne 'text' && scalar @entities;
|
||||
return;
|
||||
}
|
||||
|
||||
# Verifies an email pgp signature as being valid.
|
||||
# Returns codes so we can use the pre-existing err subref,
|
||||
# without passing everything all over the place.
|
||||
#
|
||||
# note that gpg interaction requires gpg version 1.2.4 or better.
|
||||
sub check_sig {
|
||||
my ($u, $entity, $gpg_err) = @_;
|
||||
|
||||
LJ::load_user_props($u, 'public_key');
|
||||
my $key = $u->{public_key};
|
||||
return 'no_key' unless $key;
|
||||
|
||||
# Create work directory.
|
||||
my $tmpdir = File::Temp::tempdir("ljmailgate_" . 'X' x 20, DIR=>$main::workdir);
|
||||
return 'bad_tmpdir' unless -e $tmpdir;
|
||||
|
||||
my ($in, $out, $err, $status,
|
||||
$gpg_handles, $gpg, $gpg_pid, $ret);
|
||||
|
||||
my $check = sub {
|
||||
my %rets =
|
||||
(
|
||||
'NODATA 1' => 1, # no key or no signed data
|
||||
'NODATA 2' => 2, # no signed content
|
||||
'NODATA 3' => 3, # error checking sig (crc)
|
||||
'IMPORT_RES 0' => 4, # error importing key (crc)
|
||||
'BADSIG' => 5, # good crc, bad sig
|
||||
'GOODSIG' => 6, # all is well
|
||||
);
|
||||
while (my $gline = <$status>) {
|
||||
foreach (keys %rets) {
|
||||
next unless $gline =~ /($_)/;
|
||||
return $rets{$1};
|
||||
}
|
||||
}
|
||||
return 0;
|
||||
};
|
||||
|
||||
my $gpg_cleanup = sub {
|
||||
close $in;
|
||||
close $out;
|
||||
waitpid $gpg_pid, 0;
|
||||
undef foreach $gpg, $gpg_handles;
|
||||
};
|
||||
|
||||
my $gpg_pipe = sub {
|
||||
$_ = IO::Handle->new() foreach $in, $out, $err, $status;
|
||||
$gpg_handles = GnuPG::Handles->new( stdin => $in, stdout=> $out,
|
||||
stderr => $err, status=> $status );
|
||||
$gpg = GnuPG::Interface->new();
|
||||
$gpg->options->hash_init( armor=>1, homedir=>$tmpdir );
|
||||
$gpg->options->meta_interactive( 0 );
|
||||
};
|
||||
|
||||
# Pull in user's key, add to keyring.
|
||||
$gpg_pipe->();
|
||||
$gpg_pid = $gpg->import_keys( handles=>$gpg_handles );
|
||||
print $in $key;
|
||||
$gpg_cleanup->();
|
||||
$ret = $check->();
|
||||
if ($ret && $ret == 1 || $ret == 4) {
|
||||
$$gpg_err .= " $_" while (<$err>);
|
||||
return 'invalid_key';
|
||||
}
|
||||
|
||||
my ($txt, $txt_f, $txt_e, $sig_e);
|
||||
$txt_e = (get_entity($entity))[0];
|
||||
return 'bad' unless $txt_e;
|
||||
|
||||
if ($entity->effective_type() eq 'multipart/signed') {
|
||||
# attached signature
|
||||
$sig_e = (get_entity($entity, 'application/pgp-signature'))[0];
|
||||
$txt = $txt_e->as_string();
|
||||
my $txt_fh;
|
||||
($txt_fh, $txt_f) =
|
||||
File::Temp::tempfile('plaintext_XXXXXXXX', DIR => $tmpdir);
|
||||
print $txt_fh $txt;
|
||||
close $txt_fh;
|
||||
} # otherwise, it's clearsigned
|
||||
|
||||
# Validate message.
|
||||
# txt_e->bodyhandle->path() is clearsigned message in its entirety.
|
||||
# txt_f is the ascii text that was signed (in the event of sig-as-attachment),
|
||||
# with MIME headers attached.
|
||||
$gpg_pipe->();
|
||||
$gpg_pid =
|
||||
$gpg->wrap_call( handles => $gpg_handles,
|
||||
commands => [qw( --trust-model always --verify )],
|
||||
command_args => $sig_e ?
|
||||
[$sig_e->bodyhandle->path(), $txt_f] :
|
||||
$txt_e->bodyhandle->path()
|
||||
);
|
||||
$gpg_cleanup->();
|
||||
$ret = $check->();
|
||||
if ($ret && $ret != 6) {
|
||||
$$gpg_err .= " $_" while (<$err>);
|
||||
return 'bad' if $ret =~ /[35]/;
|
||||
return 'not_signed' if $ret =~ /[12]/;
|
||||
}
|
||||
|
||||
return 'good' if $ret == 6;
|
||||
return undef;
|
||||
}
|
||||
|
||||
# Upload images to a Fotobilder installation.
|
||||
# Return codes:
|
||||
# 1 - no images found in mime entity
|
||||
# undef - failure during upload
|
||||
# http_code - failure during upload w/ code
|
||||
# hashref - { title => url } for each image uploaded
|
||||
sub upload_images
|
||||
{
|
||||
my ($entity, $u, $rv, $opts) = @_;
|
||||
return 1 unless LJ::get_cap($u, 'fb_can_upload') && $LJ::FB_SITEROOT;
|
||||
|
||||
my @imgs = get_entity($entity, 'image');
|
||||
return 1 unless scalar @imgs;
|
||||
|
||||
my @images;
|
||||
foreach my $img_entity (@imgs) {
|
||||
my $img = $img_entity->bodyhandle;
|
||||
my $path = $img->path;
|
||||
|
||||
my $result = LJ::FBUpload::do_upload(
|
||||
$u, $rv,
|
||||
{
|
||||
path => $path,
|
||||
rawdata => \$img->as_string,
|
||||
imgsec => $opts->{'imgsec'},
|
||||
galname => $opts->{'galname'},
|
||||
}
|
||||
);
|
||||
|
||||
# do upload() returned undef? This is a posting error
|
||||
# that should most likely be retried, due to something
|
||||
# wrong on our side of things.
|
||||
return if ! defined $result && $$rv;
|
||||
|
||||
# http error during upload attempt
|
||||
# decide retry based on error type in caller
|
||||
return $result unless ref $result;
|
||||
|
||||
# examine $result for errors
|
||||
if ($result->{Error}->{code}) {
|
||||
$$rv = $result->{Error}->{content};
|
||||
|
||||
# add 1000 to error code, so we can easily tell the
|
||||
# difference between fb protocol error and
|
||||
# http error when checking results.
|
||||
return $result->{Error}->{code} + 1000;
|
||||
}
|
||||
|
||||
push @images, {
|
||||
url => $result->{URL},
|
||||
width => $result->{Width},
|
||||
height => $result->{Height},
|
||||
title => $result->{Title},
|
||||
};
|
||||
}
|
||||
|
||||
return \@images if scalar @images;
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
556
livejournal/cgi-bin/ljfeed.pl
Executable file
556
livejournal/cgi-bin/ljfeed.pl
Executable file
@@ -0,0 +1,556 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ::Feed;
|
||||
|
||||
my %feedtypes = (
|
||||
rss => \&create_view_rss,
|
||||
atom => \&create_view_atom,
|
||||
foaf => \&create_view_foaf,
|
||||
);
|
||||
|
||||
sub make_feed
|
||||
{
|
||||
my ($r, $u, $remote, $opts) = @_;
|
||||
|
||||
$opts->{pathextra} =~ s!^/(\w+)!!;
|
||||
my $feedtype = $1;
|
||||
my $viewfunc = $feedtypes{$feedtype};
|
||||
|
||||
unless ($viewfunc) {
|
||||
$opts->{'handler_return'} = 404;
|
||||
return undef;
|
||||
}
|
||||
|
||||
$opts->{noitems} = 1 if $feedtype eq 'foaf';
|
||||
|
||||
$r->notes('codepath' => "feed.$feedtype") if $r;
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
|
||||
my $user = $u->{'user'};
|
||||
|
||||
if ($u->{'journaltype'} eq "R" && $u->{'renamedto'} ne "") {
|
||||
$opts->{'redir'} = LJ::journal_base($u->{'renamedto'}, $opts->{'vhost'}) . "/data/$feedtype";
|
||||
return undef;
|
||||
}
|
||||
|
||||
LJ::load_user_props($u, qw/ journaltitle journalsubtitle opt_synlevel /);
|
||||
|
||||
LJ::text_out(\$u->{$_})
|
||||
foreach ("name", "url", "urlname");
|
||||
|
||||
# opt_synlevel will default to 'full'
|
||||
$u->{'opt_synlevel'} = 'full'
|
||||
unless $u->{'opt_synlevel'} =~ /^(?:full|summary|title)$/;
|
||||
|
||||
# some data used throughout the channel
|
||||
my $journalinfo = {
|
||||
u => $u,
|
||||
link => LJ::journal_base($u) . "/",
|
||||
title => $u->{journaltitle} || $u->{name} || $u->{user},
|
||||
subtitle => $u->{journalsubtitle} || $u->{name},
|
||||
builddate => LJ::time_to_http(time()),
|
||||
};
|
||||
|
||||
# if we do not want items for this view, just call out
|
||||
return $viewfunc->($journalinfo, $u, $opts)
|
||||
if ($opts->{'noitems'});
|
||||
|
||||
# for syndicated accounts, redirect to the syndication URL
|
||||
# However, we only want to do this if the data we're returning
|
||||
# is similar. (Not FOAF, for example)
|
||||
if ($u->{'journaltype'} eq 'Y') {
|
||||
my $synurl = $dbr->selectrow_array("SELECT synurl FROM syndicated WHERE userid=$u->{'userid'}");
|
||||
unless ($synurl) {
|
||||
return 'No syndication URL available.';
|
||||
}
|
||||
$opts->{'redir'} = $synurl;
|
||||
return undef;
|
||||
}
|
||||
|
||||
## load the itemids
|
||||
my @itemids;
|
||||
my @items = LJ::get_recent_items({
|
||||
'clusterid' => $u->{'clusterid'},
|
||||
'clustersource' => 'slave',
|
||||
'remote' => $remote,
|
||||
'userid' => $u->{'userid'},
|
||||
'itemshow' => 25,
|
||||
'order' => "logtime",
|
||||
'itemids' => \@itemids,
|
||||
'friendsview' => 1, # this returns rlogtimes
|
||||
'dateformat' => "S2", # S2 format time format is easier
|
||||
});
|
||||
|
||||
$opts->{'contenttype'} = 'text/xml; charset='.$opts->{'saycharset'};
|
||||
|
||||
### load the log properties
|
||||
my %logprops = ();
|
||||
my $logtext;
|
||||
my $logdb = LJ::get_cluster_reader($u);
|
||||
LJ::load_log_props2($logdb, $u->{'userid'}, \@itemids, \%logprops);
|
||||
$logtext = LJ::get_logtext2($u, @itemids);
|
||||
|
||||
# set last-modified header, then let apache figure out
|
||||
# whether we actually need to send the feed.
|
||||
my $lastmod = 0;
|
||||
foreach my $item (@items) {
|
||||
# revtime of the item.
|
||||
my $revtime = $logprops{$item->{itemid}}->{revtime};
|
||||
$lastmod = $revtime if $revtime > $lastmod;
|
||||
|
||||
# if we don't have a revtime, use the logtime of the item.
|
||||
unless ($revtime) {
|
||||
my $itime = $LJ::EndOfTime - $item->{rlogtime};
|
||||
$lastmod = $itime if $itime > $lastmod;
|
||||
}
|
||||
}
|
||||
$r->set_last_modified($lastmod) if $lastmod;
|
||||
|
||||
# use this $lastmod as the feed's last-modified time
|
||||
# we would've liked to use something like
|
||||
# LJ::get_timeupdate_multi instead, but that only changes
|
||||
# with new updates and doesn't change on edits.
|
||||
$journalinfo->{'modtime'} = $lastmod;
|
||||
|
||||
# regarding $r->set_etag:
|
||||
# http://perl.apache.org/docs/general/correct_headers/correct_headers.html#Entity_Tags
|
||||
# It is strongly recommended that you do not use this method unless you
|
||||
# know what you are doing. set_etag() is expecting to be used in
|
||||
# conjunction with a static request for a file on disk that has been
|
||||
# stat()ed in the course of the current request. It is inappropriate and
|
||||
# "dangerous" to use it for dynamic content.
|
||||
if ((my $status = $r->meets_conditions) != Apache::Constants::OK()) {
|
||||
$opts->{handler_return} = $status;
|
||||
return undef;
|
||||
}
|
||||
|
||||
# email address of journal owner, but respect their privacy settings
|
||||
if ($u->{'allow_contactshow'} eq "Y" && $u->{'opt_whatemailshow'} ne "N" && $u->{'opt_mangleemail'} ne "Y") {
|
||||
my $cemail;
|
||||
|
||||
# default to their actual email
|
||||
$cemail = $u->{'email'};
|
||||
|
||||
# use their livejournal email if they have one
|
||||
if ($LJ::USER_EMAIL && $u->{'opt_whatemailshow'} eq "L" &&
|
||||
LJ::get_cap($u, "useremail") && ! $u->{'no_mail_alias'}) {
|
||||
|
||||
$cemail = "$u->{'user'}\@$LJ::USER_DOMAIN";
|
||||
}
|
||||
|
||||
# clean it up since we know we have one now
|
||||
$journalinfo->{email} = $cemail;
|
||||
}
|
||||
|
||||
# load tags now that we have no chance of jumping out early
|
||||
my $logtags = LJ::Tags::get_logtags($u, \@itemids);
|
||||
|
||||
my %posteru = (); # map posterids to u objects
|
||||
LJ::load_userids_multiple([map { $_->{'posterid'}, \$posteru{$_->{'posterid'}} } @items], [$u]);
|
||||
|
||||
my @cleanitems;
|
||||
ENTRY:
|
||||
foreach my $it (@items)
|
||||
{
|
||||
# load required data
|
||||
my $itemid = $it->{'itemid'};
|
||||
my $ditemid = $itemid*256 + $it->{'anum'};
|
||||
|
||||
next ENTRY if $posteru{$it->{'posterid'}} && $posteru{$it->{'posterid'}}->{'statusvis'} eq 'S';
|
||||
|
||||
if ($LJ::UNICODE && $logprops{$itemid}->{'unknown8bit'}) {
|
||||
LJ::item_toutf8($u, \$logtext->{$itemid}->[0],
|
||||
\$logtext->{$itemid}->[1], $logprops{$itemid});
|
||||
}
|
||||
|
||||
# see if we have a subject and clean it
|
||||
my $subject = $logtext->{$itemid}->[0];
|
||||
if ($subject) {
|
||||
$subject =~ s/[\r\n]/ /g;
|
||||
LJ::CleanHTML::clean_subject_all(\$subject);
|
||||
}
|
||||
|
||||
# an HTML link to the entry. used if we truncate or summarize
|
||||
my $readmore = "<b>(<a href=\"$journalinfo->{link}$ditemid.html\">Read more ...</a>)</b>";
|
||||
|
||||
# empty string so we don't waste time cleaning an entry that won't be used
|
||||
my $event = $u->{'opt_synlevel'} eq 'title' ? '' : $logtext->{$itemid}->[1];
|
||||
|
||||
# clean the event, if non-empty
|
||||
my $ppid = 0;
|
||||
if ($event) {
|
||||
|
||||
# users without 'full_rss' get their logtext bodies truncated
|
||||
# do this now so that the html cleaner will hopefully fix html we break
|
||||
unless (LJ::get_cap($u, 'full_rss')) {
|
||||
my $trunc = LJ::text_trim($event, 0, 80);
|
||||
$event = "$trunc $readmore" if $trunc ne $event;
|
||||
}
|
||||
|
||||
LJ::CleanHTML::clean_event(\$event,
|
||||
{ 'preformatted' => $logprops{$itemid}->{'opt_preformatted'} });
|
||||
|
||||
# do this after clean so we don't have to about know whether or not
|
||||
# the event is preformatted
|
||||
if ($u->{'opt_synlevel'} eq 'summary') {
|
||||
|
||||
# assume the first paragraph is terminated by two <br> or a </p>
|
||||
# valid XML tags should be handled, even though it makes an uglier regex
|
||||
if ($event =~ m!((<br\s*/?\>(</br\s*>)?\s*){2})|(</p\s*>)!i) {
|
||||
# everything before the matched tag + the tag itself
|
||||
# + a link to read more
|
||||
$event = $` . $& . $readmore;
|
||||
}
|
||||
}
|
||||
|
||||
if ($event =~ /<lj-poll-(\d+)>/) {
|
||||
my $pollid = $1;
|
||||
my $name = $dbr->selectrow_array("SELECT name FROM poll WHERE pollid=?",
|
||||
undef, $pollid);
|
||||
|
||||
if ($name) {
|
||||
LJ::Poll::clean_poll(\$name);
|
||||
} else {
|
||||
$name = "#$pollid";
|
||||
}
|
||||
|
||||
$event =~ s!<lj-poll-$pollid>!<div><a href="$LJ::SITEROOT/poll/?id=$pollid">View Poll: $name</a></div>!g;
|
||||
}
|
||||
|
||||
$ppid = $1
|
||||
if $event =~ m!<lj-phonepost journalid=['"]\d+['"] dpid=['"](\d+)['"] />!;
|
||||
}
|
||||
|
||||
my $mood;
|
||||
if ($logprops{$itemid}->{'current_mood'}) {
|
||||
$mood = $logprops{$itemid}->{'current_mood'};
|
||||
} elsif ($logprops{$itemid}->{'current_moodid'}) {
|
||||
$mood = LJ::mood_name($logprops{$itemid}->{'current_moodid'}+0);
|
||||
}
|
||||
|
||||
my $createtime = $LJ::EndOfTime - $it->{rlogtime};
|
||||
my $cleanitem = {
|
||||
itemid => $itemid,
|
||||
ditemid => $ditemid,
|
||||
subject => $subject,
|
||||
event => $event,
|
||||
createtime => $createtime,
|
||||
eventtime => $it->{alldatepart}, # ugly: this is of a different format than the other two times.
|
||||
modtime => $logprops{$itemid}->{revtime} || $createtime,
|
||||
comments => ($logprops{$itemid}->{'opt_nocomments'} == 0),
|
||||
music => $logprops{$itemid}->{'current_music'},
|
||||
mood => $mood,
|
||||
ppid => $ppid,
|
||||
tags => [ values %{$logtags->{$itemid} || {}} ],
|
||||
};
|
||||
push @cleanitems, $cleanitem;
|
||||
}
|
||||
|
||||
# fix up the build date to use entry-time
|
||||
$journalinfo->{'builddate'} = LJ::time_to_http($LJ::EndOfTime - $items[0]->{'rlogtime'}),
|
||||
|
||||
return $viewfunc->($journalinfo, $u, $opts, \@cleanitems);
|
||||
}
|
||||
|
||||
# the creator for the RSS XML syndication view
|
||||
sub create_view_rss
|
||||
{
|
||||
my ($journalinfo, $u, $opts, $cleanitems) = @_;
|
||||
|
||||
my $ret;
|
||||
|
||||
# header
|
||||
$ret .= "<?xml version='1.0' encoding='$opts->{'saycharset'}' ?>\n";
|
||||
$ret .= LJ::run_hook("bot_director", "<!-- ", " -->") . "\n";
|
||||
$ret .= "<rss version='2.0' xmlns:lj='http://www.livejournal.org/rss/lj/1.0/'>\n";
|
||||
|
||||
# channel attributes
|
||||
$ret .= "<channel>\n";
|
||||
$ret .= " <title>" . LJ::exml($journalinfo->{title}) . "</title>\n";
|
||||
$ret .= " <link>$journalinfo->{link}</link>\n";
|
||||
$ret .= " <description>" . LJ::exml("$journalinfo->{title} - $LJ::SITENAME") . "</description>\n";
|
||||
$ret .= " <managingEditor>" . LJ::exml($journalinfo->{email}) . "</managingEditor>\n" if $journalinfo->{email};
|
||||
$ret .= " <lastBuildDate>$journalinfo->{builddate}</lastBuildDate>\n";
|
||||
$ret .= " <generator>LiveJournal / $LJ::SITENAME</generator>\n";
|
||||
# TODO: add 'language' field when user.lang has more useful information
|
||||
|
||||
### image block, returns info for their current userpic
|
||||
if ($u->{'defaultpicid'}) {
|
||||
my $pic = {};
|
||||
LJ::load_userpics($pic, [ $u, $u->{'defaultpicid'} ]);
|
||||
$pic = $pic->{$u->{'defaultpicid'}}; # flatten
|
||||
|
||||
$ret .= " <image>\n";
|
||||
$ret .= " <url>$LJ::USERPIC_ROOT/$u->{'defaultpicid'}/$u->{'userid'}</url>\n";
|
||||
$ret .= " <title>" . LJ::exml($journalinfo->{title}) . "</title>\n";
|
||||
$ret .= " <link>$journalinfo->{link}</link>\n";
|
||||
$ret .= " <width>$pic->{'width'}</width>\n";
|
||||
$ret .= " <height>$pic->{'height'}</height>\n";
|
||||
$ret .= " </image>\n\n";
|
||||
}
|
||||
|
||||
my %posteru = (); # map posterids to u objects
|
||||
LJ::load_userids_multiple([map { $_->{'posterid'}, \$posteru{$_->{'posterid'}} } @$cleanitems], [$u]);
|
||||
|
||||
# output individual item blocks
|
||||
|
||||
foreach my $it (@$cleanitems)
|
||||
{
|
||||
my $itemid = $it->{itemid};
|
||||
my $ditemid = $it->{ditemid};
|
||||
$ret .= "<item>\n";
|
||||
$ret .= " <guid isPermaLink='true'>$journalinfo->{link}$ditemid.html</guid>\n";
|
||||
$ret .= " <pubDate>" . LJ::time_to_http($it->{createtime}) . "</pubDate>\n";
|
||||
$ret .= " <title>" . LJ::exml($it->{subject}) . "</title>\n" if $it->{subject};
|
||||
$ret .= " <author>" . LJ::exml($journalinfo->{email}) . "</author>" if $journalinfo->{email};
|
||||
$ret .= " <link>$journalinfo->{link}$ditemid.html</link>\n";
|
||||
# omit the description tag if we're only syndicating titles
|
||||
# note: the $event was also emptied earlier, in make_feed
|
||||
unless ($u->{'opt_synlevel'} eq 'title') {
|
||||
$ret .= " <description>" . LJ::exml($it->{event}) . "</description>\n";
|
||||
}
|
||||
if ($it->{comments}) {
|
||||
$ret .= " <comments>$journalinfo->{link}$ditemid.html</comments>\n";
|
||||
}
|
||||
$ret .= " <category>$_</category>\n" foreach map { LJ::exml($_) } @{$it->{tags} || []};
|
||||
# support 'podcasting' enclosures
|
||||
$ret .= LJ::run_hook( "pp_rss_enclosure",
|
||||
{ userid => $u->{userid}, ppid => $it->{ppid} }) if $it->{ppid};
|
||||
# TODO: add author field with posterid's email address, respect communities
|
||||
$ret .= " <lj:music>" . LJ::exml($it->{music}) . "</lj:music>\n" if $it->{music};
|
||||
$ret .= " <lj:mood>" . LJ::exml($it->{mood}) . "</lj:mood>\n" if $it->{mood};
|
||||
$ret .= "</item>\n";
|
||||
}
|
||||
|
||||
$ret .= "</channel>\n";
|
||||
$ret .= "</rss>\n";
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
|
||||
# the creator for the Atom view
|
||||
# keys of $opts:
|
||||
# saycharset - required: the charset of the feed
|
||||
# noheader - only output an <entry>..</entry> block. off by default
|
||||
# apilinks - output AtomAPI links for posting a new entry or
|
||||
# getting/editing/deleting an existing one. off by default
|
||||
# TODO: define and use an 'lj:' namespace
|
||||
|
||||
sub create_view_atom
|
||||
{
|
||||
my ($journalinfo, $u, $opts, $cleanitems) = @_;
|
||||
|
||||
my $ret;
|
||||
|
||||
# prolog line
|
||||
$ret .= "<?xml version='1.0' encoding='$opts->{'saycharset'}' ?>\n";
|
||||
$ret .= LJ::run_hook("bot_director", "<!-- ", " -->");
|
||||
|
||||
# AtomAPI interface
|
||||
my $api = $opts->{'apilinks'} ? "$LJ::SITEROOT/interface/atom" :
|
||||
"$LJ::SITEROOT/users/$u->{user}/data/atom";
|
||||
|
||||
# header
|
||||
unless ($opts->{'noheader'}) {
|
||||
$ret .= "<feed version='0.3' xmlns='http://purl.org/atom/ns#'>\n";
|
||||
|
||||
# attributes
|
||||
$ret .= "<title mode='escaped'>" . LJ::exml($journalinfo->{title}) . "</title>\n";
|
||||
$ret .= "<tagline mode='escaped'>" . LJ::exml($journalinfo->{subtitle}) . "</tagline>\n"
|
||||
if $journalinfo->{subtitle};
|
||||
$ret .= "<link rel='alternate' type='text/html' href='$journalinfo->{link}' />\n";
|
||||
|
||||
# last update
|
||||
$ret .= "<modified>" . LJ::time_to_w3c($journalinfo->{'modtime'}, 'Z')
|
||||
. "</modified>";
|
||||
|
||||
# link to the AtomAPI version of this feed
|
||||
$ret .= "<link rel='service.feed' type='application/x.atom+xml' title='";
|
||||
$ret .= LJ::ehtml($journalinfo->{title});
|
||||
$ret .= $opts->{'apilinks'} ? "' href='$api/feed' />" : "' href='$api' />";
|
||||
|
||||
if ($opts->{'apilinks'}) {
|
||||
$ret .= "<link rel='service.post' type='application/x.atom+xml' title='Create a new post' href='$api/post' />";
|
||||
}
|
||||
}
|
||||
|
||||
# output individual item blocks
|
||||
|
||||
foreach my $it (@$cleanitems)
|
||||
{
|
||||
my $itemid = $it->{itemid};
|
||||
my $ditemid = $it->{ditemid};
|
||||
|
||||
$ret .= " <entry xmlns=\"http://purl.org/atom/ns#\">\n";
|
||||
# include empty tag if we don't have a subject.
|
||||
$ret .= " <title mode='escaped'>" . LJ::exml($it->{subject}) . "</title>\n";
|
||||
$ret .= " <id>urn:lj:$LJ::DOMAIN:atom1:$journalinfo->{u}{user}:$ditemid</id>\n";
|
||||
$ret .= " <link rel='alternate' type='text/html' href='$journalinfo->{link}$ditemid.html' />\n";
|
||||
if ($opts->{'apilinks'}) {
|
||||
$ret .= "<link rel='service.edit' type='application/x.atom+xml' title='Edit this post' href='$api/edit/$itemid' />";
|
||||
}
|
||||
$ret .= " <created>" . LJ::time_to_w3c($it->{createtime}, 'Z') . "</created>\n"
|
||||
if $it->{createtime} != $it->{modtime};
|
||||
|
||||
my ($year, $mon, $mday, $hour, $min, $sec) = split(/ /, $it->{eventtime});
|
||||
$ret .= " <issued>" . sprintf("%04d-%02d-%02dT%02d:%02d:%02d",
|
||||
$year, $mon, $mday,
|
||||
$hour, $min, $sec) . "</issued>\n";
|
||||
$ret .= " <modified>" . LJ::time_to_w3c($it->{modtime}, 'Z') . "</modified>\n";
|
||||
$ret .= " <author>\n";
|
||||
$ret .= " <name>" . LJ::exml($journalinfo->{u}{name}) . "</name>\n";
|
||||
$ret .= " <email>" . LJ::exml($journalinfo->{email}) . "</email>\n" if $journalinfo->{email};
|
||||
$ret .= " </author>\n";
|
||||
$ret .= " <category term='$_' />\n" foreach map { LJ::exml($_) } @{$it->{tags} || []};
|
||||
# if syndicating the complete entry
|
||||
# -print a content tag
|
||||
# elsif syndicating summaries
|
||||
# -print a summary tag
|
||||
# else (code omitted), we're syndicating title only
|
||||
# -print neither (the title has already been printed)
|
||||
# note: the $event was also emptied earlier, in make_feed
|
||||
if ($u->{'opt_synlevel'} eq 'full') {
|
||||
$ret .= " <content type='text/html' mode='escaped'>" . LJ::exml($it->{event}) . "</content>\n";
|
||||
} elsif ($u->{'opt_synlevel'} eq 'summary') {
|
||||
$ret .= " <summary type='text/html' mode='escaped'>" . LJ::exml($it->{event}) . "</summary>\n";
|
||||
}
|
||||
|
||||
$ret .= " </entry>\n";
|
||||
}
|
||||
|
||||
unless ($opts->{'noheader'}) {
|
||||
$ret .= "</feed>\n";
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# create a FOAF page for a user
|
||||
sub create_view_foaf {
|
||||
my ($journalinfo, $u, $opts) = @_;
|
||||
my $comm = ($u->{journaltype} eq 'C');
|
||||
|
||||
my $ret;
|
||||
|
||||
# return nothing if we're not a user
|
||||
unless ($u->{journaltype} eq 'P' || $comm) {
|
||||
$opts->{handler_return} = 404;
|
||||
return undef;
|
||||
}
|
||||
|
||||
# set our content type
|
||||
$opts->{contenttype} = 'application/rdf+xml; charset=' . $opts->{saycharset};
|
||||
|
||||
# setup userprops we will need
|
||||
LJ::load_user_props($u, qw{
|
||||
aolim icq yahoo jabber msn url urlname external_foaf_url
|
||||
});
|
||||
|
||||
# create bare foaf document, for now
|
||||
$ret = "<?xml version='1.0'?>\n";
|
||||
$ret .= LJ::run_hook("bot_director", "<!-- ", " -->");
|
||||
$ret .= "<rdf:RDF\n";
|
||||
$ret .= " xml:lang=\"en\"\n";
|
||||
$ret .= " xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"\n";
|
||||
$ret .= " xmlns:rdfs=\"http://www.w3.org/2000/01/rdf-schema#\"\n";
|
||||
$ret .= " xmlns:foaf=\"http://xmlns.com/foaf/0.1/\"\n";
|
||||
$ret .= " xmlns:dc=\"http://purl.org/dc/elements/1.1/\">\n";
|
||||
|
||||
# precompute some values
|
||||
my $digest = Digest::SHA1::sha1_hex('mailto:' . $u->{email});
|
||||
|
||||
# channel attributes
|
||||
$ret .= ($comm ? " <foaf:Group>\n" : " <foaf:Person>\n");
|
||||
$ret .= " <foaf:nick>$u->{user}</foaf:nick>\n";
|
||||
if ($u->{bdate} && $u->{bdate} ne "0000-00-00" && !$comm && $u->{allow_infoshow} eq 'Y') {
|
||||
my $bdate = $u->{bdate};
|
||||
$bdate =~ s/^0000-//;
|
||||
$ret .= " <foaf:dateOfBirth>$bdate</foaf:dateOfBirth>\n";
|
||||
}
|
||||
$ret .= " <foaf:mbox_sha1sum>$digest</foaf:mbox_sha1sum>\n";
|
||||
$ret .= " <foaf:page>\n";
|
||||
$ret .= " <foaf:Document rdf:about=\"$LJ::SITEROOT/userinfo.bml?user=$u->{user}\">\n";
|
||||
$ret .= " <dc:title>$LJ::SITENAME Profile</dc:title>\n";
|
||||
$ret .= " <dc:description>Full $LJ::SITENAME profile, including information such as interests and bio.</dc:description>\n";
|
||||
$ret .= " </foaf:Document>\n";
|
||||
$ret .= " </foaf:page>\n";
|
||||
|
||||
# we want to bail out if they have an external foaf file, because
|
||||
# we want them to be able to provide their own information.
|
||||
if ($u->{external_foaf_url}) {
|
||||
$ret .= " <rdfs:seeAlso rdf:resource=\"" . LJ::eurl($u->{external_foaf_url}) . "\" />\n";
|
||||
$ret .= ($comm ? " </foaf:Group>\n" : " </foaf:Person>\n");
|
||||
$ret .= "</rdf:RDF>\n";
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# contact type information
|
||||
my %types = (
|
||||
aolim => 'aimChatID',
|
||||
icq => 'icqChatID',
|
||||
yahoo => 'yahooChatID',
|
||||
msn => 'msnChatID',
|
||||
jabber => 'jabberID',
|
||||
);
|
||||
if ($u->{allow_contactshow} eq 'Y') {
|
||||
foreach my $type (keys %types) {
|
||||
next unless $u->{$type};
|
||||
$ret .= " <foaf:$types{$type}>" . LJ::exml($u->{$type}) . "</foaf:$types{$type}>\n";
|
||||
}
|
||||
}
|
||||
|
||||
# include a user's journal page and web site info
|
||||
$ret .= " <foaf:weblog rdf:resource=\"" . LJ::journal_base($u) . "/\"/>\n";
|
||||
if ($u->{url}) {
|
||||
$ret .= " <foaf:homepage rdf:resource=\"" . LJ::eurl($u->{url});
|
||||
$ret .= "\" dc:title=\"" . LJ::exml($u->{urlname}) . "\" />\n";
|
||||
}
|
||||
|
||||
# interests, please!
|
||||
# arrayref of interests rows: [ intid, intname, intcount ]
|
||||
my $intu = LJ::get_interests($u);
|
||||
foreach my $int (@$intu) {
|
||||
LJ::text_out(\$int->[1]); # 1==interest
|
||||
$ret .= " <foaf:interest dc:title=\"". LJ::exml($int->[1]) . "\" " .
|
||||
"rdf:resource=\"$LJ::SITEROOT/interests.bml?int=" . LJ::eurl($int->[1]) . "\" />\n";
|
||||
}
|
||||
|
||||
# check if the user has a "FOAF-knows" group
|
||||
my $groups = LJ::get_friend_group($u->{userid}, { name => 'FOAF-knows' });
|
||||
my $mask = $groups ? 1 << $groups->{groupnum} : 0;
|
||||
|
||||
# now information on who you know, limited to a certain maximum number of users
|
||||
my $friends = LJ::get_friends($u->{userid}, $mask);
|
||||
my @ids = keys %$friends;
|
||||
@ids = splice(@ids, 0, $LJ::MAX_FOAF_FRIENDS) if @ids > $LJ::MAX_FOAF_FRIENDS;
|
||||
|
||||
# now load
|
||||
my %users;
|
||||
LJ::load_userids_multiple([ map { $_, \$users{$_} } @ids ], [$u]);
|
||||
|
||||
# iterate to create data structure
|
||||
foreach my $friendid (@ids) {
|
||||
next if $friendid == $u->{userid};
|
||||
my $fu = $users{$friendid};
|
||||
next if $fu->{statusvis} =~ /[DXS]/ || $fu->{journaltype} ne 'P';
|
||||
$ret .= $comm ? " <foaf:member>\n" : " <foaf:knows>\n";
|
||||
$ret .= " <foaf:Person>\n";
|
||||
$ret .= " <foaf:nick>$fu->{'user'}</foaf:nick>\n";
|
||||
$ret .= " <rdfs:seeAlso rdf:resource=\"" . LJ::journal_base($fu) ."/data/foaf\" />\n";
|
||||
$ret .= " <foaf:weblog rdf:resource=\"" . LJ::journal_base($fu) . "/\"/>\n";
|
||||
$ret .= " </foaf:Person>\n";
|
||||
$ret .= $comm ? " </foaf:member>\n" : " </foaf:knows>\n";
|
||||
}
|
||||
|
||||
# finish off the document
|
||||
$ret .= $comm ? " </foaf:Group>\n" : " </foaf:Person>\n";
|
||||
$ret .= "</rdf:RDF>\n";
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
416
livejournal/cgi-bin/ljlang.pl
Executable file
416
livejournal/cgi-bin/ljlang.pl
Executable file
@@ -0,0 +1,416 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
use LJ::Cache;
|
||||
|
||||
package LJ::Lang;
|
||||
|
||||
my @day_short = (qw[Sun Mon Tue Wed Thu Fri Sat]);
|
||||
my @day_long = (qw[Sunday Monday Tuesday Wednesday Thursday Friday Saturday]);
|
||||
my @month_short = (qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec]);
|
||||
my @month_long = (qw[January February March April May June July August September October November December]);
|
||||
|
||||
# get entire array of days and months
|
||||
sub day_list_short { return @LJ::Lang::day_short; }
|
||||
sub day_list_long { return @LJ::Lang::day_long; }
|
||||
sub month_list_short { return @LJ::Lang::month_short; }
|
||||
sub month_list_long { return @LJ::Lang::month_long; }
|
||||
|
||||
# access individual day or month given integer
|
||||
sub day_short { return $day_short[$_[0] - 1]; }
|
||||
sub day_long { return $day_long[$_[0] - 1]; }
|
||||
sub month_short { return $month_short[$_[0] - 1]; }
|
||||
sub month_long { return $month_long[$_[0] - 1]; }
|
||||
|
||||
# lang codes for individual day or month given integer
|
||||
sub day_short_langcode { return "date.day." . lc(LJ::Lang::day_long(@_)) . ".short"; }
|
||||
sub day_long_langcode { return "date.day." . lc(LJ::Lang::day_long(@_)) . ".long"; }
|
||||
sub month_short_langcode { return "date.month." . lc(LJ::Lang::month_long(@_)) . ".short"; }
|
||||
sub month_long_langcode { return "date.month." . lc(LJ::Lang::month_long(@_)) . ".long"; }
|
||||
|
||||
## ordinal suffix
|
||||
sub day_ord {
|
||||
my $day = shift;
|
||||
|
||||
# teens all end in 'th'
|
||||
if ($day =~ /1\d$/) { return "th"; }
|
||||
|
||||
# otherwise endings in 1, 2, 3 are special
|
||||
if ($day % 10 == 1) { return "st"; }
|
||||
if ($day % 10 == 2) { return "nd"; }
|
||||
if ($day % 10 == 3) { return "rd"; }
|
||||
|
||||
# everything else (0,4-9) end in "th"
|
||||
return "th";
|
||||
}
|
||||
|
||||
sub time_format
|
||||
{
|
||||
my ($hours, $h, $m, $formatstring) = @_;
|
||||
|
||||
if ($formatstring eq "short") {
|
||||
if ($hours == 12) {
|
||||
my $ret;
|
||||
my $ap = "a";
|
||||
if ($h == 0) { $ret .= "12"; }
|
||||
elsif ($h < 12) { $ret .= ($h+0); }
|
||||
elsif ($h == 12) { $ret .= ($h+0); $ap = "p"; }
|
||||
else { $ret .= ($h-12); $ap = "p"; }
|
||||
$ret .= sprintf(":%02d$ap", $m);
|
||||
return $ret;
|
||||
} elsif ($hours == 24) {
|
||||
return sprintf("%02d:%02d", $h, $m);
|
||||
}
|
||||
}
|
||||
return "";
|
||||
}
|
||||
|
||||
#### ml_ stuff:
|
||||
my $LS_CACHED = 0;
|
||||
my %DM_ID = (); # id -> { type, args, dmid, langs => { => 1, => 0, => 1 } }
|
||||
my %DM_UNIQ = (); # "$type/$args" => ^^^
|
||||
my %LN_ID = (); # id -> { ..., ..., 'children' => [ $ids, .. ] }
|
||||
my %LN_CODE = (); # $code -> ^^^^
|
||||
my $LAST_ERROR;
|
||||
my $TXT_CACHE; # LJ::Cache for text
|
||||
|
||||
sub get_cache_object { return $TXT_CACHE; }
|
||||
|
||||
sub last_error
|
||||
{
|
||||
return $LAST_ERROR;
|
||||
}
|
||||
|
||||
sub set_error
|
||||
{
|
||||
$LAST_ERROR = $_[0];
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub get_lang
|
||||
{
|
||||
my $code = shift;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
return $LN_CODE{$code};
|
||||
}
|
||||
|
||||
sub get_lang_id
|
||||
{
|
||||
my $id = shift;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
return $LN_ID{$id};
|
||||
}
|
||||
|
||||
sub get_dom
|
||||
{
|
||||
my $dmcode = shift;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
return $DM_UNIQ{$dmcode};
|
||||
}
|
||||
|
||||
sub get_dom_id
|
||||
{
|
||||
my $dmid = shift;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
return $DM_ID{$dmid};
|
||||
}
|
||||
|
||||
sub get_domains
|
||||
{
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
return values %DM_ID;
|
||||
}
|
||||
|
||||
sub get_root_lang
|
||||
{
|
||||
my $dom = shift; # from, say, get_dom
|
||||
return undef unless ref $dom eq "HASH";
|
||||
foreach (keys %{$dom->{'langs'}}) {
|
||||
if ($dom->{'langs'}->{$_}) {
|
||||
return get_lang_id($_);
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub load_lang_struct
|
||||
{
|
||||
return 1 if $LS_CACHED;
|
||||
my $dbr = LJ::get_db_reader();
|
||||
return set_error("No database available") unless $dbr;
|
||||
my $sth;
|
||||
|
||||
$TXT_CACHE = new LJ::Cache { 'maxbytes' => $LJ::LANG_CACHE_BYTES || 50_000 };
|
||||
|
||||
$sth = $dbr->prepare("SELECT dmid, type, args FROM ml_domains");
|
||||
$sth->execute;
|
||||
while (my ($dmid, $type, $args) = $sth->fetchrow_array) {
|
||||
my $uniq = $args ? "$type/$args" : $type;
|
||||
$DM_UNIQ{$uniq} = $DM_ID{$dmid} = {
|
||||
'type' => $type, 'args' => $args, 'dmid' => $dmid,
|
||||
'uniq' => $uniq,
|
||||
};
|
||||
}
|
||||
|
||||
$sth = $dbr->prepare("SELECT lnid, lncode, lnname, parenttype, parentlnid FROM ml_langs");
|
||||
$sth->execute;
|
||||
while (my ($id, $code, $name, $ptype, $pid) = $sth->fetchrow_array) {
|
||||
$LN_ID{$id} = $LN_CODE{$code} = {
|
||||
'lnid' => $id,
|
||||
'lncode' => $code,
|
||||
'lnname' => $name,
|
||||
'parenttype' => $ptype,
|
||||
'parentlnid' => $pid,
|
||||
};
|
||||
}
|
||||
foreach (values %LN_CODE) {
|
||||
next unless $_->{'parentlnid'};
|
||||
push @{$LN_ID{$_->{'parentlnid'}}->{'children'}}, $_->{'lnid'};
|
||||
}
|
||||
|
||||
$sth = $dbr->prepare("SELECT lnid, dmid, dmmaster FROM ml_langdomains");
|
||||
$sth->execute;
|
||||
while (my ($lnid, $dmid, $dmmaster) = $sth->fetchrow_array) {
|
||||
$DM_ID{$dmid}->{'langs'}->{$lnid} = $dmmaster;
|
||||
}
|
||||
|
||||
$LS_CACHED = 1;
|
||||
}
|
||||
|
||||
sub get_itemid
|
||||
{
|
||||
&LJ::nodb;
|
||||
my ($dmid, $itcode, $opts) = @_;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
$dmid += 0;
|
||||
my $itid = $dbr->selectrow_array("SELECT itid FROM ml_items WHERE dmid=$dmid AND itcode=?", undef, $itcode);
|
||||
return $itid if defined $itid;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return 0 unless $dbh;
|
||||
|
||||
# allocate a new id
|
||||
LJ::get_lock($dbh, 'global', 'mlitem_dmid') || return 0;
|
||||
$itid = $dbh->selectrow_array("SELECT MAX(itid)+1 FROM ml_items WHERE dmid=?", undef, $dmid);
|
||||
$itid ||= 1; # if the table is empty, NULL+1 == NULL
|
||||
$dbh->do("INSERT INTO ml_items (dmid, itid, itcode, notes) ".
|
||||
"VALUES (?, ?, ?, ?)", undef, $dmid, $itid, $itcode, $opts->{'notes'});
|
||||
LJ::release_lock($dbh, 'global', 'mlitem_dmid');
|
||||
|
||||
if ($dbh->err) {
|
||||
return $dbh->selectrow_array("SELECT itid FROM ml_items WHERE dmid=$dmid AND itcode=?",
|
||||
undef, $itcode);
|
||||
}
|
||||
return $itid;
|
||||
}
|
||||
|
||||
sub set_text
|
||||
{
|
||||
&LJ::nodb;
|
||||
my ($dmid, $lncode, $itcode, $text, $opts) = @_;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
|
||||
my $l = $LN_CODE{$lncode} or return set_error("Language not defined.");
|
||||
my $lnid = $l->{'lnid'};
|
||||
$dmid += 0;
|
||||
|
||||
# is this domain/language request even possible?
|
||||
return set_error("Bogus domain")
|
||||
unless exists $DM_ID{$dmid};
|
||||
return set_error("Bogus lang for that domain")
|
||||
unless exists $DM_ID{$dmid}->{'langs'}->{$lnid};
|
||||
|
||||
my $itid = get_itemid($dmid, $itcode, { 'notes' => $opts->{'notes'}});
|
||||
return set_error("Couldn't allocate itid.") unless $itid;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $txtid = 0;
|
||||
if (defined $text) {
|
||||
my $userid = $opts->{'userid'} + 0;
|
||||
# Strip bad characters
|
||||
$text =~ s/\r//;
|
||||
my $qtext = $dbh->quote($text);
|
||||
LJ::get_lock( $dbh, 'global', 'ml_text_txtid' ) || return 0;
|
||||
$txtid = $dbh->selectrow_array("SELECT MAX(txtid)+1 FROM ml_text WHERE dmid=?", undef, $dmid);
|
||||
$txtid ||= 1;
|
||||
$dbh->do("INSERT INTO ml_text (dmid, txtid, lnid, itid, text, userid) ".
|
||||
"VALUES ($dmid, $txtid, $lnid, $itid, $qtext, $userid)");
|
||||
LJ::release_lock( $dbh, 'global', 'ml_text_txtid' );
|
||||
return set_error("Error inserting ml_text: ".$dbh->errstr) if $dbh->err;
|
||||
}
|
||||
if ($opts->{'txtid'}) {
|
||||
$txtid = $opts->{'txtid'}+0;
|
||||
}
|
||||
|
||||
my $staleness = $opts->{'staleness'}+0;
|
||||
$dbh->do("REPLACE INTO ml_latest (lnid, dmid, itid, txtid, chgtime, staleness) ".
|
||||
"VALUES ($lnid, $dmid, $itid, $txtid, NOW(), $staleness)");
|
||||
return set_error("Error inserting ml_latest: ".$dbh->errstr) if $dbh->err;
|
||||
LJ::MemCache::set("ml.${lncode}.${dmid}.${itcode}", $text) if defined $text;
|
||||
|
||||
{
|
||||
my $vals;
|
||||
my $langids;
|
||||
my $rec = sub {
|
||||
my $l = shift;
|
||||
my $rec = shift;
|
||||
foreach my $cid (@{$l->{'children'}}) {
|
||||
my $clid = $LN_ID{$cid};
|
||||
if ($opts->{'childrenlatest'}) {
|
||||
my $stale = $clid->{'parenttype'} eq "diff" ? 3 : 0;
|
||||
$vals .= "," if $vals;
|
||||
$vals .= "($cid, $dmid, $itid, $txtid, NOW(), $stale)";
|
||||
}
|
||||
$langids .= "," if $langids;
|
||||
$langids .= $cid+0;
|
||||
LJ::MemCache::delete("ml.$clid->{'lncode'}.${dmid}.${itcode}");
|
||||
$rec->($clid, $rec);
|
||||
}
|
||||
};
|
||||
$rec->($l, $rec);
|
||||
|
||||
# set descendants to use this mapping
|
||||
$dbh->do("INSERT IGNORE INTO ml_latest (lnid, dmid, itid, txtid, chgtime, staleness) ".
|
||||
"VALUES $vals") if $vals;
|
||||
|
||||
# update languages that have no translation yet
|
||||
$dbh->do("UPDATE ml_latest SET txtid=$txtid WHERE dmid=$dmid ".
|
||||
"AND lnid IN ($langids) AND itid=$itid AND staleness >= 3") if $langids;
|
||||
}
|
||||
|
||||
if ($opts->{'changeseverity'} && $l->{'children'} && @{$l->{'children'}}) {
|
||||
my $in = join(",", @{$l->{'children'}});
|
||||
my $newstale = $opts->{'changeseverity'} == 2 ? 2 : 1;
|
||||
$dbh->do("UPDATE ml_latest SET staleness=$newstale WHERE lnid IN ($in) AND ".
|
||||
"dmid=$dmid AND itid=$itid AND txtid<>$txtid AND staleness < $newstale");
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub get_text
|
||||
{
|
||||
my ($lang, $code, $dmid, $vars) = @_;
|
||||
$dmid = int($dmid || 1);
|
||||
$lang ||= $LJ::DEFAULT_LANG;
|
||||
load_lang_struct() unless $LS_CACHED;
|
||||
my $cache_key = "ml.${lang}.${dmid}.${code}";
|
||||
|
||||
my $text = $TXT_CACHE->get($cache_key);
|
||||
|
||||
unless (defined $text) {
|
||||
my $mem_good = 1;
|
||||
$text = LJ::MemCache::get($cache_key);
|
||||
unless (defined $text) {
|
||||
$mem_good = 0;
|
||||
my $l = $LN_CODE{$lang} or return "?lang?";
|
||||
my $dbr = LJ::get_db_reader();
|
||||
$text = $dbr->selectrow_array("SELECT t.text".
|
||||
" FROM ml_text t, ml_latest l, ml_items i".
|
||||
" WHERE t.dmid=$dmid AND t.txtid=l.txtid".
|
||||
" AND l.dmid=$dmid AND l.lnid=$l->{lnid} AND l.itid=i.itid".
|
||||
" AND i.dmid=$dmid AND i.itcode=?", undef,
|
||||
$code);
|
||||
}
|
||||
if (defined $text) {
|
||||
$TXT_CACHE->set($cache_key, $text);
|
||||
LJ::MemCache::set($cache_key, $text) unless $mem_good;
|
||||
}
|
||||
}
|
||||
|
||||
if ($vars) {
|
||||
$text =~ s/\[\[\?([\w\-]+)\|(.+?)\]\]/resolve_plural($lang, $vars, $1, $2)/eg;
|
||||
$text =~ s/\[\[([^\[]+?)\]\]/$vars->{$1}/g;
|
||||
}
|
||||
|
||||
return $text;
|
||||
}
|
||||
|
||||
# The translation system now supports the ability to add multiple plural forms of the word
|
||||
# given different rules in a languge. This functionality is much like the plural support
|
||||
# in the S2 styles code. To use this code you must use the BML::ml function and pass
|
||||
# the number of items as one of the variables. To make sure that you are allowing the
|
||||
# utmost compatibility for each language you should not hardcode the placement of the
|
||||
# number of items in relation to the noun. Let the translation string do this for you.
|
||||
# A translation string is in the format of, with num being the variable storing the
|
||||
# number of items.
|
||||
# =[[num]] [[?num|singular|plural1|plural2|pluralx]]
|
||||
|
||||
sub resolve_plural {
|
||||
my ($lang, $vars, $varname, $wordlist) = @_;
|
||||
my $count = $vars->{$varname};
|
||||
my @wlist = split(/\|/, $wordlist);
|
||||
my $plural_form = plural_form($lang, $count);
|
||||
return $wlist[$plural_form];
|
||||
}
|
||||
|
||||
# TODO: make this faster, using AUTOLOAD and symbol tables pointing to dynamically
|
||||
# generated subs which only use $_[0] for $count.
|
||||
sub plural_form {
|
||||
my ($lang, $count) = @_;
|
||||
return plural_form_en($count) if $lang =~ /^en/;
|
||||
return plural_form_ru($count) if $lang =~ /^ru/ || $lang =~ /^uk/;
|
||||
return plural_form_fr($count) if $lang =~ /^fr/ || $lang =~ /^pt_BR/;
|
||||
return plural_form_lt($count) if $lang =~ /^lt/;
|
||||
return plural_form_pl($count) if $lang =~ /^pl/;
|
||||
return plural_form_singular() if $lang =~ /^hu/ || $lang =~ /^ja/ || $lang =~ /^tr/;
|
||||
return plural_form_lv($count) if $lang =~ /^lv/;
|
||||
return plural_form_en($count); # default
|
||||
}
|
||||
|
||||
# English, Danish, German, Norwegian, Swedish, Estonian, Finnish, Greek, Hebrew, Italian, Portugese, Spanish, Esperanto
|
||||
sub plural_form_en {
|
||||
my ($count) = shift;
|
||||
return 0 if $count == 1;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# French, Brazilian Portuguese
|
||||
sub plural_form_fr {
|
||||
my ($count) = shift;
|
||||
return 1 if $count > 1;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Croatian, Czech, Russian, Slovak, Ukrainian
|
||||
sub plural_form_ru {
|
||||
my ($count) = shift;
|
||||
return 0 if ($count%10 == 1 and $count%100 != 11);
|
||||
return 1 if ($count%10 >= 2 and $count%10 <= 4 and ($count%100 < 10 or $count%100>=20));
|
||||
return 2;
|
||||
}
|
||||
|
||||
# Polish
|
||||
sub plural_form_pl {
|
||||
my ($count) = shift;
|
||||
return 0 if($count == 1);
|
||||
return 1 if($count%10 >= 2 && $count%10 <= 4 && ($count%100 < 10 || $count%100 >= 20));
|
||||
return 2;
|
||||
}
|
||||
|
||||
# Lithuanian
|
||||
sub plural_form_lt {
|
||||
my ($count) = shift;
|
||||
return 0 if($count%10 == 1 && $count%100 != 11);
|
||||
return 1 if ($count%10 >= 2 && ($count%100 < 10 || $count%100 >= 20));
|
||||
return 2;
|
||||
}
|
||||
|
||||
# Hungarian, Japanese, Korean (not supported), Turkish
|
||||
sub plural_form_singular {
|
||||
return 0;
|
||||
}
|
||||
|
||||
# Latvian
|
||||
sub plural_form_lv {
|
||||
my ($count) = shift;
|
||||
return 0 if($count%10 == 1 && $count%100 != 11);
|
||||
return 1 if($count != 0);
|
||||
return 2;
|
||||
}
|
||||
|
||||
1;
|
||||
9400
livejournal/cgi-bin/ljlib.pl
Executable file
9400
livejournal/cgi-bin/ljlib.pl
Executable file
File diff suppressed because it is too large
Load Diff
218
livejournal/cgi-bin/ljlinks.pl
Executable file
218
livejournal/cgi-bin/ljlinks.pl
Executable file
@@ -0,0 +1,218 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
#
|
||||
# Functions for lists of links created by users for display in their journals
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ::Links;
|
||||
|
||||
# linkobj structure:
|
||||
#
|
||||
# $linkobj = [
|
||||
# { 'title' => 'link title',
|
||||
# 'url' => 'http://www.somesite.com',
|
||||
# 'children' => [ ... ],
|
||||
# },
|
||||
# { ... },
|
||||
# { ... },
|
||||
# ];
|
||||
|
||||
sub load_linkobj
|
||||
{
|
||||
my ($u, $use_master) = @_;
|
||||
return unless LJ::isu($u);
|
||||
|
||||
# check memcache for linkobj
|
||||
my $memkey = [$u->{'userid'}, "linkobj:$u->{'userid'}"];
|
||||
my $linkobj = LJ::MemCache::get($memkey);
|
||||
return $linkobj if defined $linkobj;
|
||||
|
||||
# didn't find anything in memcache
|
||||
$linkobj = [];
|
||||
|
||||
{
|
||||
# not in memcache, need to build one from db
|
||||
my $db = $use_master ? LJ::get_cluster_def_reader($u) : LJ::get_cluster_reader($u);
|
||||
|
||||
local $" = ",";
|
||||
my $sth = $db->prepare("SELECT ordernum, parentnum, title, url " .
|
||||
"FROM links WHERE journalid=?");
|
||||
$sth->execute($u->{'userid'});
|
||||
push @$linkobj, $_ while $_ = $sth->fetchrow_hashref;
|
||||
}
|
||||
|
||||
# sort in perl-space
|
||||
@$linkobj = sort { $a->{'ordernum'} <=> $b->{'ordernum'} } @$linkobj;
|
||||
|
||||
# fix up the data structure
|
||||
foreach (@$linkobj) {
|
||||
|
||||
# TODO: build child relationships
|
||||
# and store in $_->{'children'}
|
||||
|
||||
# ordernum/parentnum are only exposed via the
|
||||
# array structure, delete them here
|
||||
delete $_->{'ordernum'};
|
||||
delete $_->{'parentnum'};
|
||||
}
|
||||
|
||||
# set linkobj in memcache
|
||||
LJ::MemCache::set($memkey, $linkobj);
|
||||
|
||||
return $linkobj;
|
||||
}
|
||||
|
||||
sub save_linkobj
|
||||
{
|
||||
my ($u, $linkobj) = @_;
|
||||
return undef unless LJ::isu($u) && ref $linkobj eq 'ARRAY' && $u->writer;
|
||||
|
||||
# delete old links, we'll rebuild them shortly
|
||||
$u->do("DELETE FROM links WHERE journalid=?", undef, $u->{'userid'});
|
||||
|
||||
# only save allowed number of links
|
||||
my $numlinks = @$linkobj;
|
||||
my $caplinks = LJ::get_cap($u, "userlinks");
|
||||
$numlinks = $caplinks if $numlinks > $caplinks;
|
||||
|
||||
# build insert query
|
||||
my (@bind, @vals);
|
||||
foreach my $ct (1..$numlinks) {
|
||||
my $it = $linkobj->[$ct-1];
|
||||
|
||||
# journalid, ordernum, parentnum, url, title
|
||||
push @bind, "(?,?,?,?,?)";
|
||||
push @vals, ($u->{'userid'}, $ct, 0, $it->{'url'}, $it->{'title'});
|
||||
}
|
||||
|
||||
# invalidate memcache
|
||||
my $memkey = [$u->{'userid'}, "linkobj:$u->{'userid'}"];
|
||||
LJ::MemCache::delete($memkey);
|
||||
|
||||
# insert into database
|
||||
{
|
||||
local $" = ",";
|
||||
return $u->do("INSERT INTO links (journalid, ordernum, parentnum, url, title) " .
|
||||
"VALUES @bind", undef, @vals);
|
||||
}
|
||||
}
|
||||
|
||||
sub make_linkobj_from_form
|
||||
{
|
||||
my ($u, $post) = @_;
|
||||
return unless LJ::isu($u) && ref $post eq 'HASH';
|
||||
|
||||
my $linkobj = [];
|
||||
|
||||
# remove leading and trailing spaces
|
||||
my $stripspaces = sub {
|
||||
my $str = shift;
|
||||
$str =~ s/^\s*//;
|
||||
$str =~ s/\s*$//;
|
||||
return $str;
|
||||
};
|
||||
|
||||
# find number of links allowed
|
||||
my $numlinks = $post->{'numlinks'};
|
||||
my $caplinks = LJ::get_cap($u, "userlinks");
|
||||
$numlinks = $caplinks if $numlinks > $caplinks;
|
||||
|
||||
foreach my $num (sort { $post->{"link_${a}_ordernum"} <=>
|
||||
$post->{"link_${b}_ordernum"} } (1..$numlinks)) {
|
||||
|
||||
# title is required
|
||||
my $title = $post->{"link_${num}_title"};
|
||||
$title = $stripspaces->($title);
|
||||
next unless $title;
|
||||
|
||||
my $url = $post->{"link_${num}_url"};
|
||||
$url = $stripspaces->($url);
|
||||
|
||||
# smartly add http:// to url unless they are just inserting a blank line
|
||||
if ($url && $title ne '-') {
|
||||
$url = LJ::CleanHTML::canonical_url($url);
|
||||
}
|
||||
|
||||
# build link object element
|
||||
$post->{"link_${num}_url"} = $url;
|
||||
push @$linkobj, { 'title' => $title, 'url' => $url };
|
||||
|
||||
# TODO: build child relationships
|
||||
# push @{$linkobj->[$parentnum-1]->{'children'}}, $myself
|
||||
}
|
||||
|
||||
return $linkobj;
|
||||
}
|
||||
|
||||
# this form is in the lib so we can put it in /customize/ directly later
|
||||
sub make_modify_form
|
||||
{
|
||||
my ($u, $linkobj, $post) = @_;
|
||||
return unless LJ::isu($u) && ref $linkobj eq 'ARRAY' && ref $post eq 'HASH';
|
||||
|
||||
# TODO: parentnum column is not implemented yet
|
||||
# -- it should link to the ordernum of the parent link
|
||||
# so we can support nesting/categories of links
|
||||
|
||||
my $LINK_MIN = 5; # how many do they start with ?
|
||||
my $LINK_MORE = 5; # how many do they get when they click "more"
|
||||
my $ORDER_STEP = 10; # step order numbers by
|
||||
|
||||
# how many link inputs to show?
|
||||
my $showlinks = $post->{'numlinks'} || @$linkobj;
|
||||
my $caplinks = LJ::get_cap($u, "userlinks");
|
||||
$showlinks += $LINK_MORE if $post->{'action:morelinks'};
|
||||
$showlinks = $LINK_MIN if $showlinks < $LINK_MIN;
|
||||
$showlinks = $caplinks if $showlinks > $caplinks;
|
||||
|
||||
my $ret = "<table border='0' cellspacing='3' cellpadding='0'>";
|
||||
$ret .= "<tr><th>Order</th><th>Title/URL</th><td> </td></tr>";
|
||||
|
||||
foreach my $ct (1..$showlinks) {
|
||||
my $it = $linkobj->[$ct-1] || {};
|
||||
|
||||
$ret .= "<tr><td>";
|
||||
$ret .= LJ::html_text({ 'name' => "link_${ct}_ordernum",
|
||||
'size' => 2,
|
||||
'value' => $ct * $ORDER_STEP });
|
||||
$ret .= "</td><td>";
|
||||
|
||||
$ret .= LJ::html_text({ 'name' => "link_${ct}_title",
|
||||
'size' => 50, 'maxlength' => 255,
|
||||
'value' => $it->{'title'} });
|
||||
$ret .= "</td><td> </td></tr>";
|
||||
|
||||
$ret .= "<tr><td> </td><td>";
|
||||
$ret .= LJ::html_text({ 'name' => "link_${ct}_url",
|
||||
'size' => 50, 'maxlength' => 255,
|
||||
'value' => $it->{'url'} || "http://"});
|
||||
|
||||
# more button at the end of the last line, but only if
|
||||
# they are allowed more than the minimum
|
||||
$ret .= "<td> ";
|
||||
if ($ct >= $showlinks && $caplinks > $LINK_MIN) {
|
||||
$ret .= LJ::html_submit('action:morelinks', "More →",
|
||||
{ 'disabled' => $ct >= $caplinks,
|
||||
'noescape' => 1 });
|
||||
}
|
||||
$ret .= "</td></tr>";
|
||||
|
||||
# blank line unless this is the last line
|
||||
$ret .= "<tr><td colspan='3'> </td></tr>"
|
||||
unless $ct >= $showlinks;
|
||||
}
|
||||
|
||||
# submit button
|
||||
$ret .= "<tr><td colspan='2' align='center'>";
|
||||
$ret .= LJ::html_hidden('numlinks' => $showlinks);
|
||||
$ret .= LJ::html_submit('action:savelinks', "Save Changes");
|
||||
$ret .= "</td><td> </td></tr>";
|
||||
|
||||
$ret .= "</table>";
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
1;
|
||||
356
livejournal/cgi-bin/ljmail.pl
Executable file
356
livejournal/cgi-bin/ljmail.pl
Executable file
@@ -0,0 +1,356 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
# Send mail outbound using a weighted random selection.
|
||||
# Supports a variety of mail protocols.
|
||||
#
|
||||
|
||||
package LJ;
|
||||
|
||||
use strict;
|
||||
use Text::Wrap ();
|
||||
use MIME::Lite ();
|
||||
use Time::HiRes qw/ gettimeofday tv_interval /;
|
||||
|
||||
use IO::Socket::INET (); # temp, for use with DMTP
|
||||
|
||||
require "$ENV{LJHOME}/cgi-bin/ljlib.pl";
|
||||
|
||||
sub maildebug ($);
|
||||
sub store_message (%$$);
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::send_mail
|
||||
# des: Sends email. Character set will only be used if message is not ascii.
|
||||
# args: opt[, async_caller]
|
||||
# des-opt: Hashref of arguments. <b>Required:</b> to, from, subject, body.
|
||||
# <b>Optional:</b> toname, fromname, cc, bcc, charset, wrap
|
||||
# </LJFUNC>
|
||||
sub send_mail
|
||||
{
|
||||
my $opts = shift;
|
||||
my $async_caller = shift;
|
||||
my $time = [gettimeofday()];
|
||||
|
||||
my (
|
||||
$proto, # what protocol we decided to use
|
||||
$msg, # email message (ascii)
|
||||
$data, # email message (MIME::Lite)
|
||||
$server, # remote server object
|
||||
$hostname # hostname of mailserver selected
|
||||
);
|
||||
|
||||
# support being given a direct MIME::Lite object,
|
||||
# for queued cmdbuffer 'frozen' retries
|
||||
$data = ( ref $opts eq 'MIME::Lite' ) ? $opts : build_message($opts);
|
||||
return 0 unless $data;
|
||||
$msg = $data->as_string();
|
||||
|
||||
# ok, we're sending via the network.
|
||||
# get a preferred server/protocol, or failover to cmdbuffer.
|
||||
( $server, $proto, $hostname ) = find_server();
|
||||
unless ( $server && $proto ) {
|
||||
maildebug "Suitable mail transport not found.";
|
||||
return store_message $data, undef;
|
||||
}
|
||||
my $info = "$hostname-$proto";
|
||||
|
||||
# Now we have an active server connection,
|
||||
# and we know what protocol to use.
|
||||
|
||||
# clean addresses.
|
||||
my ( @recips, %headers );
|
||||
$headers{$_} = $data->get( $_ ) foreach qw/ from to cc bcc /;
|
||||
|
||||
$opts->{'from'} =
|
||||
( Mail::Address->parse( $data->get('from') ) )[0]->address()
|
||||
if $headers{'from'};
|
||||
|
||||
push @recips, map { $_->address() } Mail::Address->parse( $headers{'to'} ) if $headers{'to'};
|
||||
push @recips, map { $_->address() } Mail::Address->parse( $headers{'cc'} ) if $headers{'cc'};
|
||||
push @recips, map { $_->address() } Mail::Address->parse( $headers{'bcc'} ) if $headers{'bcc'};
|
||||
|
||||
unless (scalar @recips) {
|
||||
maildebug "No recipients to send to!";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# QMTP
|
||||
if ( $proto eq 'qmtp' ) {
|
||||
$server->recipient($_) foreach @recips;
|
||||
$server->sender( $opts->{'from'} );
|
||||
$server->message($msg);
|
||||
|
||||
# send!
|
||||
my $response = $server->send() or return store_message $data, $info;
|
||||
foreach ( keys %$response ) {
|
||||
return store_message $data, $info
|
||||
if $response->{$_} !~ /success/;
|
||||
}
|
||||
$server->disconnect();
|
||||
}
|
||||
|
||||
# SMTP
|
||||
if ( $proto eq 'smtp' ) {
|
||||
|
||||
$server->mail( $opts->{'from'} );
|
||||
|
||||
# this would only fail on denied relay access
|
||||
# or somesuch.
|
||||
return store_message $data, $info unless
|
||||
$server->to( join ', ', @recips );
|
||||
|
||||
$server->data();
|
||||
$server->datasend($msg);
|
||||
$server->dataend();
|
||||
|
||||
$server->quit;
|
||||
}
|
||||
|
||||
# DMTP (Danga Mail Transfer Protocol)
|
||||
# (slated for removal if our QMTP stuff is worry-free.)
|
||||
if ( $proto eq 'dmtp' ) {
|
||||
|
||||
my $len = length $msg;
|
||||
my $env = $opts->{'from'};
|
||||
|
||||
$server->print("Content-Length: $len\r\n");
|
||||
$server->print("Envelope-Sender: $env\r\n\r\n$msg");
|
||||
|
||||
return store_message $data, $info
|
||||
unless $server->getline() =~ /^OK/;
|
||||
}
|
||||
|
||||
# system mailer
|
||||
if ( $proto eq 'sendmail' ) {
|
||||
MIME::Lite->send( 'sendmail', $hostname );
|
||||
unless ( $data->send() ) {
|
||||
maildebug "Unable to send via system mailer!";
|
||||
return store_message $data, 'sendmail';
|
||||
}
|
||||
}
|
||||
|
||||
report( $data, $time, $info, $async_caller );
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub report
|
||||
{
|
||||
my ( $data, $time, $info, $async_caller ) = @_;
|
||||
|
||||
# report deliveries
|
||||
my $notes = sprintf(
|
||||
"Direct mail send to %s succeeded: %s",
|
||||
$data->get('to') ||
|
||||
$data->get('cc') ||
|
||||
$data->get('bcc'), $data->get('subject')
|
||||
);
|
||||
maildebug $notes;
|
||||
|
||||
LJ::blocking_report(
|
||||
$info, 'send_mail',
|
||||
tv_interval( $time ), $notes
|
||||
)
|
||||
unless $async_caller;
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# locate a network server,
|
||||
# return (serverobj, protocol, hostname)
|
||||
sub find_server
|
||||
{
|
||||
# operate on a copy of the server list.
|
||||
my @objects = @LJ::MAIL_TRANSPORTS;
|
||||
|
||||
# backwards compatibility with earlier ljconfig.
|
||||
unless (@objects) {
|
||||
push @objects, [ 'sendmail', $LJ::SENDMAIL, 0 ] if $LJ::SENDMAIL;
|
||||
push @objects, [ 'smtp', $LJ::SMTP_SERVER, 0 ] if $LJ::SMTP_SERVER;
|
||||
push @objects, [ 'dmtp', $LJ::DMTP_SERVER, 1 ] if $LJ::DMTP_SERVER;
|
||||
}
|
||||
|
||||
my ( $server, $proto, $hostname );
|
||||
|
||||
while ( @objects && !$proto ) {
|
||||
my $item = get_slice(@objects);
|
||||
my $select = $objects[$item];
|
||||
|
||||
maildebug "Trying server $select->[1] ($select->[0])...";
|
||||
|
||||
# check service connectivity
|
||||
|
||||
# QMTP
|
||||
if ( $select->[0] eq 'qmtp' ) {
|
||||
eval 'use Net::QMTP';
|
||||
if ($@) {
|
||||
maildebug "Net::QMTP not installed?";
|
||||
splice @objects, $item, 1;
|
||||
next;
|
||||
}
|
||||
|
||||
eval {
|
||||
$server = Net::QMTP->new( $select->[1], ConnectTimeout => 10 );
|
||||
};
|
||||
}
|
||||
|
||||
# SMTP
|
||||
elsif ( $select->[0] eq 'smtp' ) {
|
||||
eval 'use Net::SMTP';
|
||||
if ($@) {
|
||||
maildebug "Net::SMTP not installed?";
|
||||
splice @objects, $item, 1;
|
||||
next;
|
||||
}
|
||||
|
||||
eval { $server = Net::SMTP->new( $select->[1], Timeout => 10 ); };
|
||||
}
|
||||
|
||||
# DMTP
|
||||
elsif ( $select->[0] eq 'dmtp' ) {
|
||||
my $host = $select->[1];
|
||||
my $port = $host =~ s/:(\d+)$// ? $1 : 7005;
|
||||
|
||||
$server = IO::Socket::INET->new(
|
||||
PeerAddr => $host,
|
||||
PeerPort => $port,
|
||||
Proto => 'tcp'
|
||||
);
|
||||
}
|
||||
|
||||
# system sendmail binary
|
||||
elsif ( $select->[0] eq 'sendmail' ) {
|
||||
my $sendmail = $1 if $select->[1] =~ /(\S+)/;
|
||||
$server = $sendmail if -e $sendmail && -x _;
|
||||
}
|
||||
|
||||
else {
|
||||
maildebug "Unknown mail protocol";
|
||||
splice @objects, $item, 1;
|
||||
next;
|
||||
}
|
||||
|
||||
# do we have a server connection?
|
||||
# if not, remove from our selection pool and try again.
|
||||
if ( ! $server ) {
|
||||
maildebug "Could not connect";
|
||||
splice @objects, $item, 1;
|
||||
}
|
||||
else {
|
||||
maildebug "Connected";
|
||||
( $proto, $hostname ) = ( $select->[0], $select->[1] );
|
||||
}
|
||||
}
|
||||
|
||||
return ( $server, $proto, $hostname );
|
||||
}
|
||||
|
||||
# return a ready to stringify MIME::Lite object.
|
||||
sub build_message
|
||||
{
|
||||
my $opts = shift;
|
||||
|
||||
my $body = $opts->{'wrap'} ?
|
||||
Text::Wrap::wrap( '', '', $opts->{'body'} ) :
|
||||
$opts->{'body'};
|
||||
|
||||
my $to = Mail::Address->new( $opts->{'toname'}, $opts->{'to'} );
|
||||
my $from = Mail::Address->new( $opts->{'fromname'}, $opts->{'from'} );
|
||||
|
||||
my $msg = MIME::Lite->new
|
||||
(
|
||||
To => $to->format(),
|
||||
From => $from->format(),
|
||||
Cc => $opts->{'cc'} || '',
|
||||
Bcc => $opts->{'bcc'} || '',
|
||||
Data => "$body\n",
|
||||
Subject => $opts->{'subject'},
|
||||
);
|
||||
return unless $msg;
|
||||
|
||||
$msg->add(%{ $opts->{'headers'} }) if ref $opts->{'headers'};
|
||||
|
||||
$msg->attr("content-type.charset" => $opts->{'charset'})
|
||||
if $opts->{'charset'} &&
|
||||
! (LJ::is_ascii($opts->{'body'}) &&
|
||||
LJ::is_ascii($opts->{'subject'}));
|
||||
|
||||
return $msg;
|
||||
}
|
||||
|
||||
# return a weighted random slice from an array.
|
||||
sub get_slice
|
||||
{
|
||||
my @objects = @_;
|
||||
|
||||
# Find cumulative values between weights, and in total.
|
||||
my (@csums, $cumulative_sum);
|
||||
@csums = map { $cumulative_sum += abs $_->[2] } @objects;
|
||||
|
||||
# *nothing* has weight? (all zeros?) just choose one.
|
||||
# same thing as equal weights.
|
||||
return int rand scalar @objects unless $cumulative_sum;
|
||||
|
||||
# Get a random number that will be compared to
|
||||
# the 'window' of probability for quotes.
|
||||
my $rand = rand $cumulative_sum;
|
||||
|
||||
# Create number ranges between each cumulative value,
|
||||
# and check the random number to see if it falls within
|
||||
# the weighted 'window size'.
|
||||
# Remember the array slice for matching the original object to.
|
||||
my $lastval = 0;
|
||||
my $slice = 0;
|
||||
foreach (@csums) {
|
||||
last if $rand >= $lastval && $rand <= $_;
|
||||
$slice++;
|
||||
$lastval = $_;
|
||||
}
|
||||
|
||||
return $slice;
|
||||
}
|
||||
|
||||
sub store_message (%$$)
|
||||
{
|
||||
my ( $data, $type ) = @_;
|
||||
$type ||= 'none';
|
||||
|
||||
maildebug "Storing message for retry.";
|
||||
my $time = [ gettimeofday() ];
|
||||
|
||||
# try this on each cluster
|
||||
my $frozen = Storable::freeze($data);
|
||||
my $rval = LJ::do_to_cluster(
|
||||
sub {
|
||||
# first parameter is cluster id
|
||||
return LJ::cmd_buffer_add( shift(@_), 0, 'send_mail', $frozen );
|
||||
}
|
||||
);
|
||||
return undef unless $rval;
|
||||
|
||||
my $notes = sprintf(
|
||||
"Queued mail send to %s %s: %s",
|
||||
$data->get('to'), $rval ? "succeeded" : "failed",
|
||||
$data->get('subject')
|
||||
);
|
||||
maildebug $notes;
|
||||
|
||||
LJ::blocking_report(
|
||||
$type, 'send_mail',
|
||||
tv_interval($time), $notes
|
||||
);
|
||||
|
||||
# we only attempt to store the message
|
||||
# on delivery failure. if we're here, something
|
||||
# failed, so always return false.
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub maildebug ($)
|
||||
{
|
||||
return unless $LJ::EMAIL_OUTGOING_DEBUG;
|
||||
print STDERR "ljmail: " . shift() . "\n";
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
543
livejournal/cgi-bin/ljmemories.pl
Executable file
543
livejournal/cgi-bin/ljmemories.pl
Executable file
@@ -0,0 +1,543 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
package LJ::Memories;
|
||||
use strict;
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::count
|
||||
# class: web
|
||||
# des: Returns the number of memories that a user has.
|
||||
# args: uuobj
|
||||
# des-uuobj: Userid or user object to count memories of.
|
||||
# returns: Some number; undef on error.
|
||||
# </LJFUNC>
|
||||
sub count {
|
||||
my $u = shift;
|
||||
$u = LJ::want_user($u);
|
||||
return undef unless $u;
|
||||
|
||||
# check memcache first
|
||||
my $count = LJ::MemCache::get([$u->{userid}, "memct:$u->{userid}"]);
|
||||
return $count if $count;
|
||||
|
||||
# now count
|
||||
if ($u->{dversion} > 5) {
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
$count = $dbcr->selectrow_array('SELECT COUNT(*) FROM memorable2 WHERE userid = ?',
|
||||
undef, $u->{userid});
|
||||
return undef if $dbcr->err;
|
||||
} else {
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$count = $dbh->selectrow_array('SELECT COUNT(*) FROM memorable WHERE userid = ?',
|
||||
undef, $u->{userid});
|
||||
return undef if $dbh->err;
|
||||
}
|
||||
$count += 0;
|
||||
|
||||
# now put in memcache and return it
|
||||
LJ::MemCache::set([$u->{userid}, "memct:$u->{userid}"], $count, 43200); # 12 hours
|
||||
return $count;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::create
|
||||
# class: web
|
||||
# des: Create a new memory for a user.
|
||||
# args: uuobj, opts, kwids?
|
||||
# des-uuobj: User id or user object to insert memory for.
|
||||
# des-opts: Hashref of options that define the memory; keys = journalid, ditemid, des, security
|
||||
# des-kwids: Optional; arrayref of keyword ids to categorize this memory under
|
||||
# returns: 1 on success, undef on error
|
||||
# </LJFUNC>
|
||||
sub create {
|
||||
my ($u, $opts, $kwids) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
return undef unless $u && %{$opts || {}};
|
||||
|
||||
# make sure we got enough options
|
||||
my ($userid, $journalid, $ditemid, $des, $security) =
|
||||
($u->{userid}, map { $opts->{$_} } qw(journalid ditemid des security));
|
||||
$userid += 0;
|
||||
$journalid += 0;
|
||||
$ditemid += 0;
|
||||
$security ||= 'public';
|
||||
$kwids ||= [ LJ::get_keyword_id($u, '*') ]; # * means no category
|
||||
$des = LJ::trim($des);
|
||||
return undef unless $userid && $journalid && $ditemid && $des && $security && @$kwids;
|
||||
return undef unless $security =~ /^(?:public|friends|private)$/;
|
||||
|
||||
# we have valid data, now let's insert it
|
||||
if ($u->{dversion} > 5) {
|
||||
return undef unless $u->writer;
|
||||
|
||||
# allocate memory id to use
|
||||
my $memid = LJ::alloc_user_counter($u, 'R');
|
||||
return undef unless $memid;
|
||||
|
||||
# insert main memory
|
||||
$u->do("INSERT INTO memorable2 (userid, memid, journalid, ditemid, des, security) " .
|
||||
"VALUES (?, ?, ?, ?, ?, ?)", undef, $userid, $memid, $journalid, $ditemid, $des, $security);
|
||||
return undef if $u->err;
|
||||
|
||||
# insert keywords
|
||||
my $val = join ',', map { "($u->{userid}, $memid, $_)" } @$kwids;
|
||||
$u->do("REPLACE INTO memkeyword2 (userid, memid, kwid) VALUES $val");
|
||||
|
||||
} else {
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return undef unless $dbh;
|
||||
|
||||
# insert main memory
|
||||
$dbh->do("INSERT INTO memorable (userid, journalid, jitemid, des, security) " .
|
||||
"VALUES (?, ?, ?, ?, ?)", undef, $userid, $journalid, $ditemid, $des, $security);
|
||||
return undef if $dbh->err;
|
||||
|
||||
# insert keywords
|
||||
my $memid = $dbh->{mysql_insertid}+0;
|
||||
my $val = join ',', map { "($memid, $_)" } @$kwids;
|
||||
$dbh->do("REPLACE INTO memkeyword (memid, kwid) VALUES $val");
|
||||
}
|
||||
|
||||
# clear out memcache
|
||||
LJ::MemCache::delete([$u->{userid}, "memct:$u->{userid}"]);
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::delete_by_id
|
||||
# class: web
|
||||
# des: Deletes a bunch of memories by memid.
|
||||
# args: uuboj, memids
|
||||
# des-uuobj: User id or user object to delete memories of.
|
||||
# des-memids: Arrayref of memids.
|
||||
# returns: 1 on success; undef on error.
|
||||
# </LJFUNC>
|
||||
sub delete_by_id {
|
||||
my ($u, $memids) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$memids = [ $memids ] if $memids && !ref $memids; # so they can just pass a single thing...
|
||||
return undef unless $u && @{$memids || []};
|
||||
|
||||
# setup
|
||||
my ($db, $table) = $u->{dversion} > 5 ?
|
||||
($u, '2') :
|
||||
(LJ::get_db_writer(), '');
|
||||
|
||||
# if dversion 5, verify the ids
|
||||
my $in = join ',', map { $_+0 } @$memids;
|
||||
if ($u->{dversion} == 5) {
|
||||
$memids = $db->selectcol_arrayref("SELECT memid FROM memorable WHERE userid = ? AND memid IN ($in)",
|
||||
undef, $u->{userid});
|
||||
return undef if $db->err;
|
||||
return 1 unless @{$memids || []}; # if we got nothing, pretend success
|
||||
$in = join ',', map { $_+0 } @$memids;
|
||||
}
|
||||
|
||||
# delete actual memory
|
||||
$db->do("DELETE FROM memorable$table WHERE userid = ? AND memid IN ($in)", undef, $u->{userid});
|
||||
return undef if $db->err;
|
||||
|
||||
# delete keyword associations
|
||||
my $euser = $u->{dversion} > 5 ? "userid = $u->{userid} AND" : '';
|
||||
$db->do("DELETE FROM memkeyword$table WHERE $euser memid IN ($in)");
|
||||
|
||||
# delete cache of count
|
||||
LJ::MemCache::delete([$u->{userid}, "memct:$u->{userid}"]);
|
||||
|
||||
# success at this point, since the first delete succeeded
|
||||
return 1;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_keyword_counts
|
||||
# class: web
|
||||
# des: Get a list of keywords and the counts for memories, showing how many memories are under
|
||||
# each keyword.
|
||||
# args: uuobj, opts?
|
||||
# des-uuobj: User id or object of user.
|
||||
# des-opts: Optional; hashref passed to _memory_getter, suggested keys are security and filter
|
||||
# if you want to get only certain memories in the keyword list
|
||||
# returns: Hashref { kwid => count }; undef on error
|
||||
# </LJFUNC>
|
||||
sub get_keyword_counts {
|
||||
my ($u, $opts) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
return undef unless $u;
|
||||
|
||||
# get all of the user's memories that fit the filtering
|
||||
my $memories = LJ::Memories::get_by_user($u, { %{$opts || {}}, notext => 1 });
|
||||
return undef unless defined $memories; # error case
|
||||
return {} unless %$memories; # just no memories case
|
||||
my @memids = map { $_+0 } keys %$memories;
|
||||
|
||||
# now let's get the keywords these memories use
|
||||
my $in = join ',', @memids;
|
||||
my $kwids;
|
||||
if ($u->{dversion} > 5) {
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
$kwids = $dbcr->selectcol_arrayref("SELECT kwid FROM memkeyword2 WHERE userid = ? AND memid IN ($in)",
|
||||
undef, $u->{userid});
|
||||
return undef if $dbcr->err;
|
||||
} else {
|
||||
my $dbr = LJ::get_db_reader();
|
||||
$kwids = $dbr->selectcol_arrayref("SELECT kwid FROM memkeyword WHERE memid IN ($in)");
|
||||
return undef if $dbr->err;
|
||||
}
|
||||
|
||||
# and now combine them
|
||||
my %res;
|
||||
$res{$_}++ foreach @$kwids;
|
||||
|
||||
# done, return
|
||||
return \%res;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_keywordids
|
||||
# class: web
|
||||
# des: Get all keyword ids a user has used for a certain memory.
|
||||
# args: uuobj, memid
|
||||
# des-uuobj: User id or user object to check memory of.
|
||||
# des-memid: Memory id to get keyword ids for.
|
||||
# returns: Arrayref of keywordids; undef on error.
|
||||
# </LJFUNC>
|
||||
sub get_keywordids {
|
||||
my ($u, $memid) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$memid += 0;
|
||||
return undef unless $u && $memid;
|
||||
|
||||
# definitive reader/master because this function is usually called when
|
||||
# someone is on an edit page.
|
||||
my $kwids;
|
||||
if ($u->{dversion} > 5) {
|
||||
my $dbcr = LJ::get_cluster_def_reader($u);
|
||||
$kwids = $dbcr->selectcol_arrayref('SELECT kwid FROM memkeyword2 WHERE userid = ? AND memid = ?',
|
||||
undef, $u->{userid}, $memid);
|
||||
return undef if $dbcr->err;
|
||||
|
||||
} else {
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$kwids = $dbh->selectcol_arrayref('SELECT kwid FROM memkeyword WHERE memid = ?', undef, $memid);
|
||||
return undef if $dbh->err;
|
||||
}
|
||||
|
||||
# all good, return
|
||||
return $kwids;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::update_memory
|
||||
# class: web
|
||||
# des: Updates the description and security of a memory.
|
||||
# args: uuobj, memid, updopts
|
||||
# des-uuobj: User id or user object to update memory of.
|
||||
# des-memid: Memory id to update.
|
||||
# des-updopts: Update options, hashref with keys 'des' and 'security', values being what
|
||||
# you want to update the memory to have.
|
||||
# returns: 1 on success, undef on error
|
||||
# </LJFUNC>
|
||||
sub update_memory {
|
||||
my ($u, $memid, $upd) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$memid += 0;
|
||||
return unless $u && $memid && %{$upd || {}};
|
||||
|
||||
# get database handle
|
||||
my ($db, $table) = $u->{dversion} > 5 ?
|
||||
($u, '2') :
|
||||
(LJ::get_db_writer(), '');
|
||||
return undef unless $db;
|
||||
|
||||
# construct update lines... only valid things we can update are des and security
|
||||
my @updates;
|
||||
foreach my $what (keys %$upd) {
|
||||
next unless $what =~ m/^(?:des|security)$/;
|
||||
push @updates, "$what=" . $db->quote($upd->{$what});
|
||||
}
|
||||
my $updstr = join ',', @updates;
|
||||
|
||||
# now perform update
|
||||
$db->do("UPDATE memorable$table SET $updstr WHERE userid = ? AND memid = ?",
|
||||
undef, $u->{userid}, $memid);
|
||||
return undef if $db->err;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# this messy function gets memories based on an options hashref. this is an
|
||||
# API API and isn't recommended for use by BML etc... add to the API and have
|
||||
# API functions call this if needed.
|
||||
#
|
||||
# options in $opts hashref:
|
||||
# security => [ 'public', 'private', ... ], or some subset thereof
|
||||
# filter => 'all' | 'own' | 'other', filter -- defaults to all
|
||||
# notext => 1/0, if on, do not load/return description field
|
||||
# byid => [ 1, 2, 3, ... ], load memories by *memid*
|
||||
# byditemid => [ 1, 2, 3 ... ], load by ditemid (MUST specify journalid too)
|
||||
# journalid => 1, find memories by ditemid (see above) for this journalid
|
||||
#
|
||||
# note that all memories are loaded from a single user, specified as the first
|
||||
# parameter. does not let you load memories from more than one user.
|
||||
sub _memory_getter {
|
||||
my ($u, $opts) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
$opts ||= {};
|
||||
return undef unless $u;
|
||||
|
||||
# various selection options
|
||||
my $secwhere = '';
|
||||
if (@{$opts->{security} || []}) {
|
||||
my @secs;
|
||||
foreach my $sec (@{$opts->{security}}) {
|
||||
push @secs, $sec
|
||||
if $sec =~ /^(?:public|friends|private)$/;
|
||||
}
|
||||
$secwhere = "AND security IN (" . join(',', map { "'$_'" } @secs) . ")";
|
||||
}
|
||||
my $extrawhere;
|
||||
if ($opts->{filter} eq 'all') { $extrawhere = ''; }
|
||||
elsif ($opts->{filter} eq 'own') { $extrawhere = "AND journalid = $u->{userid}"; }
|
||||
elsif ($opts->{filter} eq 'other') { $extrawhere = "AND journalid <> $u->{userid}"; }
|
||||
my $des = $opts->{notext} ? '' : 'des, ';
|
||||
my $selwhere;
|
||||
if (@{$opts->{byid} || []}) {
|
||||
# they want to get some explicit memories by memid
|
||||
my $in = join ',', map { $_+0 } @{$opts->{byid}};
|
||||
$selwhere = "AND memid IN ($in)";
|
||||
} elsif ($opts->{byditemid} && $opts->{journalid}) {
|
||||
# or, they want to see if a memory exists for a particular item
|
||||
my $selitemid = $u->{dversion} > 5 ? "ditemid" : "jitemid";
|
||||
$opts->{byditemid} += 0;
|
||||
$opts->{journalid} += 0;
|
||||
$selwhere = "AND journalid = $opts->{journalid} AND $selitemid = $opts->{byditemid}";
|
||||
} elsif ($opts->{byditemid}) {
|
||||
# get memory, OLD STYLE so journalid is 0
|
||||
my $selitemid = $u->{dversion} > 5 ? "ditemid" : "jitemid";
|
||||
$opts->{byditemid} += 0;
|
||||
$selwhere = "AND journalid = 0 AND $selitemid = $opts->{byditemid}";
|
||||
}
|
||||
|
||||
# load up memories into hashref
|
||||
my (%memories, $sth);
|
||||
if ($u->{dversion} > 5) {
|
||||
# new clustered memories
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
$sth = $dbcr->prepare("SELECT memid, userid, journalid, ditemid, $des security " .
|
||||
"FROM memorable2 WHERE userid = ? $selwhere $secwhere $extrawhere");
|
||||
} else {
|
||||
# old global memories
|
||||
my $dbr = LJ::get_db_reader();
|
||||
$sth = $dbr->prepare("SELECT memid, userid, journalid, jitemid, $des security " .
|
||||
"FROM memorable WHERE userid = ? $selwhere $secwhere $extrawhere");
|
||||
}
|
||||
|
||||
# general execution and fetching for return
|
||||
$sth->execute($u->{userid});
|
||||
return undef if $sth->err;
|
||||
while ($_ = $sth->fetchrow_hashref()) {
|
||||
# we have to do this ditemid->jitemid to make old code work,
|
||||
# but this can probably go away at some point...
|
||||
if (defined $_->{ditemid}) {
|
||||
$_->{jitemid} = $_->{ditemid};
|
||||
} else {
|
||||
$_->{ditemid} = $_->{jitemid};
|
||||
}
|
||||
$memories{$_->{memid}} = $_;
|
||||
}
|
||||
return \%memories;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_by_id
|
||||
# class: web
|
||||
# des: Get memories given some memory ids.
|
||||
# args: uuobj, memids
|
||||
# des-uuobj: User id or user object to get memories for.
|
||||
# des-memids: The rest of the memory ids. Array. (Pass them in as individual parameters...)
|
||||
# returns: Hashref of memories with keys being memid; undef on error.
|
||||
# </LJFUNC>
|
||||
sub get_by_id {
|
||||
my $u = shift;
|
||||
return {} unless @_; # make sure they gave us some ids
|
||||
|
||||
# pass to getter to get by id
|
||||
return LJ::Memories::_memory_getter($u, { byid => [ map { $_+0 } @_ ] });
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_by_ditemid
|
||||
# class: web
|
||||
# des: Get memory for a given journal entry.
|
||||
# args: uuobj, journalid, ditemid
|
||||
# des-uuobj: User id or user object to get memories for.
|
||||
# des-journalid: Userid for journal entry is in.
|
||||
# des-ditemid: Display itemid of entry.
|
||||
# returns: Hashref of individual memory.
|
||||
# </LJFUNC>
|
||||
sub get_by_ditemid {
|
||||
my ($u, $jid, $ditemid) = @_;
|
||||
$jid += 0;
|
||||
$ditemid += 0;
|
||||
return undef unless $ditemid; # _memory_getter checks $u and $jid isn't necessary
|
||||
# because this might be an old-style memory
|
||||
|
||||
# pass to getter with appropriate options
|
||||
my $memhash = LJ::Memories::_memory_getter($u, { byditemid => $ditemid, journalid => $jid });
|
||||
return undef unless %{$memhash || {}};
|
||||
return [ values %$memhash ]->[0]; # ugly
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_by_user
|
||||
# class: web
|
||||
# des: Get memories given a user.
|
||||
# args: uuobj
|
||||
# des-uuobj: User id or user object to get memories for.
|
||||
# returns: Hashref of memories with keys being memid; undef on error.
|
||||
# </LJFUNC>
|
||||
sub get_by_user {
|
||||
# simply passes through to _memory_getter
|
||||
return LJ::Memories::_memory_getter(@_);
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_by_keyword
|
||||
# class: web
|
||||
# des: Get memories given a user and a keyword/keyword id.
|
||||
# args: uuobj, kwoid, opts
|
||||
# des-uuobj: User id or user object to get memories for.
|
||||
# des-kwoid: Keyword (string) or keyword id (number) to get memories for.
|
||||
# des-opts: Hashref of extra options to pass through to memory getter. Suggested options
|
||||
# are filter and security for limiting the memories returned.
|
||||
# returns: Hashref of memories with keys being memid; undef on error.
|
||||
# </LJFUNC>
|
||||
sub get_by_keyword {
|
||||
my ($u, $kwoid, $opts) = @_;
|
||||
$u = LJ::want_user($u);
|
||||
my $kwid = $kwoid+0;
|
||||
my $kw = defined $kwoid && !$kwid ? $kwoid : undef;
|
||||
return undef unless $u && ($kwid || defined $kw);
|
||||
|
||||
# two entirely separate codepaths, depending on the user's dversion.
|
||||
my $memids;
|
||||
if ($u->{dversion} > 5) {
|
||||
# the smart way
|
||||
my $dbcr = LJ::get_cluster_reader($u);
|
||||
return undef unless $dbcr;
|
||||
|
||||
# get keyword id if we don't have it
|
||||
if (defined $kw) {
|
||||
$kwid = $dbcr->selectrow_array('SELECT kwid FROM userkeywords WHERE userid = ? AND keyword = ?',
|
||||
undef, $u->{userid}, $kw)+0;
|
||||
}
|
||||
return undef unless $kwid;
|
||||
|
||||
# now get the actual memory ids
|
||||
$memids = $dbcr->selectcol_arrayref('SELECT memid FROM memkeyword2 WHERE userid = ? AND kwid = ?',
|
||||
undef, $u->{userid}, $kwid);
|
||||
return undef if $dbcr->err;
|
||||
} else {
|
||||
# the dumb way
|
||||
my $dbr = LJ::get_db_reader();
|
||||
return undef unless $dbr;
|
||||
|
||||
# get keyword id if we don't have it
|
||||
if (defined $kw) {
|
||||
$kwid = $dbr->selectrow_array('SELECT kwid FROM keywords WHERE keyword = ?', undef, $kw)+0;
|
||||
}
|
||||
return undef unless $kwid;
|
||||
|
||||
# now get memory ids. this has to join. :(
|
||||
$memids = $dbr->selectcol_arrayref('SELECT m.memid FROM memorable m, memkeyword mk ' .
|
||||
'WHERE m.userid = ? AND mk.memid = m.memid AND mk.kwid = ?',
|
||||
undef, $u->{userid}, $kwid);
|
||||
return undef if $dbr->err;
|
||||
}
|
||||
|
||||
# standard in both cases
|
||||
return {} unless @{$memids || []};
|
||||
return LJ::Memories::_memory_getter($u, { %{$opts || {}}, byid => $memids });
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::get_keywords
|
||||
# class:
|
||||
# des: Retrieves keyword/keyids without big joins, returns a hashref.
|
||||
# args: uobj
|
||||
# des-uobj: User object to get keyword pairs for.
|
||||
# returns: Hashref; { keywordid => keyword }
|
||||
# </LJFUNC>
|
||||
sub get_keywords {
|
||||
my $u = shift;
|
||||
$u = LJ::want_user($u);
|
||||
return undef unless $u;
|
||||
|
||||
my $use_reader = 0;
|
||||
my $memkey = [$u->{userid},"memkwid:$u->{userid}"];
|
||||
my $ret = LJ::MemCache::get($memkey);
|
||||
return $ret if defined $ret;
|
||||
$ret = {};
|
||||
|
||||
if ($u->{dversion} > 5) {
|
||||
# new style clustered code
|
||||
my $dbcm = LJ::get_cluster_def_reader($u);
|
||||
unless ($dbcm) {
|
||||
$use_reader = 1;
|
||||
$dbcm = LJ::get_cluster_reader($u);
|
||||
}
|
||||
my $ids = $dbcm->selectcol_arrayref('SELECT DISTINCT kwid FROM memkeyword2 WHERE userid = ?',
|
||||
undef, $u->{userid});
|
||||
if (@{$ids || []}) {
|
||||
my $in = join ",", @$ids;
|
||||
my $rows = $dbcm->selectall_arrayref('SELECT kwid, keyword FROM userkeywords ' .
|
||||
"WHERE userid = ? AND kwid IN ($in)", undef, $u->{userid});
|
||||
$ret->{$_->[0]} = $_->[1] foreach @{$rows || []};
|
||||
}
|
||||
|
||||
} else {
|
||||
# old style code using global
|
||||
my $dbh = LJ::get_db_writer();
|
||||
unless ($dbh) {
|
||||
$use_reader = 1;
|
||||
$dbh = LJ::get_db_reader();
|
||||
}
|
||||
my $sth = $dbh->prepare("SELECT DISTINCT mk.kwid ".
|
||||
"FROM ".
|
||||
" memorable m FORCE INDEX (uniq),".
|
||||
" memkeyword mk ".
|
||||
"WHERE mk.memid=m.memid AND m.userid=?");
|
||||
$sth->execute($u->{userid});
|
||||
my @ids;
|
||||
push @ids, $_ while $_ = $sth->fetchrow_array;
|
||||
|
||||
if (@ids) {
|
||||
my $in = join(",", @ids);
|
||||
$sth = $dbh->prepare("SELECT kwid, keyword FROM keywords WHERE kwid IN ($in)");
|
||||
$sth->execute;
|
||||
|
||||
while (my ($id,$kw) = $sth->fetchrow_array) {
|
||||
$ret->{$id} = $kw;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
LJ::MemCache::set($memkey, $ret, 86400) unless $use_reader;
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::Memories::updated_keywords
|
||||
# class: web
|
||||
# des: Deletes memcached keyword data.
|
||||
# args: uobj
|
||||
# des-uobj: User object to clear memcached keywords for.
|
||||
# returns: undef.
|
||||
# </LJFUNC>
|
||||
sub updated_keywords {
|
||||
my $u = shift;
|
||||
return unless ref $u;
|
||||
LJ::MemCache::delete([$u->{userid},"memkwid:$u->{userid}"]);
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
952
livejournal/cgi-bin/ljpoll.pl
Executable file
952
livejournal/cgi-bin/ljpoll.pl
Executable file
@@ -0,0 +1,952 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Poll;
|
||||
|
||||
use strict;
|
||||
use HTML::TokeParser ();
|
||||
|
||||
require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
|
||||
|
||||
sub clean_poll
|
||||
{
|
||||
my $ref = shift;
|
||||
if ($$ref !~ /[<>]/) {
|
||||
LJ::text_out($ref);
|
||||
return;
|
||||
}
|
||||
|
||||
my $poll_eat = [qw[head title style layer iframe applet object]];
|
||||
my $poll_allow = [qw[a b i u strong em img]];
|
||||
my $poll_remove = [qw[bgsound embed object caption link font]];
|
||||
|
||||
LJ::CleanHTML::clean($ref, {
|
||||
'wordlength' => 40,
|
||||
'addbreaks' => 0,
|
||||
'eat' => $poll_eat,
|
||||
'mode' => 'deny',
|
||||
'allow' => $poll_allow,
|
||||
'remove' => $poll_remove,
|
||||
});
|
||||
LJ::text_out($ref);
|
||||
}
|
||||
|
||||
|
||||
sub contains_new_poll
|
||||
{
|
||||
my $postref = shift;
|
||||
return ($$postref =~ /<lj-poll\b/i);
|
||||
}
|
||||
|
||||
sub parse
|
||||
{
|
||||
&LJ::nodb;
|
||||
my ($postref, $error, $iteminfo) = @_;
|
||||
|
||||
$iteminfo->{'posterid'} += 0;
|
||||
$iteminfo->{'journalid'} += 0;
|
||||
|
||||
my $newdata;
|
||||
|
||||
my $popen = 0;
|
||||
my %popts;
|
||||
|
||||
my $qopen = 0;
|
||||
my %qopts;
|
||||
|
||||
my $iopen = 0;
|
||||
my %iopts;
|
||||
|
||||
my @polls; # completed parsed polls
|
||||
|
||||
my $p = HTML::TokeParser->new($postref);
|
||||
|
||||
# if we're being called from mailgated, then we're not in web context and therefore
|
||||
# do not have any BML::ml functionality. detect this now and report errors in a
|
||||
# plaintext, non-translated form to be bounced via email.
|
||||
my $have_bml = eval { BML::ml() } || ! $@;
|
||||
|
||||
my $err = sub {
|
||||
# more than one element, either make a call to BML::ml
|
||||
# or build up a semi-useful error string from it
|
||||
if (@_ > 1) {
|
||||
if ($have_bml) {
|
||||
$$error = BML::ml(@_);
|
||||
return 0;
|
||||
}
|
||||
|
||||
$$error = shift() . ": ";
|
||||
while (my ($k, $v) = each %{$_[0]}) {
|
||||
$$error .= "$k=$v,";
|
||||
}
|
||||
chop $$error;
|
||||
return 0;
|
||||
}
|
||||
|
||||
# single element, either look up in %BML::ML or return verbatim
|
||||
$$error = $have_bml ? $BML::ML{$_[0]} : $_[0];
|
||||
return 0;
|
||||
};
|
||||
|
||||
while (my $token = $p->get_token)
|
||||
{
|
||||
my $type = $token->[0];
|
||||
my $append;
|
||||
|
||||
if ($type eq "S") # start tag
|
||||
{
|
||||
my $tag = $token->[1];
|
||||
my $opts = $token->[2];
|
||||
|
||||
######## Begin poll tag
|
||||
|
||||
if ($tag eq "lj-poll") {
|
||||
return $err->('poll.error.nested', { 'tag' => 'lj-poll' })
|
||||
if $popen;
|
||||
|
||||
$popen = 1;
|
||||
%popts = ();
|
||||
$popts{'questions'} = [];
|
||||
|
||||
$popts{'name'} = $opts->{'name'};
|
||||
$popts{'whovote'} = lc($opts->{'whovote'}) || "all";
|
||||
$popts{'whoview'} = lc($opts->{'whoview'}) || "all";
|
||||
|
||||
if ($popts{'whovote'} ne "all" &&
|
||||
$popts{'whovote'} ne "friends")
|
||||
{
|
||||
return $err->('poll.error.whovote');
|
||||
}
|
||||
if ($popts{'whoview'} ne "all" &&
|
||||
$popts{'whoview'} ne "friends" &&
|
||||
$popts{'whoview'} ne "none")
|
||||
{
|
||||
return $err->('poll.error.whoview');
|
||||
}
|
||||
}
|
||||
|
||||
######## Begin poll question tag
|
||||
|
||||
elsif ($tag eq "lj-pq")
|
||||
{
|
||||
return $err->('poll.error.nested', { 'tag' => 'lj-pq' })
|
||||
if $qopen;
|
||||
|
||||
return $err->('poll.error.missingljpoll')
|
||||
unless $popen;
|
||||
|
||||
$qopen = 1;
|
||||
%qopts = ();
|
||||
$qopts{'items'} = [];
|
||||
|
||||
$qopts{'type'} = $opts->{'type'};
|
||||
if ($qopts{'type'} eq "text") {
|
||||
my $size = 35;
|
||||
my $max = 255;
|
||||
if (defined $opts->{'size'}) {
|
||||
if ($opts->{'size'} > 0 &&
|
||||
$opts->{'size'} <= 100)
|
||||
{
|
||||
$size = $opts->{'size'}+0;
|
||||
} else {
|
||||
return $err->('poll.error.badsize');
|
||||
}
|
||||
}
|
||||
if (defined $opts->{'maxlength'}) {
|
||||
if ($opts->{'maxlength'} > 0 &&
|
||||
$opts->{'maxlength'} <= 255)
|
||||
{
|
||||
$max = $opts->{'maxlength'}+0;
|
||||
} else {
|
||||
return $err->('poll.error.badmaxlength');
|
||||
}
|
||||
}
|
||||
|
||||
$qopts{'opts'} = "$size/$max";
|
||||
}
|
||||
if ($qopts{'type'} eq "scale")
|
||||
{
|
||||
my $from = 1;
|
||||
my $to = 10;
|
||||
my $by = 1;
|
||||
|
||||
if (defined $opts->{'from'}) {
|
||||
$from = int($opts->{'from'});
|
||||
}
|
||||
if (defined $opts->{'to'}) {
|
||||
$to = int($opts->{'to'});
|
||||
}
|
||||
if (defined $opts->{'by'}) {
|
||||
$by = int($opts->{'by'});
|
||||
}
|
||||
if ($by < 1) {
|
||||
return $err->('poll.error.scaleincrement');
|
||||
}
|
||||
if ($from >= $to) {
|
||||
return $err->('poll.error.scalelessto');
|
||||
}
|
||||
if ((($to-$from)/$by) > 20) {
|
||||
return $err->('poll.error.scaletoobig');
|
||||
}
|
||||
$qopts{'opts'} = "$from/$to/$by";
|
||||
}
|
||||
|
||||
$qopts{'type'} = lc($opts->{'type'}) || "text";
|
||||
|
||||
if ($qopts{'type'} ne "radio" &&
|
||||
$qopts{'type'} ne "check" &&
|
||||
$qopts{'type'} ne "drop" &&
|
||||
$qopts{'type'} ne "scale" &&
|
||||
$qopts{'type'} ne "text")
|
||||
{
|
||||
return $err->('poll.error.unknownpqtype');
|
||||
}
|
||||
|
||||
|
||||
}
|
||||
|
||||
######## Begin poll item tag
|
||||
|
||||
elsif ($tag eq "lj-pi")
|
||||
{
|
||||
if ($iopen) {
|
||||
return $err->('poll.error.nested', { 'tag' => 'lj-pi' });
|
||||
}
|
||||
if (! $qopen) {
|
||||
return $err->('poll.error.missingljpq');
|
||||
}
|
||||
if ($qopts{'type'} eq "text")
|
||||
{
|
||||
return $err->('poll.error.noitemstext');
|
||||
}
|
||||
|
||||
$iopen = 1;
|
||||
%iopts = ();
|
||||
}
|
||||
|
||||
#### not a special tag. dump it right back out.
|
||||
|
||||
else
|
||||
{
|
||||
$append .= "<$tag";
|
||||
foreach (keys %$opts) {
|
||||
$append .= " $_=\"$opts->{$_}\"";
|
||||
}
|
||||
$append .= ">";
|
||||
}
|
||||
}
|
||||
elsif ($type eq "E")
|
||||
{
|
||||
my $tag = $token->[1];
|
||||
|
||||
##### end POLL
|
||||
|
||||
if ($tag eq "lj-poll") {
|
||||
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-poll' })
|
||||
unless $popen;
|
||||
|
||||
$popen = 0;
|
||||
|
||||
return $err->('poll.error.noquestions')
|
||||
unless @{$popts{'questions'}};
|
||||
|
||||
$popts{'journalid'} = $iteminfo->{'journalid'};
|
||||
$popts{'posterid'} = $iteminfo->{'posterid'};
|
||||
|
||||
push @polls, { %popts };
|
||||
|
||||
$append .= "<lj-poll-placeholder>";
|
||||
}
|
||||
|
||||
##### end QUESTION
|
||||
|
||||
elsif ($tag eq "lj-pq") {
|
||||
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pq' })
|
||||
unless $qopen;
|
||||
|
||||
unless ($qopts{'type'} eq "scale" ||
|
||||
$qopts{'type'} eq "text" ||
|
||||
@{$qopts{'items'}})
|
||||
{
|
||||
return $err->('poll.error.noitems');
|
||||
}
|
||||
|
||||
$qopts{'qtext'} =~ s/^\s+//;
|
||||
$qopts{'qtext'} =~ s/\s+$//;
|
||||
my $len = length($qopts{'qtext'})
|
||||
or return $err->('poll.error.notext');
|
||||
|
||||
push @{$popts{'questions'}}, { %qopts };
|
||||
$qopen = 0;
|
||||
|
||||
}
|
||||
|
||||
##### end ITEM
|
||||
|
||||
elsif ($tag eq "lj-pi") {
|
||||
return $err->('poll.error.tagnotopen', { 'tag' => 'lj-pi' })
|
||||
unless $iopen;
|
||||
|
||||
$iopts{'item'} =~ s/^\s+//;
|
||||
$iopts{'item'} =~ s/\s+$//;
|
||||
|
||||
my $len = length($iopts{'item'});
|
||||
return $err->('poll.error.pitoolong', { 'len' => $len, })
|
||||
if $len > 255 || $len < 1;
|
||||
|
||||
push @{$qopts{'items'}}, { %iopts };
|
||||
$iopen = 0;
|
||||
}
|
||||
|
||||
###### not a special tag.
|
||||
|
||||
else
|
||||
{
|
||||
$append .= "</$tag>";
|
||||
}
|
||||
}
|
||||
elsif ($type eq "T" || $type eq "D")
|
||||
{
|
||||
$append = $token->[1];
|
||||
}
|
||||
elsif ($type eq "C") {
|
||||
# ignore comments
|
||||
}
|
||||
elsif ($type eq "PI") {
|
||||
$newdata .= "<?$token->[1]>";
|
||||
}
|
||||
else {
|
||||
$newdata .= "<!-- OTHER: " . $type . "-->\n";
|
||||
}
|
||||
|
||||
##### append stuff to the right place
|
||||
if (length($append))
|
||||
{
|
||||
if ($iopen) {
|
||||
$iopts{'item'} .= $append;
|
||||
}
|
||||
elsif ($qopen) {
|
||||
$qopts{'qtext'} .= $append;
|
||||
}
|
||||
elsif ($popen) {
|
||||
0; # do nothing.
|
||||
} else {
|
||||
$newdata .= $append;
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
if ($popen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-poll' }); }
|
||||
if ($qopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pq' }); }
|
||||
if ($iopen) { return $err->('poll.error.unlockedtag', { 'tag' => 'lj-pi' }); }
|
||||
|
||||
$$postref = $newdata;
|
||||
return @polls;
|
||||
}
|
||||
|
||||
# preview poll
|
||||
# -- accepts $poll hashref as found in the array returned by LJ::Poll::parse()
|
||||
sub preview {
|
||||
my $poll = shift;
|
||||
return unless ref $poll eq 'HASH';
|
||||
|
||||
my $ret = '';
|
||||
|
||||
$ret .= "<form action='#'>\n";
|
||||
$ret .= "<b>" . BML::ml('poll.pollnum', { 'num' => 'xxxx' }) . "</b>";
|
||||
if ($poll->{'name'}) {
|
||||
LJ::Poll::clean_poll(\$poll->{'name'});
|
||||
$ret .= " <i>$poll->{'name'}</i>";
|
||||
}
|
||||
$ret .= "<br />\n";
|
||||
$ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$poll->{whovote}}, 'whoview' => $BML::ML{'poll.security.'.$poll->{whoview}}, });
|
||||
|
||||
# iterate through all questions
|
||||
foreach my $q (@{$poll->{'questions'}}) {
|
||||
if ($q->{'qtext'}) {
|
||||
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||||
$ret .= "<p>$q->{'qtext'}</p>\n";
|
||||
}
|
||||
$ret .= "<div style='margin: 10px 0 10px 40px'>";
|
||||
|
||||
# text questions
|
||||
if ($q->{'type'} eq 'text') {
|
||||
my ($size, $max) = split(m!/!, $q->{'opts'});
|
||||
$ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max });
|
||||
|
||||
# scale questions
|
||||
} elsif ($q->{'type'} eq 'scale') {
|
||||
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||||
$by ||= 1;
|
||||
my $count = int(($to-$from)/$by) + 1;
|
||||
my $do_radios = ($count <= 11);
|
||||
|
||||
# few opts, display radios
|
||||
if ($do_radios) {
|
||||
$ret .= "<table><tr valign='top' align='center'>\n";
|
||||
for (my $at = $from; $at <= $to; $at += $by) {
|
||||
$ret .= "<td>" . LJ::html_check({ 'type' => 'radio' }) . "<br />$at</td>\n";
|
||||
}
|
||||
$ret .= "</tr></table>\n";
|
||||
|
||||
# many opts, display select
|
||||
} else {
|
||||
my @optlist = ();
|
||||
for (my $at = $from; $at <= $to; $at += $by) {
|
||||
push @optlist, ('', $at);
|
||||
}
|
||||
$ret .= LJ::html_select({}, @optlist);
|
||||
}
|
||||
|
||||
# questions with items
|
||||
} else {
|
||||
|
||||
# drop-down list
|
||||
if ($q->{'type'} eq 'drop') {
|
||||
my @optlist = ('', '');
|
||||
foreach my $it (@{$q->{'items'}}) {
|
||||
LJ::Poll::clean_poll(\$it->{'item'});
|
||||
push @optlist, ('', $it->{'item'});
|
||||
}
|
||||
$ret .= LJ::html_select({}, @optlist);
|
||||
|
||||
|
||||
# radio or checkbox
|
||||
} else {
|
||||
foreach my $it (@{$q->{'items'}}) {
|
||||
LJ::Poll::clean_poll(\$it->{'item'});
|
||||
$ret .= LJ::html_check({ 'type' => $q->{'type'} }) . "$it->{'item'}<br />\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
$ret .= "</div>\n";
|
||||
|
||||
}
|
||||
|
||||
$ret .= LJ::html_submit('', $BML::ML{'poll.submit'}, { 'disabled' => 1 }) . "\n";
|
||||
$ret .= "</form>";
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# note: $itemid is a $ditemid (display itemid, *256 + anum)
|
||||
sub register
|
||||
{
|
||||
&LJ::nodb;
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $post = shift;
|
||||
my $error = shift;
|
||||
my $itemid = shift;
|
||||
my @polls = @_;
|
||||
|
||||
foreach my $po (@polls)
|
||||
{
|
||||
my %popts = %$po;
|
||||
$popts{'itemid'} = $itemid+0;
|
||||
|
||||
#### CREATE THE POLL!
|
||||
|
||||
my $sth = $dbh->prepare("INSERT INTO poll (itemid, journalid, posterid, whovote, whoview, name) " .
|
||||
"VALUES (?, ?, ?, ?, ?, ?)");
|
||||
$sth->execute($itemid, $popts{'journalid'}, $popts{'posterid'},
|
||||
$popts{'whovote'}, $popts{'whoview'}, $popts{'name'});
|
||||
if ($dbh->err) {
|
||||
$$error = BML::ml('poll.dberror', { errmsg => $dbh->errstr });
|
||||
return 0;
|
||||
}
|
||||
my $pollid = $dbh->{'mysql_insertid'};
|
||||
|
||||
$$post =~ s/<lj-poll-placeholder>/<lj-poll-$pollid>/; # NOT global replace!
|
||||
|
||||
## start inserting poll questions
|
||||
my $qnum = 0;
|
||||
foreach my $q (@{$popts{'questions'}})
|
||||
{
|
||||
$qnum++;
|
||||
$sth = $dbh->prepare("INSERT INTO pollquestion (pollid, pollqid, sortorder, type, opts, qtext) " .
|
||||
"VALUES (?, ?, ?, ?, ?, ?)");
|
||||
$sth->execute($pollid, $qnum, $qnum, $q->{'type'}, $q->{'opts'}, $q->{'qtext'});
|
||||
if ($dbh->err) {
|
||||
$$error = BML::ml('poll.dberror.questions', { errmsg => $dbh->errstr });
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $pollqid = $dbh->{'mysql_insertid'};
|
||||
|
||||
## start inserting poll items
|
||||
my $inum = 0;
|
||||
foreach my $it (@{$q->{'items'}}) {
|
||||
$inum++;
|
||||
$dbh->do("INSERT INTO pollitem (pollid, pollqid, pollitid, sortorder, item) " .
|
||||
"VALUES (?, ?, ?, ?, ?)", undef, $pollid, $qnum, $inum, $inum, $it->{'item'});
|
||||
if ($dbh->err) {
|
||||
$$error = BML::ml('poll.dberror.items', { errmsg => $dbh->errstr });
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
## end inserting poll items
|
||||
|
||||
}
|
||||
## end inserting poll questions
|
||||
|
||||
} ### end while over all poles
|
||||
|
||||
}
|
||||
|
||||
sub show_polls
|
||||
{
|
||||
&LJ::nodb;
|
||||
my $itemid = shift;
|
||||
my $remote = shift;
|
||||
my $postref = shift;
|
||||
|
||||
$$postref =~ s/<lj-poll-(\d+)>/&show_poll($itemid, $remote, $1)/eg;
|
||||
}
|
||||
|
||||
sub show_poll
|
||||
{
|
||||
&LJ::nodb;
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $itemid = shift;
|
||||
my $remote = shift;
|
||||
my $pollid = shift;
|
||||
my $opts = shift; # hashref. {"mode" => results/enter/ans}
|
||||
my $sth;
|
||||
|
||||
my $mode = $opts->{'mode'};
|
||||
$pollid += 0;
|
||||
|
||||
my $po = $dbr->selectrow_hashref("SELECT * FROM poll WHERE pollid=?", undef, $pollid);
|
||||
return "<b>[" . BML::ml('poll.error.pollnotfound', { 'num' => $pollid }) . "]</b>" unless $po;
|
||||
return "<b>[$BML::ML{'poll.error.noentry'}]</b>"
|
||||
if $itemid && $po->{'itemid'} != $itemid;
|
||||
|
||||
my ($can_vote, $can_view) = find_security($po, $remote);
|
||||
|
||||
# update the mode if we need to
|
||||
$mode = 'results' unless $remote;
|
||||
if (!$mode && $remote) {
|
||||
my $time = $dbr->selectrow_array('SELECT datesubmit FROM pollsubmission '.
|
||||
'WHERE pollid=? AND userid=?', undef, $pollid, $remote->{userid});
|
||||
$mode = $time ? 'results' : $can_vote ? 'enter' : 'results';
|
||||
}
|
||||
|
||||
### load all the questions
|
||||
my @qs;
|
||||
$sth = $dbr->prepare('SELECT * FROM pollquestion WHERE pollid=?');
|
||||
$sth->execute($pollid);
|
||||
push @qs, $_ while $_ = $sth->fetchrow_hashref;
|
||||
@qs = sort { $a->{sortorder} <=> $b->{sortorder} } @qs;
|
||||
|
||||
### load all the items
|
||||
my %its;
|
||||
$sth = $dbr->prepare("SELECT pollqid, pollitid, item FROM pollitem WHERE pollid=? ORDER BY sortorder");
|
||||
$sth->execute($pollid);
|
||||
while (my ($qid, $itid, $item) = $sth->fetchrow_array) {
|
||||
push @{$its{$qid}}, [ $itid, $item ];
|
||||
}
|
||||
|
||||
# see if we have a hook for alternate poll contents
|
||||
my $ret = LJ::run_hook('alternate_show_poll_html', $po, $mode, \@qs);
|
||||
return $ret if $ret;
|
||||
|
||||
### view answers to a particular question in a poll
|
||||
if ($mode eq "ans")
|
||||
{
|
||||
return "<b>[$BML::ML{'poll.error.cantview'}]</b>"
|
||||
unless $can_view;
|
||||
|
||||
# get the question from @qs, which we loaded earlier
|
||||
my $q;
|
||||
foreach (@qs) {
|
||||
$q = $_ if $_->{pollqid} == $opts->{qid};
|
||||
}
|
||||
return "<b>[$BML::ML{'poll.error.questionnotfound'}]</b>"
|
||||
unless $q;
|
||||
|
||||
# get the item information from %its, also loaded earlier
|
||||
my %it;
|
||||
$it{$_->[0]} = $_->[1] foreach (@{$its{$opts->{qid}}});
|
||||
|
||||
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||||
$ret .= $q->{'qtext'};
|
||||
$ret .= "<p>";
|
||||
|
||||
my $LIMIT = 2000;
|
||||
$sth = $dbr->prepare("SELECT u.user, pr.value, ps.datesubmit ".
|
||||
"FROM useridmap u, pollresult pr, pollsubmission ps " .
|
||||
"WHERE u.userid=pr.userid AND pr.pollid=? AND pollqid=? " .
|
||||
"AND ps.pollid=pr.pollid AND ps.userid=pr.userid LIMIT $LIMIT");
|
||||
$sth->execute($pollid, $opts->{'qid'});
|
||||
|
||||
my @res;
|
||||
push @res, $_ while $_ = $sth->fetchrow_hashref;
|
||||
@res = sort { $a->{datesubmit} cmp $b->{datesubmit} } @res;
|
||||
|
||||
foreach my $res (@res) {
|
||||
my ($user, $value) = ($res->{user}, $res->{value});
|
||||
|
||||
## some question types need translation; type 'text' doesn't.
|
||||
if ($q->{'type'} eq "radio" || $q->{'type'} eq "drop") {
|
||||
$value = $it{$value};
|
||||
}
|
||||
elsif ($q->{'type'} eq "check") {
|
||||
$value = join(", ", map { $it{$_} } split(/,/, $value));
|
||||
}
|
||||
|
||||
LJ::Poll::clean_poll(\$value);
|
||||
$ret .= "<p>" . LJ::ljuser($user) . " -- $value</p>\n";
|
||||
}
|
||||
|
||||
# temporary
|
||||
if (@res == $LIMIT) {
|
||||
$ret .= "<p>[$BML::ML{'poll.error.truncated'}]</p>";
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
# Users cannot vote unless they are logged in
|
||||
return "<?needlogin?>"
|
||||
if $mode eq 'enter' && !$remote;
|
||||
|
||||
my $do_form = $mode eq 'enter' && $can_vote;
|
||||
my %preval;
|
||||
|
||||
if ($do_form) {
|
||||
$sth = $dbr->prepare("SELECT pollqid, value FROM pollresult WHERE pollid=? AND userid=?");
|
||||
$sth->execute($pollid, $remote->{'userid'});
|
||||
while (my ($qid, $value) = $sth->fetchrow_array) {
|
||||
$preval{$qid} = $value;
|
||||
}
|
||||
|
||||
$ret .= "<form action='$LJ::SITEROOT/poll/?id=$pollid' method='post'>";
|
||||
$ret .= LJ::form_auth();
|
||||
$ret .= LJ::html_hidden('pollid', $pollid);
|
||||
}
|
||||
|
||||
$ret .= "<b><a href='$LJ::SITEROOT/poll/?id=$pollid'>" . BML::ml('poll.pollnum', { 'num' => $pollid }) . "</a></b> ";
|
||||
if ($po->{'name'}) {
|
||||
LJ::Poll::clean_poll(\$po->{'name'});
|
||||
$ret .= "<i>$po->{'name'}</i>";
|
||||
}
|
||||
$ret .= "<br />\n";
|
||||
$ret .= BML::ml('poll.security', { 'whovote' => $BML::ML{'poll.security.'.$po->{whovote}},
|
||||
'whoview' => $BML::ML{'poll.security.'.$po->{whoview}} });
|
||||
my $text = LJ::run_hook('extra_poll_description', $po, \@qs);
|
||||
$ret .= "<br />$text" if $text;
|
||||
|
||||
## go through all questions, adding to buffer to return
|
||||
foreach my $q (@qs)
|
||||
{
|
||||
my $qid = $q->{'pollqid'};
|
||||
LJ::Poll::clean_poll(\$q->{'qtext'});
|
||||
$ret .= "<p>$q->{'qtext'}</p><div style='margin: 10px 0 10px 40px'>";
|
||||
|
||||
### get statistics, for scale questions
|
||||
my ($valcount, $valmean, $valstddev, $valmedian);
|
||||
if ($q->{'type'} eq "scale")
|
||||
{
|
||||
## manually add all the possible values, since they aren't in the database
|
||||
## (which was the whole point of making a "scale" type):
|
||||
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||||
$by = 1 unless ($by > 0 and int($by) == $by);
|
||||
for (my $at=$from; $at<=$to; $at+=$by) {
|
||||
push @{$its{$qid}}, [ $at, $at ]; # note: fake itemid, doesn't matter, but needed to be unique
|
||||
}
|
||||
|
||||
$sth = $dbr->prepare("SELECT COUNT(*), AVG(value), STDDEV(value) FROM pollresult WHERE pollid=? AND pollqid=?");
|
||||
$sth->execute($pollid, $qid);
|
||||
($valcount, $valmean, $valstddev) = $sth->fetchrow_array;
|
||||
|
||||
# find median:
|
||||
$valmedian = 0;
|
||||
if ($valcount == 1) {
|
||||
$valmedian = $valmean;
|
||||
} elsif ($valcount > 1) {
|
||||
my ($mid, $fetch);
|
||||
# fetch two mids and average if even count, else grab absolute middle
|
||||
$fetch = ($valcount % 2) ? 1 : 2;
|
||||
$mid = int(($valcount+1)/2);
|
||||
my $skip = $mid-1;
|
||||
|
||||
$sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=? " .
|
||||
"ORDER BY value+0 LIMIT $skip,$fetch");
|
||||
$sth->execute($pollid, $qid);
|
||||
while (my ($v) = $sth->fetchrow_array) {
|
||||
$valmedian += $v;
|
||||
}
|
||||
$valmedian /= $fetch;
|
||||
}
|
||||
}
|
||||
|
||||
my $usersvoted = 0;
|
||||
my %itvotes;
|
||||
my $maxitvotes = 1;
|
||||
|
||||
if ($mode eq "results")
|
||||
{
|
||||
### to see individual's answers
|
||||
$ret .= "<a href='$LJ::SITEROOT/poll/?id=$pollid&qid=$qid&mode=ans'>$BML::ML{'poll.viewanswers'}</a><br />";
|
||||
|
||||
### but, if this is a non-text item, and we're showing results, need to load the answers:
|
||||
if ($q->{'type'} ne "text") {
|
||||
$sth = $dbr->prepare("SELECT value FROM pollresult WHERE pollid=? AND pollqid=?");
|
||||
$sth->execute($pollid, $qid);
|
||||
while (my ($val) = $sth->fetchrow_array) {
|
||||
$usersvoted++;
|
||||
if ($q->{'type'} eq "check") {
|
||||
foreach (split(/,/,$val)) {
|
||||
$itvotes{$_}++;
|
||||
}
|
||||
} else {
|
||||
$itvotes{$val}++;
|
||||
}
|
||||
}
|
||||
|
||||
foreach (values %itvotes) {
|
||||
$maxitvotes = $_ if ($_ > $maxitvotes);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#### text questions are the easy case
|
||||
|
||||
if ($q->{'type'} eq "text" && $do_form) {
|
||||
my ($size, $max) = split(m!/!, $q->{'opts'});
|
||||
|
||||
$ret .= LJ::html_text({ 'size' => $size, 'maxlength' => $max,
|
||||
'name' => "pollq-$qid", 'value' => $preval{$qid} });
|
||||
}
|
||||
|
||||
#### drop-down list
|
||||
elsif ($q->{'type'} eq 'drop' && $do_form) {
|
||||
my @optlist = ('', '');
|
||||
foreach my $it (@{$its{$qid}}) {
|
||||
my ($itid, $item) = @$it;
|
||||
LJ::Poll::clean_poll(\$item);
|
||||
push @optlist, ($itid, $item);
|
||||
}
|
||||
$ret .= LJ::html_select({ 'name' => "pollq-$qid",
|
||||
'selected' => $preval{$qid} }, @optlist);
|
||||
}
|
||||
|
||||
#### scales (from 1-10) questions
|
||||
|
||||
elsif ($q->{'type'} eq "scale" && $do_form) {
|
||||
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||||
$by ||= 1;
|
||||
my $count = int(($to-$from)/$by) + 1;
|
||||
my $do_radios = ($count <= 11);
|
||||
|
||||
# few opts, display radios
|
||||
if ($do_radios) {
|
||||
|
||||
$ret .= "<table><tr valign='top' align='center'>";
|
||||
|
||||
for (my $at=$from; $at<=$to; $at+=$by) {
|
||||
$ret .= "<td style='text-align: center;'>";
|
||||
$ret .= LJ::html_check({ 'type' => 'radio', 'name' => "pollq-$qid",
|
||||
'value' => $at, 'id' => "pollq-$pollid-$qid-$at",
|
||||
'selected' => (defined $preval{$qid} && $at == $preval{$qid}) });
|
||||
$ret .= "<br /><label for='pollq-$pollid-$qid-$at'>$at</label></td>";
|
||||
}
|
||||
|
||||
$ret .= "</tr></table>\n";
|
||||
|
||||
# many opts, display select
|
||||
# but only if displaying form
|
||||
} else {
|
||||
|
||||
my @optlist = ('', '');
|
||||
for (my $at=$from; $at<=$to; $at+=$by) {
|
||||
push @optlist, ($at, $at);
|
||||
}
|
||||
$ret .= LJ::html_select({ 'name' => "pollq-$qid", 'selected' => $preval{$qid} }, @optlist);
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
#### now, questions with items
|
||||
|
||||
else
|
||||
{
|
||||
my $do_table = 0;
|
||||
|
||||
if ($q->{'type'} eq "scale") { # implies ! do_form
|
||||
my $stddev = sprintf("%.2f", $valstddev);
|
||||
my $mean = sprintf("%.2f", $valmean);
|
||||
$ret .= BML::ml('poll.scaleanswers', { 'mean' => $mean, 'median' => $valmedian, 'stddev' => $stddev });
|
||||
$ret .= "<br />\n";
|
||||
$do_table = 1;
|
||||
$ret .= "<table>";
|
||||
}
|
||||
|
||||
foreach my $it (@{$its{$qid}})
|
||||
{
|
||||
my ($itid, $item) = @$it;
|
||||
LJ::Poll::clean_poll(\$item);
|
||||
|
||||
# displaying a radio or checkbox
|
||||
if ($do_form) {
|
||||
$ret .= LJ::html_check({ 'type' => $q->{'type'}, 'name' => "pollq-$qid",
|
||||
'value' => $itid, 'id' => "pollq-$pollid-$qid-$itid",
|
||||
'selected' => ($preval{$qid} =~ /\b$itid\b/) });
|
||||
$ret .= " <label for='pollq-$pollid-$qid-$itid'>$item</label><br />";
|
||||
next;
|
||||
}
|
||||
|
||||
# displaying results
|
||||
my $count = $itvotes{$itid}+0;
|
||||
my $percent = sprintf("%.1f", (100 * $count / ($usersvoted||1)));
|
||||
my $width = 20+int(($count/$maxitvotes)*380);
|
||||
|
||||
if ($do_table) {
|
||||
$ret .= "<tr valign='middle'><td align='right'>$item</td>";
|
||||
$ret .= "<td><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
|
||||
$ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
|
||||
$ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
|
||||
$ret .= "<b>$count</b> ($percent%)</td></tr>";
|
||||
} else {
|
||||
$ret .= "<p>$item<br />";
|
||||
$ret .= "<span style='white-space: nowrap'><img src='$LJ::IMGPREFIX/poll/leftbar.gif' align='absmiddle' height='14' width='7' />";
|
||||
$ret .= "<img src='$LJ::IMGPREFIX/poll/mainbar.gif' align='absmiddle' height='14' width='$width' alt='$count ($percent%)' />";
|
||||
$ret .= "<img src='$LJ::IMGPREFIX/poll/rightbar.gif' align='absmiddle' height='14' width='7' /> ";
|
||||
$ret .= "<b>$count</b> ($percent%)</span></p>";
|
||||
}
|
||||
}
|
||||
|
||||
if ($do_table) {
|
||||
$ret .= "</table>";
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
$ret .= "</div>";
|
||||
}
|
||||
|
||||
if ($do_form) {
|
||||
$ret .= LJ::html_submit('poll-submit', $BML::ML{'poll.submit'}) . "</form>\n";;
|
||||
}
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub find_security
|
||||
{
|
||||
&LJ::nodb;
|
||||
|
||||
my $po = shift;
|
||||
my $remote = shift;
|
||||
my $sth;
|
||||
|
||||
## if remote is poll owner, can do anything.
|
||||
if ($remote && $remote->{'userid'} == $po->{'posterid'}) {
|
||||
return (1, 1);
|
||||
}
|
||||
|
||||
## need to be both a person and with a visible journal to vote
|
||||
if ($remote &&
|
||||
($remote->{'journaltype'} ne "P" || $remote->{'statusvis'} ne "V")) {
|
||||
return (0, 0);
|
||||
}
|
||||
|
||||
my $is_friend = 0;
|
||||
if (($po->{'whoview'} eq "friends" ||
|
||||
$po->{'whovote'} eq "friends") && $remote)
|
||||
{
|
||||
$is_friend = LJ::is_friend($po->{'journalid'}, $remote->{'userid'});
|
||||
}
|
||||
|
||||
my %sec;
|
||||
if ($po->{'whoview'} eq "all" ||
|
||||
($po->{'whoview'} eq "friends" && $is_friend) ||
|
||||
($po->{'whoview'} eq "none" && $remote && $remote->{'userid'} == $po->{'posterid'}))
|
||||
{
|
||||
$sec{'view'} = 1;
|
||||
}
|
||||
|
||||
if ($po->{'whovote'} eq "all" ||
|
||||
($po->{'whovote'} eq "friends" && $is_friend))
|
||||
{
|
||||
$sec{'vote'} = 1;
|
||||
}
|
||||
|
||||
if ($sec{'vote'} && (LJ::is_banned($remote, $po->{'journalid'}) ||
|
||||
LJ::is_banned($remote, $po->{'posterid'}))) {
|
||||
$sec{'vote'} = 0;
|
||||
}
|
||||
|
||||
return ($sec{'vote'}, $sec{'view'});
|
||||
}
|
||||
|
||||
sub submit
|
||||
{
|
||||
&LJ::nodb;
|
||||
|
||||
my $remote = shift;
|
||||
my $form = shift;
|
||||
my $error = shift;
|
||||
my $sth;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
|
||||
unless ($remote) {
|
||||
$$error = $BML::ML{'error.noremote'}; # instead of <?needremote?>, because errors are displayed in LJ::bad_input()
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $pollid = $form->{'pollid'}+0;
|
||||
my $po = $dbh->selectrow_hashref("SELECT itemid, whovote, journalid, posterid, whoview, whovote, name ".
|
||||
"FROM poll WHERE pollid=?", undef, $pollid);
|
||||
unless ($po) {
|
||||
$$error = $BML::ML{'poll.error.nopollid'};
|
||||
return 0;
|
||||
}
|
||||
|
||||
my ($can_vote, undef) = find_security($po, $remote);
|
||||
|
||||
unless ($can_vote) {
|
||||
$$error = $BML::ML{'poll.error.cantvote'};
|
||||
return 0;
|
||||
}
|
||||
|
||||
### load all the questions
|
||||
my @qs;
|
||||
$sth = $dbh->prepare("SELECT pollqid, type, opts, qtext FROM pollquestion WHERE pollid=?");
|
||||
$sth->execute($pollid);
|
||||
push @qs, $_ while $_ = $sth->fetchrow_hashref;
|
||||
|
||||
foreach my $q (@qs) {
|
||||
my $qid = $q->{'pollqid'}+0;
|
||||
my $val = $form->{"pollq-$qid"};
|
||||
if ($q->{'type'} eq "check") {
|
||||
## multi-selected items are comma separated from htdocs/poll/index.bml
|
||||
$val = join(",", sort { $a <=> $b } split(/,/, $val));
|
||||
}
|
||||
if ($q->{'type'} eq "scale") {
|
||||
my ($from, $to, $by) = split(m!/!, $q->{'opts'});
|
||||
if ($val < $from || $val > $to) {
|
||||
# bogus! cheating?
|
||||
$val = "";
|
||||
}
|
||||
}
|
||||
if ($val ne "") {
|
||||
$dbh->do("REPLACE INTO pollresult (pollid, pollqid, userid, value) VALUES (?, ?, ?, ?)",
|
||||
undef, $pollid, $qid, $remote->{'userid'}, $val);
|
||||
} else {
|
||||
$dbh->do("DELETE FROM pollresult WHERE pollid=? AND pollqid=? AND userid=?",
|
||||
undef, $pollid, $qid, $remote->{'userid'});
|
||||
}
|
||||
}
|
||||
|
||||
## finally, register the vote happened
|
||||
$dbh->do("REPLACE INTO pollsubmission (pollid, userid, datesubmit) VALUES (?, ?, NOW())",
|
||||
undef, $pollid, $remote->{'userid'});
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
3287
livejournal/cgi-bin/ljprotocol.pl
Executable file
3287
livejournal/cgi-bin/ljprotocol.pl
Executable file
File diff suppressed because it is too large
Load Diff
45
livejournal/cgi-bin/ljtodo.pl
Executable file
45
livejournal/cgi-bin/ljtodo.pl
Executable file
@@ -0,0 +1,45 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Todo;
|
||||
|
||||
sub get_permissions
|
||||
{
|
||||
my ($dbh, $perm, $opts) = @_;
|
||||
my $sth;
|
||||
my $u = $opts->{'user'};
|
||||
my $remote = $opts->{'remote'};
|
||||
my $it = $opts->{'item'};
|
||||
|
||||
return () unless $remote;
|
||||
|
||||
if ($u->{'userid'} == $remote->{'userid'}) {
|
||||
$perm->{'delete'} = 1;
|
||||
$perm->{'edit'} = 1;
|
||||
$perm->{'add'} = 1;
|
||||
} else {
|
||||
my $quser = $dbh->quote($u->{'user'});
|
||||
|
||||
## check if you're an admin of that journal
|
||||
my $is_manager = LJ::can_manage($remote, $u);
|
||||
if ($is_manager) {
|
||||
$perm->{'add'} = 1;
|
||||
$perm->{'delete'} = 1;
|
||||
$perm->{'edit'} = 1;
|
||||
} else {
|
||||
# TAG:FR:ljtodo:get_friends_in_group
|
||||
foreach my $priv (qw(add edit delete)) {
|
||||
my $group = LJ::get_friend_group($u, { name => "priv-todo-$priv" });
|
||||
next unless $group;
|
||||
my $mask = 1 << $group->{groupnum};
|
||||
my $friends = LJ::get_friends($u, $mask);
|
||||
$perm->{$priv} = 1 if $friends->{$remote->{userid}};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return %permission;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
2361
livejournal/cgi-bin/ljviews.pl
Executable file
2361
livejournal/cgi-bin/ljviews.pl
Executable file
File diff suppressed because it is too large
Load Diff
33
livejournal/cgi-bin/modperl.pl
Executable file
33
livejournal/cgi-bin/modperl.pl
Executable file
@@ -0,0 +1,33 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::ModPerl;
|
||||
use strict;
|
||||
use lib "$ENV{'LJHOME'}/cgi-bin";
|
||||
use Apache;
|
||||
|
||||
# pull in libraries and do per-start initialization once.
|
||||
require "modperl_subs.pl";
|
||||
|
||||
# do per-restart initialization
|
||||
LJ::ModPerl::setup_restart();
|
||||
|
||||
# delete itself from %INC to make sure this file is run again
|
||||
# when apache is restarted
|
||||
delete $INC{"$ENV{'LJHOME'}/cgi-bin/modperl.pl"};
|
||||
|
||||
# remember modtime of all loaded libraries
|
||||
if ($LJ::IS_DEV_SERVER) {
|
||||
%LJ::LIB_MOD_TIME = ();
|
||||
while (my ($k, $file) = each %INC) {
|
||||
next if $LJ::LIB_MOD_TIME{$file};
|
||||
next unless $file =~ m!^\Q$LJ::HOME\E!;
|
||||
my $mod = (stat($file))[9];
|
||||
$LJ::LIB_MOD_TIME{$file} = $mod;
|
||||
}
|
||||
}
|
||||
|
||||
# compatibility with old location of LJ::email_check:
|
||||
*BMLCodeBlock::check_email = \&LJ::check_email;
|
||||
|
||||
1;
|
||||
137
livejournal/cgi-bin/modperl_subs.pl
Executable file
137
livejournal/cgi-bin/modperl_subs.pl
Executable file
@@ -0,0 +1,137 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
# to be require'd by modperl.pl
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ;
|
||||
|
||||
use Apache;
|
||||
use Apache::LiveJournal;
|
||||
use Apache::CompressClientFixup;
|
||||
use Apache::BML;
|
||||
use Apache::SendStats;
|
||||
use Apache::DebateSuicide;
|
||||
|
||||
use Digest::MD5;
|
||||
use MIME::Words;
|
||||
use Text::Wrap ();
|
||||
use LWP::UserAgent ();
|
||||
use Storable;
|
||||
use Time::HiRes ();
|
||||
use Image::Size ();
|
||||
use POSIX ();
|
||||
|
||||
use LJ::SpellCheck;
|
||||
use LJ::TextMessage;
|
||||
use LJ::Blob;
|
||||
use LJ::Captcha;
|
||||
use LJ::OpenID;
|
||||
use MogileFS qw(+preload);
|
||||
use DDLockClient ();
|
||||
|
||||
# Try to load GTop library
|
||||
BEGIN { $LJ::HAVE_GTOP = eval "use GTop (); 1;" }
|
||||
|
||||
# Try to load DBI::Profile
|
||||
BEGIN { $LJ::HAVE_DBI_PROFILE = eval "use DBI::Profile (); 1;" }
|
||||
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljlang.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljpoll.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/htmlcontrols.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/weblib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/imageconf.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/propparse.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/supportlib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/cleanhtml.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/portal.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/talklib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljtodo.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljfeed.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljlinks.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/directorylib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/emailcheck.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljmemories.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/ljmail.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/sysban.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/synlib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/communitylib.pl";
|
||||
require "$ENV{'LJHOME'}/cgi-bin/taglib.pl";
|
||||
|
||||
# preload site-local libraries, if present:
|
||||
require "$ENV{'LJHOME'}/cgi-bin/modperl_subs-local.pl"
|
||||
if -e "$ENV{'LJHOME'}/cgi-bin/modperl_subs-local.pl";
|
||||
|
||||
$LJ::IMGPREFIX_BAK = $LJ::IMGPREFIX;
|
||||
$LJ::STATPREFIX_BAK = $LJ::STATPREFIX;
|
||||
|
||||
package LJ::ModPerl;
|
||||
|
||||
# pull in a lot of useful stuff before we fork children
|
||||
|
||||
sub setup_start {
|
||||
|
||||
# auto-load some stuff before fork:
|
||||
Storable::thaw(Storable::freeze({}));
|
||||
foreach my $minifile ("GIF89a", "\x89PNG\x0d\x0a\x1a\x0a", "\xFF\xD8") {
|
||||
Image::Size::imgsize(\$minifile);
|
||||
}
|
||||
DBI->install_driver("mysql");
|
||||
LJ::CleanHTML::helper_preload();
|
||||
|
||||
# set this before we fork
|
||||
$LJ::CACHE_CONFIG_MODTIME = (stat("$ENV{'LJHOME'}/cgi-bin/ljconfig.pl"))[9];
|
||||
|
||||
eval { setup_start_local(); };
|
||||
}
|
||||
|
||||
sub setup_restart {
|
||||
|
||||
# setup httpd.conf things for the user:
|
||||
Apache->httpd_conf("DocumentRoot $LJ::HTDOCS")
|
||||
if $LJ::HTDOCS;
|
||||
Apache->httpd_conf("ServerAdmin $LJ::ADMIN_EMAIL")
|
||||
if $LJ::ADMIN_EMAIL;
|
||||
|
||||
Apache->httpd_conf(qq{
|
||||
|
||||
# This interferes with LJ's /~user URI, depending on the module order
|
||||
<IfModule mod_userdir.c>
|
||||
UserDir disabled
|
||||
</IfModule>
|
||||
|
||||
PerlInitHandler Apache::LiveJournal
|
||||
PerlInitHandler Apache::SendStats
|
||||
PerlFixupHandler Apache::CompressClientFixup
|
||||
PerlCleanupHandler Apache::SendStats
|
||||
PerlCleanupHandler Apache::DebateSuicide
|
||||
PerlChildInitHandler Apache::SendStats
|
||||
DirectoryIndex index.html index.bml
|
||||
});
|
||||
|
||||
if ($LJ::BML_DENY_CONFIG) {
|
||||
Apache->httpd_conf("PerlSetVar BML_denyconfig \"$LJ::BML_DENY_CONFIG\"\n");
|
||||
}
|
||||
|
||||
unless ($LJ::SERVER_TOTALLY_DOWN)
|
||||
{
|
||||
Apache->httpd_conf(qq{
|
||||
# BML support:
|
||||
<Files ~ "\\.bml\$">
|
||||
SetHandler perl-script
|
||||
PerlHandler Apache::BML
|
||||
</Files>
|
||||
|
||||
# User-friendly error messages
|
||||
ErrorDocument 404 /404-error.html
|
||||
ErrorDocument 500 /500-error.html
|
||||
|
||||
});
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
setup_start();
|
||||
|
||||
1;
|
||||
481
livejournal/cgi-bin/parsefeed.pl
Executable file
481
livejournal/cgi-bin/parsefeed.pl
Executable file
@@ -0,0 +1,481 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ::ParseFeed;
|
||||
|
||||
use XML::RSS;
|
||||
use XML::Parser;
|
||||
|
||||
|
||||
# parse_feed parses an RSS/Atom feed
|
||||
# arguments: content and, optionally, type, specifying "atom" or
|
||||
# "rss". If type isn't supplied, the function will try to guess it
|
||||
# based on contents.
|
||||
# It returns $feed, which is a hash
|
||||
# with the following keys:
|
||||
# type - 'atom' or 'rss'
|
||||
# version - version of the feed in its standard
|
||||
# link - URL of the feed
|
||||
# title - title of the feed
|
||||
# description - description of the feed
|
||||
# # TODO: more kinds of info?
|
||||
#
|
||||
# items - arrayref of item hashes, in the same order they were in the feed
|
||||
# each item contains:
|
||||
# link - URL of the item
|
||||
# id - unique identifier (optional)
|
||||
# text - text of the item
|
||||
# subject - subject
|
||||
# time - in format 'yyyy-mm-dd hh:mm' (optional)
|
||||
# the second argument returned is $error, which, if defined, is a human-readable
|
||||
# error string. the third argument is arrayref of items, same as
|
||||
# $feed->{'items'}.
|
||||
|
||||
sub parse_feed
|
||||
{
|
||||
my ($content, $type) = @_;
|
||||
my ($feed, $items, $error);
|
||||
my $parser;
|
||||
|
||||
# is it RSS or Atom?
|
||||
# Atom feeds are rare for now, so prefer to err in favor of RSS
|
||||
# simple heuristic: Atom feeds will have '<feed' somewhere at the beginning
|
||||
# TODO: maybe store the feed's type on creation in a userprop and not guess here
|
||||
|
||||
my $cut = substr($content, 0, 255);
|
||||
if ($type eq 'atom' || $cut =~ m!\<feed!) {
|
||||
# try treating it as an atom feed
|
||||
$parser = new XML::Parser(Style=>'Stream', Pkg=>'LJ::ParseFeed::Atom');
|
||||
return ("", "failed to create XML parser") unless $parser;
|
||||
eval {
|
||||
$parser->parse($content);
|
||||
};
|
||||
if ($@) {
|
||||
$error = "XML parser error: $@";
|
||||
} else {
|
||||
($feed, $items, $error) = LJ::ParseFeed::Atom::results();
|
||||
};
|
||||
|
||||
if ($feed || $type eq 'atom') {
|
||||
# there was a top-level <feed> there, or we're forced to treat
|
||||
# as an Atom feed, so even if $error is set,
|
||||
# don't try RSS
|
||||
$feed->{'type'} = 'atom';
|
||||
return ($feed, $error, $items);
|
||||
}
|
||||
}
|
||||
|
||||
# try parsing it as RSS
|
||||
$parser = new XML::RSS;
|
||||
return ("", "failed to create RSS parser") unless $parser;
|
||||
eval {
|
||||
$parser->parse($content);
|
||||
};
|
||||
if ($@) {
|
||||
$error = "RSS parser error: $@";
|
||||
return ("", $error);
|
||||
}
|
||||
|
||||
$feed = {};
|
||||
$feed->{'type'} = 'rss';
|
||||
$feed->{'version'} = $parser->{'version'};
|
||||
|
||||
foreach (qw (link title description)) {
|
||||
$feed->{$_} = $parser->{'channel'}->{$_}
|
||||
if $parser->{'channel'}->{$_};
|
||||
}
|
||||
|
||||
$feed->{'items'} = [];
|
||||
|
||||
foreach(@{$parser->{'items'}}) {
|
||||
my $item = {};
|
||||
$item->{'subject'} = $_->{'title'};
|
||||
$item->{'text'} = $_->{'description'};
|
||||
$item->{'link'} = $_->{'link'} if $_->{'link'};
|
||||
$item->{'id'} = $_->{'guid'} if $_->{'guid'};
|
||||
|
||||
my $nsdc = 'http://purl.org/dc/elements/1.1/';
|
||||
my $nsenc = 'http://purl.org/rss/1.0/modules/content/';
|
||||
if ($_->{$nsenc} && ref($_->{$nsenc}) eq "HASH") {
|
||||
# prefer content:encoded if present
|
||||
$item->{'text'} = $_->{$nsenc}->{'encoded'}
|
||||
if defined $_->{$nsenc}->{'encoded'};
|
||||
}
|
||||
|
||||
if ($_->{'pubDate'}) {
|
||||
my $time = time822_to_time($_->{'pubDate'});
|
||||
$item->{'time'} = $time if $time;
|
||||
}
|
||||
if ($_->{$nsdc} && ref($_->{$nsdc}) eq "HASH") {
|
||||
if ($_->{$nsdc}->{date}) {
|
||||
my $time = w3cdtf_to_time($_->{$nsdc}->{date});
|
||||
$item->{'time'} = $time if $time;
|
||||
}
|
||||
}
|
||||
push @{$feed->{'items'}}, $item;
|
||||
}
|
||||
|
||||
return ($feed, undef, $feed->{'items'});
|
||||
}
|
||||
|
||||
# convert rfc822-time in RSS's <pubDate> to our time
|
||||
# see http://www.faqs.org/rfcs/rfc822.html
|
||||
# RFC822 specifies 2 digits for year, and RSS2.0 refers to RFC822,
|
||||
# but real RSS2.0 feeds apparently use 4 digits.
|
||||
sub time822_to_time {
|
||||
my $t822 = shift;
|
||||
# remove day name if present
|
||||
$t822 =~ s/^\s*\w+\s*,//;
|
||||
# remove whitespace
|
||||
$t822 =~ s/^\s*//;
|
||||
# break it up
|
||||
if ($t822 =~ m!(\d?\d)\s+(\w+)\s+(\d\d\d\d)\s+(\d?\d):(\d\d)!) {
|
||||
my ($day, $mon, $year, $hour, $min) = ($1,$2,$3,$4,$5);
|
||||
$day = "0" . $day if length($day) == 1;
|
||||
$hour = "0" . $hour if length($hour) == 1;
|
||||
$mon = {'Jan'=>'01', 'Feb'=>'02', 'Mar'=>'03', 'Apr'=>'04',
|
||||
'May'=>'05', 'Jun'=>'06', 'Jul'=>'07', 'Aug'=>'08',
|
||||
'Sep'=>'09', 'Oct'=>'10', 'Nov'=>'11', 'Dec'=>'12'}->{$mon};
|
||||
return undef unless $mon;
|
||||
return "$year-$mon-$day $hour:$min";
|
||||
} else {
|
||||
return undef;
|
||||
}
|
||||
}
|
||||
|
||||
# convert W3C-DTF to our internal format
|
||||
# see http://www.w3.org/TR/NOTE-datetime
|
||||
# Based very loosely on code from DateTime::Format::W3CDTF,
|
||||
# which isn't stable yet so we can't use it directly.
|
||||
sub w3cdtf_to_time {
|
||||
my $tw3 = shift;
|
||||
|
||||
# TODO: Should somehow return the timezone offset
|
||||
# so that it can stored... but we don't do timezones
|
||||
# yet anyway. For now, just strip the timezone
|
||||
# portion if it is present, along with the decimal
|
||||
# fractions of a second.
|
||||
|
||||
$tw3 =~ s/(?:\.\d+)?(?:[+-]\d{1,2}:\d{1,2}|Z)$//;
|
||||
$tw3 =~ s/^\s*//; $tw3 =~ s/\s*$//; # Eat any superflous whitespace
|
||||
|
||||
# We can only use complete times, so anything which
|
||||
# doesn't feature the time part is considered invalid.
|
||||
|
||||
# This is working around clients that don't implement W3C-DTF
|
||||
# correctly, and only send single digit values in the dates.
|
||||
# 2004-4-8T16:9:4Z vs 2004-04-08T16:09:44Z
|
||||
# If it's more messed up than that, reject it outright.
|
||||
$tw3 =~ /^(\d{4})-(\d{1,2})-(\d{1,2})T(\d{1,2}):(\d{1,2})(?::(\d{1,2}))?$/
|
||||
or return undef;
|
||||
|
||||
my %pd; # parsed date
|
||||
$pd{Y} = $1; $pd{M} = $2; $pd{D} = $3;
|
||||
$pd{h} = $4; $pd{m} = $5; $pd{s} = $6;
|
||||
|
||||
# force double digits
|
||||
foreach (qw/ M D h m s /) {
|
||||
next unless defined $pd{$_};
|
||||
$pd{$_} = sprintf "%02d", $pd{$_};
|
||||
}
|
||||
|
||||
return $pd{s} ? "$pd{Y}-$pd{M}-$pd{D} $pd{h}:$pd{m}:$pd{s}" :
|
||||
"$pd{Y}-$pd{M}-$pd{D} $pd{h}:$pd{m}";
|
||||
}
|
||||
|
||||
package LJ::ParseFeed::Atom;
|
||||
|
||||
our ($feed, $item, $data);
|
||||
our ($ddepth, $dholder); # for accumulating;
|
||||
our @items;
|
||||
our $error;
|
||||
|
||||
sub err {
|
||||
$error = shift unless $error;
|
||||
}
|
||||
|
||||
sub results {
|
||||
return ($feed, \@items, $error);
|
||||
}
|
||||
|
||||
# $name under which we'll store accumulated data may be different
|
||||
# from $tag which causes us to store it
|
||||
# $name may be a scalarref pointing to where we should store
|
||||
# swallowing is achieved by calling startaccum('');
|
||||
|
||||
sub startaccum {
|
||||
my $name = shift;
|
||||
|
||||
return err("Tag found under neither <feed> nor <entry>")
|
||||
unless $feed || $item;
|
||||
$data = ""; # defining $data triggers accumulation
|
||||
$ddepth = 1;
|
||||
|
||||
$dholder = undef
|
||||
unless $name;
|
||||
# if $name is a scalarref, it's actually our $dholder
|
||||
if (ref($name) eq 'SCALAR') {
|
||||
$dholder = $name;
|
||||
} else {
|
||||
$dholder = ($item ? \$item->{$name} : \$feed->{$name})
|
||||
if $name;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub swallow {
|
||||
return startaccum('');
|
||||
}
|
||||
|
||||
sub StartDocument {
|
||||
($feed, $item, $data) = (undef, undef, undef);
|
||||
@items = ();
|
||||
undef $error;
|
||||
}
|
||||
|
||||
sub StartTag {
|
||||
# $_ carries the unparsed tag
|
||||
my ($p, $tag) = @_;
|
||||
my $holder;
|
||||
|
||||
# do nothing if there has been an error
|
||||
return if $error;
|
||||
|
||||
# are we just accumulating data?
|
||||
if (defined $data) {
|
||||
$data .= $_;
|
||||
$ddepth++;
|
||||
return;
|
||||
}
|
||||
|
||||
# where we'll usually store info
|
||||
$holder = $item ? $item : $feed;
|
||||
|
||||
TAGS: {
|
||||
if ($tag eq 'feed') {
|
||||
return err("Nested <feed> tags")
|
||||
if $feed;
|
||||
$feed = {};
|
||||
$feed->{'standard'} = 'atom';
|
||||
$feed->{'version'} = $_{'version'};
|
||||
return err("No version specified in <feed>")
|
||||
unless $feed->{'version'};
|
||||
return err("Incompatible version specified in <feed>")
|
||||
unless $feed->{'version'} eq '0.3';
|
||||
last TAGS;
|
||||
}
|
||||
if ($tag eq 'entry') {
|
||||
return err("Nested <entry> tags")
|
||||
if $item;
|
||||
$item = {};
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
# at this point, we must have a top-level <feed> or <entry>
|
||||
# to write into
|
||||
return err("Tag found under neither <feed> nor <entry>")
|
||||
unless $holder;
|
||||
|
||||
if ($tag eq 'link') {
|
||||
# ignore links with rel= anything but alternate
|
||||
unless ($_{'rel'} eq 'alternate') {
|
||||
swallow();
|
||||
last TAGS;
|
||||
}
|
||||
$holder->{'link'} = $_{'href'};
|
||||
return err("No href attribute in <link>")
|
||||
unless $holder->{'link'};
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
if ($tag eq 'content') {
|
||||
return err("<content> outside <entry>")
|
||||
unless $item;
|
||||
# if type is multipart/alternative, we continue recursing
|
||||
# otherwise we accumulate
|
||||
my $type = $_{'type'} || "text/plain";
|
||||
unless ($type eq "multipart/alternative") {
|
||||
push @{$item->{'contents'}}, [$type, ""];
|
||||
startaccum(\$item->{'contents'}->[-1]->[1]);
|
||||
last TAGS;
|
||||
}
|
||||
# it's multipart/alternative, so recurse, but don't swallow
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
# store tags which should require no further
|
||||
# processing as they are, and others under _atom_*, to be processed
|
||||
# in EndTag under </entry>
|
||||
if ($tag eq 'title') {
|
||||
if ($item) { # entry's subject
|
||||
startaccum("subject");
|
||||
} else { # feed's title
|
||||
startaccum($tag);
|
||||
}
|
||||
last TAGS;
|
||||
}
|
||||
if ($tag eq 'id') {
|
||||
unless ($item) {
|
||||
swallow(); # we don't need feed-level <id>
|
||||
} else {
|
||||
startaccum($tag);
|
||||
}
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
if ($tag eq 'tagline' && !$item) { # feed's tagline, our "description"
|
||||
startaccum("description");
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
# accumulate and store
|
||||
startaccum("_atom_" . $tag);
|
||||
last TAGS;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub EndTag {
|
||||
# $_ carries the unparsed tag
|
||||
my ($p, $tag) = @_;
|
||||
|
||||
# do nothing if there has been an error
|
||||
return if $error;
|
||||
|
||||
# are we accumulating data?
|
||||
if (defined $data) {
|
||||
$ddepth--;
|
||||
if ($ddepth == 0) { # stop accumulating
|
||||
$$dholder = $data
|
||||
if $dholder;
|
||||
undef $data;
|
||||
return;
|
||||
}
|
||||
$data .= $_;
|
||||
return;
|
||||
}
|
||||
|
||||
TAGS: {
|
||||
if ($tag eq 'entry') {
|
||||
# finalize item...
|
||||
# generate suitable text from $item->{'contents'}
|
||||
my $content;
|
||||
$item->{'contents'} ||= [];
|
||||
unless (scalar(@{$item->{'contents'}}) >= 1) {
|
||||
# this item had no <content>
|
||||
# maybe it has <summary>? if so, use <summary>
|
||||
# TODO: type= or encoding issues here? perhaps unite
|
||||
# handling of <summary> with that of <content>?
|
||||
if ($item->{'_atom_summary'}) {
|
||||
$item->{'text'} = $item->{'_atom_summary'};
|
||||
delete $item->{'contents'};
|
||||
} else {
|
||||
# nothing to display, so ignore this entry
|
||||
undef $item;
|
||||
last TAGS;
|
||||
}
|
||||
}
|
||||
|
||||
unless ($item->{'text'}) { # unless we already have text
|
||||
if (scalar(@{$item->{'contents'}}) == 1) {
|
||||
# only one <content> section
|
||||
$content = $item->{'contents'}->[0];
|
||||
} else {
|
||||
# several <content> section, must choose the best one
|
||||
foreach (@{$item->{'contents'}}) {
|
||||
if ($_->[0] eq "application/xhtml+xml") { # best match
|
||||
$content = $_;
|
||||
last; # don't bother to look at others
|
||||
}
|
||||
if ($_->[0] =~ m!html!) { # some kind of html/xhtml/html+xml, etc.
|
||||
# choose this unless we've already chosen some html
|
||||
$content = $_
|
||||
unless $content->[0] =~ m!html!;
|
||||
next;
|
||||
}
|
||||
if ($_->[0] eq "text/plain") {
|
||||
# choose this unless we have some html already
|
||||
$content = $_
|
||||
unless $content->[0] =~ m!html!;
|
||||
next;
|
||||
}
|
||||
}
|
||||
# if we didn't choose anything, pick the first one
|
||||
$content = $item->{'contents'}->[0]
|
||||
unless $content;
|
||||
}
|
||||
|
||||
# we ignore the 'mode' attribute of <content>. If it's "xml", we've
|
||||
# stringified it by accumulation; if it's "escaped", our parser
|
||||
# unescaped it
|
||||
# TODO: handle mode=base64?
|
||||
|
||||
$item->{'text'} = $content->[1];
|
||||
delete $item->{'contents'};
|
||||
}
|
||||
|
||||
# generate time
|
||||
my $w3time = $item->{'_atom_modified'} || $item->{'_atom_created'};
|
||||
my $time;
|
||||
if ($w3time) {
|
||||
# see http://www.w3.org/TR/NOTE-datetime for format
|
||||
# we insist on having granularity up to a minute,
|
||||
# and ignore finer data as well as the timezone, for now
|
||||
if ($w3time =~ m!^(\d\d\d\d)-(\d\d)-(\d\d)T(\d\d):(\d\d)!) {
|
||||
$time = "$1-$2-$3 $4:$5";
|
||||
}
|
||||
}
|
||||
if ($time) {
|
||||
$item->{'time'} = $time;
|
||||
}
|
||||
|
||||
# get rid of all other tags we don't need anymore
|
||||
foreach (keys %$item) {
|
||||
delete $item->{$_} if substr($_, 0, 6) eq '_atom_';
|
||||
}
|
||||
|
||||
push @items, $item;
|
||||
undef $item;
|
||||
last TAGS;
|
||||
}
|
||||
if ($tag eq 'feed') {
|
||||
# finalize feed
|
||||
# get rid of all other tags we don't need anymore
|
||||
foreach (keys %$feed) {
|
||||
delete $feed->{$_} if substr($_, 0, 6) eq '_atom_';
|
||||
}
|
||||
|
||||
# link the feed with its itms
|
||||
$feed->{'items'} = \@items
|
||||
if $feed;
|
||||
last TAGS;
|
||||
}
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub Text {
|
||||
my $p = shift;
|
||||
|
||||
# do nothing if there has been an error
|
||||
return if $error;
|
||||
|
||||
$data .= $_ if defined $data;
|
||||
}
|
||||
|
||||
sub PI {
|
||||
# ignore processing instructions
|
||||
return;
|
||||
}
|
||||
|
||||
sub EndDocument {
|
||||
# if we parsed a feed, link items to it
|
||||
$feed->{'items'} = \@items
|
||||
if $feed;
|
||||
return;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
1141
livejournal/cgi-bin/portal.pl
Executable file
1141
livejournal/cgi-bin/portal.pl
Executable file
File diff suppressed because it is too large
Load Diff
167
livejournal/cgi-bin/propparse.pl
Executable file
167
livejournal/cgi-bin/propparse.pl
Executable file
@@ -0,0 +1,167 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ;
|
||||
|
||||
$verbose = 0;
|
||||
@obs = ();
|
||||
|
||||
sub load_objects_from_file
|
||||
{
|
||||
my ($file, $oblist) = @_;
|
||||
|
||||
# hard-code these common (er, only) cases
|
||||
if ($file eq "views.dat" || $file eq "vars.dat") {
|
||||
$file = "$LJ::HOME/doc/raw/s1/$file";
|
||||
}
|
||||
|
||||
open (FIL, $file);
|
||||
load_objects(\*FIL, $oblist);
|
||||
close FIL;
|
||||
}
|
||||
|
||||
sub load_objects
|
||||
{
|
||||
my ($fh, $oblist) = @_;
|
||||
my $l;
|
||||
|
||||
while ($l = <$fh>)
|
||||
{
|
||||
chomp $l;
|
||||
next unless ($l =~ /\S/);
|
||||
next if ($l =~ /^\#/);
|
||||
if ($l =~ /^\{\s*(\S+)\s*$/)
|
||||
{
|
||||
&load_object($fh, $1, $oblist);
|
||||
}
|
||||
else
|
||||
{
|
||||
print STDERR "Unexpected line: $l\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub load_object
|
||||
{
|
||||
my ($fh, $obname, $listref) = @_;
|
||||
my $var = "";
|
||||
my $vartype = "";
|
||||
my $ob = { name => $obname, props => {} };
|
||||
my $l;
|
||||
|
||||
print "Loading object $obname ... \n" if $verbose;
|
||||
SUCKLINES:
|
||||
while ($l = <$fh>)
|
||||
{
|
||||
chomp $l;
|
||||
if ($l =~ /^\.(\S+)\s*$/)
|
||||
{
|
||||
$var = $1;
|
||||
print "current var = $var\n" if $verbose;
|
||||
next SUCKLINES;
|
||||
}
|
||||
if ($l =~ /^\}\s*$/)
|
||||
{
|
||||
print "End object $obname.\n" if $verbose;
|
||||
last SUCKLINES;
|
||||
}
|
||||
next unless $var;
|
||||
next unless ($l =~ /\S/);
|
||||
next if ($l =~ /^\#/);
|
||||
|
||||
if ($l =~ /^\{\s*(\S+)\s*$/)
|
||||
{
|
||||
print "Encounted object ($1) as property.\n" if $verbose;
|
||||
if (defined $ob->{'props'}->{$var})
|
||||
{
|
||||
if (ref $ob->{'props'}->{$var} ne "ARRAY")
|
||||
{
|
||||
print STDERR "Object encountered where text expected.\n";
|
||||
my $blah = [];
|
||||
&load_object($fh, "blah", $blah); # ignore object
|
||||
}
|
||||
else
|
||||
{
|
||||
&load_object($fh, $1, $ob->{'props'}->{$var});
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
$ob->{'props'}->{$var} = [];
|
||||
&load_object($fh, $1, $ob->{'props'}->{$var});
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
print "Normal line.\n" if $verbose;
|
||||
if (defined $ob->{'props'}->{$var})
|
||||
{
|
||||
print "defined.\n" if $verbose;
|
||||
if (ref $ob->{'props'}->{$var} eq "ARRAY")
|
||||
{
|
||||
print STDERR "Scalar found where object expected!\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
print "appending var \"$var\".\n" if $verbose;
|
||||
$ob->{'props'}->{$var} .= "\n$l";
|
||||
}
|
||||
}
|
||||
else
|
||||
{
|
||||
print "setting $var to $l\n" if $verbose;
|
||||
$ob->{'props'}->{$var} = $l;
|
||||
}
|
||||
}
|
||||
|
||||
} # end while
|
||||
print "done loading object $obname\n" if $verbose;
|
||||
|
||||
push @{$listref}, $ob;
|
||||
|
||||
} # end sub
|
||||
|
||||
sub xlinkify
|
||||
{
|
||||
my ($a) = $_[0];
|
||||
$$a =~ s/\[var\[([A-Z0-9\_]{2,})\]\]/<a href=\"\/developer\/varinfo.bml?$1\">$1<\/a>/g;
|
||||
$$a =~ s/\[view\[(\S+?)\]\]/<a href=\"\/developer\/views.bml\#$1\">$1<\/a>/g;
|
||||
}
|
||||
|
||||
sub dump_struct
|
||||
{
|
||||
my ($ref, $depth) = @_;
|
||||
my $type = ref $ref;
|
||||
my $indent = " "x$depth;
|
||||
if ($type eq "ARRAY")
|
||||
{
|
||||
print "ARRAY\n";
|
||||
my $count = 0;
|
||||
foreach (@{$ref})
|
||||
{
|
||||
print $indent, "[$count] = ";
|
||||
&dump_struct($_, $depth+1);
|
||||
$count++;
|
||||
}
|
||||
}
|
||||
elsif ($type eq "HASH")
|
||||
{
|
||||
print "HASH\n";
|
||||
my $k;
|
||||
foreach $k (sort keys %{$ref})
|
||||
{
|
||||
print $indent, "{$k} = ";
|
||||
&dump_struct($ref->{$k}, $depth+1);
|
||||
}
|
||||
}
|
||||
elsif ($type eq "")
|
||||
{
|
||||
print $ref, "\n";
|
||||
}
|
||||
else
|
||||
{
|
||||
print $indent, "UNKNOWN_TYPE";
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
24
livejournal/cgi-bin/redirect.dat
Executable file
24
livejournal/cgi-bin/redirect.dat
Executable file
@@ -0,0 +1,24 @@
|
||||
/community.bml /community/
|
||||
/communities /community/
|
||||
/support.bml /support/
|
||||
/addfriend.bml /friends/add.bml
|
||||
/editfriendgroups.bml /friends/editgroups.bml
|
||||
/editfriends.bml /friends/edit.bml
|
||||
/editfriends_do.bml /friends/edit_do.bml
|
||||
/friendgraph.bml /friends/graph.bml
|
||||
/friendsfilter.bml /friends/filter.bml
|
||||
/createstyle.bml /styles/create.bml
|
||||
/editstyle.bml /styles/edit.bml
|
||||
/stylebrowser /styles/browse/
|
||||
/friendgraph.bml /friends/graph.bml
|
||||
/textmessage.bml /tools/textmessage.bml
|
||||
/memories.bml /tools/memories.bml
|
||||
/memadd.bml /tools/memadd.bml
|
||||
/faq.bml /support/faq.bml
|
||||
/faqbrowse.bml /support/faqbrowse.bml
|
||||
/setscheme.bml /manage/siteopts.bml
|
||||
/setlang.bml /manage/siteopts.bml
|
||||
/uploadpic.bml /editpics.bml
|
||||
/uploadpic_do.bml /editpics.bml
|
||||
/modify_do.bml /modify.bml
|
||||
/editjournal_do.bml /editjournal.bml
|
||||
285
livejournal/cgi-bin/statslib.pl
Executable file
285
livejournal/cgi-bin/statslib.pl
Executable file
@@ -0,0 +1,285 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
#
|
||||
# Partial Stats
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ::Stats;
|
||||
|
||||
%LJ::Stats::INFO = (
|
||||
# jobname => { type => 'global' || 'clustered',
|
||||
# jobname => jobname
|
||||
# statname => statname || [statname1, statname2]
|
||||
# handler => sub {},
|
||||
# max_age => age }
|
||||
);
|
||||
|
||||
sub LJ::Stats::register_stat {
|
||||
my $stat = shift;
|
||||
return undef unless ref $stat eq 'HASH';
|
||||
|
||||
$stat->{'type'} = $stat->{'type'} eq 'clustered' ? 'clustered' : 'global';
|
||||
return undef unless $stat->{'jobname'};
|
||||
$stat->{'statname'} ||= $stat->{'jobname'};
|
||||
return undef unless ref $stat->{'handler'} eq 'CODE';
|
||||
delete $stat->{'max_age'} unless $stat->{'max_age'} > 0;
|
||||
|
||||
# register in master INFO hash
|
||||
$LJ::Stats::INFO{$stat->{'jobname'}} = $stat;
|
||||
|
||||
return 1;
|
||||
};
|
||||
|
||||
sub LJ::Stats::run_stats {
|
||||
my @stats = @_ ? @_ : sort keys %LJ::Stats::INFO;
|
||||
|
||||
foreach my $jobname (@stats) {
|
||||
|
||||
my $stat = $LJ::Stats::INFO{$jobname};
|
||||
|
||||
# stats calculated on global db reader
|
||||
if ($stat->{'type'} eq "global") {
|
||||
unless (LJ::Stats::need_calc($jobname)) {
|
||||
print "-I- Up-to-date: $jobname\n";
|
||||
next;
|
||||
}
|
||||
|
||||
# rather than passing an actual db handle to the stat handler,
|
||||
# just pass a getter subef so it can be revalidated as necessary
|
||||
my $dbr_getter = sub {
|
||||
return LJ::Stats::get_db("dbr")
|
||||
or die "Can't get db reader handle.";
|
||||
};
|
||||
|
||||
print "-I- Running: $jobname\n";
|
||||
|
||||
my $res = $stat->{'handler'}->($dbr_getter);
|
||||
die "Error running '$jobname' handler on global reader."
|
||||
unless $res;
|
||||
|
||||
# 2 cases:
|
||||
# - 'statname' is an arrayref, %res structure is ( 'statname' => { 'arg' => 'val' } )
|
||||
# - 'statname' is scalar, %res structure is ( 'arg' => 'val' )
|
||||
{
|
||||
if (ref $stat->{'statname'} eq 'ARRAY') {
|
||||
foreach my $statname (@{$stat->{'statname'}}) {
|
||||
foreach my $key (keys %{$res->{$statname}}) {
|
||||
LJ::Stats::save_stat($statname, $key, $res->{$statname}->{$key});
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $statname = $stat->{'statname'};
|
||||
foreach my $key (keys %$res) {
|
||||
LJ::Stats::save_stat($statname, $key, $res->{$key});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
LJ::Stats::save_calc($jobname);
|
||||
|
||||
next;
|
||||
}
|
||||
|
||||
# stats calculated per-cluster
|
||||
if ($stat->{'type'} eq "clustered") {
|
||||
|
||||
foreach my $cid (@LJ::CLUSTERS) {
|
||||
unless (LJ::Stats::need_calc($jobname, $cid)) {
|
||||
print "-I- Up-to-date: $jobname, cluster $cid\n";
|
||||
next;
|
||||
}
|
||||
|
||||
# pass a dbcr getter subref so the stat handler knows how
|
||||
# to revalidate its database handles, by invoking this closure
|
||||
my $dbcr_getter = sub {
|
||||
return LJ::Stats::get_db("dbcr", $cid)
|
||||
or die "Can't get cluster $cid db handle.";
|
||||
};
|
||||
|
||||
print "-I- Running: $jobname, cluster $cid\n";
|
||||
|
||||
my $res = $stat->{'handler'}->($dbcr_getter, $cid);
|
||||
die "Error running '$jobname' handler on cluster $cid."
|
||||
unless $res;
|
||||
|
||||
# 2 cases:
|
||||
# - 'statname' is an arrayref, %res structure is ( 'statname' => { 'arg' => 'val' } )
|
||||
# - 'statname' is scalar, %res structure is ( 'arg' => 'val' )
|
||||
{
|
||||
if (ref $stat->{'statname'} eq 'ARRAY') {
|
||||
foreach my $statname (@{$stat->{'statname'}}) {
|
||||
foreach my $key (keys %{$res->{$statname}}) {
|
||||
LJ::Stats::save_part($statname, $cid, $key, $res->{$statname}->{$key});
|
||||
}
|
||||
}
|
||||
} else {
|
||||
my $statname = $stat->{'statname'};
|
||||
foreach my $key (keys %$res) {
|
||||
LJ::Stats::save_part($statname, $cid, $key, $res->{$key});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
LJ::Stats::save_calc($jobname, $cid);
|
||||
}
|
||||
|
||||
# save the summation(s) of the statname(s) we found above
|
||||
if (ref $stat->{'statname'} eq 'ARRAY') {
|
||||
foreach my $statname (@{$stat->{'statname'}}) {
|
||||
LJ::Stats::save_sum($statname);
|
||||
}
|
||||
} else {
|
||||
LJ::Stats::save_sum($stat->{'statname'});
|
||||
}
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return 1;
|
||||
};
|
||||
|
||||
# get raw dbr/dbh/cluster handle
|
||||
sub LJ::Stats::get_db {
|
||||
my $type = shift;
|
||||
return undef unless $type;
|
||||
my $cid = shift;
|
||||
|
||||
# tell DBI to revalidate connections before returning them
|
||||
$LJ::DBIRole->clear_req_cache();
|
||||
|
||||
my $opts = {raw=>1,nocache=>1}; # get_dbh opts
|
||||
|
||||
# global handles
|
||||
if ($type eq "dbr") {
|
||||
my @roles = $LJ::STATS_FORCE_SLOW ? ("slow") : ("slave", "master");
|
||||
|
||||
my $db = LJ::get_dbh($opts, @roles);
|
||||
return $db if $db;
|
||||
|
||||
# don't fall back to slave/master if STATS_FORCE_SLOW is on
|
||||
die "ERROR: Could not get handle for slow database role\n"
|
||||
if $LJ::STATS_FORCE_SLOW;
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
return LJ::get_dbh($opts, 'master')
|
||||
if $type eq "dbh";
|
||||
|
||||
# cluster handles
|
||||
return undef unless $cid > 0;
|
||||
return LJ::get_cluster_def_reader($opts, $cid)
|
||||
if $type eq "dbcm" || $type eq "dbcr";
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
# save a given stat to the 'stats' table in the db
|
||||
sub LJ::Stats::save_stat {
|
||||
my ($cat, $statkey, $val) = @_;
|
||||
return undef unless $cat && $statkey && $val;
|
||||
|
||||
# replace/insert stats row
|
||||
my $dbh = LJ::Stats::get_db("dbh");
|
||||
$dbh->do("REPLACE INTO stats (statcat, statkey, statval) VALUES (?, ?, ?)",
|
||||
undef, $cat, $statkey, $val);
|
||||
die $dbh->errstr if $dbh->err;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# note the last calctime of a given stat
|
||||
sub LJ::Stats::save_calc {
|
||||
my ($jobname, $cid) = @_;
|
||||
return unless $jobname;
|
||||
|
||||
my $dbh = LJ::Stats::get_db("dbh");
|
||||
$dbh->do("REPLACE INTO partialstats (jobname, clusterid, calctime) " .
|
||||
"VALUES (?,?,UNIX_TIMESTAMP())", undef, $jobname, $cid || 1);
|
||||
die $dbh->errstr if $dbh->err;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# save partial stats
|
||||
sub LJ::Stats::save_part {
|
||||
my ($statname, $cid, $arg, $value) = @_;
|
||||
return undef unless $statname && $cid > 0;
|
||||
|
||||
# replace/insert partialstats(data) row
|
||||
my $dbh = LJ::Stats::get_db("dbh");
|
||||
$dbh->do("REPLACE INTO partialstatsdata (statname, arg, clusterid, value) " .
|
||||
"VALUES (?,?,?,?)", undef, $statname, $arg, $cid, $value);
|
||||
die $dbh->errstr if $dbh->err;
|
||||
|
||||
return 1;
|
||||
};
|
||||
|
||||
# see if a given stat is stale
|
||||
sub LJ::Stats::need_calc {
|
||||
my ($jobname, $cid) = @_;
|
||||
return undef unless $jobname;
|
||||
|
||||
my $dbr = LJ::Stats::get_db("dbr");
|
||||
my $calctime = $dbr->selectrow_array("SELECT calctime FROM partialstats " .
|
||||
"WHERE jobname=? AND clusterid=?",
|
||||
undef, $jobname, $cid || 1);
|
||||
|
||||
my $max = $LJ::Stats::INFO{$jobname}->{'max_age'} || 3600*6; # 6 hours default
|
||||
return ($calctime < time() - $max);
|
||||
}
|
||||
|
||||
# sum up counts for all clusters
|
||||
sub LJ::Stats::save_sum {
|
||||
my $statname = shift;
|
||||
return undef unless $statname;
|
||||
|
||||
# get sum of this stat for all clusters
|
||||
my $dbr = LJ::Stats::get_db("dbr");
|
||||
my $sth = $dbr->prepare("SELECT arg, SUM(value) FROM partialstatsdata " .
|
||||
"WHERE statname=? GROUP BY 1");
|
||||
$sth->execute($statname);
|
||||
while (my ($arg, $count) = $sth->fetchrow_array) {
|
||||
next unless $count;
|
||||
LJ::Stats::save_stat($statname, $arg, $count);
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# get number of pages, given a total row count
|
||||
sub LJ::Stats::num_blocks {
|
||||
my $row_tot = shift;
|
||||
return 0 unless $row_tot;
|
||||
|
||||
return int($row_tot / $LJ::STATS_BLOCK_SIZE) + (($row_tot % $LJ::STATS_BLOCK_SIZE) ? 1 : 0);
|
||||
}
|
||||
|
||||
# get low/high ids for a BETWEEN query based on page number
|
||||
sub LJ::Stats::get_block_bounds {
|
||||
my ($block, $offset) = @_;
|
||||
return ($offset+0, $offset+$LJ::Stats::BLOCK_SIZE) unless $block;
|
||||
|
||||
# calculate min, then add one to not overlap previous max,
|
||||
# unless there was no previous max so we set to 0 so we don't
|
||||
# miss rows with id=0
|
||||
my $min = ($block-1)*$LJ::STATS_BLOCK_SIZE + 1;
|
||||
$min = $min == 1 ? 0 : $min;
|
||||
|
||||
return ($offset+$min, $offset+$block*$LJ::STATS_BLOCK_SIZE);
|
||||
}
|
||||
|
||||
sub LJ::Stats::block_status_line {
|
||||
my ($block, $total) = @_;
|
||||
return "" unless $LJ::Stats::VERBOSE;
|
||||
return "" if $total == 1; # who cares about percentage for one block?
|
||||
|
||||
# status line gets called AFTER work is done, so we show percentage
|
||||
# for $block+1, that way the final line displays 100%
|
||||
my $pct = sprintf("%.2f", 100*($block / ($total || 1)));
|
||||
return " [$pct%] Processing block $block of $total.\n";
|
||||
}
|
||||
|
||||
1;
|
||||
742
livejournal/cgi-bin/supportlib.pl
Executable file
742
livejournal/cgi-bin/supportlib.pl
Executable file
@@ -0,0 +1,742 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Support;
|
||||
|
||||
use strict;
|
||||
use Digest::MD5 qw(md5_hex);
|
||||
|
||||
require "$ENV{'LJHOME'}/cgi-bin/sysban.pl";
|
||||
|
||||
## pass $id of zero or blank to get all categories
|
||||
sub load_cats
|
||||
{
|
||||
my ($id) = @_;
|
||||
my $hashref = {};
|
||||
$id += 0;
|
||||
my $where = $id ? "WHERE spcatid=$id" : "";
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $sth = $dbr->prepare("SELECT * FROM supportcat $where");
|
||||
$sth->execute;
|
||||
$hashref->{$_->{'spcatid'}} = $_ while ($_ = $sth->fetchrow_hashref);
|
||||
return $hashref;
|
||||
}
|
||||
|
||||
sub load_email_to_cat_map
|
||||
{
|
||||
my $map = {};
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $sth = $dbr->prepare("SELECT * FROM supportcat ORDER BY sortorder DESC");
|
||||
$sth->execute;
|
||||
while (my $sp = $sth->fetchrow_hashref) {
|
||||
next unless ($sp->{'replyaddress'});
|
||||
$map->{$sp->{'replyaddress'}} = $sp;
|
||||
}
|
||||
return $map;
|
||||
}
|
||||
|
||||
sub calc_points
|
||||
{
|
||||
my ($sp, $secs) = @_;
|
||||
my $base = $sp->{_cat}->{'basepoints'};
|
||||
$secs = int($secs / (3600*6));
|
||||
my $total = ($base + $secs);
|
||||
if ($total > 10) { $total = 10; }
|
||||
$total ||= 1;
|
||||
return $total;
|
||||
}
|
||||
|
||||
sub init_remote
|
||||
{
|
||||
my $remote = shift;
|
||||
return unless $remote;
|
||||
LJ::load_user_privs($remote,
|
||||
qw(supportclose supporthelp
|
||||
supportdelete supportread
|
||||
supportviewinternal supportmakeinternal
|
||||
supportmovetouch supportviewscreened
|
||||
supportchangesummary));
|
||||
}
|
||||
|
||||
# given all the categories, maps a catkey into a cat
|
||||
sub get_cat_by_key
|
||||
{
|
||||
my ($cats, $cat) = @_;
|
||||
foreach (keys %$cats) {
|
||||
if ($cats->{$_}->{'catkey'} eq $cat) {
|
||||
return $cats->{$_};
|
||||
}
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub filter_cats
|
||||
{
|
||||
my $remote = shift;
|
||||
my $cats = shift;
|
||||
|
||||
return grep {
|
||||
can_read_cat($_, $remote);
|
||||
} sorted_cats($cats);
|
||||
}
|
||||
|
||||
sub sorted_cats
|
||||
{
|
||||
my $cats = shift;
|
||||
return sort { $a->{'catname'} cmp $b->{'catname'} } values %$cats;
|
||||
}
|
||||
|
||||
# takes raw support request record and puts category info in it
|
||||
# so it can be used in other functions like can_*
|
||||
sub fill_request_with_cat
|
||||
{
|
||||
my ($sp, $cats) = @_;
|
||||
$sp->{_cat} = $cats->{$sp->{'spcatid'}};
|
||||
}
|
||||
|
||||
sub is_poster
|
||||
{
|
||||
my ($sp, $remote, $auth) = @_;
|
||||
|
||||
# special case with non-logged in requesters that use miniauth
|
||||
if ($auth && $auth eq mini_auth($sp)) {
|
||||
return 1;
|
||||
}
|
||||
return 0 unless $remote;
|
||||
|
||||
if ($sp->{'reqtype'} eq "email") {
|
||||
if ($remote->{'email'} eq $sp->{'reqemail'} && $remote->{'status'} eq "A") {
|
||||
return 1;
|
||||
}
|
||||
} elsif ($sp->{'reqtype'} eq "user") {
|
||||
if ($remote->{'userid'} eq $sp->{'requserid'}) { return 1; }
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub can_see_helper
|
||||
{
|
||||
my ($sp, $remote) = @_;
|
||||
if ($sp->{_cat}->{'hide_helpers'}) {
|
||||
if (can_help($sp, $remote)) {
|
||||
return 1;
|
||||
}
|
||||
if (LJ::check_priv($remote, "supportviewinternal", $sp->{_cat}->{'catkey'})) {
|
||||
return 1;
|
||||
}
|
||||
if (LJ::check_priv($remote, "supportviewscreened", $sp->{_cat}->{'catkey'})) {
|
||||
return 1;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub can_read
|
||||
{
|
||||
my ($sp, $remote, $auth) = @_;
|
||||
return (is_poster($sp, $remote, $auth) ||
|
||||
can_read_cat($sp->{_cat}, $remote));
|
||||
}
|
||||
|
||||
sub can_read_cat
|
||||
{
|
||||
my ($cat, $remote) = @_;
|
||||
return unless ($cat);
|
||||
return ($cat->{'public_read'} ||
|
||||
LJ::check_priv($remote, "supportread", $cat->{'catkey'}));
|
||||
}
|
||||
|
||||
sub can_bounce
|
||||
{
|
||||
my ($sp, $remote) = @_;
|
||||
if ($sp->{_cat}->{'public_read'}) {
|
||||
if (LJ::check_priv($remote, "supportclose", "")) { return 1; }
|
||||
}
|
||||
my $catkey = $sp->{_cat}->{'catkey'};
|
||||
if (LJ::check_priv($remote, "supportclose", $catkey)) { return 1; }
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub can_lock
|
||||
{
|
||||
my ($sp, $remote) = @_;
|
||||
return 1 if $sp->{_cat}->{public_read} && LJ::check_priv($remote, 'supportclose', '');
|
||||
return 1 if LJ::check_priv($remote, 'supportclose', $sp->{_cat}->{catkey});
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub can_close
|
||||
{
|
||||
my ($sp, $remote, $auth) = @_;
|
||||
if (is_poster($sp, $remote, $auth)) { return 1; }
|
||||
if ($sp->{_cat}->{'public_read'}) {
|
||||
if (LJ::check_priv($remote, "supportclose", "")) { return 1; }
|
||||
}
|
||||
my $catkey = $sp->{_cat}->{'catkey'};
|
||||
if (LJ::check_priv($remote, "supportclose", $catkey)) { return 1; }
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub can_append
|
||||
{
|
||||
my ($sp, $remote, $auth) = @_;
|
||||
if (is_poster($sp, $remote, $auth)) { return 1; }
|
||||
return 0 unless $remote;
|
||||
return 0 unless $remote->{'statusvis'} eq "V";
|
||||
if ($sp->{_cat}->{'allow_screened'}) { return 1; }
|
||||
if (can_help($sp, $remote)) { return 1; }
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub is_locked
|
||||
{
|
||||
my $sp = shift;
|
||||
my $spid = ref $sp ? $sp->{spid} : $sp+0;
|
||||
return undef unless $spid;
|
||||
my $props = LJ::Support::load_props($spid);
|
||||
return $props->{locked} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub lock
|
||||
{
|
||||
my $sp = shift;
|
||||
my $spid = ref $sp ? $sp->{spid} : $sp+0;
|
||||
return undef unless $spid;
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$dbh->do("REPLACE INTO supportprop (spid, prop, value) VALUES (?, 'locked', 1)", undef, $spid);
|
||||
}
|
||||
|
||||
sub unlock
|
||||
{
|
||||
my $sp = shift;
|
||||
my $spid = ref $sp ? $sp->{spid} : $sp+0;
|
||||
return undef unless $spid;
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$dbh->do("DELETE FROM supportprop WHERE spid = ? AND prop = 'locked'", undef, $spid);
|
||||
}
|
||||
|
||||
# privilege policy:
|
||||
# supporthelp with no argument gives you all abilities in all public_read categories
|
||||
# supporthelp with a catkey arg gives you all abilities in that non-public_read category
|
||||
# supportread with a catkey arg is required to view requests in a non-public_read category
|
||||
# all other privs work like:
|
||||
# no argument = global, where category is public_read or user has supportread on that category
|
||||
# argument = local, priv applies in that category only if it's public or user has supportread
|
||||
sub support_check_priv
|
||||
{
|
||||
my ($sp, $remote, $priv) = @_;
|
||||
return 1 if can_help($sp, $remote);
|
||||
return 0 unless can_read_cat($sp->{_cat}, $remote);
|
||||
return 1 if LJ::check_priv($remote, $priv, '') && $sp->{_cat}->{public_read};
|
||||
return 1 if LJ::check_priv($remote, $priv, $sp->{_cat}->{catkey});
|
||||
return 0;
|
||||
}
|
||||
|
||||
# can they read internal comments? if they're a helper or have
|
||||
# extended supportread (with a plus sign at the end of the category key)
|
||||
sub can_read_internal
|
||||
{
|
||||
my ($sp, $remote) = @_;
|
||||
return 1 if LJ::Support::support_check_priv($sp, $remote, 'supportviewinternal');
|
||||
return 1 if LJ::check_priv($remote, "supportread", $sp->{_cat}->{catkey}."+");
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub can_make_internal
|
||||
{
|
||||
return LJ::Support::support_check_priv(@_, 'supportmakeinternal');
|
||||
}
|
||||
|
||||
sub can_read_screened
|
||||
{
|
||||
return LJ::Support::support_check_priv(@_, 'supportviewscreened');
|
||||
}
|
||||
|
||||
sub can_perform_actions
|
||||
{
|
||||
return LJ::Support::support_check_priv(@_, 'supportmovetouch');
|
||||
}
|
||||
|
||||
sub can_change_summary
|
||||
{
|
||||
return LJ::Support::support_check_priv(@_, 'supportchangesummary');
|
||||
}
|
||||
|
||||
sub can_help
|
||||
{
|
||||
my ($sp, $remote) = @_;
|
||||
if ($sp->{_cat}->{'public_read'}) {
|
||||
if ($sp->{_cat}->{'public_help'}) {
|
||||
return 1;
|
||||
}
|
||||
if (LJ::check_priv($remote, "supporthelp", "")) { return 1; }
|
||||
}
|
||||
my $catkey = $sp->{_cat}->{'catkey'};
|
||||
if (LJ::check_priv($remote, "supporthelp", $catkey)) { return 1; }
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub load_props
|
||||
{
|
||||
my $spid = shift;
|
||||
return unless $spid;
|
||||
|
||||
my %props = (); # prop => value
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $sth = $dbr->prepare("SELECT prop, value FROM supportprop WHERE spid=?");
|
||||
$sth->execute($spid);
|
||||
while (my ($prop, $value) = $sth->fetchrow_array) {
|
||||
$props{$prop} = $value;
|
||||
}
|
||||
|
||||
return \%props;
|
||||
}
|
||||
|
||||
# $loadreq is used by /abuse/report.bml and
|
||||
# ljcmdbuffer.pl to signify that the full request
|
||||
# should not be loaded. To simplify code going live,
|
||||
# Whitaker and I decided to not try and merge it
|
||||
# into the new $opts hash.
|
||||
|
||||
# $opts->{'db_force'} loads the request from a
|
||||
# global master. Needed to prevent a race condition
|
||||
# where the request may not have replicated to slaves
|
||||
# in the time needed to load an auth code.
|
||||
|
||||
sub load_request
|
||||
{
|
||||
my ($spid, $loadreq, $opts) = @_;
|
||||
my $sth;
|
||||
|
||||
$spid += 0;
|
||||
|
||||
# load the support request
|
||||
my $db = $opts->{'db_force'} ? LJ::get_db_writer() : LJ::get_db_reader();
|
||||
|
||||
$sth = $db->prepare("SELECT * FROM support WHERE spid=$spid");
|
||||
$sth->execute;
|
||||
my $sp = $sth->fetchrow_hashref;
|
||||
|
||||
return undef unless $sp;
|
||||
|
||||
# load the category the support requst is in
|
||||
$sth = $db->prepare("SELECT * FROM supportcat WHERE spcatid=$sp->{'spcatid'}");
|
||||
$sth->execute;
|
||||
$sp->{_cat} = $sth->fetchrow_hashref;
|
||||
|
||||
# now load the user's request text, if necessary
|
||||
if ($loadreq) {
|
||||
$sp->{body} = $db->selectrow_array("SELECT message FROM supportlog WHERE spid = ? AND type = 'req'",
|
||||
undef, $sp->{spid});
|
||||
}
|
||||
|
||||
return $sp;
|
||||
}
|
||||
|
||||
sub load_response
|
||||
{
|
||||
my $splid = shift;
|
||||
my $sth;
|
||||
|
||||
$splid += 0;
|
||||
|
||||
# load the support request
|
||||
my $dbh = LJ::get_db_writer();
|
||||
$sth = $dbh->prepare("SELECT * FROM supportlog WHERE splid=$splid");
|
||||
$sth->execute;
|
||||
my $res = $sth->fetchrow_hashref;
|
||||
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub get_answer_types
|
||||
{
|
||||
my ($sp, $remote, $auth) = @_;
|
||||
my @ans_type;
|
||||
|
||||
if (is_poster($sp, $remote, $auth)) {
|
||||
push @ans_type, ("comment", "More information");
|
||||
return @ans_type;
|
||||
}
|
||||
|
||||
if (can_help($sp, $remote)) {
|
||||
push @ans_type, ("screened" => "Screened Response",
|
||||
"answer" => "Answer",
|
||||
"comment" => "Comment or Question");
|
||||
} elsif ($sp->{_cat}->{'allow_screened'}) {
|
||||
push @ans_type, ("screened" => "Screened Response");
|
||||
}
|
||||
|
||||
if (can_make_internal($sp, $remote) &&
|
||||
! $sp->{_cat}->{'public_help'})
|
||||
{
|
||||
push @ans_type, ("internal" => "Internal Comment / Action");
|
||||
}
|
||||
|
||||
if (can_bounce($sp, $remote)) {
|
||||
push @ans_type, ("bounce" => "Bounce to Email & Close");
|
||||
}
|
||||
|
||||
return @ans_type;
|
||||
}
|
||||
|
||||
sub file_request
|
||||
{
|
||||
my $errors = shift;
|
||||
my $o = shift;
|
||||
|
||||
my $email = $o->{'reqtype'} eq "email" ? $o->{'reqemail'} : "";
|
||||
my $log = { 'uniq' => $o->{'uniq'},
|
||||
'email' => $email };
|
||||
my $userid = 0;
|
||||
|
||||
unless ($email) {
|
||||
if ($o->{'reqtype'} eq "user") {
|
||||
my $u = LJ::load_userid($o->{'requserid'});
|
||||
$userid = $u->{'userid'};
|
||||
|
||||
$log->{'user'} = $u->{'user'};
|
||||
$log->{'email'} = $u->{'email'};
|
||||
|
||||
if (LJ::sysban_check('support_user', $u->{'user'})) {
|
||||
return LJ::sysban_block($userid, "Support request blocked based on user", $log);
|
||||
}
|
||||
|
||||
$email = $u->{'email'};
|
||||
}
|
||||
}
|
||||
|
||||
if (LJ::sysban_check('support_email', $email)) {
|
||||
return LJ::sysban_block($userid, "Support request blocked based on email", $log);
|
||||
}
|
||||
if (LJ::sysban_check('support_uniq', $o->{'uniq'})) {
|
||||
return LJ::sysban_block($userid, "Support request blocked based on uniq", $log);
|
||||
}
|
||||
|
||||
my $reqsubject = LJ::trim($o->{'subject'});
|
||||
my $reqbody = LJ::trim($o->{'body'});
|
||||
|
||||
unless ($reqsubject) {
|
||||
push @$errors, "You must enter a problem summary.";
|
||||
}
|
||||
unless ($reqbody) {
|
||||
push @$errors, "You did not enter a support request.";
|
||||
}
|
||||
|
||||
my $cats = LJ::Support::load_cats();
|
||||
push @$errors, "Invalid support category" unless $cats->{$o->{'spcatid'}+0};
|
||||
|
||||
if (@$errors) { return 0; }
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
|
||||
my $dup_id = 0;
|
||||
my $qsubject = $dbh->quote($reqsubject);
|
||||
my $qbody = $dbh->quote($reqbody);
|
||||
my $qreqtype = $dbh->quote($o->{'reqtype'});
|
||||
my $qrequserid = $o->{'requserid'}+0;
|
||||
my $qreqname = $dbh->quote($o->{'reqname'});
|
||||
my $qreqemail = $dbh->quote($o->{'reqemail'});
|
||||
my $qspcatid = $o->{'spcatid'}+0;
|
||||
|
||||
my $scat = $cats->{$qspcatid};
|
||||
|
||||
# make the authcode
|
||||
my $authcode = LJ::make_auth_code(15);
|
||||
my $qauthcode = $dbh->quote($authcode);
|
||||
|
||||
my $md5 = md5_hex("$qreqname$qreqemail$qsubject$qbody");
|
||||
my $sth;
|
||||
|
||||
$dbh->do("LOCK TABLES support WRITE, duplock WRITE");
|
||||
$sth = $dbh->prepare("SELECT dupid FROM duplock WHERE realm='support' AND reid=0 AND userid=$qrequserid AND digest='$md5'");
|
||||
$sth->execute;
|
||||
($dup_id) = $sth->fetchrow_array;
|
||||
if ($dup_id) {
|
||||
$dbh->do("UNLOCK TABLES");
|
||||
return $dup_id;
|
||||
}
|
||||
|
||||
my ($urlauth, $url, $spid); # used at the bottom
|
||||
|
||||
my $sql = "INSERT INTO support (spid, reqtype, requserid, reqname, reqemail, state, authcode, spcatid, subject, timecreate, timetouched, timeclosed, timelasthelp) VALUES (NULL, $qreqtype, $qrequserid, $qreqname, $qreqemail, 'open', $qauthcode, $qspcatid, $qsubject, UNIX_TIMESTAMP(), UNIX_TIMESTAMP(), 0, 0)";
|
||||
$sth = $dbh->prepare($sql);
|
||||
$sth->execute;
|
||||
|
||||
if ($dbh->err) {
|
||||
my $error = $dbh->errstr;
|
||||
$dbh->do("UNLOCK TABLES");
|
||||
push @$errors, "<b>Database error:</b> (report this)<br>$error";
|
||||
return 0;
|
||||
}
|
||||
$spid = $dbh->{'mysql_insertid'};
|
||||
|
||||
$dbh->do("INSERT INTO duplock (realm, reid, userid, digest, dupid, instime) VALUES ('support', 0, $qrequserid, '$md5', $spid, NOW())");
|
||||
$dbh->do("UNLOCK TABLES");
|
||||
|
||||
unless ($spid) {
|
||||
push @$errors, "<b>Database error:</b> (report this)<br>Didn't get a spid.";
|
||||
return 0;
|
||||
}
|
||||
|
||||
# save meta-data for this request
|
||||
my @data;
|
||||
my $add_data = sub {
|
||||
my $q = $dbh->quote($_[1]);
|
||||
return unless $q && $q ne 'NULL';
|
||||
push @data, "($spid, '$_[0]', $q)";
|
||||
};
|
||||
$add_data->($_, $o->{$_}) foreach qw(uniq useragent);
|
||||
$dbh->do("INSERT INTO supportprop (spid, prop, value) VALUES " . join(',', @data));
|
||||
|
||||
$dbh->do("INSERT INTO supportlog (splid, spid, timelogged, type, faqid, userid, message) ".
|
||||
"VALUES (NULL, $spid, UNIX_TIMESTAMP(), 'req', 0, $qrequserid, $qbody)");
|
||||
|
||||
my $body;
|
||||
my $miniauth = mini_auth({ 'authcode' => $authcode });
|
||||
$url = "$LJ::SITEROOT/support/see_request.bml?id=$spid";
|
||||
$urlauth = "$url&auth=$miniauth";
|
||||
|
||||
$body = "Your $LJ::SITENAME support request regarding \"$o->{'subject'}\" has been filed and will be answered as soon as possible. Your request tracking number is $spid.\n\n";
|
||||
$body .= "You can track your request's progress or add information here:\n\n ";
|
||||
$body .= $urlauth;
|
||||
$body .= "\n\nIf you figure out the problem before somebody gets back to you, please cancel your request by clicking this:\n\n ";
|
||||
$body .= "$LJ::SITEROOT/support/act.bml?close;$spid;$authcode";
|
||||
|
||||
unless ($scat->{'no_autoreply'})
|
||||
{
|
||||
LJ::send_mail({
|
||||
'to' => $email,
|
||||
'from' => $LJ::BOGUS_EMAIL,
|
||||
'fromname' => "$LJ::SITENAME Support",
|
||||
'charset' => 'utf-8',
|
||||
'subject' => "Support Request \#$spid",
|
||||
'body' => $body
|
||||
});
|
||||
}
|
||||
|
||||
# attempt to buffer job to send email (but don't care if it fails)
|
||||
LJ::do_to_cluster(sub {
|
||||
# first parameter is cluster id
|
||||
return LJ::cmd_buffer_add(shift(@_), 0, 'support_notify', { spid => $spid, type => 'new' });
|
||||
});
|
||||
|
||||
# and we're done
|
||||
return $spid;
|
||||
}
|
||||
|
||||
sub append_request
|
||||
{
|
||||
my $sp = shift; # support request to be appended to.
|
||||
my $re = shift; # hashref of attributes of response to be appended
|
||||
my $sth;
|
||||
|
||||
# $re->{'body'}
|
||||
# $re->{'type'} (req, answer, comment, internal, screened)
|
||||
# $re->{'faqid'}
|
||||
# $re->{'remote'} (remote if known)
|
||||
# $re->{'uniq'} (uniq of remote)
|
||||
|
||||
my $remote = $re->{'remote'};
|
||||
my $posterid = $remote ? $remote->{'userid'} : 0;
|
||||
|
||||
# check for a sysban
|
||||
my $log = { 'uniq' => $re->{'uniq'} };
|
||||
if ($remote) {
|
||||
|
||||
$log->{'user'} = $remote->{'user'};
|
||||
$log->{'email'} = $remote->{'email'};
|
||||
|
||||
if (LJ::sysban_check('support_user', $remote->{'user'})) {
|
||||
return LJ::sysban_block($remote->{'userid'}, "Support request blocked based on user", $log);
|
||||
}
|
||||
if (LJ::sysban_check('support_email', $remote->{'email'})) {
|
||||
return LJ::sysban_block($remote->{'userid'}, "Support request blocked based on email", $log);
|
||||
}
|
||||
}
|
||||
|
||||
if (LJ::sysban_check('support_uniq', $re->{'uniq'})) {
|
||||
my $userid = $remote ? $remote->{'userid'} : 0;
|
||||
return LJ::sysban_block($userid, "Support request blocked based on uniq", $log);
|
||||
}
|
||||
|
||||
my $message = $re->{'body'};
|
||||
$message =~ s/^\s+//;
|
||||
$message =~ s/\s+$//;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
|
||||
my $qmessage = $dbh->quote($message);
|
||||
my $qtype = $dbh->quote($re->{'type'});
|
||||
|
||||
my $qfaqid = $re->{'faqid'}+0;
|
||||
my $quserid = $posterid+0;
|
||||
my $spid = $sp->{'spid'}+0;
|
||||
|
||||
my $sql = "INSERT INTO supportlog (splid, spid, timelogged, type, faqid, userid, message) VALUES (NULL, $spid, UNIX_TIMESTAMP(), $qtype, $qfaqid, $quserid, $qmessage)";
|
||||
$dbh->do($sql);
|
||||
my $splid = $dbh->{'mysql_insertid'};
|
||||
|
||||
if ($posterid) {
|
||||
# add to our index of recently replied to support requests per-user.
|
||||
$dbh->do("INSERT IGNORE INTO support_youreplied (userid, spid) VALUES (?, ?)", undef,
|
||||
$posterid, $spid);
|
||||
die $dbh->errstr if $dbh->err;
|
||||
|
||||
# and also lazily clean out old stuff:
|
||||
$sth = $dbh->prepare("SELECT s.spid FROM support s, support_youreplied yr ".
|
||||
"WHERE yr.userid=? AND yr.spid=s.spid AND s.state='closed' ".
|
||||
"AND s.timeclosed < UNIX_TIMESTAMP() - 3600*72");
|
||||
$sth->execute($posterid);
|
||||
my @to_del;
|
||||
push @to_del, $_ while ($_) = $sth->fetchrow_array;
|
||||
if (@to_del) {
|
||||
my $in = join(", ", map { $_ + 0 } @to_del);
|
||||
$dbh->do("DELETE FROM support_youreplied WHERE userid=? AND spid IN ($in)",
|
||||
undef, $posterid);
|
||||
}
|
||||
}
|
||||
|
||||
# attempt to buffer job to send email (but don't care if it fails)
|
||||
LJ::do_to_cluster(sub {
|
||||
# first parameter is cluster id
|
||||
return LJ::cmd_buffer_add(shift(@_), 0, 'support_notify', { spid => $spid, splid => $splid, type => 'update' });
|
||||
});
|
||||
|
||||
return $splid;
|
||||
}
|
||||
|
||||
# userid may be undef/0 in the setting to zero case
|
||||
sub set_points
|
||||
{
|
||||
my ($spid, $userid, $points) = @_;
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
if ($points) {
|
||||
$dbh->do("REPLACE INTO supportpoints (spid, userid, points) ".
|
||||
"VALUES (?,?,?)", undef, $spid, $userid, $points);
|
||||
} else {
|
||||
$userid ||= $dbh->selectrow_array("SELECT userid FROM supportpoints WHERE spid=?",
|
||||
undef, $spid);
|
||||
$dbh->do("DELETE FROM supportpoints WHERE spid=?", undef, $spid);
|
||||
}
|
||||
|
||||
$dbh->do("REPLACE INTO supportpointsum (userid, totpoints, lastupdate) ".
|
||||
"SELECT userid, SUM(points), UNIX_TIMESTAMP() FROM supportpoints ".
|
||||
"WHERE userid=? GROUP BY 1", undef, $userid) if $userid;
|
||||
}
|
||||
|
||||
sub touch_request
|
||||
{
|
||||
my ($spid) = @_;
|
||||
|
||||
# no touching if the request is locked
|
||||
return 0 if LJ::Support::is_locked($spid);
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
|
||||
$dbh->do("UPDATE support".
|
||||
" SET state='open', timeclosed=0, timetouched=UNIX_TIMESTAMP()".
|
||||
" WHERE spid=?",
|
||||
undef, $spid)
|
||||
or return 0;
|
||||
|
||||
set_points($spid, undef, 0);
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub mail_response_to_user
|
||||
{
|
||||
my $sp = shift;
|
||||
my $splid = shift;
|
||||
|
||||
$splid += 0;
|
||||
|
||||
my $res = load_response($splid);
|
||||
|
||||
my $email;
|
||||
if ($sp->{'reqtype'} eq "email") {
|
||||
$email = $sp->{'reqemail'};
|
||||
} else {
|
||||
my $u = LJ::load_userid($sp->{'requserid'});
|
||||
$email = $u->{'email'};
|
||||
}
|
||||
|
||||
my $spid = $sp->{'spid'}+0;
|
||||
my $faqid = $res->{'faqid'}+0;
|
||||
|
||||
my $type = $res->{'type'};
|
||||
|
||||
# don't mail internal comments (user shouldn't see) or
|
||||
# screened responses (have to wait for somebody to approve it first)
|
||||
return if ($type eq "internal" || $type eq "screened");
|
||||
|
||||
# the only way it can be zero is if it's a reply to an email, so it's
|
||||
# problem the person replying to their own request, so we don't want
|
||||
# to mail them:
|
||||
return unless ($res->{'userid'});
|
||||
|
||||
# also, don't send them their own replies:
|
||||
return if ($sp->{'requserid'} == $res->{'userid'});
|
||||
|
||||
my $body = "";
|
||||
my $dbh = LJ::get_db_writer();
|
||||
my $what = $type eq "answer" ? "an answer to" : "a comment on";
|
||||
$body .= "Below is $what your support question regarding \"$sp->{'subject'}\"\n";
|
||||
|
||||
my $miniauth = mini_auth($sp);
|
||||
$body .= "($LJ::SITEROOT/support/see_request.bml?id=$spid&auth=$miniauth).\n\n";
|
||||
|
||||
$body .= "="x70 . "\n\n";
|
||||
if ($faqid) {
|
||||
my $faqname = "";
|
||||
my $sth = $dbh->prepare("SELECT question FROM faq WHERE faqid=$faqid");
|
||||
$sth->execute;
|
||||
($faqname) = $sth->fetchrow_array;
|
||||
if ($faqname) {
|
||||
$body .= "FAQ REFERENCE: $faqname\n";
|
||||
$body .= "$LJ::SITEROOT/support/faqbrowse.bml?faqid=$faqid";
|
||||
$body .= "\n\n";
|
||||
}
|
||||
}
|
||||
|
||||
$body .= "$res->{'message'}\n\nDid this answer your question?\nYES:\n";
|
||||
|
||||
$body .= "$LJ::SITEROOT/support/act.bml?close;$spid;$sp->{'authcode'}";
|
||||
$body .= ";$splid" if $type eq "answer";
|
||||
$body .= "\nNO:\n$LJ::SITEROOT/support/see_request.bml?id=$spid&auth=$miniauth\n\n";
|
||||
$body .= "If you are having problems using any of the links in this email, please try copying and pasting the *entire* link into your browser's address bar rather than clicking on it.";
|
||||
|
||||
my $fromemail = $LJ::BOGUS_EMAIL;
|
||||
if ($sp->{_cat}->{'replyaddress'}) {
|
||||
my $miniauth = mini_auth($sp);
|
||||
$fromemail = $sp->{_cat}->{'replyaddress'};
|
||||
# insert mini-auth stuff:
|
||||
my $rep = "+${spid}z$miniauth\@";
|
||||
$fromemail =~ s/\@/$rep/;
|
||||
}
|
||||
|
||||
LJ::send_mail({
|
||||
'to' => $email,
|
||||
'from' => $fromemail,
|
||||
'fromname' => "$LJ::SITENAME Support",
|
||||
'charset' => 'utf-8',
|
||||
'subject' => "Re: $sp->{'subject'}",
|
||||
'body' => $body
|
||||
});
|
||||
|
||||
if ($type eq "answer") {
|
||||
$dbh->do("UPDATE support SET timelasthelp=UNIX_TIMESTAMP() WHERE spid=$spid");
|
||||
}
|
||||
}
|
||||
|
||||
sub mini_auth
|
||||
{
|
||||
my $sp = shift;
|
||||
return substr($sp->{'authcode'}, 0, 4);
|
||||
}
|
||||
|
||||
1;
|
||||
35
livejournal/cgi-bin/synlib.pl
Executable file
35
livejournal/cgi-bin/synlib.pl
Executable file
@@ -0,0 +1,35 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
package LJ::Syn;
|
||||
use strict;
|
||||
|
||||
sub get_popular_feeds
|
||||
{
|
||||
my $popsyn = LJ::MemCache::get("popsyn");
|
||||
unless ($popsyn) {
|
||||
$popsyn = [];
|
||||
|
||||
my $dbr = LJ::get_db_reader();
|
||||
my $sth = $dbr->prepare("SELECT userid, synurl, numreaders FROM syndicated ".
|
||||
"WHERE numreaders > 0 ".
|
||||
"AND lastnew > DATE_SUB(NOW(), INTERVAL 14 DAY) ".
|
||||
"ORDER BY numreaders DESC LIMIT 1000");
|
||||
$sth->execute();
|
||||
while (my @row = $sth->fetchrow_array) {
|
||||
push @$popsyn, [ @row ];
|
||||
}
|
||||
|
||||
# load u objects so we can get usernames
|
||||
my %users;
|
||||
LJ::load_userids_multiple([ map { $_, \$users{$_} } map { $_->[0] } @$popsyn ]);
|
||||
unshift @$_, $users{$_->[0]}->{'user'}, $users{$_->[0]}->{'name'} foreach @$popsyn;
|
||||
# format is: [ user, name, userid, synurl, numreaders ]
|
||||
# set in memcache
|
||||
my $expire = time() + 3600; # 1 hour
|
||||
LJ::MemCache::set("popsyn", $popsyn, $expire);
|
||||
}
|
||||
return $popsyn;
|
||||
}
|
||||
|
||||
1;
|
||||
175
livejournal/cgi-bin/sysban.pl
Executable file
175
livejournal/cgi-bin/sysban.pl
Executable file
@@ -0,0 +1,175 @@
|
||||
#!/usr/bin/perl
|
||||
#
|
||||
|
||||
use strict;
|
||||
|
||||
package LJ;
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::sysban_check
|
||||
# des: Given a 'what' and 'value', checks to see if a ban exists
|
||||
# args: what, value
|
||||
# des-what: The ban type
|
||||
# des-value: The value which triggers the ban
|
||||
# returns: 1 if a ban exists, 0 otherwise
|
||||
# </LJFUNC>
|
||||
sub sysban_check {
|
||||
my ($what, $value) = @_;
|
||||
|
||||
# cache if ip ban
|
||||
if ($what eq 'ip') {
|
||||
|
||||
my $now = time();
|
||||
my $ip_ban_delay = $LJ::SYSBAN_IP_REFRESH || 120;
|
||||
|
||||
# check memcache first if not loaded
|
||||
unless ($LJ::IP_BANNED_LOADED + $ip_ban_delay > $now) {
|
||||
my $memval = LJ::MemCache::get("sysban:ip");
|
||||
if ($memval) {
|
||||
*LJ::IP_BANNED = $memval;
|
||||
$LJ::IP_BANNED_LOADED = $now;
|
||||
} else {
|
||||
$LJ::IP_BANNED_LOADED = 0;
|
||||
}
|
||||
}
|
||||
|
||||
# is it already cached in memory?
|
||||
if ($LJ::IP_BANNED_LOADED) {
|
||||
return (defined $LJ::IP_BANNED{$value} &&
|
||||
($LJ::IP_BANNED{$value} == 0 || # forever
|
||||
$LJ::IP_BANNED{$value} > time())); # not-expired
|
||||
}
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return undef unless $dbh;
|
||||
|
||||
# build cache from db
|
||||
%LJ::IP_BANNED = ();
|
||||
my $sth = $dbh->prepare("SELECT value, UNIX_TIMESTAMP(banuntil) FROM sysban " .
|
||||
"WHERE status='active' AND what='ip' " .
|
||||
"AND NOW() > bandate " .
|
||||
"AND (NOW() < banuntil OR banuntil IS NULL)");
|
||||
$sth->execute;
|
||||
return undef if $dbh->err;
|
||||
while (my ($val, $exp) = $sth->fetchrow_array) {
|
||||
$LJ::IP_BANNED{$val} = $exp || 0;
|
||||
}
|
||||
|
||||
# set in memcache
|
||||
LJ::MemCache::set("sysban:ip", \%LJ::IP_BANNED, $ip_ban_delay);
|
||||
$LJ::IP_BANNED_LOADED = time();
|
||||
|
||||
# return value to user
|
||||
return $LJ::IP_BANNED{$value};
|
||||
}
|
||||
|
||||
# cache if uniq ban
|
||||
if ($what eq 'uniq') {
|
||||
|
||||
# check memcache first if not loaded
|
||||
unless ($LJ::UNIQ_BANNED_LOADED) {
|
||||
my $memval = LJ::MemCache::get("sysban:uniq");
|
||||
if ($memval) {
|
||||
*LJ::UNIQ_BANNED = $memval;
|
||||
$LJ::UNIQ_BANNED_LOADED++;
|
||||
}
|
||||
}
|
||||
|
||||
# is it already cached in memory?
|
||||
if ($LJ::UNIQ_BANNED_LOADED) {
|
||||
return (defined $LJ::UNIQ_BANNED{$value} &&
|
||||
($LJ::UNIQ_BANNED{$value} == 0 || # forever
|
||||
$LJ::UNIQ_BANNED{$value} > time())); # not-expired
|
||||
}
|
||||
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return undef unless $dbh;
|
||||
|
||||
# set this now before the query
|
||||
$LJ::UNIQ_BANNED_LOADED++;
|
||||
|
||||
# build cache from db
|
||||
%LJ::UNIQ_BANNED = ();
|
||||
my $sth = $dbh->prepare("SELECT value, UNIX_TIMESTAMP(banuntil) FROM sysban " .
|
||||
"WHERE status='active' AND what='uniq' " .
|
||||
"AND NOW() > bandate " .
|
||||
"AND (NOW() < banuntil OR banuntil IS NULL)");
|
||||
$sth->execute();
|
||||
return undef $LJ::UNIQ_BANNED_LOADED if $sth->err;
|
||||
while (my ($val, $exp) = $sth->fetchrow_array) {
|
||||
$LJ::UNIQ_BANNED{$val} = $exp || 0;
|
||||
}
|
||||
|
||||
# set in memcache
|
||||
my $exp = 60*15; # 15 minutes
|
||||
LJ::MemCache::set("sysban:uniq", \%LJ::UNIQ_BANNED, $exp);
|
||||
|
||||
# return value to user
|
||||
return $LJ::UNIQ_BANNED{$value};
|
||||
}
|
||||
|
||||
# non-ip bans come straight from the db
|
||||
my $dbh = LJ::get_db_writer();
|
||||
return undef unless $dbh;
|
||||
|
||||
return $dbh->selectrow_array("SELECT COUNT(*) FROM sysban " .
|
||||
"WHERE status='active' AND what=? AND value=? " .
|
||||
"AND NOW() > bandate " .
|
||||
"AND (NOW() < banuntil OR banuntil=0 OR banuntil IS NULL)",
|
||||
undef, $what, $value);
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::sysban_note
|
||||
# des: Inserts a properly-formatted row into statushistory noting that a ban has been triggered
|
||||
# args: userid?, notes, vars
|
||||
# des-userid: The userid which triggered the ban, if available
|
||||
# des-notes: A very brief description of what triggered the ban
|
||||
# des-vars: A hashref of helpful variables to log, keys being variable name and values being values
|
||||
# returns: nothing
|
||||
# </LJFUNC>
|
||||
sub sysban_note
|
||||
{
|
||||
my ($userid, $notes, $vars) = @_;
|
||||
|
||||
$notes .= ":";
|
||||
map { $notes .= " $_=$vars->{$_};" if $vars->{$_} } sort keys %$vars;
|
||||
LJ::statushistory_add($userid, 0, 'sysban_trig', $notes);
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
# <LJFUNC>
|
||||
# name: LJ::sysban_block
|
||||
# des: Notes a sysban in statushistory and returns a fake http error message to the user
|
||||
# args: userid?, notes, vars
|
||||
# des-userid: The userid which triggered the ban, if available
|
||||
# des-notes: A very brief description of what triggered the ban
|
||||
# des-vars: A hashref of helpful variables to log, keys being variable name and values being values
|
||||
# returns: nothing
|
||||
# </LJFUNC>
|
||||
sub sysban_block
|
||||
{
|
||||
my ($userid, $notes, $vars) = @_;
|
||||
|
||||
LJ::sysban_note($userid, $notes, $vars);
|
||||
|
||||
my $msg = <<'EOM';
|
||||
<html>
|
||||
<head>
|
||||
<title>503 Service Unavailable</title>
|
||||
</head>
|
||||
<body>
|
||||
<h1>503 Service Unavailable</h1>
|
||||
The service you have requested is temporarily unavailable.
|
||||
</body>
|
||||
</html>
|
||||
EOM
|
||||
|
||||
# may not run from web context (e.g. mailgated.pl -> supportlib -> ..)
|
||||
eval { BML::http_response(200, $msg); };
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
1185
livejournal/cgi-bin/taglib.pl
Executable file
1185
livejournal/cgi-bin/taglib.pl
Executable file
File diff suppressed because it is too large
Load Diff
3095
livejournal/cgi-bin/talklib.pl
Executable file
3095
livejournal/cgi-bin/talklib.pl
Executable file
File diff suppressed because it is too large
Load Diff
3
livejournal/cgi-bin/userpicmagic.txt
Executable file
3
livejournal/cgi-bin/userpicmagic.txt
Executable file
@@ -0,0 +1,3 @@
|
||||
0 beshort 0xffd8 image/jpeg
|
||||
0 string GIF image/gif
|
||||
0 string \211PNG image/png
|
||||
1762
livejournal/cgi-bin/weblib.pl
Executable file
1762
livejournal/cgi-bin/weblib.pl
Executable file
File diff suppressed because it is too large
Load Diff
Reference in New Issue
Block a user