Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
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;
# This might need some cleaning up if nothing is using it.
if ($form->{subid} && !$options->{nodelete}) {
my $subid_q = $self->sqlQuote($form->{subid});
# Try updating del to 1, but only if it's still 0
my $rows = $self->sqlUpdate("submissions",
{ del => 1 }, "subid=$subid_q AND del=0"
);
if ($rows) {
$self->setUser($uid,
{ -deletedsubmissions => 'deletedsubmissions+1' }
);
push @subid, $form->{subid};
}
}
for (keys %{$form}) {
# $form has several new internal variables that match this regexp, so
# the logic below should always check $t.
next unless /^(\w+)_(\d+)$/;
my($t, $n) = ($1, $2);
my $n_q = $self->sqlQuote($n);
if ($t eq "note" || $t eq "comment" || $t eq "skid") {
$form->{"note_$n"} = "" if $form->{"note_$n"} eq " ";
if ($form->{$_}) {
my %sub = (
note => $form->{"note_$n"},
comment => $form->{"comment_$n"},
primaryskid => $form->{"skid_$n"}
);
if (!$sub{note}) {
delete $sub{note};
$sub{-note} = 'NULL';
}
$self->sqlUpdate('submissions',
\%sub, "subid=$n_q"
);
}
} elsif ($t eq 'del' && !$options->{nodelete}) {
if ($options->{accepted}) {
$self->sqlUpdate('submissions',
{ del => 2 }, "subid=$n_q"
);
push @subid, $n;
} else {
# Try updating del to 1, but only if it's still 0
my $rows = $self->sqlUpdate('submissions',
{ del => 1 }, "subid=$n_q AND del=0"
);
if ($rows) {
$self->setUser($uid,
{ -deletedsubmissions => 'deletedsubmissions+1' }
);
push @subid, $n;
}
}
}
}
if ($constants->{plugin}{FireHose} && @subid > 0) {
my $firehose = getObject("Slash::FireHose");
$firehose->rejectItemBySubid(\@subid);
}
return @subid;
}
########################################################
sub deleteSession {
my($self, $uid) = @_;
return unless $uid;
$uid = defined($uid) || getCurrentUser('uid');
if (defined $uid) {
$self->sqlDelete("sessions", "uid=$uid");
}
}
########################################################
sub deleteDiscussion {
my($self, $did) = @_;
$self->sqlDelete("discussions", "id=$did");
my $comment_ids = $self->sqlSelectAll('cid', 'comments', "sid=$did");
$self->sqlDelete("comments", "sid=$did");
$self->sqlDelete("comment_text",
"cid IN ("
. join(",", map { $_->[0] } @$comment_ids)
. ")"
) if @$comment_ids;
my $constants = getCurrentStatic();
if ($constants->{m1}) {
my $moddb = getObject("Slash::$constants->{m1_pluginname}");
if ($moddb) {
$moddb->deleteModeratorlog({ sid => $did });
}
}
}
########################################################
# Delete a topic. At least for now (2004/09), we are requiring a
# replacement topic ID to be specified, so parents and children of
# the deleted topic can be re-established.
sub deleteTopic {
my($self, $tid, $newtid) = @_;
my $constants = getCurrentStatic();
my $tid_q = $self->sqlQuote($tid);
my $newtid_q = $self->sqlQuote($newtid);
my $tree = $self->getTopicTree();
my $ok = 1;
my $errmsg = "";
if (!$tid) {
$ok = 0; $errmsg = "no topic to delete was given";
}
if ($ok && !$newtid) {
$ok = 0; $errmsg = "no replacement topic given";
}
if ($ok && $tid == $newtid) {
$ok = 0; $errmsg = "cannot replace topic with itself";
}
if ($ok && !$tree->{$tid}) {
$ok = 0; $errmsg = "topic to delete not found";
}
if ($ok && !$tree->{$newtid}) {
$ok = 0; $errmsg = "replacement topic not found";
}
if ($ok) {
my @tid_children = $self->getAllChildrenTids($tid);
my @newtid_children = $self->getAllChildrenTids($newtid);
my @tid_parents = $self->getAllParentsTids($tid);
my @newtid_parents = $self->getAllParentsTids($newtid);
my %tid_parents = map { ($_, 1) } @tid_parents;
my %newtid_parents = map { ($_, 1) } @newtid_parents;
my $badtid;
if (($badtid) = grep { $tid_parents{$_} } @newtid_children) {
$ok = 0; $errmsg = "replacement topic is a (grand,etc.?)parent of deleted topic child $badtid";
} elsif (($badtid) = grep { $newtid_parents{$_} } @tid_children) {
$ok = 0; $errmsg = "replacement topic is a (grand,etc.?)child of deleted topic parent $badtid";
}
}
if (!$ok) {
return($ok, $errmsg);
}
# We have to do two things in the topic_parents table. In both
# cases, we ignore failed UPDATEs, which will happen if the new
# tid/parent_tid unique key collides with an existing row, which
# would indicate that the topic in question has a relationship
# with the new topic already. Ignoring the failure means that
# the already-existing min_weight will be unchanged, which is
# what we want. Afterwards we delete any rows which failed to
# UPDATE.
# The first thing is to update the to-be-deleted topic's children
# to instead point to its replacement. In case one of the
# topic's children _is_ the replacement, don't make it loop to
# itself (and the resulting busted row will be deleted).
$self->sqlUpdate('topic_parents',
{ parent_tid => $newtid },
"parent_tid=$tid_q AND tid != $newtid_q",
{ ignore => 1 });
$self->sqlDelete('topic_parents', "parent_tid=$tid_q");
# Second, update the to-be-deleted topic's parents to instead
# be pointed-to by its replacement. In case one of the topic's
# parents _is_ the replacement, don't make it loop to itself
# (and the resulting busted row will be deleted, same as above).
$self->sqlUpdate('topic_parents',
{ tid => $newtid },
"tid=$tid_q AND parent_tid != $newtid_q",
{ ignore => 1 });
$self->sqlDelete('topic_parents', "tid=$tid_q");
# Now update existing objects that had the old tid as a topic to
# have the new tid. Stories are a special case so skip those
# for now.
# These tables have topics stored as 'tid'.
$self->sqlUpdate("submissions", { tid => $newtid }, "tid=$tid_q");
if ($constants->{plugin}{Journal}) {
$self->sqlUpdate("journals", { tid => $newtid }, "tid=$tid_q");
}
$self->sqlUpdate("discussions", { topic => $newtid }, "topic=$tid_q");
$self->sqlUpdate("pollquestions", { topic => $newtid }, "topic=$tid_q");
# OK, for stories, it's a little more complicated because we have
# not just a tid column, but two other tables. First we mark
# stories as needing to be re-rendered.
$self->markTopicsDirty([ $tid, $newtid ]);
# Then change the stories.tid column.
$self->sqlUpdate("stories", { tid => $newtid }, "tid=$tid_q");
# Now change everything in the chosen and rendered tables.
# Stories with both old and new already existing will have this
# fail because (stoid,tid) is a unique index, but that is OK.
$self->sqlUpdate("story_topics_chosen", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
$self->sqlUpdate("story_topics_rendered", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
# Delete any rows that failed to change because of the
# unique index.
$self->sqlDelete("story_topics_chosen", "tid=$tid_q");
$self->sqlDelete("story_topics_rendered", "tid=$tid_q");
# Finally, we nuke the topic from the topic tables themselves
# (except topic_parents which we have already taken care of).
$self->sqlDelete("topics", "tid=$tid_q");
$self->sqlUpdate("topic_nexus", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
$self->sqlDelete("topic_nexus", "tid=$tid_q");
$self->sqlUpdate("topic_nexus_dirty", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
$self->sqlDelete("topic_nexus_dirty", "tid=$tid_q");
$self->sqlUpdate("topic_nexus_extras", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
$self->sqlDelete("topic_nexus_extras", "tid=$tid_q");
$self->sqlUpdate("topic_param", { tid => $newtid }, "tid=$tid_q", { ignore => 1 });
$self->sqlDelete("topic_param", "tid=$tid_q");
$self->setVar('topic_tree_lastchange', time());
return (1, "");
}
########################################################
sub revertBlock {
my($self, $bid) = @_;
my $bid_q = $self->sqlQuote($bid);
my $block = $self->sqlSelect("block", "backup_blocks", "bid = $bid_q");
$self->sqlUpdate("blocks", { block => $block }, "bid = $bid_q");
}
########################################################
sub deleteBlock {
my($self, $bid) = @_;
my $bid_q = $self->sqlQuote($bid);
$self->sqlDelete("blocks", "bid = $bid_q");
}
########################################################
sub deleteTemplate {
my($self, $tpid) = @_;
my $tpid_q = $self->sqlQuote($tpid);
$self->sqlDelete("templates", "tpid = $tpid_q");
}
########################################################
sub deleteSection {
my($self, $section) = @_;
errorLog("deleteSection called");
my $section_q = $self->sqlQuote($section);
$self->sqlDelete("sections", "section=$section_q");
}
########################################################
sub deleteContentFilter {
my($self, $id) = @_;
my $id_q = $self->sqlQuote($id);
$self->sqlDelete("content_filters", "filter_id=$id_q");
}
########################################################
sub saveTopic {
# this is designed to take lots of data and filter it,
# so we can't just take additional params and put them in
# the param table; for now, put them in $options -- pudge
my($self, $topic, $options) = @_;
my $tid = $topic->{tid} || 0;
my $rows = $self->sqlCount('topics', "tid=$tid");
my $image = $topic->{image2} || $topic->{image};
my $submittable = $topic->{submittable} || 'no';
my $searchable = $topic->{searchable} || 'no';
my $storypickable = $topic->{storypickable} || 'no';
my $data = {
keyword => $topic->{keyword},
textname => $topic->{textname},
series => $topic->{series} eq 'yes' ? 'yes' : 'no',
image => $image,
width => $topic->{width} || '',
height => $topic->{height} || '',
submittable => $submittable eq 'no' ? 'no' : 'yes',
searchable => $searchable eq 'no' ? 'no' : 'yes',
storypickable => $storypickable eq 'no' ? 'no' : 'yes',
};
if ($rows == 0) {
### tids under 10000 are reserved for "normal" tids, where > 10000
### are for tids where we want to have a specific tid, such as
### for topics groups that might be moved between sites
### XXXSECTIONTOPICS
my $where = 'tid < 10000';
my $default_tid = 0;
if ($options->{lower_limit}) {
$where = "tid > $options->{lower_limit}";
if ($options->{upper_limit}) {
$where .= " AND tid < $options->{upper_limit}";
}
$default_tid = $options->{lower_limit};
}
# we could do a LOCK TABLE, because this will be used so seldom, but
# OTOH, if tasks use this to dump a lot of data, it could mean a lot
# of locks. this is a little bit trickier, but should be fine. -- pudge
my $tries = 0;
RETRY: {
$self->sqlDo("SET AUTOCOMMIT=0");
$tid = $self->sqlSelect('MAX(tid)', 'topics', $where);
$tid ||= $default_tid;
$data->{tid} = ++$tid;
if ($self->sqlInsert('topics', $data)) {
$self->sqlDo("COMMIT");
$self->sqlDo("SET AUTOCOMMIT=1");
} else {
$self->sqlDo("ROLLBACK");
$self->sqlDo("SET AUTOCOMMIT=1");
errorLog("$DBI::errstr");
# only try a few times before giving up
return 0 if ++$tries > 5;
goto RETRY;
}
}
} else {
$self->sqlUpdate('topics', $data, "tid=$tid");
}
if ($options->{param}) {
my $params = $options->{param};
for my $name (keys %$params) {
if (defined $params->{$name} && length $params->{$name}) {
$self->sqlReplace('topic_param', {
tid => $tid,
name => $name,
value => $params->{$name}
});
} else {
my $name_q = $self->sqlQuote($name);
$self->sqlDelete('topic_param',
"tid = $tid AND name = $name_q"
);
}
}
}
my %dirty_topics;
##### XXXSECTIONTOPICS check for recursives
for my $x (qw(parent child)) {
my %relations;
my $name = $x . '_topic';
if ($topic->{_multi}{$name} && ref($topic->{_multi}{$name}) eq 'ARRAY') {
%relations = map { $_ => undef } grep { $_ } @{$topic->{_multi}{$name}};
} elsif ($topic->{$name}) {
if (ref($topic->{$name}) eq 'HASH') {
%relations = map { $_ => $topic->{$name}{$_} } grep { $_ } keys %{$topic->{$name}};
} elsif (ref($topic->{$name}) eq 'ARRAY') {
%relations = map { $_ => undef } grep { $_ } @{$topic->{$name}};
} else {
%relations = ($topic->{$name} => undef);
}
}
my $del_str = join ',', keys %relations;
if ($x eq 'parent') {
my $tids = $self->sqlSelectColArrayref("parent_tid", "topic_parents", "tid=$tid");
$dirty_topics{$_}++ for @$tids;
$self->sqlDelete('topic_parents', "tid=$tid AND parent_tid NOT IN ($del_str)") if $del_str;
} elsif ($x eq 'child') {
my $tids = $self->sqlSelectColArrayref("tid", "topic_parents", "parent_tid=$tid");
$dirty_topics{$_}++ for @$tids;
$self->sqlDelete('topic_parents', "parent_tid=$tid AND tid NOT IN ($del_str)") if $del_str;
}
for my $thistid (keys %relations) {
$dirty_topics{$thistid}++;
my %relation = (
tid => $tid,
parent_tid => $thistid,
);
$relation{min_weight} = $relations{$thistid} if defined $relations{$thistid};
if ($x eq 'child') {
@relation{qw(tid parent_tid)} = @relation{qw(parent_tid tid)};
}
$self->sqlInsert('topic_parents', \%relation, { ignore => 1 });
# update changed weights
$self->sqlUpdate('topic_parents',
{ min_weight => $relation{min_weight} },
"tid = $relation{tid} AND parent_tid = $relation{parent_tid}",
) if $relation{min_weight};
}
}
if ($topic->{nexus}) {
$self->sqlInsert('topic_nexus', { tid => $tid }, { ignore => 1 });
} else {
$self->sqlDelete('topic_nexus', "tid=$tid");
}
$self->markTopicsDirty([ $tid, keys %dirty_topics ]);
return $tid;
}
##################################################################
# Another hated method -Brian
sub saveBlock {
my($self, $bid) = @_;
my($rows) = $self->sqlSelect('count(*)', 'blocks',
'bid=' . $self->sqlQuote($bid)
);
my $form = getCurrentForm();
if ($form->{save_new} && $rows > 0) {
return $rows;
}
if ($rows == 0) {
$self->sqlInsert('blocks', { bid => $bid, seclev => 500 });
}
my($portal, $retrieve) = (0, 0, 0);
# If someone marks a block as a portald block then potald is a portald
# something tell me I may regret this... -Brian
$form->{type} = 'portald' if $form->{portal} == 1;
# this is to make sure that a static block doesn't get
# saved with retrieve set to true
$form->{retrieve} = 0 if $form->{type} ne 'portald';
# If a block is a portald block then portal=1. type
# is done so poorly -Brian
$form->{portal} = 1 if $form->{type} eq 'portald';
$form->{block} = $self->autoUrl($form->{section}, $form->{block})
unless $form->{type} eq 'template';
if ($rows == 0 || $form->{blocksavedef}) {
$self->sqlUpdate('blocks', {
seclev => $form->{bseclev},
block => $form->{block},
description => $form->{description},
type => $form->{type},
ordernum => $form->{ordernum},
title => $form->{title},
url => $form->{url},
rdf => $form->{rdf},
rss_template => $form->{rss_template},
items => $form->{items},
skin => $form->{skin},
retrieve => $form->{retrieve},
all_skins => $form->{all_skins},
autosubmit => $form->{autosubmit},