Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: fda1c295ac
Fetching contributors…

Cannot retrieve contributors at this time

12670 lines (11072 sloc) 410.122 kb
# This code is a part of Slash, and is released under the GPL.
# Copyright 1997-2005 by Open Source Technology Group. See README
# and COPYING for more information, or see http://slashcode.com/.
package Slash::DB::MySQL;
use strict;
use Socket;
use Digest::MD5 'md5_hex';
use Time::HiRes;
use Time::Local;
use Date::Format qw(time2str);
use Data::Dumper;
use Slash::Utility;
use Storable qw(thaw nfreeze);
use URI ();
use Slash::Custom::ParUserAgent;
use vars qw($_proxy_port);
use base 'Slash::DB';
use base 'Slash::DB::Utility';
use Slash::Constants ':messages';
our $VERSION = $Slash::Constants::VERSION;
# Fry: How can I live my life if I can't tell good from evil?
# For the getDescriptions() method
my %descriptions = (
'sortcodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='sortcodes'") },
'generic'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='$_[2]'") },
'genericstring'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='$_[2]'") },
'statuscodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='statuscodes'") },
'yes_no'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='yes_no'") },
'story023'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='story023'") },
'submission-notes'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='submission-notes'") },
'submission-state'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='submission-state'") },
'months'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='months'") },
'years'
=> sub { $_[0]->sqlSelectMany('name,name', 'code_param', "type='years'") },
'blocktype'
=> sub { $_[0]->sqlSelectMany('name,name', 'code_param', "type='blocktype'") },
'tzcodes'
=> sub { $_[0]->sqlSelectMany('tz,off_set', 'tzcodes') },
'tzdescription'
=> sub { $_[0]->sqlSelectMany('tz,description', 'tzcodes') },
'dateformats'
=> sub { $_[0]->sqlSelectMany('id,description', 'dateformats') },
'datecodes'
=> sub { $_[0]->sqlSelectMany('id,format', 'dateformats') },
'discussiontypes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='discussiontypes'") },
'commentmodes'
=> sub { $_[0]->sqlSelectMany('mode,name', 'commentmodes') },
'threshcodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='threshcodes'") },
'threshcode_values'
=> sub { $_[0]->sqlSelectMany('code,code', 'code_param', "type='threshcodes'") },
'postmodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='postmodes'") },
'issuemodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='issuemodes'") },
'vars'
=> sub { $_[0]->sqlSelectMany('name,name', 'vars') },
'topics'
=> sub { $_[0]->sqlSelectMany('tid,textname', 'topics') },
'non_nexus_topics'
=> sub { $_[0]->sqlSelectMany('topics.tid AS tid,textname', 'topics LEFT JOIN topic_nexus ON topic_nexus.tid=topics.tid', "topic_nexus.tid IS NULL") },
'highlighted-topics-submittable'
=> sub { $_[0]->sqlSelectMany('topics.tid AS tid, IF(topic_nexus.tid IS NULL, textname, CONCAT("*",textname))', 'topics LEFT JOIN topic_nexus ON topic_nexus.tid=topics.tid', "submittable='yes'") },
'non_nexus_topics-submittable'
=> sub { $_[0]->sqlSelectMany('topics.tid AS tid,textname', 'topics LEFT JOIN topic_nexus ON topic_nexus.tid=topics.tid', "topic_nexus.tid IS NULL AND submittable='yes'") },
'non_nexus_topics-storypickable'
=> sub { $_[0]->sqlSelectMany('topics.tid AS tid,textname', 'topics LEFT JOIN topic_nexus ON topic_nexus.tid=topics.tid', "topic_nexus.tid IS NULL AND storypickable='yes'") },
'nexus_topics'
=> sub { $_[0]->sqlSelectMany('topics.tid AS tid,textname', 'topics, topic_nexus', 'topic_nexus.tid=topics.tid') },
'maillist'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='maillist'") },
'session_login'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='session_login'") },
'cookie_location'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='cookie_location'") },
'sortorder'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='sortorder'") },
'displaycodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='displaycodes'") },
'displaycodes_sectional'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='displaycodes_sectional'") },
'commentcodes'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='commentcodes'") },
'commentcodes_extended'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='commentcodes' OR type='commentcodes_extended'") },
'skins'
=> sub { $_[0]->sqlSelectMany('skid,title', 'skins') },
'skins-all'
=> sub { $_[0]->sqlSelectMany('skid,title', 'skins') },
'skins-submittable'
=> sub { $_[0]->sqlSelectMany('skid,title', 'skins', "submittable='yes'") },
'skins-searchable'
=> sub { $_[0]->sqlSelectMany('skid,title', 'skins', "searchable='yes'") },
'skins-storypickable'
=> sub { $_[0]->sqlSelectMany('skid,title', 'skins', "storypickable='yes'") },
'topics-submittable'
=> sub { $_[0]->sqlSelectMany('tid,textname', 'topics', "submittable='yes'") },
'topics-searchable'
=> sub { $_[0]->sqlSelectMany('tid,textname', 'topics', "searchable='yes'") },
'topics-storypickable'
=> sub { $_[0]->sqlSelectMany('tid,textname', 'topics', "storypickable='yes'") },
'static_block'
=> sub { $_[0]->sqlSelectMany('bid,bid', 'blocks', "$_[2] >= seclev AND type != 'portald'") },
'portald_block'
=> sub { $_[0]->sqlSelectMany('bid,bid', 'blocks', "$_[2] >= seclev AND type = 'portald'") },
'static_block_section'
=> sub { $_[0]->sqlSelectMany('bid,bid', 'blocks', "$_[2]->{seclev} >= seclev AND section='$_[2]->{section}' AND type != 'portald'") },
'portald_block_section'
=> sub { $_[0]->sqlSelectMany('bid,bid', 'blocks', "$_[2]->{seclev} >= seclev AND section='$_[2]->{section}' AND type = 'portald'") },
'color_block'
=> sub { $_[0]->sqlSelectMany('bid,bid', 'blocks', "type = 'color'") },
'authors'
=> sub { $_[0]->sqlSelectMany('uid,nickname', 'authors_cache', "author = 1") },
'all-authors'
=> sub { $_[0]->sqlSelectMany('uid,nickname', 'authors_cache') },
'admins'
=> sub { $_[0]->sqlSelectMany('uid,nickname', 'users', 'seclev >= 100') },
'users'
=> sub { $_[0]->sqlSelectMany('uid,nickname', 'users') },
'templates'
=> sub { $_[0]->sqlSelectMany('tpid,name', 'templates') },
'keywords'
=> sub { $_[0]->sqlSelectMany('id,CONCAT(keyword, " - ", name)', 'related_links') },
'pages'
=> sub { $_[0]->sqlSelectMany('distinct page,page', 'templates') },
'templateskins'
=> sub { $_[0]->sqlSelectMany('DISTINCT skin, skin', 'templates') },
'plugins'
=> sub { $_[0]->sqlSelectMany('value,description', 'site_info', "name='plugin'") },
'site_info'
=> sub { $_[0]->sqlSelectMany('name,value', 'site_info', "name != 'plugin'") },
'forms'
=> sub { $_[0]->sqlSelectMany('value,value', 'site_info', "name = 'form'") },
'journal_discuss'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='journal_discuss'") },
'section_extra_types'
=> sub { $_[0]->sqlSelectMany('code,name', 'code_param', "type='extra_types'") },
'otherusersparam'
=> sub { $_[0]->sqlSelectMany('code,name', 'string_param', "type='otherusersparam'") },
'bytelimit'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='bytelimit'") },
'bytelimit_sub'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='bytelimit' OR type='bytelimit_sub'") },
'countries'
=> sub { $_[0]->sqlSelectMany(
'code,CONCAT(code," (",name,")") as name',
'string_param',
'type="iso_countries"',
'ORDER BY name'
);
},
'us_states'
=> sub { $_[0]->sqlSelectMany(
'code,CONCAT(code," (",name,")") as name',
'string_param',
'type="us_states"',
'ORDER BY name'
);
},
'ca_provinces'
=> sub { $_[0]->sqlSelectMany(
'code,CONCAT(code," (",name,")") as name',
'string_param',
'type="ca_provinces"',
'ORDER BY name'
);
},
'states_and_provinces'
=> sub { $_[0]->sqlSelectMany(
'code,CONCAT(code," (",name,")") as name',
'string_param',
'type="ca_provinces" OR type="us_states"',
'ORDER BY name'
);
},
'forums'
=> sub { $_[0]->sqlSelectMany('subsections.id, subsections.title', 'section_subsections, subsections', "section_subsections.subsection=subsections.id AND section_subsections.section='forums'") },
'discussion_kinds'
=> sub { $_[0]->sqlSelectMany('dkid, name', 'discussion_kinds') },
'd2_comment_q'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='d2_comment_q' AND code != 0") },
'd2_comment_q_all'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='d2_comment_q'") },
'd2_comment_limits'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='d2_comment_limits'") },
'd2_comment_order'
=> sub { $_[0]->sqlSelectMany('code, name', 'code_param', "type='d2_comment_order'") },
'mediatypes'
=> sub { $_[0]->sqlSelectMany('code, name', 'string_param', "type='mediatypes'")}
);
########################################################
sub _whereFormkey {
my($self, $options) = @_;
my $ipid = getCurrentUser('ipid');
my $uid = getCurrentUser('uid');
my $where;
# anonymous user without cookie, check host, not ipid
if (isAnon($uid) || $options->{force_ipid}) {
$where = "ipid = '$ipid'";
} else {
$where = "uid = '$uid'";
}
return $where;
};
# XXX I don't think this method is used anywhere. Also, I'm
# really sure these "Notes" are about five years out of date.
# Can we delete this code? - Jamie, August 2006
# (It's used in Slash::DB::Utility::new)
########################################################
# Notes:
# formAbuse, use defaults as ENV, be able to override
# (pudge idea).
# description method cleanup. (done)
# fetchall_rowref vs fetch the hashses and push'ing
# them into an array (good arguments for both)
# break up these methods into multiple classes and
# use the dB classes to override methods (this
# could end up being very slow though since the march
# is kinda slow...).
# the getAuthorEdit() methods need to be refined
########################################################
########################################################
sub init {
my($self) = @_;
# These are here to remind us of what exists
$self->{_codeBank} = {};
$self->{_boxes} = {};
$self->{_sectionBoxes} = {};
$self->{_comment_text} = {};
$self->{_comment_text_full} = {};
$self->{_story_comm} = {};
# Do all cache elements contain '_cache_' in it, if so, we should
# probably perform a delete on anything matching, here.
}
# XXX I'm pretty sure these next 3 methods can be eliminated
# from the code. Or, they can actually be written properly and
# everyplace we do sqlDo("AUTOCOMMIT=0") we can use these
# instead. Of course the Finish/Cancel would do
# COMMIT/ROLLBACK. - Jamie, August 2006
########################################################
# Yes, this is ugly, and we can ditch it in about 6 months
# Turn off autocommit here
sub sqlTransactionStart {
my($self, $arg) = @_;
$self->sqlDo($arg);
}
########################################################
# Put commit here
sub sqlTransactionFinish {
my($self) = @_;
$self->sqlDo("UNLOCK TABLES");
}
########################################################
# In another DB put rollback here
sub sqlTransactionCancel {
my($self) = @_;
$self->sqlDo("UNLOCK TABLES");
}
########################################################
sub getBadgeDescriptions {
my($self) = @_;
return $self->{_badge_cache} ||= $self->sqlSelectAllHashref(
'badge_id', 'badge_id,badge_icon,badge_text,badge_url', 'badge_ids'
);
}
########################################################
sub createComment {
my($self, $comment) = @_;
return -1 unless dbAvailable("write_comments");
my $comment_text = $comment->{comment};
delete $comment->{comment};
$comment->{signature} = md5_hex($comment_text);
$comment->{-date} = 'NOW()';
$comment->{len} = length($comment_text);
$comment->{pointsorig} = $comment->{points} || 0;
$comment->{pointsmax} = $comment->{points} || 0;
$comment->{sid} = $self->getStoidFromSidOrStoid($comment->{sid})
or return -1;
if ($comment->{pid}) {
# If we're being asked to parent this comment to another,
# verify that the other comment exists and is in this
# same discussion.
my $pid_sid = 0;
my $pid_q = $self->sqlQuote($comment->{pid});
$pid_sid = $self->sqlSelect('sid', 'comments', "cid=$pid_q");
return -1 unless $pid_sid && $pid_sid == $comment->{sid};
my $pid_subject = '';
$pid_subject = $self->sqlSelect("subject", "comments",
"cid=" . $self->sqlQuote($comment->{pid}));
# see comments.pl:editComment()
$pid_subject =~ s/^Re://i;
$pid_subject =~ s/\s\s/ /g;
if (length $pid_subject &&
$comment->{subject} =~ /^Re:\Q$pid_subject\E$/) {
$comment->{subject_orig} = 'no';
}
}
$comment->{subject} = $self->truncateStringForCharColumn($comment->{subject},
'comments', 'subject');
$comment->{badge_id} = 0;
my $user_comm = $self->getUser($comment->{uid});
$comment->{badge_id} = $user_comm->{acl}{employee} && $user_comm->{badge_id}
? $user_comm->{badge_id}
: 0;
$self->sqlDo("SET AUTOCOMMIT=0");
my $cid;
if ($self->sqlInsert('comments', $comment)) {
$cid = $self->getLastInsertId();
} else {
$self->sqlDo("ROLLBACK");
$self->sqlDo("SET AUTOCOMMIT=1");
errorLog("$DBI::errstr");
return -1;
}
unless ($self->sqlInsert('comment_text', {
cid => $cid,
comment => $comment_text,
})) {
$self->sqlDo("ROLLBACK");
$self->sqlDo("SET AUTOCOMMIT=1");
errorLog("$DBI::errstr");
return -1;
}
# should this be conditional on the others happening?
# is there some sort of way to doublecheck that this value
# is correct? -- pudge
# This is fine as is; if the insert failed, we've already
# returned out of this method. - Jamie
unless ($self->sqlUpdate(
"discussions",
{ -commentcount => 'commentcount+1' },
"id=$comment->{sid}",
)) {
$self->sqlDo("ROLLBACK");
$self->sqlDo("SET AUTOCOMMIT=1");
errorLog("$DBI::errstr");
return -1;
}
$self->sqlDo("COMMIT");
$self->sqlDo("SET AUTOCOMMIT=1");
my $searchtoo = getObject('Slash::SearchToo');
if ($searchtoo) {
# $searchtoo->storeRecords(comments => $cid, { add => 1 });
}
return $cid;
}
sub createCommentLog {
my($self, $data) = @_;
$data->{'-ts'} = "NOW()";
$self->sqlInsert("comment_log", $data);
}
sub getRecentCommentLog {
my($self, $options) = @_;
$self->sqlSelectAllHashrefArray("*", "comment_log, comments",
"comment_log.cid=comments.cid", "ORDER BY ts DESC LIMIT 100"
);
}
########################################################
# Right now, $from and $reason don't matter, but they
# might someday.
sub getModPointsNeeded {
my($self, $from, $to, $reason) = @_;
# Always 1 point for a downmod.
return 1 if $to < $from;
my $constants = getCurrentStatic();
my $pn = $constants->{mod_up_points_needed} || {};
return $pn->{$to} || 1;
}
sub getCSSValuesHashForCol {
my($self, $col) = @_;
my $values = $self->sqlSelectColArrayref($col, 'css', '', '', { distinct => 1 });
my $result = { map { $_ => 1 } @$values };
return $result;
}
sub getCSS {
my($self) = @_;
my $user = getCurrentUser();
my $page = $user->{currentPage};
my $skin = getCurrentSkin('name');
my $admin = $user->{is_admin};
my $theme = ($user->{simpledesign} || $user->{pda}) ? "light" : $user->{css_theme};
my $constants = getCurrentStatic();
my $expire_time = $constants->{css_expire} || 3600;
$expire_time += int(rand(60)) if $expire_time;
_genericCacheRefresh($self, 'css', $expire_time);
_genericCacheRefresh($self, 'css_pages', $expire_time);
_genericCacheRefresh($self, 'css_skins', $expire_time);
_genericCacheRefresh($self, 'css_themes', $expire_time);
my $css_ref = $self->{_css_cache} ||= {};
my $css_pages_ref = $self->{_css_pages_cache};
my $css_skins_ref = $self->{_css_skins_cache};
my $css_themes_ref = $self->{_css_themes_cache};
$css_pages_ref = $self->getCSSValuesHashForCol('page') if !$css_pages_ref;
$css_skins_ref = $self->getCSSValuesHashForCol('skin') if !$css_skins_ref;
$css_themes_ref= $self->getCSSValuesHashForCol('theme') if !$css_themes_ref;
my $lowbandwidth = ($user->{lowbandwidth} || $user->{pda}) ? "yes" : "no";
$page = '' if !$css_pages_ref->{$page};
$skin = '' if !$css_skins_ref->{$skin};
$theme = '' if !$css_themes_ref->{$theme};
return $css_ref->{$skin}{$page}{$admin}{$theme}{$lowbandwidth}
if exists $css_ref->{$skin}{$page}{$admin}{$theme}{$lowbandwidth};
my @clauses;
my $page_q = $self->sqlQuote($page);
my $page_in = $page ? "(page = '' or page = $page_q)" : "page = ''";
push @clauses, $page_in;
my $skin_in = $skin ? "(skin = '' or skin = '$skin')" : "skin = ''";
push @clauses, $skin_in;
push @clauses, "admin='no'" if !$admin;
my $theme_q = $self->sqlQuote($theme);
my $theme_in = $theme ? "(theme='' or theme=$theme_q)" : "theme=''";
push @clauses, $theme_in;
push @clauses, "lowbandwidth='$lowbandwidth'" if $lowbandwidth eq "no";
my $where = "css.ctid=css_type.ctid AND ";
$where .= join ' AND ', @clauses;
my $css = $self->sqlSelectAllHashrefArray("rel,type,media,file,title,ie_cond", "css, css_type", $where, "ORDER BY css_type.ordernum, css.ordernum");
$css_ref->{$skin}{$page}{$admin}{$theme}{$lowbandwidth} = $css;
return $css;
}
########################################################
# ok, I was tired of trying to mold getDescriptions into
# taking more args.
sub getTemplateList {
my($self, $skin, $page) = @_;
my $templatelist = {};
my $where = "seclev <= " . getCurrentUser('seclev');
$where .= " AND skin = '$skin'" if $skin;
$where .= " AND page = '$page'" if $page;
my $qlid = $self->_querylog_start("SELECT", "templates");
my $sth = $self->sqlSelectMany('tpid,name', 'templates', $where);
while (my($tpid, $name) = $sth->fetchrow) {
$templatelist->{$tpid} = $name;
}
$self->_querylog_finish($qlid);
return $templatelist;
}
########################################################
sub getTopicParam {
my($self, $tid_wanted, $val, $force_cache_freshen) = @_;
my $constants = getCurrentStatic();
my $table_cache = "_topicparam_cache";
my $table_cache_time = "_topicparam_cache_time";
return undef unless $tid_wanted;
_genericCacheRefresh($self, 'topicparam', $constants->{block_expire});
my $is_in_local_cache = exists $self->{$table_cache}{$tid_wanted};
my $use_local_cache = $is_in_local_cache && !$force_cache_freshen;
if (!$is_in_local_cache || $force_cache_freshen) {
my $tid_clause = "tid=".$self->sqlQuote($tid_wanted);
my $params = $self->sqlSelectAllKeyValue('name,value', 'topic_param', $tid_clause);
$self->{$table_cache_time} = time() if !$self->{$table_cache_time};
$self->{$table_cache}{$tid_wanted} = $params;
}
my $hr = $self->{$table_cache}{$tid_wanted};
my $retval;
if ($val && !ref $val) {
if (exists $hr->{$val}) {
$retval = $hr->{$val};
}
} else {
my %return = %$hr;
$retval = \%return;
}
return $retval;
}
########################################################
# If no tid is given, returns the whole tree. Otherwise,
# returns the data for the topic with that numeric id.
#
# Feb 2005 - Topic params no longer kept in tree, should
# be fetched with getTopicParam
sub getTopicTree {
my($self, $tid_wanted, $options) = @_;
my $constants = getCurrentStatic();
my $table_cache = "_topictree_cache";
my $table_cache_time = "_topictree_cache_time";
_genericCacheRefresh($self, 'topictree',
$options->{no_cache} ? -1 : $constants->{block_expire}
);
if ($self->{$table_cache_time}) {
if ($tid_wanted) {
return $self->{$table_cache}{$tid_wanted} || undef;
} else {
return $self->{$table_cache};
}
}
# Cache needs to be built, so build it.
my $tree_ref = $self->{$table_cache} ||= {};
if (my $regex = $constants->{debughash_getTopicTree}) {
$tree_ref = debugHash($regex, $tree_ref) unless tied($tree_ref);
}
my $topics = $self->sqlSelectAllHashref("tid", "*", "topics");
my $topic_nexus = $self->sqlSelectAllHashref("tid", "*", "topic_nexus");
my $topic_nexus_dirty = $self->sqlSelectAllHashref("tid", "*", "topic_nexus_dirty");
my $topic_parents = $self->sqlSelectAllHashrefArray("*", "topic_parents");
for my $tid (keys %$topics) {
$tree_ref->{$tid} = $topics->{$tid};
$tree_ref->{$tid}{submittable} = $topics->{$tid}{submittable} eq "yes" ? 1 : 0;
$tree_ref->{$tid}{searchable} = $topics->{$tid}{searchable} eq "yes" ? 1 : 0;
$tree_ref->{$tid}{storypickable} = $topics->{$tid}{storypickable} eq "yes" ? 1 : 0;
}
for my $tid (keys %$topic_nexus) {
$tree_ref->{$tid}{nexus} = 1;
for my $key (keys %{$topic_nexus->{$tid}}) {
$tree_ref->{$tid}{$key} = $topic_nexus->{$tid}{$key};
}
}
for my $tid (keys %$topic_nexus_dirty) {
$tree_ref->{$tid}{nexus_dirty} = 1;
}
for my $tp_hr (@$topic_parents) {
my($parent, $child, $m_w) = @{$tp_hr}{qw( parent_tid tid min_weight )};
$tree_ref->{$child}{parent}{$parent} = $m_w;
$tree_ref->{$parent}{child}{$child} = $m_w;
}
for my $tid (keys %$tree_ref) {
if (exists $tree_ref->{$tid}{child}) {
my $c_hr = $tree_ref->{$tid}{child};
my @child_ids = sort {
$tree_ref->{$a}{textname} cmp $tree_ref->{$b}{textname}
||
$tree_ref->{$a}{keyword} cmp $tree_ref->{$b}{keyword}
||
$a <=> $b
} keys %$c_hr;
$tree_ref->{$tid}{children} = [ @child_ids ];
}
if (exists $tree_ref->{$tid}{parent}) {
my $p_hr = $tree_ref->{$tid}{parent};
my @parent_ids = sort {
$tree_ref->{$a}{textname} cmp $tree_ref->{$b}{textname}
||
$tree_ref->{$a}{keyword} cmp $tree_ref->{$b}{keyword}
||
$a <=> $b
} keys %$p_hr;
$tree_ref->{$tid}{parents} = [ @parent_ids ];
}
}
my $skins = $self->getSkins();
for my $skid (keys %$skins) {
next unless $skins->{$skid}{nexus};
$tree_ref->{$skins->{$skid}{nexus}}{skid} = $skid;
}
$self->confirmTopicTree($tree_ref);
$self->{$table_cache} = $tree_ref;
$self->{$table_cache_time} = time;
if ($tid_wanted) {
return $tree_ref->{$tid_wanted} || undef;
} else {
return $tree_ref;
}
}
########################################################
# Given a topic tree, check it for loops (trees should not have
# loops). Die if there's an error.
sub confirmTopicTree {
my($self, $tree) = @_;
# First, get the "central tree." This is the tree that excludes
# recursively all leaf nodes. A leaf node is a topic which
# has fewer than two other topics attached to it. Such a node
# obviously cannot be part of any loop. By removing the outer
# layer so to speak of such topics, then repeating the removal
# until the tree does not change, we are left with a smaller
# tree (possibly empty) which will be faster to check for loops.
# For example, if a tree consists of A->B->C, the first pass
# will strip off A and C since they have only one node connecting
# to a non-leaf; the second pass strips off B since it now has
# zero nodes connecting to non-leafs.
#my $start_time = Time::HiRes::time;
my $n_tree_keys = scalar(keys %$tree);
my %leaf = ( );
while (1) {
my $n_start_leaf_keys = scalar(keys %leaf);
#print STDERR scalar(keys %leaf) . " leaf keys START: " . join(" ", sort { $a <=> $b } keys %leaf) . "\n";
for my $tid (sort { $a <=> $b } keys %$tree) {
next if $leaf{$tid};
my $links = 0;
my @parents = ( ); my @children = ( );
if ($tree->{$tid}{parents}) {
@parents = grep { !$leaf{$_} } @{ $tree->{$tid}{parents} };
$links += scalar @parents;
}
if ($tree->{$tid}{children}) {
@children = grep { !$leaf{$_} } @{ $tree->{$tid}{children} };
$links += scalar @children;
}
#print STDERR "tid $tid has $links non-leaf: parents '@parents' children '@children'\n";
if ($links < 2) {
$leaf{$tid} = 1;
}
}
#print STDERR scalar(keys %leaf) . " leaf keys END: " . join(" ", sort { $a <=> $b } keys %leaf) . "\n";
# If that didn't turn up any new leaf nodes, or if
# that's the whole tree, we've found them all.
last if scalar(keys %leaf) == $n_start_leaf_keys
|| scalar(keys %leaf) == $n_tree_keys;
}
#print STDERR scalar(localtime) . " tree " . scalar(keys %$tree) . " nodes, of which " . scalar(keys %leaf) . " are leaf nodes\n";
# If the entire tree is made up of leaf nodes, we're done already.
return 1 if scalar(keys %leaf) == scalar(keys %$tree);
# We walk the remaining tree recursively. First scanning down for
# children, then up for parents. Along the way, we mark vetted
# topics, as they are vetted, in the $vetted hashref.
sub _vet_node_children {
my($tree, $leaf, $vetted, $tid, $parents) = @_;
return if $vetted->{$tid};
if ($parents->{$tid}) {
die "Topic tree error: loop found at tid $tid, parents "
. join(" ", sort { $a <=> $b } keys %$parents );
}
return unless $tree->{$tid}{children};
my @children = grep { !$leaf->{$_} && !$vetted->{$_} } @{ $tree->{$tid}{children} };
for my $child (@children) {
my %parents_copy = %$parents;
$parents_copy{$tid} = 1;
#print STDERR "tid $tid child-recursing down to $child with parents: " . join(" ", sort { $a <=> $b } keys %parents_copy ) . "\n";
_vet_node_children($tree, $leaf, $vetted, $child, \%parents_copy);
}
#print STDERR "vetted for children: $tid (parents: " . join(" ", sort { $a <=> $b } keys %$parents ) . ")\n";
$vetted->{$tid} = 1;
}
sub _vet_node_parents {
my($tree, $leaf, $vetted, $tid, $children) = @_;
return if $vetted->{$tid};
if ($children->{$tid}) {
die "Topic tree error: loop found at tid $tid, children "
. join(" ", sort { $a <=> $b } keys %$children );
}
return unless $tree->{$tid}{parents};
my @parents = grep { !$leaf->{$_} && !$vetted->{$_} } @{ $tree->{$tid}{parents} };
for my $parent (@parents) {
my %children_copy = %$children;
$children_copy{$tid} = 1;
#print STDERR "tid $tid parent-recursing up to $parent with children: " . join(" ", sort { $a <=> $b } keys %children_copy ) . "\n";
_vet_node_parents($tree, $leaf, $vetted, $parent, \%children_copy);
}
#print STDERR "vetted for parents: $tid (children: " . join(" ", sort { $a <=> $b } keys %$children ) . ")\n";
$vetted->{$tid} = 1;
}
my %vetted_children = ( );
my %vetted_parents = ( );
for my $tid (sort { $a <=> $b } grep { !$leaf{$_} } keys %$tree) {
#print STDERR "BEGIN vetting $tid (" . scalar(keys %vetted_children) . " vetted children, " . scalar(keys %vetted_parents) . " vetted parents)\n";
_vet_node_children($tree, \%leaf, \%vetted_children, $tid, { });
_vet_node_parents($tree, \%leaf, \%vetted_parents, $tid, { });
}
#print STDERR sprintf("%s tree vetted in %0.6f secs\n", scalar(localtime), Time::HiRes::time - $start_time);
return 1;
}
########################################################
# Given two topic IDs, returns 1 if the first is a parent
# (or grandparent, etc.) and 0 if it is not. For this
# method's purposes, a topic is not a parent of itself.
# If an optional 'weight' is specified, all links followed
# must have a min_weight less than or equal to that weight.
# Or if an optional 'min_min_weight' is specified, all
# links followed must have a min_weight greater than or
# equal to it. Both implies both, of course.
# XXXSECTIONTOPICS this could be cached for efficiency, no idea how much time that would save
sub isTopicParent {
my($self, $parent, $child, $options) = @_;
my $tree = $self->getTopicTree();
return 0 unless $tree->{$parent} && $tree->{$child};
return 0 if $parent == $child;
my $max_min_weight = $options->{weight} || 2**31-1;
my $min_min_weight = $options->{min_min_weight} || 0;
my @topics = ( $child );
my %new_topics;
while (@topics) {
%new_topics = ( );
for my $tid (@topics) {
next unless $tree->{$tid}{parent};
# This topic has one or more parents. Add
# them to the list we're following up, but
# only if the link from this topic to the
# parent does not specify a minimum weight
# higher or lower than required.
my $p_hr = $tree->{$tid}{parent};
my @parents =
grep { $p_hr->{$_} >= $min_min_weight }
grep { $p_hr->{$_} <= $max_min_weight }
keys %$p_hr;
for my $p (@parents) {
return 1 if $p == $parent;
$new_topics{$p} = 1;
}
}
@topics = keys %new_topics;
}
return 0;
}
########################################################
sub getNexusTids {
my($self) = @_;
my $tree = $self->getTopicTree();
return grep { $tree->{$_}{nexus} } sort { $a <=> $b } keys %$tree;
}
########################################################
# Starting with $start_tid, which may or may not be a nexus,
# walk down all its child topics and return their tids.
# Note that the original tid, $start_tid, is not itself returned.
sub getAllChildrenTids {
my($self, $start_tid) = @_;
my $tree = $self->getTopicTree();
my %all_children = ( );
my @cur_children = ( $start_tid );
my %grandchildren;
while (@cur_children) {
%grandchildren = ( );
for my $child (@cur_children) {
# This topic is a nexus, and a child of the
# start nexus. Note it so it gets returned.
$all_children{$child} = 1;
# Now walk through all its children, marking
# nexuses as grandchildren that must be
# walked through on the next pass.
for my $gchild (keys %{$tree->{$child}{child}}) {
$grandchildren{$gchild} = 1;
}
}
@cur_children = keys %grandchildren;
}
delete $all_children{$start_tid};
return sort { $a <=> $b } keys %all_children;
}
########################################################
# Starting with $start_tid, which may or may not be a nexus,
# walk up all its parent topics and return their tids.
# Note that the original tid, $start_tid, is not itself returned.
sub getAllParentsTids {
my($self, $start_tid) = @_;
my $tree = $self->getTopicTree();
my %all_parents = ( );
my @cur_parents = ( $start_tid );
my %grandparents;
while (@cur_parents) {
%grandparents = ( );
for my $parent (@cur_parents) {
# This topic is a nexus, and a parent of the
# start nexus. Note it so it gets returned.
$all_parents{$parent} = 1;
# Now walk through all its parents, marking
# nexuses as grandparents that must be
# walked through on the next pass.
for my $gparent (keys %{$tree->{$parent}{parent}}) {
$grandparents{$gparent} = 1;
}
}
@cur_parents = keys %grandparents;
}
delete $all_parents{$start_tid};
return sort { $a <=> $b } keys %all_parents;
}
########################################################
# Starting with $start_tid, a nexus ID, walk down all its child nexuses
# and return their tids. Note that the original tid, $start_tid, is
# not itself returned.
sub getNexusChildrenTids {
my($self, $start_tid) = @_;
my $tree = $self->getTopicTree();
my %all_children = ( );
my @cur_children = ( $start_tid );
my %grandchildren;
while (@cur_children) {
%grandchildren = ( );
for my $child (@cur_children) {
# This topic is a nexus, and a child of the
# start nexus. Note it so it gets returned.
$all_children{$child} = 1;
# Now walk through all its children, marking
# nexuses as grandchildren that must be
# walked through on the next pass.
for my $gchild (keys %{$tree->{$child}{child}}) {
# skip if the min_weight from this parent to
# this child is negative (indicating the
# child topic _forbids_ the parent topic)
next if $tree->{$child}{child}{$gchild} < 0;
# only add nexus topics
next unless $tree->{$gchild}{nexus};
$grandchildren{$gchild} = 1;
}
}
@cur_children = keys %grandchildren;
}
delete $all_children{$start_tid};
return [ sort { $a <=> $b } keys %all_children ];
}
########################################################
# Returns a boolean indicating whether it would be safe to add
# a new topic with parent and child tids as specified. "Safe"
# means there would be no loops; if false is returned, the
# topic must not be added because it would introduce loops.
# Works for any combination of parent/child tids including
# none of either or both (in which case it's always safe).
sub wouldBeSafeToAddTopic {
my($self, $parent_tids_ar, $child_tids_ar) = @_;
return 1 if !$parent_tids_ar || !$child_tids_ar
|| !@$parent_tids_ar || !@$child_tids_ar;
my %all_new_parents = ( );
for my $parent (@$parent_tids_ar) {
$all_new_parents{$parent} = 1;
my @new_parents = $self->getAllParentsTids($parent);
for my $gparent (@new_parents) {
$all_new_parents{$gparent} = 1;
}
}
my %all_new_children = ( );
for my $child (@$child_tids_ar) {
$all_new_children{$child} = 1;
my @new_children = $self->getAllChildrenTids($child);
for my $gchild (@new_children) {
$all_new_children{$gchild} = 1;
}
}
# If the intersection of all the new parents and all the new
# children contains at least one topic, then it's unsafe.
for my $child (keys %all_new_children) {
return 0 if $all_new_parents{$child};
}
# Otherwise, it's safe.
return 1;
}
########################################################
# Returns a boolean indicating whether it would be safe to add
# a parent<->child link between two topics (i.e. add a row to
# the topic_parents table). "Safe" means there would be no
# loops; if false is returned, the link must not be added
# because it would introduce loops.
sub wouldBeSafeToAddTopicLink {
my($self, $parent_tid, $child_tid) = @_;
return 0 if !$parent_tid || !$child_tid || $parent_tid == $child_tid;
my %all_parents = ( $parent_tid, 1 );
my @new_parents = $self->getAllParentsTids($parent_tid);
for my $parent (@new_parents) {
$all_parents{$parent} = 1;
}
my %all_children = ( $child_tid, 1 );
my @new_children = $self->getAllChildrenTids($child_tid);
for my $child (@new_children) {
$all_children{$child} = 1;
}
# If there are any topics which are both a child of the
# child and a parent of the parent (or if the child and
# parent are already parent and child!) then there's a
# loop.
for my $tid (keys %all_children) {
return 0 if $all_parents{$tid};
}
# Otherwise, it's safe.
return 1;
}
########################################################
sub deleteRelatedLink {
my($self, $id) = @_;
$self->sqlDelete("related_links", "id=$id");
}
########################################################
sub getNexusExtras {
my($self, $tid, $options) = @_;
return [ ] unless $tid;
$options ||= {};
my $content_type = $options->{content_type} || "story";
my $content_type_q = $self->sqlQuote($content_type);
my $content_type_clause = "";
$content_type_clause = " AND content_type = $content_type_q " if $content_type ne "all";
my $tid_q = $self->sqlQuote($tid);
my $answer = $self->sqlSelectAll(
'extras_textname, extras_keyword, type, content_type, required, ordering, extras_id',
'topic_nexus_extras',
"tid = $tid_q $content_type_clause ",
"ORDER by ordering, extras_id"
);
return $answer;
}
########################################################
sub getNexuslistFromChosen {
my($self, $chosen_hr) = @_;
return [ ] unless $chosen_hr;
my $rendered_hr = $self->renderTopics($chosen_hr);
my @nexuses = $self->getNexusTids();
@nexuses = grep { $rendered_hr->{$_} } @nexuses;
return [ @nexuses ];
}
########################################################
# XXXSECTIONTOPICS we should remove duplicates from the list
# returned. If 2 or more nexuses have the same extras_keyword,
# that keyword should only be returned once.
sub getNexusExtrasForChosen {
my($self, $chosen_hr, $options) = @_;
return [ ] unless $chosen_hr;
$options ||= {};
$options->{content_type} ||= "story";
my $nexuses = $self->getNexuslistFromChosen($chosen_hr);
my $seen_extras = {};
my $extras = [ ];
my $index = 0;
for my $nexusid (@$nexuses) {
my $ex_ar = $self->getNexusExtras($nexusid, $options);
foreach my $extra (@$ex_ar) {
unless (defined $seen_extras->{$extra->[1]}) {
push @$extras, $extra;
$seen_extras->{$extra->[1]}++;
} elsif ($extra->[4] eq "yes"){
$extras->[$seen_extras->{$extra->[1]}] = "yes";
}
$index++;
}
}
return $extras;
}
sub createNexusExtra {
my($self, $tid, $extra) = @_;
$extra ||= {};
return unless $tid && $extra->{extras_keyword};
$extra->{tid} = $tid;
$extra->{type} ||= "text";
$extra->{content_type} ||= "story";
$extra->{required} ||= "no";
$self->sqlInsert("topic_nexus_extras", $extra);
}
sub updateNexusExtra {
my($self, $extras_id, $extra) = @_;
return unless $extras_id && $extra;
$extra->{type} ||= "text";
$extra->{content_type} ||= "story";
$extra->{required} ||= "no";
my $extras_id_q = $self->sqlQuote($extras_id);
$self->sqlUpdate("topic_nexus_extras", $extra, "extras_id = $extras_id_q");
}
sub deleteNexusExtra {
my($self, $extras_id) = @_;
return unless $extras_id;
my $extras_id_q = $self->sqlQuote($extras_id);
$self->sqlDelete('topic_nexus_extras', "extras_id = $extras_id_q");
}
########################################################
# There's still no interface for adding 'list' type extras.
# Maybe later.
sub setNexusExtras {
my($self, $tid, $extras) = @_;
return unless $tid;
my $tid_q = $self->sqlQuote($tid);
$self->sqlDelete("topic_nexus_extras", "tid=$tid_q");
for (@{$extras}) {
$self->sqlInsert('topic_nexus_extras', {
tid => $tid,
extras_keyword => $_->[0],
extras_textname => $_->[1],
type => 'text',
});
}
}
sub setNexusCurrentQid {
my($self, $nexus_id, $qid) = @_;
return $self->sqlUpdate("topic_nexus", { current_qid => $qid }, "tid = $nexus_id");
}
########################################################
sub getSectionExtras {
my($self, $section) = @_;
errorLog("getSectionExtras called");
return undef;
}
########################################################
sub setSectionExtras {
my($self, $section, $extras) = @_;
errorLog("setSectionExtras called");
return undef;
}
########################################################
sub getContentFilters {
my($self, $formname, $field) = @_;
my $field_string = $field ne '' ? " AND field = '$field'" : " AND field != ''";
my $filters = $self->sqlSelectAll("*", "content_filters",
"regex != '' $field_string AND form = '$formname'");
return $filters;
}
########################################################
sub createSubmission {
my($self, $submission) = @_;
return unless $submission && $submission->{story};
my $constants = getCurrentStatic();
my $data;
$data->{story} = delete $submission->{story} || '';
$data->{subj} = delete $submission->{subj} || '';
$data->{subj} = $self->truncateStringForCharColumn($data->{subj}, 'submissions', 'subj');
$data->{ipid} = getCurrentUser('ipid');
$data->{subnetid} = getCurrentUser('subnetid');
$data->{email} = delete $submission->{email} || '';
$data->{email} = $self->truncateStringForCharColumn($data->{email}, 'submissions', 'email');
my $emailuri = URI->new($data->{email});
my $emailhost = "";
$emailhost = $emailuri->host() if $emailuri && $emailuri->can("host");
$data->{emaildomain} = fullhost_to_domain($emailhost);
$data->{emaildomain} = $self->truncateStringForCharColumn($data->{emaildomain}, 'submissions', 'emaildomain');
$data->{uid} = delete $submission->{uid} || getCurrentStatic('anonymous_coward_uid');
$data->{'-time'} = delete $submission->{'time'};
$data->{'-time'} ||= 'NOW()';
$data->{primaryskid} = delete $submission->{primaryskid} || $constants->{mainpage_skid};
$data->{tid} = delete $submission->{tid} || $constants->{mainpage_skid};
# To help cut down on duplicates generated by automated routines. For
# crapflooders, we will need to look into an alternate methods.
# Filters of some sort, maybe?
$data->{signature} = md5_hex($data->{story});
$self->sqlInsert('submissions', $data);
my $subid = $self->getLastInsertId;
# The next line makes sure that we get any section_extras in the DB - Brian
$self->setSubmission($subid, $submission) if $subid && keys %$submission;
if ($constants->{plugin}{FireHose}) {
my $firehose = getObject("Slash::FireHose");
my $firehose_id = $firehose->createItemFromSubmission($subid);
if ($firehose_id) {
my $discussion_id = $self->createDiscussion({
uid => 0,
kind => 'submission',
title => $data->{subj},
topic => $data->{tid},
primaryskid => $data->{primaryskid},
commentstatus => 'logged_in',
url => "$constants->{rootdir}/firehose.pl?op=view&id=$firehose_id"
});
if ($discussion_id) {
$firehose->setFireHose($firehose_id, {
discussion => $discussion_id,
});
}
}
}
return $subid;
}
########################################################
# this is just for tracking what admins are currently looking at,
# and when they last accessed the site
sub getSessionInstance {
my($self, $uid) = @_;
my $admin_timeout = getCurrentStatic('admin_timeout');
$self->sqlDelete("sessions",
"NOW() > DATE_ADD(lasttime, INTERVAL $admin_timeout MINUTE)"
);
my($lasttitle, $last_sid, $last_subid, $last_fhid, $last_action) = $self->sqlSelect(
'lasttitle, last_sid, last_subid, last_fhid, last_action',
'sessions',
"uid=$uid"
);
if(!$lasttitle) {
$self->sqlReplace('sessions', {
-uid => $uid,
lasttitle => $lasttitle || '',
last_sid => $last_sid || '',
last_subid => $last_subid || '0',
last_fhid => $last_fhid || '0',
last_action => $last_action || '',
});
}
}
########################################################
sub getLastSessionText {
my($self, $uid) = @_;
my $uid_q = $self->sqlQuote($uid);
return $self->sqlSelect("lasttitle", "sessions", "uid=$uid_q", "ORDER BY lasttime DESC LIMIT 1");
}
########################################################
sub setContentFilter {
my($self, $formname) = @_;
my $form = getCurrentForm();
$formname ||= $form->{formname};
$self->sqlUpdate("content_filters", {
regex => $form->{regex},
form => $formname,
modifier => $form->{modifier},
field => $form->{field},
ratio => $form->{ratio},
minimum_match => $form->{minimum_match},
minimum_length => $form->{minimum_length},
err_message => $form->{err_message},
}, "filter_id=$form->{filter_id}"
);
}
########################################################
# This creates an entry in the accesslog
sub createAccessLog {
my($self, $op, $dat, $status) = @_;
return if !dbAvailable('write_accesslog');
my $constants = getCurrentStatic();
my $form = getCurrentForm();
my $user = getCurrentUser();
my $r = Apache->request;
my $bytes = $r->bytes_sent;
$user ||= {};
$user->{state} ||= {};
return if $op eq 'css' && $constants->{accesslog_css_skip};
my $reader = getObject('Slash::DB', { db_type => 'reader' });
if ($op =~ /^(?:image|css|js)$/ && $constants->{accesslog_imageregex}) {
return if $constants->{accesslog_imageregex} eq 'NONE';
my $uri = $r->uri;
return unless $uri =~ $constants->{accesslog_imageregex};
$dat ||= $uri;
}
return if $op eq 'slashdot-it'
&& ( !$constants->{slashdotit_accesslog}
|| ( $constants->{slashdotit_accesslog} < 1
&& rand() > $constants->{slashdotit_accesslog} ) );
my $uid = $user->{uid} || $constants->{anonymous_coward_uid};
my $skin_name = getCurrentSkin('name');
# XXXSKIN - i think these are no longer special cases ...
# The following two are special cases
# if ($op eq 'index' || $op eq 'article') {
# $section = ($form && $form->{section})
# ? $form->{section}
# : $constants->{section};
# }
my($ipid, $subnetid) = (getCurrentUser('ipid'), getCurrentUser('subnetid'));
if (!$ipid || !$subnetid) {
($ipid, $subnetid) = get_ipids($r->connection->remote_ip);
}
if ( $op eq 'index' && $dat =~ m|^([^/]*)| ) {
my $firstword = $1;
if ($reader->getSkidFromName($firstword)) {
$skin_name = $firstword;
}
}
if ($dat =~ /(.*)\/(\d{2}\/\d{2}\/\d{2}\/\d{4,7}).*/) {
$dat = $2;
$op = 'article';
my $firstword = $1;
if ($reader->getSkidFromName($firstword)) {
$skin_name = $firstword;
}
}
my $duration;
if ($Slash::Apache::User::request_start_time) {
$duration = Time::HiRes::time - $Slash::Apache::User::request_start_time;
$Slash::Apache::User::request_start_time = 0;
$duration = 0 if $duration < 0; # sanity check
} else {
$duration = 0;
}
my $local_addr = inet_ntoa(
( unpack_sockaddr_in($r->connection()->local_addr()) )[1]
);
$status ||= $r->status;
my $skid = $reader->getSkidFromName($skin_name);
my $query_string = $ENV{QUERY_STRING} || 'none';
my $referrer = $r->header_in("Referer");
if (!$referrer && $query_string =~ /\bfrom=(\w+)\b/) {
$referrer = $1;
}
my $insert = {
host_addr => $ipid,
subnetid => $subnetid,
dat => $dat,
uid => $uid,
skid => $skid,
bytes => $bytes,
op => $op,
-ts => 'NOW()',
query_string => $self->truncateStringForCharColumn($query_string, 'accesslog', 'query_string'),
user_agent => $ENV{HTTP_USER_AGENT} ? $self->truncateStringForCharColumn($ENV{HTTP_USER_AGENT}, 'accesslog', 'user_agent') : 'undefined',
duration => $duration,
local_addr => $local_addr,
static => $user->{state}{_dynamic_page} ? 'no' : 'yes',
secure => $user->{state}{ssl} || 0,
referer => $referrer,
status => $status,
};
return if !$user->{is_admin} && $constants->{accesslog_disable};
if ($constants->{accesslog_insert_cachesize} && !$user->{is_admin}) {
# Save up multiple accesslog inserts until we can do them all at once.
push @{$self->{_accesslog_insert_cache}}, $insert;
my $size = scalar(@{$self->{_accesslog_insert_cache}});
if ($size >= $constants->{accesslog_insert_cachesize}) {
$self->_writeAccessLogCache;
}
} else {
$self->sqlInsert('accesslog', $insert, { delayed => 1 });
}
}
sub _writeAccessLogCache {
my($self) = @_;
return if !dbAvailable('write_accesslog');
return unless ref($self->{_accesslog_insert_cache})
&& @{$self->{_accesslog_insert_cache}};
# $self->{_dbh}{AutoCommit} = 0;
$self->sqlDo("SET AUTOCOMMIT=0");
while (my $hr = shift @{$self->{_accesslog_insert_cache}}) {
$self->sqlInsert('accesslog', $hr, { delayed => 1 });
}
# $self->{_dbh}->commit;
# $self->{_dbh}{AutoCommit} = 1;
$self->sqlDo("COMMIT");
$self->sqlDo("SET AUTOCOMMIT=1");
}
##########################################################
# This creates an entry in the accesslog for admins -Brian
sub createAccessLogAdmin {
my($self, $op, $dat, $status) = @_;
return if !dbAvailable('write_accesslog');
return if $op =~ /^images?$/;
my $constants = getCurrentStatic();
my $form = getCurrentForm();
my $user = getCurrentUser();
my $r = Apache->request;
# $ENV{SLASH_USER} wasn't working, was giving us some failed inserts
# with uid NULL.
my $uid = $user->{uid};
my $gSkin = getCurrentSkin();
errorLog("gSkin is empty") unless $gSkin;
my $skid = $gSkin->{skid} || 0;
# And just what was the admin doing? -Brian
$op = $form->{op} if $form->{op};
$status ||= $r->status;
my $form_freeze = nfreeze($form);
$self->sqlInsert('accesslog_admin', {
host_addr => $r->connection->remote_ip,
dat => $dat,
uid => $uid,
skid => $skid,
bytes => $r->bytes_sent,
op => $op,
form => $form_freeze ? $self->truncateStringForCharColumn($form_freeze, 'accesslog_admin', 'form') : '',
-ts => 'NOW()',
query_string => $ENV{QUERY_STRING} ? $self->truncateStringForCharColumn($ENV{QUERY_STRING}, 'accesslog_admin', 'query_string') : '0',
user_agent => $ENV{HTTP_USER_AGENT} ? $self->truncateStringForCharColumn($ENV{HTTP_USER_AGENT}, 'accesslog_admin', 'user_agent') : 'undefined',
secure => Slash::Apache::ConnectionIsSecure(),
status => $status,
}, { delayed => 1 });
}
########################################################
# pass in additional optional descriptions
sub getDescriptions {
my($self, $codetype, $optional, $flag, $altdescs) = @_;
return unless $codetype;
my $codeBank_hash_ref = {};
$optional ||= '';
$altdescs ||= '';
# I am extending this, without the extension the cache was
# not always returning the right data -Brian
my $cache = '_getDescriptions_' . $codetype . $optional . $altdescs;
if ($flag) {
undef $self->{$cache};
} else {
return $self->{$cache} if $self->{$cache};
}
$altdescs ||= {};
my $descref = $altdescs->{$codetype} || $descriptions{$codetype};
if (!$descref) { errorLog("getDescriptions - no descref for codetype '$codetype'") }
return $codeBank_hash_ref unless $descref;
# I don't really feel like editing the entire %descriptions hash to
# list each table with each codetype, so for now at least, I'm just
# lumping all them together. Which seems to be fine because on the
# sites whose querylogs we've examined so far, 'descriptions'
# accounts for, as you might expect, a miniscule amount of DB traffic.
my $qlid = $self->_querylog_start('SELECT', 'descriptions');
my $sth = $descref->(@_);
return { } if !$sth;
# allow $descref to return a hashref, instead of a statement handle
if (ref($sth) =~ /::st$/) {
while (my($id, $desc) = $sth->fetchrow) {
$codeBank_hash_ref->{$id} = $desc;
}
$sth->finish;
} else {
@{$codeBank_hash_ref}{keys %$sth} = values %$sth;
}
$self->_querylog_finish($qlid);
$self->{$cache} = $codeBank_hash_ref if getCurrentStatic('cache_enabled');
return $codeBank_hash_ref;
}
########################################################
sub deleteUser {
my($self, $uid) = @_;
return unless $uid;
$self->setUser($uid, {
bio => '',
nickname => 'deleted user',
matchname => 'deleted user',
realname => 'deleted user',
realemail => '',
fakeemail => '',
newpasswd => '',
newpasswd_ts => undef,
homepage => '',
passwd => '',
people => '',
sig => '',
seclev => 0
});
my $rows = $self->sqlDelete("users_param", "uid=$uid");
$self->setUser_delete_memcached($uid);
return $rows;
}
########################################################
# Get user info from the users table.
sub getUserAuthenticate {
my($self, $uid_try, $passwd, $kind, $temp_ok) = @_;
my($newpass, $cookpasswd);
return undef unless $uid_try && $passwd;
# if $kind is 1, then only try to auth password as plaintext
# if $kind is 2, then only try to auth password as encrypted
# if $kind is 3, then only try to auth user with logtoken
# if $kind is 4, then only try to auth user with "public" logtoken,
# that can be used outside and separate of login session
# if $kind is undef or 0, try as logtoken (the most common case),
# then encrypted, then as plaintext
my($EITHER, $PLAIN, $ENCRYPTED, $LOGTOKEN, $PUBLIC) = (0, 1, 2, 3, 4);
my($UID, $PASSWD, $NEWPASSWD) = (0, 1, 2);
$kind ||= $EITHER;
my $uid_try_q = $self->sqlQuote($uid_try);
my $uid_verified = 0;
if ($kind == $PUBLIC) {
if ($passwd eq $self->getLogToken($uid_try, 0, 2) ||
$passwd eq $self->getLogToken($uid_try, 0, 9)
) {
$uid_verified = $uid_try;
$cookpasswd = $passwd;
}
} elsif ($kind == $LOGTOKEN || $kind == $EITHER) {
# get existing logtoken, if exists
if ($passwd eq $self->getLogToken($uid_try) || (
$temp_ok && $passwd eq $self->getLogToken($uid_try, 0, 1)
)) {
$uid_verified = $uid_try;
$cookpasswd = $passwd;
}
}
if ($kind != $PUBLIC && $kind != $LOGTOKEN && !$uid_verified) {
my($db_uid, $db_passwd, $db_newpasswd) = $self->sqlSelect(
'uid,passwd,newpasswd',
'users',
"uid=$uid_try_q"
);
# try ENCRYPTED -> ENCRYPTED
if ($kind == $EITHER || $kind == $ENCRYPTED) {
if (comparePassword($passwd, $db_passwd, $uid_try, 0, ($kind == $ENCRYPTED))) {
$uid_verified = $db_uid;
# get existing logtoken, if exists, or new one
$cookpasswd = $self->getLogToken($uid_verified, 1);
}
}
# try PLAINTEXT -> ENCRYPTED
if (($kind == $EITHER || $kind == $PLAIN) && !$uid_verified) {
if (comparePassword($passwd, $db_passwd, $uid_try, ($kind == $PLAIN), 0)) {
$uid_verified = $db_uid;
# get existing logtoken, if exists, or new one
$cookpasswd = $self->getLogToken($uid_verified, 1);
}
}
# try PLAINTEXT -> NEWPASS
if (($kind == $EITHER || $kind == $PLAIN) && !$uid_verified) {
if (comparePassword($passwd, $db_newpasswd, $uid_try, ($kind == $PLAIN), 0)) {
my $cryptpasswd = encryptPassword($passwd, $uid_try);
$self->sqlUpdate('users', {
newpasswd => '',
passwd => $cryptpasswd
}, "uid=$uid_try_q");
$newpass = 1;
$uid_verified = $db_uid;
# delete existing logtokens
$self->deleteLogToken($uid_verified, 1);
# create new logtoken
$cookpasswd = $self->setLogToken($uid_verified);
}
}
}
# If we tried to authenticate and failed, log this attempt to
# the badpasswords table.
if (!$uid_verified) {
$self->createBadPasswordLog($uid_try, $passwd);
}
# return UID alone in scalar context
return wantarray ? ($uid_verified, $cookpasswd, $newpass) : $uid_verified;
}
########################################################
# Log a bad password in a login attempt.
sub createBadPasswordLog {
my($self, $uid, $password_wrong) = @_;
my $constants = getCurrentStatic();
# Failed login attempts as the anonymous coward don't count.
return if !$uid || $uid == $constants->{anonymous_coward_uid};
# Bad passwords that don't come through the web,
# we don't bother to log.
my $r = Apache->request;
return unless $r;
# We also store the realemail field of the actual user account
# at the time the password was tried, so later, if the password
# is cracked and the account stolen, there is a record of who
# the real owner is.
my $realemail = $self->getUser($uid, 'realemail') || '';
my($ip, $subnet) = get_ipids($r->connection->remote_ip, 1);
$self->sqlInsert("badpasswords", {
uid => $uid,
password => $password_wrong,
ip => $ip,
subnet => $subnet,
realemail => $realemail,
} );
my $warn_limit = $constants->{bad_password_warn_user_limit} || 0;
my $bp_count = $self->getBadPasswordCountByUID($uid);
# We only warn a user at the Xth bad password attempt. We don't want to
# generate a message for every bad attempt over a threshold
if ($bp_count && $bp_count == $warn_limit) {
my $messages = getObject("Slash::Messages");
return unless $messages;
my $users = $messages->checkMessageCodes(
MSG_CODE_BADPASSWORD, [$uid]
);
if (@$users) {
my $uid_q = $self->sqlQuote($uid);
my $nick = $self->sqlSelect("nickname", "users", "uid=$uid_q");
my $bp = $self->getBadPasswordIPsByUID($uid);
my $data = {
template_name => 'badpassword_msg',
subject => 'Bad login attempts warning',
nickname => $nick,
uid => $uid,
bp_count => $bp_count,
bp_ips => $bp
};
$messages->create($users->[0],
MSG_CODE_BADPASSWORD, $data, 0, '', 'now'
);
}
}
}
########################################################
sub getBadPasswordsByUID {
my($self, $uid) = @_;
my $uid_q = $self->sqlQuote($uid);
my $ar = $self->sqlSelectAllHashrefArray(
"ip, password, DATE_FORMAT(ts, '%Y-%m-%d %h:%i:%s') AS ts",
"badpasswords",
"uid=$uid_q AND ts > DATE_SUB(NOW(), INTERVAL 1 DAY)");
return $ar;
}
########################################################
sub getBadPasswordCountByUID {
my($self, $uid) = @_;
my $uid_q = $self->sqlQuote($uid);
return $self->sqlCount("badpasswords",
"uid=$uid_q AND ts > DATE_SUB(NOW(), INTERVAL 1 DAY)");
}
########################################################
sub getBadPasswordIPsByUID {
my($self, $uid) = @_;
my $uid_q = $self->sqlQuote($uid);
my $ar = $self->sqlSelectAllHashrefArray(
"ip, COUNT(*) AS c,
MIN(DATE_FORMAT(ts, '%Y-%m-%d %h:%i:%s')) AS mints,
MAX(DATE_FORMAT(ts, '%Y-%m-%d %h:%i:%s')) AS maxts",
"badpasswords",
"uid=$uid_q AND ts > DATE_SUB(NOW(), INTERVAL 1 DAY)",
"GROUP BY ip ORDER BY c DESC"
);
}
########################################################
# Make a new password, save it in the DB, and return it.
sub getNewPasswd {
my($self, $uid) = @_;
my $newpasswd = changePassword();
$self->sqlUpdate('users', {
newpasswd => encryptPassword($newpasswd, $uid),
-newpasswd_ts => 'NOW()',
}, 'uid=' . $self->sqlQuote($uid));
return $newpasswd;
}
########################################################
# reset's a user's account forcing them to get the
# new password via their registered mail account.
sub resetUserAccount {
my($self, $uid) = @_;
my $newpasswd = changePassword();
my $enc = encryptPassword($newpasswd, $uid);
$self->sqlUpdate('users', {
passwd => $enc,
newpasswd => $enc,
newpasswd_ts => undef, # should this be NOW() ?
}, 'uid=' . $self->sqlQuote($uid));
return $newpasswd;
}
########################################################
# get proper cookie location
sub _getLogTokenCookieLocation {
my($self, $uid) = @_;
my $user = getCurrentUser();
my $temp_str = $user->{state}{login_temp} || 'no';
my $public_str = $user->{state}{login_public} || 'no';
my $cookie_location = $temp_str eq 'yes'
? 'classbid'
: $self->getUser($uid, 'cookie_location');
my $locationid = get_ipids('', '', $cookie_location);
return($locationid, $temp_str, $public_str);
}
########################################################
# Get a logtoken from the DB, or create a new one
sub _logtoken_read_memcached {
my($self, $uid, $temp_str, $public_str, $locationid) = @_;
my $mcd = $self->getMCD();
return undef unless $mcd;
my $mcdkey = "$self->{_mcd_keyprefix}:lt:";
my $lt_str = $uid
. ":" . ($temp_str eq 'yes' ? 1 : 0)
. ":" . ($public_str eq 'yes' ? 1 : 0)
. ":" . $locationid;
my $value = $mcd->get("$mcdkey$lt_str");
#print STDERR scalar(gmtime) . " $$ _lt_read_mcd lt_str=$lt_str value='$value'\n";
return $value;
}
sub _logtoken_write_memcached {
my($self, $uid, $temp_str, $public_str, $locationid, $value, $seconds) = @_;
# Take a few seconds off this expiration time, because it's what's
# in the DB that's authoritative; for those last few seconds,
# requests will have to go to the DB.
$seconds -= 3;
return unless $seconds > 0;
my $mcd = $self->getMCD();
return unless $mcd;
my $mcdkey = "$self->{_mcd_keyprefix}:lt:";
my $lt_str = $uid
. ":" . ($temp_str eq 'yes' ? 1 : 0)
. ":" . ($public_str eq 'yes' ? 1 : 0)
. ":" . $locationid;
$mcd->set("$mcdkey$lt_str", $value, $seconds);
#print STDERR scalar(gmtime) . " $$ _lt_write_mcd lt_str=$lt_str value='$value' seconds=$seconds\n";
}
sub _logtoken_delete_memcached {
my($self, $uid, $temp_str, $public_str, $locationid) = @_;
my $mcd = $self->getMCD();
return unless $mcd;
my $mcdkey = "$self->{_mcd_keyprefix}:lt:";
if ($temp_str && $public_str) {
# Delete just this one logtoken for this user.
my $lt_str = $uid
. ":" . ($temp_str eq 'yes' ? 1 : 0)
. ":" . ($public_str eq 'yes' ? 1 : 0)
. ":" . $locationid;
# The 3 means "don't accept new writes to this key for 3 seconds."
$mcd->delete("$mcdkey$lt_str", 3);
#print STDERR scalar(gmtime) . " $$ _lt_delete_mcd deleted lt_str=$lt_str\n";
} else {
# Not having a temp_str and public_str and locationid passed in
# means we must delete all logtokens for this user. Select
# them from the DB and delete them one at a time.
my $uid_q = $self->sqlQuote($uid);
my $logtokens_ar = $self->sqlSelectAllHashrefArray(
"temp, locationid",
"users_logtokens",
"uid=$uid_q");
for my $data (@$logtokens_ar) {
my($temp_str, $locationid) = ($data->{temp}, $data->{locationid});
$public_str ||= 0;
my $lt_str = $uid
. ":" . ($temp_str eq 'yes' ? 1 : 0)
. ":" . ($public_str eq 'yes' ? 1 : 0)
. ":" . $locationid;
# The 3 means "don't accept new writes to this key for 3 seconds."
$mcd->delete("$mcdkey$lt_str", 3);
#print STDERR scalar(gmtime) . " $$ _lt_delete_mcd deleted lt_str=$lt_str\n";
}
}
}
# yes, $special should probably not be a numeral .... -- pudge
sub getLogToken {
my($self, $uid, $new, $special, $bump_public) = @_;
my $user = getCurrentUser();
my $uid_q = $self->sqlQuote($uid);
$special ||= 0;
my $force_temp = $special == 1;
my $force_public = $special == 2;
my $force_plain = $special == 9;
my $login_temp = $user->{state}{login_temp};
my $login_public = $user->{state}{login_public};
# set the temp value, if forced
if ($force_plain) {
$user->{state}{login_temp} = 'no';
$user->{state}{login_public} = 'no';
} elsif ($force_temp) {
$user->{state}{login_temp} = 'yes';
} elsif ($force_public) {
$user->{state}{login_public} = 'yes';
}
my($locationid, $temp_str, $public_str) = $self->_getLogTokenCookieLocation($uid);
my $where = join(" AND ",
"uid=$uid_q",
"locationid='$locationid'",
"temp='$temp_str'",
"public='$public_str'");
my $value = $self->_logtoken_read_memcached($uid, $temp_str, $public_str, $locationid) || '';
#print STDERR scalar(gmtime) . " $$ getLogToken value from mcd '$value' for uid=$uid temp_str=$temp_str public_str=$public_str locationid=$locationid\n";
if (!$value) {
my $thiswhere = $where;
$thiswhere .= ' AND expires >= NOW()' if $public_str ne 'yes';
$value = $self->sqlSelect(
'value', 'users_logtokens',
$thiswhere
) || '';
}
#print STDERR scalar(gmtime) . " $$ getLogToken value '$value'\n";
# always bump expiration for temp logins
if ($value && $temp_str eq 'yes') {
my $minutes = getCurrentStatic('login_temp_minutes') || 10;
$self->updateLogTokenExpires($uid, $temp_str, $public_str, $locationid, $value, $minutes*60);
#print STDERR scalar(gmtime) . " $$ getLogToken called updateLogTokenExpires for temp, uid=$uid value=$value\n";
}
# bump expiration for public (aka RSS) logins if the caller requested it
if ($value && $public_str eq 'yes' && $bump_public) {
my $days = getCurrentStatic('login_nontemp_days') || 365;
$self->updateLogTokenExpires($uid, $temp_str, $public_str, $locationid, $value, $days*86400);
#print STDERR scalar(gmtime) . " $$ getLogToken called updateLogTokenExpires for public, uid=$uid value=$value\n";
}
# if $new, then create a new value if none exists
if ($new && !$value) {
$value = $self->setLogToken($uid) || '';
#print STDERR scalar(gmtime) . " $$ getLogToken called set, value='$value'\n";
}
# reset the temp values
$user->{state}{login_temp} = $login_temp unless $value;
$user->{state}{login_public} = $login_public;
#print STDERR scalar(gmtime) . " $$ getLogToken returning, value='$value'\n";
return $value;
}
########################################################
# Make a new logtoken, save it in the DB, and return it
sub setLogToken {
my($self, $uid) = @_;
my $logtoken = createLogToken();
my($locationid, $temp_str, $public_str) = $self->_getLogTokenCookieLocation($uid);
my $constants = getCurrentStatic();
my $nontemp_days = $constants->{login_nontemp_days} || 365;
my($interval, $seconds) = ("$nontemp_days DAY", $nontemp_days * 86400);
if ($temp_str eq 'yes') {
my $minutes = getCurrentStatic('login_temp_minutes') || 1;
($interval, $seconds) = ("$minutes MINUTE", $minutes * 60);
}
my $rows = $self->sqlReplace('users_logtokens', {
uid => $uid,
locationid => $locationid,
temp => $temp_str,
public => $public_str,
value => $logtoken,
-expires => "DATE_ADD(NOW(), INTERVAL $interval)"
});
if ($rows) {
$self->_logtoken_write_memcached($uid, $temp_str, $public_str,
$locationid, $logtoken, $seconds);
}
# prune logtokens table, each user should not have too many
my $uid_q = $self->sqlQuote($uid);
my $max = getCurrentStatic('logtokens_max') || 2;
my $where = "uid = $uid_q AND temp = '$temp_str' AND public = '$public_str'";
my $total = $self->sqlCount('users_logtokens', $where);
if ($total > $max) {
my $limit = $total - $max;
my $logtokens = $self->sqlSelectAllHashref(
'lid', 'lid, uid, temp, public, locationid',
'users_logtokens', $where,
"ORDER BY expires LIMIT $limit"
);
my @lids = sort { $a <=> $b } keys %$logtokens;
for my $lid (@lids) {
my $lt = $logtokens->{$lid};
$self->_logtoken_delete_memcached(
$lt->{uid},
$lt->{temp},
$lt->{public},
$lt->{locationid}
);
}
my $lids_text = join(",", @lids);
$self->sqlDelete('users_logtokens', "lid IN ($lids_text)");
}
#print STDERR scalar(gmtime) . " $$ setLogToken replaced uid=$uid temp=$temp_str public=$public_str locationid=$locationid logtoken='$logtoken' rows='$rows'\n";
return $logtoken;
}
########################################################
# Update the expiration time of a logtoken
sub updateLogTokenExpires {
my($self, $uid, $temp_str, $public_str, $locationid, $value, $seconds) = @_;
my $uid_q = $self->sqlQuote($uid);
my $where = join(" AND ",
"uid=$uid_q",
"locationid='$locationid'",
"temp='$temp_str'",
"public='$public_str'");
my $rows = $self->sqlUpdate('users_logtokens', {
-expires => "DATE_ADD(NOW(), INTERVAL $seconds SECOND)"
}, $where);
#print STDERR scalar(gmtime) . " $$ updateLogTokenExpires where='$where' seconds=$seconds rows='$rows'\n";
$self->_logtoken_write_memcached($uid, $temp_str, $public_str,
$locationid, $value, $seconds);
return $rows;
}
########################################################
# Delete logtoken(s)
sub deleteLogToken {
my($self, $uid, $all) = @_;
my $uid_q = $self->sqlQuote($uid);
my $where = "uid=$uid_q";
if (!$all) {
my($locationid, $temp_str, $public_str) = $self->_getLogTokenCookieLocation($uid);
$where .= " AND locationid='$locationid' AND temp='$temp_str' AND public='$public_str'";
$self->_logtoken_delete_memcached($uid, $temp_str, $public_str, $locationid);
$self->sqlDelete('users_logtokens', $where);
} else {
$self->_logtoken_delete_memcached($uid);
$self->sqlDelete('users_logtokens', $where);
}
#print STDERR scalar(gmtime) . " $$ deleteLogToken where='$where'\n";
}
########################################################
# Get user info from the users table.
# May be worth it to cache this at some point
sub getUserUID {
my($self, $name) = @_;
# We may want to add BINARY to this. -Brian
#
# The concern is that MySQL's "=" matches text chars that are not
# bit-for-bit equal, e.g. a-umlaut may "=" a, but that BINARY
# matching is apparently significantly slower than non-BINARY.
# Adding the ORDER at least makes the results predictable so this
# is not exploitable -- no one can add a later account that will
# make an earlier one inaccessible. A better method would be to
# grab all uid/nicknames that MySQL thinks match, and then to
# compare them (in order) in perl until a real bit-for-bit match
# is found. -jamie
# Actually there is a way to optimize a table for binary searches
# I believe -Brian
my($uid) = $self->sqlSelect(
'uid',
'users',
'nickname=' . $self->sqlQuote($name),
'ORDER BY uid ASC'
);
return $uid;
}
########################################################
# Get user info from the users table with email address.
# May be worth it to cache this at some point
sub getUserEmail {
my($self, $email) = @_;
my($uid) = $self->sqlSelect('uid', 'users',
'realemail=' . $self->sqlQuote($email)
);
return $uid;
}
#################################################################
# Corrected all of the above (those messages will go away soon.
# -Brian, Tue Jan 21 14:49:30 PST 2003
sub getCommentsByGeneric {
my($self, $where_clause, $num, $min, $options) = @_;
$options ||= {};
$min ||= 0;
my $limit = " LIMIT $min, $num " if $num;
my $force_index = "";
$force_index = " FORCE INDEX(uid_date) " if $options->{force_index};
$where_clause = "($where_clause) AND date > DATE_SUB(NOW(), INTERVAL $options->{limit_days} DAY)"
if $options->{limit_days};
$where_clause .= " AND cid >= $options->{cid_at_or_after} " if $options->{cid_at_or_after};
my $sort_field = $options->{sort_field} || "date";
my $sort_dir = $options->{sort_dir} || "DESC";
my $comments = $self->sqlSelectAllHashrefArray(
'*', "comments $force_index", $where_clause,
"ORDER BY $sort_field $sort_dir $limit");
return $comments;
}
#################################################################
sub getCommentsByUID {
my($self, $uid, $num, $min, $options) = @_;
my $constants = getCurrentStatic();
$options ||= {};
$options->{force_index} = 1 if $constants->{user_comments_force_index};
return $self->getCommentsByGeneric("uid=$uid", $num, $min, $options);
}
#################################################################
sub getCommentsByIPID {
my($self, $id, $num, $min, $options) = @_;
return $self->getCommentsByGeneric("ipid='$id'", $num, $min, $options);
}
#################################################################
sub getCommentsBySubnetID {
my($self, $id, $num, $min, $options) = @_;
return $self->getCommentsByGeneric("subnetid='$id'", $num, $min, $options);
}
#################################################################
# Avoid using this one unless absolutely necessary; if you know
# whether you have an IPID or a SubnetID, those queries take a
# fraction of a second, but this "OR" is a table scan.
sub getCommentsByIPIDOrSubnetID {
my($self, $id, $num, $min, $options) = @_;
my $constants = getCurrentStatic();
my $where = "(ipid='$id' OR subnetid='$id') ";
$where .= " AND cid >= $constants->{comments_forgetip_mincid} " if $constants->{comments_forgetip_mincid};
return $self->getCommentsByGeneric(
$where, $num, $min, $options
);
}
#################################################################
# Get list of DBs, original plan: never cache
# Now (July 2003) the plan is that we want to cache this lightly.
# At one call to this method per click, this select ends up being
# pretty expensive despite its small data return size and despite
# its having a near-100% hit rate in MySQL 4.x's query cache.
# Since we only update the dbs table with a periodic check anyway,
# we're never going to get an _instantaneous_ failover from reader
# to writer, so caching this just makes failover slightly _less_
# immediate. I can live with that. - Jamie 2003/07/24
{ # closure surrounding getDBs and getDB
# shared between sites, not a big deal
my $_getDBs_cached_nextcheck;
sub getDBs {
my($self) = @_;
my $constants = getCurrentStatic();
my $cache = getCurrentCache();
my $dbs_cache_time = 5; # this was 10, let's try 5
if ($cache->{dbs} && (($_getDBs_cached_nextcheck || 0) > time)) {
#use Data::Dumper;
#$Data::Dumper::Sortkeys = 1;
#print STDERR scalar(gmtime) . " $$ returning cached: " . Dumper($cache->{dbs});
return \%{ $cache->{dbs} };
}
my $dbs = $self->sqlSelectAllHashref('id', '*', 'dbs');
# If the DB was down previously, over how long a period does it
# get brought back up to speed?
my $dbs_revive_seconds = $constants->{dbs_revive_seconds} || 30;
# Calculate the real weight for each DB and write it into its
# hashref.
for my $dbid (keys %$dbs) {
my $db = $dbs->{$dbid};
my $weight_start = $db->{weight};
$weight_start = 1 if !$weight_start || $weight_start < 1;
# If we had cached data for this, then even though it expired,
# pull in the _last_seen_dead field. We'll overwrite it if
# necessary and write it back into the cache in a moment.
if ($cache->{dbs} && $cache->{dbs}{$dbid}) {
#print STDERR scalar(gmtime) . " $$ dbid=$dbid lsd=" . ($cache->{dbs}{$dbid}{_last_seen_dead} || 0) . "\n";
$db->{_last_seen_dead} = $cache->{dbs}{$dbid}{_last_seen_dead} || 0;
}
# Now calculate the factor for the DB being dead or alive,
# which will always be a number between 0 and 1.
my $weight_alive_factor = 1;
if ($db->{isalive} ne 'yes') {
$weight_alive_factor = 0;
$db->{_last_seen_dead} = time;
#print STDERR scalar(gmtime) . " $$ dbid=$dbid dead, lsd set to $db->{_last_seen_dead}\n";
} else {
# This DB is alive.
my $time_alive = time - ($db->{_last_seen_dead} || 0);
#print STDERR scalar(gmtime) . " $$ dbid=$dbid alive, time_alive=$time_alive, revive=$dbs_revive_seconds\n";
if ($time_alive < $dbs_revive_seconds) {
# This DB was not alive recently, so
# bring its weight_alive_factor back up
# to the normal level over a period of
# $dbs_revive_seconds seconds.
$weight_alive_factor = $time_alive / $dbs_revive_seconds;
}
}
# We square the weight_alive_factor because that eases the
# DB back up to speed, starting it slow when its caches
# are empty and accelerating once they've had a chance to
# fill.
$db->{weight_final} = $weight_start
* $weight_alive_factor ** 2
* $db->{weight_adjust};
#printf STDERR scalar(gmtime) . " $$ dbid=$dbid weights: %.3f %.3f %.3f %.3f\n", $weight_start, $weight_alive_factor**2, $db->{weight_adjust}, $db->{weight_final};
}
# The amount of time to cache this has to be hardcoded, since
# we obviously aren't able to get it from the DB at this level.
# This could be adjusted, but it should be on the same order as
# how often the balance_readers task runs (which right now is
# hardcoded to 5 seconds).
$_getDBs_cached_nextcheck = time + $dbs_cache_time;
# Cache it.
$cache->{dbs} = \%{ $dbs };
#print STDERR gmtime() . " $$ getDBs setting cache: " . Dumper($dbs);
return $dbs;
}
#################################################################
# get virtual user of a db type, for use when $user->{state}{dbs}
# not filled in
sub getDB {
my($self, $db_type) = @_;
my $dbs = $self->getDBs();
# Get a list of all usable dbids with this type.
my @dbids_usable =
sort { $a <=> $b }
grep { $dbs->{$_}{type} eq $db_type
&& $dbs->{$_}{weight_final} > 0 }
keys %$dbs;
#print STDERR scalar(gmtime) . " $$ dbids_usable for type '$db_type': '@dbids_usable'\n";
# If there is exactly zero or one DB that's usable, this is easy.
my $n_usable = scalar @dbids_usable;
if ($n_usable == 0) {
return undef;
} elsif ($n_usable == 1) {
return $dbs->{$dbids_usable[0]}{virtual_user};
}
# Add up the total weight of all usable DBs.
my $weight_total = 0;
for my $dbid (@dbids_usable) {
#printf STDERR "dbid=$dbid weight_final=$dbs->{$dbid}{weight_final}\n";
$weight_total += $dbs->{$dbid}{weight_final};
}
# Do the random pick.
my $x = rand(1) * $weight_total;
#printf STDERR "weight_total=%.3f x=%.3f\n", $weight_total, $x;
# Iterate through the usable dbids until we get to the one that
# was chosen. Actually, we don't include the last one in our
# checking; if we get to the last one, we return it. This is
# probably about a nanosecond faster, but more importantly, in
# case of a logic error or weird floating-point roundoff thing,
# it does something reasonable.
for my $i (0 .. $n_usable-2) {
my $dbid = $dbids_usable[$i];
$x -= $dbs->{$dbid}{weight_final};
if ($x <= 0) {
#print STDERR "returning $i of $n_usable, dbid=$dbid\n";
return $dbs->{$dbid}{virtual_user};
}
}
# It wasn't any of the others, and we know all the choices are
# good, so it must be the last one.
#print STDERR "returning last option, dbid=$dbids_usable[-1]\n";
return $dbs->{ $dbids_usable[-1] }{virtual_user};
}
} # end closure surrounding getDBs and getDB
#################################################################
# Utility function to return an array of all the virtual users for
# all the DBs of one specific type.
sub getDBVUsForType {
my($self, $type) = @_;
my $dbs = $self->getDBs();
return map { $dbs->{$_}{virtual_user} }
grep { $dbs->{$_}{type} eq $type }
keys %$dbs;
}
#################################################################
# Writing to the dbs_readerstatus table.
sub createDBReaderStatus {
my($self, $hr) = @_;
return $self->sqlInsert("dbs_readerstatus", $hr);
}
#################################################################
# Methods for reading and writing the dbs_readerstatus_queries table.
sub getDBReaderStatusQueryId {
my($self, $text) = @_;
my $id = $self->getDBReaderStatusQueryId_raw($text)
|| $self->createDBReaderStatusQuery($text);
return $id;
}
sub getDBReaderStatusQueryId_raw {
my($self, $text) = @_;
my $text_q = $self->sqlQuote($text);
return $self->sqlSelect("rsqid", "dbs_readerstatus_queries",
"text = $text_q");
}
sub createDBReaderStatusQuery {
my($self, $text) = @_;
$self->sqlInsert("dbs_readerstatus_queries",
{ rsqid => undef, text => $text },
{ ignore => 1 });
return $self->getLastInsertId();
}
#################################################################
sub getDBVirtualUsers {
my($self) = @_;
return $self->sqlSelectColArrayref('virtual_user', 'dbs')
}
#################################################################
# get list of DBs, never cache
# (do caching in getSlashConf)
# See code comment in getObject().
sub getClasses {
my($self) = @_;
my $classes = $self->sqlSelectAllHashref('class', '*', 'classes');
return $classes;
}
#################################################################
# Just create an empty content_filter
sub createContentFilter {
my($self, $formname) = @_;
$self->sqlInsert("content_filters", {
regex => '',
form => $formname,
modifier => '',
field => '',
ratio => 0,
minimum_match => 0,
minimum_length => 0,
err_message => ''
});
my $filter_id = $self->getLastInsertId({ table => 'content_filters', prime => 'filter_id' });
return $filter_id;
}
#################################################################
sub existsEmail {
my($self, $email) = @_;
# Returns count of users matching $email.
return ($self->sqlSelect('uid', 'users',
'realemail=' . $self->sqlQuote($email)))[0];
}
#################################################################
sub existsUid {
my($self, $uid) = @_;
return $self->sqlSelect('uid', 'users', 'uid=' . $self->sqlQuote($uid));
}
#################################################################
# Ok, this is now a transaction. This means that if we lose the DB
# while this is going on, we won't end up with a half created user.
# -Brian
sub createUser {
my($self, $matchname, $email, $newuser) = @_;
return unless $matchname && $email && $newuser;
$email =~ s/\s//g; # strip whitespace from emails
return if ($self->sqlSelect(
"uid", "users",
"matchname=" . $self->sqlQuote($matchname)
))[0] || $self->existsEmail($email);
$self->sqlDo("SET AUTOCOMMIT=0");
$self->sqlInsert("users", {
uid => undef,
realemail => $email,
nickname => $newuser,
matchname => $matchname,
seclev => 1,
passwd => encryptPassword(changePassword())
});
my $uid = $self->getLastInsertId({ table => 'users', prime => 'uid' });
unless ($uid) {
$self->sqlDo("ROLLBACK");
$self->sqlDo("SET AUTOCOMMIT=1");
}
return unless $uid;
# Since TEXT/BLOB columns can't have a DEFAULT value, and since in
# strict mode MySQL 5.0 will no longer silently supply the empty
# string as a default for TEXT NOT NULL, we need to explicitly set
# those columns to the empty string upon creation.
$self->sqlInsert("users_info", {
uid => $uid,
-lastaccess => 'NOW()',
-created_at => 'NOW()',
bio => '',
});
$self->sqlInsert("users_prefs", { uid => $uid });
$self->sqlInsert("users_comments", { uid => $uid });
$self->sqlInsert("users_hits", { uid => $uid });
$self->sqlInsert("users_index", {
uid => $uid,
story_never_topic => '',
slashboxes => '',
story_always_topic => '',
});
# All param fields should be set here, as some code may not behave
# properly if the values don't exist.
#
# You know, I know this might be slow, but maybe this thing could be
# initialized by a template? Wild thought, but that would prevent
# site admins from having to edit CODE to set this stuff up.
#
# - Cliff
# Initialize the expiry variables...
# ...users start out as registered...
my $constants = getCurrentStatic();
my $initdomain = fullhost_to_domain($email);
$self->setUser($uid, {
'registered' => 1,
'expiry_comm' => $constants->{min_expiry_comm},
'expiry_days' => $constants->{min_expiry_days},
'user_expiry_comm' => $constants->{min_expiry_comm},
'user_expiry_days' => $constants->{min_expiry_days},
initdomain => $initdomain,
created_ipid => getCurrentUser('ipid'),
});
$self->sqlDo("COMMIT");
$self->sqlDo("SET AUTOCOMMIT=1");
$self->setUser_delete_memcached($uid);
return $uid;
}
########################################################
sub setVar {
my($self, $name, $value) = @_;
my $name_q = $self->sqlQuote($name);
my $retval;
if (ref $value) {
my $update = { };
for my $k (qw( value description )) {
$update->{$k} = $value->{$k} if defined $value->{$k};
}
return 0 unless $update;
$retval = $self->sqlUpdate('vars', $update, "name=$name_q");
} else {
$retval = $self->sqlUpdate('vars', {
value => $value
}, "name=$name_q");
}
$self->setVar_delete_memcached();
return $retval;
}
########################################################
sub setSession {
my($self, $name, $value) = @_;
if (!$value->{lasttime}) {
$value->{'-lasttime'} = "NOW()"
}
$self->sqlUpdate('sessions', $value, 'uid=' . $self->sqlQuote($name));
}
########################################################
sub setBlock {
_genericSet('blocks', 'bid', '', @_);
}
########################################################
sub setRelatedLink {
_genericSet('related_links', 'id', '', @_);
}
########################################################
sub setDiscussion {
my($self, $id, $discussion) = @_;
if ($discussion->{kind}) {
my $kinds = $self->getDescriptions('discussion_kinds');
my $kind = delete $discussion->{kind};
my %r_kinds;
@r_kinds{values %$kinds} = keys %$kinds;
$discussion->{dkid} = $r_kinds{$kind} if $r_kinds{$kind};
}
_genericSet('discussions', 'id', '', @_);
}
########################################################
sub setDiscussionBySid {
_genericSet('discussions', 'sid', '', @_);
}
########################################################
sub setTemplate {
my($self, $tpid, $hash) = @_;
# Instructions don't get passed to the DB.
delete $hash->{instructions};
# Nor does a version (yet).
delete $hash->{version};
for (qw| page name skin |) {
next unless $hash->{$_};
if ($hash->{$_} =~ /;/) {
errorLog("Semicolon found, $_='$hash->{$_}', setTemplate aborted");
return;
}
}
_genericSet('templates', 'tpid', '', @_);
}
########################################################
sub getCommentChildren {
my($self, $cid) = @_;
my($scid) = $self->sqlSelectAll('cid', 'comments', "pid=$cid");
return $scid;
}
########################################################
sub getCommentsStartingAt {
my($self, $start_at, $options) = @_;
my $limit = ($options->{limit} && $options->{limit}) ? "LIMIT $options->{limit}" : "";
my $order = ($options->{order} && $options->{order} eq "DESC") ? "DESC" : "ASC";
my($comments) = $self->sqlSelectAllHashrefArray('*', 'comments', "cid >= $start_at", "ORDER BY cid $order $limit");
return $comments;
}
########################################################
# Does what it says, deletes one comment.
# For optimization's sake (not that Slashdot really deletes a lot of
# comments, currently one every four years!) commentcount and hitparade
# are updated from comments.pl's delete() function.
sub deleteComment {
my($self, $cid, $discussion_id) = @_;
my @comment_tables = qw( comment_text comments );
# We have to update the discussion, so make sure we have its id.
if (!$discussion_id) {
($discussion_id) = $self->sqlSelect("sid", 'comments', "cid=$cid");
}
my $total_rows = 0;
for my $table (@comment_tables) {
$total_rows += $self->sqlDelete($table, "cid=$cid");
}
my $constants = getCurrentStatic();
if ($constants->{m1}) {
my $moddb = getObject("Slash::$constants->{m1_pluginname}");
if ($moddb) {
$moddb->deleteModeratorlog({ cid => $cid });
}
}
if ($total_rows != scalar(@comment_tables)) {
# XXX This should be wrapped in a transaction
# instead of just throwing an error that may never
# be seen. However it gets tricky because some sites
# may still have comment_text as a MyISAM table for
# the FULLTEXT search index, and transactions don't
# work across table types. SearchToo may alleviate
# this problem soon. - Jamie 2006/10
errorLog("deleteComment cid $cid from $discussion_id,"
. " only $total_rows deletions");
return 0;
}
return 1;
}
########################################################
sub getCommentPid {
my($self, $sid, $cid) = @_;
$self->sqlSelect('pid', 'comments', "sid='$sid' AND cid=$cid");
}
########################################################
# This has been grandfathered in to the new section-topics regime
# because it's fairly important. Ultimately this should go away
# because we want to start asking "is this story in THIS nexus,"
# not "is it viewable anywhere on the site." But as long as it
# is still around, try to make it work retroactively. - Jamie 2004/05
# XXXSECTIONTOPICS get rid of this eventually
# If no $start_tid is passed in, this will return "sectional" stories
# as viewable, i.e. a story in _any_ nexus will be viewable.
sub checkStoryViewable {
my($self, $sid, $start_tid, $options) = @_;
return unless $sid;
my $stoid = $self->getStoidFromSidOrStoid($sid);
return 0 unless $stoid;
return 0 if $self->sqlCount(
"story_param",
"stoid = '$stoid' AND name='neverdisplay' AND value > 0");
my @nexuses;
if ($start_tid) {
push @nexuses, $start_tid;
} else {
@nexuses = $self->getNexusTids();
}
my $nexus_clause = join ',', @nexuses;
# If stories.time is not involved, this goes very fast; we
# just look for rows in a single table, and either they're
# there or not.
if ($options->{no_time_restrict}) {
my $count = $self->sqlCount(
"story_topics_rendered",
"stoid = '$stoid' AND tid IN ($nexus_clause)");
return $count > 0 ? 1 : 0;
}
# We need to look at stories.time, so this is a join.
$options ||= {};
my($column_time, $where_time) = $self->_stories_time_clauses({
try_future => 1, must_be_subscriber => 1
});
my $time_clause = $options->{no_time_restrict} ? "" : " AND $where_time";
my $count = $self->sqlCount(
"stories, story_topics_rendered",
"stories.stoid = '$stoid'
AND stories.stoid = story_topics_rendered.stoid
AND story_topics_rendered.tid IN ($nexus_clause)
$time_clause",
);
return $count >= 1 ? 1 : 0;
}
sub checkStoryInNexus {
my($self, $stoid, $nexus_tid) = @_;
my $stoid_q = $self->sqlQuote($stoid);
my $tid_q = $self->sqlQuote($nexus_tid);
return $self->sqlCount("story_topics_rendered",
"stoid=$stoid_q AND tid=$tid_q");
}
########################################################
# Returns 1 if and only if a discussion is viewable only to subscribers
# (and admins).
sub checkDiscussionIsInFuture {
my($self, $discussion) = @_;
return 0 unless $discussion && $discussion->{sid};
my($column_time, $where_time) = $self->_stories_time_clauses({
try_future => 1,
must_be_subscriber => 0,
column_name => "ts",
});
my $count = $self->sqlCount(
'discussions',
"id='$discussion->{id}' AND type != 'archived'
AND $where_time
AND ts > NOW()"
);
return $count;
}
########################################################
# $id is a discussion id. -Brian
sub checkDiscussionPostable {
my($self, $id) = @_;
return 0 unless $id;
my $constants = getCurrentStatic();
# This should do it.
my($column_time, $where_time) = $self->_stories_time_clauses({
try_future => $constants->{subscribe_future_post},
must_be_subscriber => 1,
column_name => 'ts',
});
my $count = $self->sqlCount(
'discussions',
"id='$id' AND type != 'archived' AND $where_time",
);
return 0 unless $count;
# Now, we are going to get paranoid and run the story checker against it
my $discussion = $self->getDiscussion($id, [ qw(dkid sid) ]);
if ($discussion->{sid}) {
my $kinds = $self->getDescriptions('discussion_kinds');
if ($kinds->{ $discussion->{dkid} } eq 'story') {
return $self->checkStoryViewable($discussion->{sid});
}
}
return 1;
}
########################################################
sub setSection {
errorLog("setSection called");
_genericSet('sections', 'section', '', @_);
}
########################################################
sub createSection {
my($self, $hash) = @_;
errorLog("createSection called");
$self->sqlInsert('sections', $hash);
}
########################################################
sub setDiscussionDelCount {
my($self, $sid, $count) = @_;
return unless $sid;
my $where = '';
if ($sid =~ /^\d+$/) {
$where = "id=$sid";
} else {
$where = "sid=" . $self->sqlQuote($sid);
}
$self->sqlUpdate(
'discussions',
{
-commentcount => "commentcount-$count",
flags => "dirty",
},
$where
);
}
########################################################
# Long term, this needs to be modified to take in account
# of someone wanting to delete a submission that is
# not part in the form
sub deleteSubmission {
my($self, $options, $nodelete) = @_; # $nodelete param is obsolete
my $uid = getCurrentUser('uid');
my $form = getCurrentForm();
my $constants = getCurrentStatic();
my @subid;
$options = {} unless ref $options;
$options->{nodelete} = $nodelete if defined $nodelete;