saint/discourse-legacysite-perl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

First pass at adding key files

Browse Source
This commit is contained in:
dsainty
2024-06-17 21:49:12 +10:00
commit aa25e9347f
1274 changed files with 392549 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

95
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/CatLinks.pm Normal file
View File

@ -0,0 +1,95 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: CatLinks.pm,v 1.4 2006/03/25 01:13:35 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
package Links::Table::CatLinks;
# ==================================================================
use strict;
use Links qw/:payment :objects/;
use GT::SQL;
use GT::SQL::Table;
use vars qw /@ISA $ERROR_MESSAGE @DELETING/;
@ISA = qw/GT::SQL::Table/;
$ERROR_MESSAGE = 'GT::SQL';
@DELETING = (); # Used by Links::Table::Links
sub delete {
# -----------------------------------------------------------------------------
# We override the default CatLinks delete to delete any links that will no
# longer be referenced as a result of the deletion.
#
my ($self, $cond) = @_;
ref $cond or return $self->fatal(BADARGS => '$catlinks->delete(condition)');
# Get the CatLinks rows that are about to be deleted
my (%delete, %links);
my $sth = $self->select($cond);
while (my $row = $sth->fetchrow_hashref) {
$delete{$row->{LinkID}}++;
if (exists $links{$row->{LinkID}}) {
push @{$links{$row->{LinkID}}}, $row->{CategoryID};
}
else {
$links{$row->{LinkID}} = [$row->{CategoryID}];
}
}
# Delete the CatLinks rows
my $ret = $self->SUPER::delete($cond) or return;
# Get the links that still exist in the CatLinks table after the delete (ie.
# links that were in multiple categories). These are the links that shouldn't
# be deleted from the Links table.
my @remaining = keys %delete ? $self->select('LinkID', { LinkID => [keys %delete] })->fetchall_list : ();
for (@remaining, @DELETING) {
delete $delete{$_};
}
# Non-validated links don't increment Category counts.
my @notval = keys %links ? $DB->table('Links')->select('ID', { ID => [keys %links], isValidated => 'No' })->fetchall_list : ();
for (@notval, @DELETING) {
delete $links{$_};
}
# Any links in %delete have no references to it from CatLinks
if (keys %delete) {
$DB->table('Links')->delete({ ID => [keys %delete] });
}
# Build a list of categories that need their counts updated
my %cats;
for (keys %links) {
for (@{$links{$_}}) {
$cats{$_}++;
}
}
# Update the Category link counts
if (keys %cats) {
my $category = $DB->table('Category');
my %change;
while (my ($catid, $count) = each %cats) {
push @{$change{-$count}}, $catid;
}
$category->link_count(\%change);
while (my ($change, $ids) = each %change) {
$category->update({ Direct_Links => \("Direct_Links - " . abs $change) }, { ID => $ids });
}
}
$ret;
}
1;

638
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Category.pm Normal file
View File

@ -0,0 +1,638 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: Category.pm,v 1.29 2009/05/11 05:57:45 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
package Links::Table::Category;
# ==================================================================
use strict;
use Links qw/:payment :objects/;
use GT::SQL;
use GT::SQL::Table;
use GT::Lock qw/lock unlock LOCK_TRY/;
use vars qw /@ISA $ERRORS $ERROR_MESSAGE/;
@ISA = qw/GT::SQL::Table/;
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
BADCATNAME => "Invalid category name: %s",
BADCATID => "Invalid category id: %s",
BADCATSUG => "There is no category with that name. Perhaps you meant: %s",
CATEXISTS => "A category with the name '%s' already exists.",
};
# We wrap new() to handle updating Number_of_Links - but only once: the first
# time a Category table object is created.
sub new {
my $self = shift->SUPER::new(@_) or return;
return $self if $STASH{expired_links}++;
my $links = $DB->table('Links');
my $cond;
if ($CFG->{payment}->{enabled}) {
$cond = GT::SQL::Condition->new(
ExpiryCounted => '=' => 0,
ExpiryDate => '<' => time,
isValidated => '=' => 'Yes'
);
}
else {
$cond = GT::SQL::Condition->new(
ExpiryCounted => '=' => 1,
isValidated => '=' => 'Yes'
);
}
# Don't select the ID's here because we haven't established a lock. Since
# most requests won't catch expired links, doing a count here to avoid
# needing the lock is going to be slightly slower occassionally, but
# usually faster.
return $self unless $links->count($cond);
# We've now determined that there _are_ links that have expired that
# haven't been counted yet, so we establish a lock (to prevent a race
# condition), and then update the links counts for categories that have
# newly-expired links. If getting the lock fails, simply return - this is
# only likely to happen when another process has the lock and is performing
# the updates already, or when a previous process with a lock died - the
# 120 should make sure that such a condition doesn't last longer than 2
# minutes.
lock cat_link_count => 1, LOCK_TRY, 120
or return $self;
my @links = $links->select(ID => $cond)->fetchall_list;
unless (@links) { # Despite the above count, there might not be links now if we had to wait for a lock
unlock 'cat_link_count';
return $self;
}
if ($CFG->{payment}->{expired_is_free}) {
# This gets a bit hairy - expired links need to become free but NOT in
# required categories. On the other hand, links in non-required
# categories don't affect the count.
my %req_links = map { $_ => 1 } $DB->table('Category', 'CatLinks')->select(LinkID => { LinkID => \@links, Payment_Mode => $CFG->{payment}->{mode} == REQUIRED ? [GLOBAL, REQUIRED] : REQUIRED })->fetchall_list;
my @to_free = grep !$req_links{$_}, @links;
if (@to_free) {
$DB->table('Links')->update({ LinkExpired => \'ExpiryDate' }, { ID => \@to_free });
$DB->table('Links')->update({ ExpiryDate => FREE }, { ID => \@to_free });
}
@links = keys %req_links;
unless (@links) {
unlock 'cat_link_count';
return $self;
}
}
my $catlinks = $DB->table('CatLinks');
$catlinks->select_options('GROUP BY CategoryID');
my %cats = $catlinks->select(CategoryID => 'COUNT(*)' => { LinkID => \@links })->fetchall_list; # FIXME this query can be huge and will fail (the select() will fail and return undef)
my %adjust;
my %direct_adj;
my $parents = $self->parents([keys %cats]);
for my $cat_id (keys %cats) {
$adjust{$cat_id} ||= 0;
$adjust{$cat_id} += $cats{$cat_id};
$direct_adj{$cat_id} ||= 0;
$direct_adj{$cat_id} += $cats{$cat_id};
for (@{$parents->{$cat_id}}) {
$adjust{$_} ||= 0;
$adjust{$_} += $adjust{$cat_id};
}
}
my %change;
while (my ($id, $change) = each %adjust) {
push @{$change{$CFG->{payment}->{enabled} ? -$change : $change}}, $id;
}
my %change_direct;
while (my ($id, $change) = each %direct_adj) {
push @{$change_direct{$CFG->{payment}->{enabled} ? -$change : $change}}, $id;
}
while (my ($adjust, $ids) = each %change) {
$self->update({ Number_of_Links => \("Number_of_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids });
}
while (my ($adjust, $ids) = each %change_direct) {
$self->update({ Direct_Links => \("Direct_Links " . ($adjust >= 0 ? '+' : '-') . ' ' . abs $adjust) }, { ID => $ids });
}
$links->update({ ExpiryCounted => $CFG->{payment}->{enabled} ? 1 : 0 }, { ID => \@links });
unlock 'cat_link_count';
return $self;
}
sub add {
# -------------------------------------------------------------------
# Adds a category, but passes it through the plugin system.
#
my $self = shift;
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
$PLG->dispatch('add_category', sub { return $self->_plg_add(@_) }, $p);
}
sub _plg_add {
# -------------------------------------------------------------------
# Add a category.
#
my ($self, $p) = @_;
$self->can_add($p) or return;
# If successful, we need to update timestamps of parents to denote a change.
if (my $id = $self->SUPER::add($p)) {
if ($p->{FatherID}) {
$self->update(
{ Timestmp => \"NOW()" },
{ ID => $self->parents($id) },
{ GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
);
}
return $id;
}
else {
return;
}
}
sub can_add {
# -------------------------------------------------------------------
# Confirms that a category can be added.
#
my $self = shift;
my $p = $self->common_param(@_) or return $self->warn(BADARGS => 'Usage: $table->add(HASH or HASH_REF or CGI)');
# Checks that the FatherID exists and set the full name.
$p->{FatherID} ||= 0;
if ($p->{FatherID} =~ /\D/) {
my $sth = $self->select(ID => Full_Name => { Full_Name => $p->{FatherID} });
if (my @row = $sth->fetchrow) {
$p->{FatherID} = $row[0];
$p->{Full_Name} = "$row[1]/$p->{Name}";
}
else {
my $names = $self->suggestions($p->{FatherID});
return $self->warn(
@$names
? (BADCATSUG => '<ul>' . join('', map "<li>$_</li>", @$names) . '</ul>')
: (BADCATNAME => $p->{FatherId})
);
}
}
elsif ($p->{FatherID} != 0) {
my $full_name = $self->get_name_from_id($p->{FatherID}) or return $self->warn(BADCATID => $p->{FatherID});
$p->{Full_Name} = "$full_name/$p->{Name}";
}
else {
$p->{Full_Name} = $p->{Name};
}
# Checks that there is no other category with the same (Name, FatherID)
return $self->warn(CATEXISTS => $p->{Name})
if $self->count({ Name => $p->{Name}, FatherID => $p->{FatherID} });
return 1;
}
sub delete {
# -------------------------------------------------------------------
# Deletes a category, but passes through the plugin system.
#
my ($self, $where) = @_;
if (not ref $where or ref $where eq 'ARRAY') {
$where = { ID => $where };
}
return $self->fatal(BADARGS => 'Usage: $category->delete(condition)')
unless ref $where eq 'HASH' or UNIVERSAL::isa($where, 'GT::SQL::Condition');
my $ret;
my %cats = $self->select(qw/ID Direct_Links/ => $where)->fetchall_list;
if ($PLG->active_plugins('delete_category')) {
for my $id (keys %cats) {
my $r = $PLG->dispatch('delete_category', sub { return $self->SUPER::delete(@_) }, { ID => $id });
$ret += $r if defined $r;
}
$ret = '0 but true' if (defined $ret and $ret == 0) or not keys %cats;
}
else {
$ret = $self->SUPER::delete($where);
}
return $ret unless $ret;
# Clear out the cache as the hierarchy has changed.
$self->_clear_cache;
$ret;
}
sub modify {
# -------------------------------------------------------------------
# Modifies a category, but passes through the plugin system.
#
my ($self, $cat) = @_;
$PLG->dispatch('modify_category', sub { return $self->_plg_modify(@_) }, $cat);
}
sub _plg_modify {
# -------------------------------------------------------------------
# Modify a single category.
#
my $self = shift;
my $set = shift or return $self->error('BADARGS', 'FATAL', "Usage: \$cat->modify( { col => value ... } ).");
my $id = $set->{ID} or return $self->error('BADARGS', 'FATAL', "No primary key passed to modify!");
# Get the original info.
my $orig = $self->select(qw/ID FatherID Full_Name Name Number_of_Links/ => { ID => $id })->fetchrow_hashref
or return $self->warn(BADCATID => $id);
# Fix up the father ID.
$set->{FatherID} ||= 0;
if ($set->{FatherID} !~ /^\d+$/) {
my $new_id = $self->get_id_from_name($set->{FatherID});
if (! $new_id) {
my $names = $self->suggestions($set->{FatherID});
return $self->error(@$names
? ('BADCATSUG', 'WARN', "<ul>" . join('', map "<li>$_</li>", @$names) . "</ul>")
: ('BADCATNAME', 'WARN', $set->{FatherID})
);
}
$set->{FatherID} = $new_id;
}
$self->can_modify($set, $orig) or return;
if ($orig->{Name} eq $set->{Name} and $orig->{FatherID} == $set->{FatherID}) {
# Name and parent haven't changed, no special modify handling needed
return $self->SUPER::modify($set);
}
elsif ($orig->{FatherID} == $set->{FatherID}) {
# Name has changed, but parent is the same: update ancestors'
# timestamps, change the full name, and update subcategory names.
($set->{Full_Name} = $orig->{Full_Name}) =~ s/\Q$orig->{Name}\E$/$set->{Name}/i;
my $ret = $self->SUPER::modify($set);
if ($ret) {
# Update was successful, update the timestamp of old and new parents
# Clear the as the tree just changed
$self->_clear_cache;
if ($set->{FatherID}) {
my $parents = $self->parents($id);
$self->update({ Timestmp => \"NOW()" }, { ID => $parents }, { GT_SQL_SKIP_CHECK => 1 })
if @$parents;
}
$self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name});
}
return $ret;
}
else {
# The category has moved; get the new parent's full name and update
my $fn = $self->select(Full_Name => { ID => $set->{FatherID} })->fetchrow;
$set->{Full_Name} = ($fn ? "$fn/" : '') . $set->{Name};
my $ret = $self->SUPER::modify($set);
if ($ret) {
# Clear the cache as the tree has changed.
$self->_clear_cache;
$self->update_full_name($id, $orig->{Full_Name}, $set->{Full_Name});
# Now update counters on the above parents.
# Clear out the cache as otherwise we get our old parents.
if ($orig->{Number_of_Links} != 0) {
$self->link_count($orig->{FatherID}, -$orig->{Number_of_Links});
$self->link_count($set->{FatherID}, $orig->{Number_of_Links});
}
}
# Clear out the cache.
$self->_clear_cache;
return $ret;
}
}
sub update_full_name {
# -----------------------------------------------------------------------------
# Call this after changing a category's Full_Name to change all the category's
# children's full names. Call with the category ID, old full name, and new
# full name.
#
my ($self, $id, $old, $new) = @_;
my @children = @{$self->children($id)};
my $new_escaped = $self->quote($new . '/');
my $old_offset = length($old) + 2;
my $set;
if (lc $self->{connect}->{driver} eq 'mysql') {
$set = "CONCAT($new_escaped, SUBSTRING(Full_Name, $old_offset))";
}
elsif (lc $self->{connect}->{driver} eq 'pg') {
$set = "$new_escaped || SUBSTRING(Full_Name, $old_offset)";
}
elsif (lc $self->{connect}->{driver} eq 'odbc' or lc $self->{connect}->{driver} eq 'mssql') {
$set = "$new_escaped + SUBSTRING(Full_Name, $old_offset, 255)";
}
elsif (lc $self->{connect}->{driver} eq 'oracle') {
$set = "$new_escaped || SUBSTR(Full_Name, $old_offset)";
}
if ($set) {
$self->update(
{ Full_Name => \$set },
{ ID => \@children },
{ GT_SQL_SKIP_CHECK => 1 }
);
}
else {
my $sth = $self->select(qw/ID Full_Name/ => { ID => \@children });
while (my ($id, $full_name) = $sth->fetchrow) {
$full_name =~ s/^\Q$old/$new/ or next;
$self->update({ Full_Name => $full_name }, { ID => $id }, { GT_SQL_SKIP_CHECK => 1 });
}
}
}
sub can_modify {
# -------------------------------------------------------------------
# Returns 1 if a record can be modified, undef otherwise.
#
my ($self, $new, $orig) = @_;
# If the FatherID has changed, make sure the new father exists. If it's 0, then
# it's the root category and we don't worry about it.
if ($orig->{FatherID} != $new->{FatherID} or $orig->{Name} ne $new->{Name}) {
if ($orig->{FatherID} != $new->{FatherID} and $new->{FatherID}) {
$self->count({ ID => $new->{FatherID} }) or return $self->error('BADCATID', 'WARN', $new->{FatherID});
}
# Now make sure the new FatherID,Name doesn't exist as it must be unique.
$self->count({ FatherID => $new->{FatherID}, Name => $new->{Name} }, GT::SQL::Condition->new(ID => '!=' => $orig->{ID})) and return $self->error('CATEXISTS', 'WARN', $new->{Name});
}
return 1;
}
sub template_set {
# -------------------------------------------------------------------
# Return the value of template set to use for a given category.
#
my $self = shift;
my $id = shift or return $self->error('BADARGS', 'FATAL', "Must pass category id to template_set");
return '' unless (exists $self->{schema}->{cols}->{Category_Template});
return $self->{_template_cache}->{$id} if (exists $self->{_template_cache}->{$id});
# If this category has a template set, use it.
my $cat_info = $self->select(Category_Template => { ID => $id })->fetchrow;
# Otherwise look at its parents.
unless ($cat_info) {
my $parents = $self->parents($id);
for my $parent (@$parents) {
$cat_info = $self->select(Category_Template => { ID => $parent })->fetchrow
and last;
}
}
$self->{_template_cache}->{$id} = $cat_info || '';
return $self->{_template_cache}->{$id};
}
sub parents {
# -----------------------------------------------------------------------------
# Returns parent ID's given one or more category ID's. If called with a single
# category ID, the return value is an array reference of the ID's of the
# category's parents, from father => root. If called with an array reference
# of category ID's, the return value is a hash reference of
# (ID => [rootid ... parentid]) pairs, with one pair for each category.
#
my $self = shift;
my $id = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to parents");
my (%ret, @lookup);
for (ref $id ? @$id : $id) {
unless ($ret{$_} = $self->{_parent_cache}->{$_}) {
push @lookup, $_;
}
}
if (@lookup) {
my $parents = $self->tree->parent_ids(id => \@lookup, include_dist => 1);
for (@lookup) {
$ret{$_} = $self->{_parent_cache}->{$_} = [sort { $parents->{$_}->{$b} <=> $parents->{$_}->{$a} } keys %{$parents->{$_}}];
}
}
return ref $id
? \%ret
: [reverse @{$ret{$id}}];
}
sub children {
# -----------------------------------------------------------------------------
# Exactly like parents(), except you get descendants rather than ancestors, and
# you get them in shallowest => deepest.
#
my $self = shift;
my $id = shift or return $self->error('BADARGS', 'FATAL', "No category id passed to children");
my (%ret, @lookup);
for (ref $id ? @$id : $id) {
unless ($ret{$_} = $self->{_child_cache}->{$_}) {
push @lookup, $_;
}
}
if (@lookup) {
my $children = $self->tree->child_ids(id => \@lookup, include_dist => 1);
for (@lookup) {
$ret{$_} = $self->{_child_cache}->{$_} = [sort { $children->{$_}->{$a} <=> $children->{$_}->{$b} } keys %{$children->{$_}}];
}
}
return ref $id
? \%ret
: $ret{$id};
}
sub suggestions {
# -----------------------------------------------------------------------------
# Returns a list of suggested category names. Takes a name and optional limit.
#
my $self = shift;
my $name = shift;
$name =~ y/\r\n//d;
$name =~ /\S/ or return [];
$self->select_options('LIMIT 10');
return [$self->select(Full_Name => GT::SQL::Condition->new(Full_Name => LIKE => "%$name%"))->fetchall_list];
}
sub link_count {
# -----------------------------------------------------------------------------
# Change the Number_of_Links count by n for specified id, and all parents. You
# can pass multiple ID's by passing an array reference for ID. You can pass
# both multiple change values by passing a hash reference of (CHANGE => [ID,
# ...]) pairs as the ID (the change value passed to the function will be
# ignored). Note that Direct_Links counts are NOT changed.
#
my ($self, $id, $change) = @_;
my %id;
if (!$id or ref $id eq 'ARRAY' and !@$id) {
return;
}
elsif (ref $id eq 'HASH') {
%id = %$id;
}
else {
%id = ($change => ref $id ? $id : [$id]);
}
my %final;
while (my ($change, $id) = each %id) {
for (@$id) {
$final{$_} = ($final{$_} || 0) + $change;
}
my $parents = $self->tree->parent_ids(id => $id);
for my $parent (keys %$parents) {
for (@{$parents->{$parent}}) {
$final{$_} += $change;
}
}
}
my %change;
for (keys %final) {
push @{$change{$final{$_}}}, $_;
}
for (keys %change) {
$self->update(
{ Number_of_Links => \('Number_of_Links' . ($_ > 0 ? ' + ' : ' - ') . abs) },
{ ID => $change{$_} },
{ GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
);
}
}
sub changed {
# -------------------------------------------------------------------
# Returns a statement handle that can be looped through to get a list
# of changed categories.
#
Links::init_date();
my $self = shift;
my $date = GT::Date::date_get(defined $_[0] ? $_[0] : time);
my $sth = $self->select(GT::SQL::Condition->new(Timestmp => '>=' => $date ));
return $sth;
}
sub get_id_from_name {
# -------------------------------------------------------------------
# Returns the category id based on the name.
#
my ($self, $name) = @_;
$name =~ y/\r\n//d;
$name =~ /\S/ or return;
return $self->{_id_cache}->{$name} if exists $self->{_id_cache}->{$name};
$self->{_id_cache}->{$name} = $self->select(ID => { Full_Name => $name })->fetchrow_array;
return $self->{_id_cache}->{$name};
}
sub get_name_from_id {
# -------------------------------------------------------------------
# Returns the category full name based on the id.
#
my ($self, $id) = @_;
return $self->{_name_cache}->{$id} if exists $self->{_name_cache}->{$id};
return $self->{_name_cache}->{$id} = $self->select(Full_Name => { ID => $id })->fetchrow;
}
sub as_url {
# -------------------------------------------------------------------
#
my ($self, $name, $format) = @_;
return $PLG->dispatch('category_as_url', sub { return $self->_as_url(@_) }, $name, $format);
}
sub _as_url {
# -------------------------------------------------------------------
# Return the passed-in category name as a formatted category path, usable for
# static templates.
#
my ($self, $name, $format) = @_;
my $cat = $self->select({ Full_Name => $name })->fetchrow_hashref
or return $name;
require Links::Tools;
$format ||= $IN->param('d') ? $CFG->{build_category_dynamic} ? "%$CFG->{build_category_dynamic}%" : '' : $CFG->{build_category_format};
$format ||= '%Full_Name%';
if ($format eq '%Full_Name%' and ($IN->param('d') or $CFG->{build_format_compat})) {
# Old Links SQL's (prior to configurable category naming) didn't
# coalesce multiple _'s into a single _, and dynamic mode still depends
# on that behaviour - so if the format is just Full_Name, mimic the old
# behaviour.
(my $ret = $cat->{Full_Name}) =~ y|a-zA-Z0-9_/-|_|c;
return $ret;
}
if ($format =~ /%Full_ID%/) {
$cat->{Full_ID} = join '/', (@{$self->tree->parent_ids(id => $cat->{ID})}, $cat->{ID});
}
return Links::Tools::parse_format(
$format,
%$cat,
clean => 1
);
}
sub set_new {
# -------------------------------------------------------------------
# Sets the new flag for a given category id (or list).
#
my $self = shift;
my @ids = ref $_[0] eq 'ARRAY' ? @{shift()} : shift;
my $rel = $DB->table('Links', 'CatLinks', 'Category');
for my $id (@ids) {
my $parents = $self->parents($id);
my @pids = reverse @$parents;
push @pids, $id;
for my $pid (@pids) {
my $children = $self->children($pid);
$rel->select_options('GROUP BY Add_Date');
my $sth = $rel->select(qw/MAX(Add_Date) isNew/ => GT::SQL::Condition->new(
CategoryID => '=' => [$pid, @$children],
VIEWABLE
));
my ($newest, $new) = $sth->fetchrow;
$self->update(
{ Has_New_Links => $new || 'No', Newest_Link => $newest },
{ ID => $pid },
{ GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
);
}
}
}
sub _clear_cache {
# -------------------------------------------------------------------
# Clear out cache results whenever a category is added/deleted/changed.
#
my $self = shift;
delete @$self{qw{_parent_cache _child_cache _name_cache _id_cache _template_cache}};
return 1;
}
1;

41
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/ClickTrack.pm Normal file
View File

@ -0,0 +1,41 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: ClickTrack.pm,v 1.3 2009/05/08 19:56:50 brewt Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
#
# ClickTrack is subclassed so that new() is wrapped to handle ClickTrack table
# cleanups - but only the first time a ClickTrack table object is created, and
# only once / day.
package Links::Table::ClickTrack;
use strict;
use Links qw/$CFG %STASH/;
use GT::SQL::Table ();
use vars qw/@ISA/;
@ISA = 'GT::SQL::Table';
sub new {
my $self = shift->SUPER::new(@_) or return;
return $self if $STASH{clicktrack_cleanup}++;
Links::init_date();
my $cleanup_date = GT::Date::date_get(time - 2*24*60*60, '%yyyy%-%mm%-%dd%');
return $self if $CFG->{last_clicktrack_cleanup} and $cleanup_date eq $CFG->{last_clicktrack_cleanup};
$self->delete(GT::SQL::Condition->new(Created => '<' => $cleanup_date));
$CFG->{last_clicktrack_cleanup} = $cleanup_date;
$CFG->save;
$self;
}
1;

630
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Links.pm Normal file
View File

@ -0,0 +1,630 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: Links.pm,v 1.33 2009/05/11 05:57:45 brewt Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
package Links::Table::Links;
# ==================================================================
use strict;
use Links qw/:payment :objects/;
use GT::SQL;
use GT::SQL::Table;
use vars qw /@ISA $DEBUG $ERRORS $ERROR_MESSAGE $CATLINK/;
@ISA = qw/GT::SQL::Table/;
$DEBUG = 0;
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
NOCATEGORY => "You did not specify a category for this link.",
BADCATSUG => "There is no category with that name. Perhaps you meant: %s",
BADCATEGORY => "Invalid Category '%s', it does not exist.",
};
sub _query {
# -------------------------------------------------------------------
# Overrides the default query to allow searching on category values.
#
my $self = shift;
my $opts = $self->common_param(@_) or return $self->fatal(BADARGS => '$obj->insert(HASH or HASH_REF or CGI) only.');
# Parse date/time
if ($opts->{ExpiryDate} and $opts->{ExpiryDate} !~ /^\s*-?\d+\s*$/) {
my $converted = Links::date_to_time($opts->{ExpiryDate});
$opts->{ExpiryDate} = $converted if defined $converted;
}
my $cat_id = $opts->{'CatLinks.CategoryID'} or return $self->SUPER::_query($opts);
$cat_id = $self->clean_category_ids($cat_id) or return;
# Strip out values that are empty or blank (as query is generally
# derived from cgi input).
my %input = map { $_ => $opts->{$_} } grep { defined $opts->{$_} and $opts->{$_} !~ /^\s*$/ } keys %$opts;
$opts = \%input;
# Create a CatLinks,Links table to do the search.
my $db = $DB->table('CatLinks','Links');
# Now start handling the search
my $cond = $self->build_query_cond($opts, $self->{schema}->{cols});
if ( (ref $cond) =~ /::sth/i ) {
return $cond;
}
# Set the limit clause, defaults to 25, set to -1 for none.
my $in = $self->_get_search_opts($opts);
my $offset = ($in->{nh} - 1) * $in->{mh};
$db->select_options("ORDER BY $in->{sb} $in->{so}") if $in->{sb};
$db->select_options("LIMIT $in->{mh} OFFSET $offset") unless $in->{mh} == -1;
# Add to the condition the category clause.
my $final = new GT::SQL::Condition;
$final->add($cond) if $cond;
$final->add('CatLinks.CategoryID', 'IN', $cat_id);
# Now do the select.
my @sel;
push @sel, $final if $final;
push @sel, $opts->{rs} if $opts->{rs} and $final;
my $sth = $db->select(@sel) or return;
$self->{last_hits} = $db->hits;
return $sth;
}
sub add {
# -------------------------------------------------------------------
# Adds a link, but passes through Plugins::Dispatch.
#
my $self = shift;
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
$PLG->dispatch('add_link', sub { $self->_plg_add(@_) }, $p);
}
sub _plg_add {
# -------------------------------------------------------------------
# Add a link.
#
my ($self, $p) = @_;
# Check to see if we can add a link, all errors get cascaded back.
$p->{'CatLinks.CategoryID'} or return $self->warn('NOCATEGORY');
$p->{'CatLinks.CategoryID'} = $self->clean_category_ids($p->{'CatLinks.CategoryID'}) or return;
$self->set_date_flags($p);
my $counted = ($p->{isValidated} eq 'Yes' and $p->{ExpiryDate} >= time);
if ($p->{ExpiryDate} >= time) {
$p->{ExpiryCounted} = 0;
}
else {
$p->{ExpiryCounted} = 1;
}
# Add the link, and return if there was an error, the error is propogated back.
my $id = $self->SUPER::add($p) or return;
# Now add all the categories that the link belongs too.
my $cat = $DB->table('Category');
my $cat_lnk = $DB->table('CatLinks');
my @cat_ids = ref $p->{'CatLinks.CategoryID'} ? @{$p->{'CatLinks.CategoryID'}} : $p->{'CatLinks.CategoryID'};
my %parents;
# Get a list of all the parents that this will affect.
foreach my $cat_id (@cat_ids) {
$cat_lnk->insert({ LinkID => $id, CategoryID => $cat_id }) or return;
if ($counted) {
for (@{$cat->parents($cat_id)}) { $parents{$_}++ }
$parents{$cat_id}++;
}
}
# Now update those categories.
if ($counted) {
$cat->update(
{ Newest_Link => $p->{Add_Date}, Has_New_Links => 'Yes', Number_of_Links => \"Number_of_Links + 1" },
{ ID => [keys %parents] },
{ GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 }
);
$cat->update({ Direct_Links => \"Direct_Links + 1" }, { ID => \@cat_ids });
}
return $id;
}
sub delete {
# -----------------------------------------------------------------------------
# Deletes one or more links; there is a 'delete_link' hook below that can be
# used by plugins.
#
my ($self, $where) = @_;
if (not ref $where or ref $where eq 'ARRAY') {
$where = { ID => $where };
}
return $self->fatal(BADARGS => 'Usage: $links->delete(condition)')
unless (ref $where eq 'HASH' and keys %$where) or (UNIVERSAL::isa($where, 'GT::SQL::Condition') and $where->sql);
my $CatLinks = $DB->table('CatLinks');
# Sometimes { ID => x, CatLinks.CategoryID => y } gets passed in; it is
# wrong - CatLinks->delete should be used instead, which will recall this
# subroutine if any links need to be deleted.
if (ref $where eq 'HASH' and $where->{ID} and not ref $where->{ID}
and $where->{'CatLinks.CategoryID'} and not ref $where->{'CatLinks.CategoryID'}) {
return $CatLinks->delete({ LinkID => $where->{ID}, CategoryID => $where->{'CatLinks.CategoryID'} });
}
# Delete called with a normal condition
my $links = $self->select(qw/ID isValidated Add_Date ExpiryDate ExpiryCounted/ => $where)->fetchall_hashref;
@$links or return '0 but true';
my $new_cutoff = GT::Date::timelocal(0, 0, 0, (localtime time - $CFG->{build_new_cutoff})[3 .. 5]);
my (@counts, @new);
for (@$links) {
my $add_time = GT::Date::timelocal(GT::Date::parse_format($_->{Add_Date}, GT::Date::FORMAT_DATE));
if ($_->{isValidated} eq 'Yes' and ($_->{ExpiryDate} >= time or not $_->{ExpiryCounted})) {
push @counts, $_->{ID};
push @new, $_->{ID} if $add_time >= $new_cutoff;
}
}
# Figure out how much each category needs to be decremented
$CatLinks->select_options("GROUP BY CategoryID");
my %cats = $CatLinks->select(CategoryID => 'COUNT(*)' => { LinkID => \@counts })->fetchall_list;
my %change;
while (my ($catid, $count) = each %cats) {
push @{$change{-$count}}, $catid;
}
my $ret;
{
# CatLinks, which has an fk to Links.ID, needs to know what we're
# deleting so that it doesn't try to recall Links->delete
local @Links::Table::CatLinks::DELETING;
if ($PLG->active_plugins('delete_link')) {
for (@$links) {
@Links::Table::CatLinks::DELETING = $_->{ID};
my $r = $PLG->dispatch('delete_link', sub { return $self->_plg_delete_link(@_) }, { ID => $_->{ID} });
$ret += $r if defined $r;
}
$ret = '0 but true' if defined $ret and $ret == 0;
}
else {
# delete_link plugin hook isn't being used, a single delete will do it
my @lids = map $_->{ID}, @$links;
@Links::Table::CatLinks::DELETING = @lids;
$ret = $self->SUPER::delete({ ID => \@lids });
}
}
my $Category = $DB->table('Category');
$Category->link_count(\%change);
while (my ($change, $ids) = each %change) {
$Category->update({ Direct_Links => \("Direct_Links - " . abs $change) }, { ID => $ids });
}
$CatLinks->select_options("GROUP BY CategoryID");
my @new_cats = $CatLinks->select(CategoryID => { LinkID => \@new })->fetchall_list;
# Now reset new flags on categories.
if ($ret and @new_cats) {
$Category->set_new(\@new_cats);
}
return $ret;
}
sub _plg_delete_link {
# -----------------------------------------------------------------------------
# Deletes a single link ID (plugin hook 'delete_link'. The second argument,
# $link, will, for historic reasons, always be a hash reference containing an
# 'ID' key, the value of which is the ID of the link to be deleted.
#
my ($self, $link) = @_;
my $link_id = $link->{ID};
return $self->SUPER::delete({ ID => $link_id });
}
sub modify {
# -------------------------------------------------------------------
# Modifies a link, but passes through the plugin system.
#
my ($self, $link) = @_;
$PLG->dispatch('modify_link', sub { return $self->_plg_modify(@_) }, $link);
}
sub _plg_modify {
# -------------------------------------------------------------------
# Modify a single link.
#
my $self = shift;
my $set = shift or return $self->fatal(BADARGS => "Usage: \$cat->modify( { col => value ... } ).");
my $id = $set->{ID} or return $self->fatal(BADARGS => "No primary key passed to modify!");
# Let's set the changed date to right now.
Links::init_date();
$set->{Mod_Date} = GT::Date::date_get();
# Force it to uncounted so that category counts will be properly updated
$set->{ExpiryCounted} = 0;
# Check to see if we can modify (makes sure valid category id's were set).
$set->{'CatLinks.CategoryID'} or return $self->warn('NOCATEGORY');
$set->{'CatLinks.CategoryID'} = $self->clean_category_ids($set->{'CatLinks.CategoryID'}) or return;
$self->set_date_flags($set);
# Check to see if we are changing from not validated => validated.
my ($old_validated, $old_expiry) = $self->select(qw/isValidated ExpiryDate/ => { ID => $set->{ID} })->fetchrow;
# Check that the ExpiryDate is valid for the categories the link is in.
require Links::Payment;
my $expiry = (exists $set->{ExpiryDate} and $set->{ExpiryDate}) ? $set->{ExpiryDate} : $old_expiry;
$expiry = Links::Payment::check_expiry_date({ ExpiryDate => $expiry }, $set->{'CatLinks.CategoryID'});
$set->{ExpiryDate} = $expiry if $expiry;
my $new_validated = exists $set->{isValidated} ? $set->{isValidated} : $old_validated;
my $new_expiry = exists $set->{ExpiryDate} ? $set->{ExpiryDate} : $old_expiry;
my $was_counted = $old_validated eq 'Yes' && $old_expiry >= time;
my $now_counted = $new_validated eq 'Yes' && $new_expiry >= time;
if (exists $set->{ExpiryDate}) {
$set->{ExpiryCounted} = $set->{ExpiryDate} >= time ? 0 : 1;
}
=for comment
Here are the various cases that the category count update code needs to handle and what to do in those cases:
add the link to a new category
was counted, now_counted increment new cat
!was counted, now counted increment new cat
was counted, !now counted nothing
!was counted, !now counted nothing
remove the link from a category
was counted, now_counted decrement old cat (CatLinks handles correctly)
!was counted, now counted nothing (CatLinks handles incorrectly and decrements in some cases, we fix and increment)
was counted, !now counted decrement old cat (CatLinks handles correctly)
!was counted, !now counted nothing (CatLinks handles correctly)
no category changes
was counted, now_counted nothing
!was counted, now counted increment cats
was counted, !now counted decrement cats
!was counted, !now counted nothing
the above combined (what the code needs to do)
was counted, now_counted increment new cats
!was counted, now counted increment curr cats, leave removed cats
was counted, !now counted decrement cats except removed and new cats (ie. decrement curr cats, except new cats)
!was counted, !now counted nothing
=cut
# Do the update.
my $ret = $self->SUPER::modify($set);
# Check to see if the link has been moved into another category.
if ($ret) {
my $cat_lnk = $DB->table('CatLinks');
my %orig_ids = map { $_ => 1 } $cat_lnk->select(CategoryID => { LinkID => $id })->fetchall_list;
my %cat_ids = map { $_ => 1 } ref $set->{'CatLinks.CategoryID'} ? @{$set->{'CatLinks.CategoryID'}} : $set->{'CatLinks.CategoryID'};
# Categories that the link has just been added to
my @new_cats = grep !$orig_ids{$_}, keys %cat_ids;
# Categories that the link has just been removed from
my @old_cats = grep !$cat_ids{$_}, keys %orig_ids;
my %link_adjustment;
my $Category = $DB->table('Category');
# CatLinks doesn't update category counts on insert, so it's done further down in the code
if (@new_cats) {
$cat_lnk->insert_multiple([qw/LinkID CategoryID/], map [$id, $_], @new_cats);
}
# However, deleting from CatLinks does result in updated category counts
if (@old_cats) {
$cat_lnk->delete({ LinkID => $id, CategoryID => \@old_cats });
# If the link has been modified from isValidated = No to Yes then the delete()
# from CatLinks will end up incorrectly decrementing the category count. If
# this is the case, then the count needs to increment to comphensate for this
# bug. This isn't !$was_counted && $now_counted because CatLinks delete
# currently does not take ExpiryDate into consideration.
push @{$link_adjustment{1}}, @old_cats if $old_validated eq 'No' and $new_validated eq 'Yes';
}
# The status hasn't changed: increment the new categories
if ($was_counted and $now_counted) {
push @{$link_adjustment{1}}, @new_cats if @new_cats;
}
# It wasn't viewable, but is now: increment all the current categories
elsif (not $was_counted and $now_counted) {
push @{$link_adjustment{1}}, keys %cat_ids;
}
# Was viewable, but now isn't: decrement all the current categories (except new ones)
elsif ($was_counted and not $now_counted) {
# Don't decrement counts on new categories, since the addition of the link
# never incremented the count in the first place
my %not_new = %cat_ids;
for (@new_cats) {
delete $not_new{$_};
}
push @{$link_adjustment{-1}}, keys %not_new;
}
# Otherwise, it wasn't visible and still isn't, or it was visible but now
# isn't. In both cases, the new categories don't need to be incremented.
# Actually adjust the link counts:
$Category->link_count(\%link_adjustment);
while (my ($change, $ids) = each %link_adjustment) {
$Category->update({ Direct_Links => \("Direct_Links" . ($change > 0 ? ' + ' : ' - ') . abs $change) }, { ID => $ids });
}
# If this link is now validated this link, let's update category counters and new flags.
# It also needs to be updated if a link has been added to new categories.
if ((not $was_counted and $now_counted) or @new_cats) {
foreach my $cat (keys %cat_ids) {
my @cats = ($cat, @{$Category->parents($cat)});
my $cond = GT::SQL::Condition->new(ID => '=', \@cats);
if ($set->{isNew} eq 'Yes') {
$Category->update({ Has_New_Links => 'Yes' }, $cond, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 });
}
$cond->add('Newest_Link', '<', $set->{Add_Date});
$Category->update({ Newest_Link => $set->{Add_Date} }, $cond, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 });
}
}
# Update the category timestamps to let people know that the page has changed.
$Category->update({ Timestmp => \"NOW()" }, { ID => [keys %cat_ids, @old_cats] }, { GT_SQL_SKIP_CHECK => 1, GT_SQL_SKIP_INDEX => 1 });
}
return $ret;
}
sub update {
# -------------------------------------------------------------------
# Update a link.
#
my ($self, $set, $where) = @_;
my $ret = $self->SUPER::update($set, $where);
# Update the Category Timestmp of links which have certain columns updated
for (split(/\s*,\s*/, $CFG->{links_cols_update_category})) {
if (exists $set->{$_}) {
my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', $where)->fetchall_list;
$DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats });
last;
}
}
return $ret;
}
sub detailed_url {
# -----------------------------------------------------------------------------
# Takes one or more link ID's, returns one or more parsed detailed URL/paths in
# the same order and position the links were passed in, NOT prefixed with
# build_detail_url/build_detail_path. If the ID passed in is actually a
# hashref, it is assumed that this hash ref includes a full set of Links and
# Category values for the link.
#
my ($self, @ids) = @_;
my (@links, @sel_links, $need_select);
for (@ids) {
if (ref) {
push @links, $_;
push @sel_links, undef;
}
else {
push @links, undef;
push @sel_links, $_;
$need_select++;
}
}
if ($need_select) {
my %links_cols = %{$self->cols};
# Only select Category columns that don't conflict with Links columns.
my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols};
my $rel = $DB->table(qw/Links CatLinks Category/);
my %links = map { $_->{ID} => $_ } @{$rel->select(
'Links.*', @cat_cols, 'CategoryID', { LinkID => [grep $_, @sel_links] }
)->fetchall_hashref};
for my $i (0 .. $#sel_links) {
$links[$i] = $links{$sel_links[$i]} if $sel_links[$i];
}
}
require Links::Tools;
my $format;
$format = $CFG->{build_detail_format} unless $IN->param('d');
$format ||= '%ID%';
$format .= '_%ID%' unless $format =~ /%ID%/;
my @ret = $PLG->dispatch('detailed_url', sub {
my ($format, @links) = @_;
my @ret;
for (@links) {
my $parsed;
if ($_) {
# Make Full_Name act the same for both category and detailed urls. Set
# build_format_compat = 2 if you want the < 3.3 behaviour of coalesced _'s for
# Full_Name.
if ($CFG->{build_format_compat} == 1) {
(my $fn = $_->{Full_Name}) =~ y|a-zA-Z0-9_/-|_|c;
$format =~ s/%Full_Name%/$fn/g;
}
$parsed = Links::Tools::parse_format(
$format,
%$_,
clean => 1
);
$parsed =~ s{(^|[/\\])index$}{${1}_index};
$parsed .= $CFG->{build_extension};
}
push @ret, $parsed;
}
return @ret;
}, $format, @links);
return wantarray ? @ret : $ret[0];
}
sub category_detailed_url {
# -----------------------------------------------------------------------------
# A wrapper to detailed_url which will return url's which given a category id,
# will only return url's which take the category into consideration. The only
# use for this is when a link is in multiple categories.
#
my ($self, $cat_id, @ids) = @_;
my %links_cols = %{$self->cols};
# Only select Category columns that don't conflict with Links columns.
my @cat_cols = grep !$links_cols{$_}, keys %{$DB->table('Category')->cols};
my @links;
my $rel = $DB->table(qw/Links CatLinks Category/);
for (@ids) {
push @links, $rel->select('Links.*', @cat_cols, 'CategoryID', { LinkID => $_, CategoryID => $cat_id })->fetchrow_hashref;
}
my @ret = $self->detailed_url(@links);
return wantarray ? @ret : $ret[0];
}
sub clean_category_ids {
# -------------------------------------------------------------------
# Takes an argument which could be a list of category names or ids
# and returns an array ref of ids.
#
my ($self, $arg) = @_;
my $cat = $DB->table('Category');
# Fix up Category Names => Id numbers and offer suggestions
# if name was not found.
if (! ref $arg and $arg !~ /^\d*$/) {
my @cat_names = split /\n\r?/, $arg;
my @cat_ids = ();
foreach my $name (@cat_names) {
$name =~ s/[\r\n]//g; # Textareas have a nasty habit of putting \r's on the results.
my $id = ($name =~ /^\d+$/) ? $name : $cat->get_id_from_name($name);
if ($id) {
push(@cat_ids, $id);
}
else {
my $names = $cat->suggestions($name);
return $self->error(@$names
? ('BADCATSUG', 'WARN', "<ul>" . join('', map "<li>$_</li>", @$names) . "</ul>")
: ('BADCATEGORY', 'WARN', $name)
);
}
}
return \@cat_ids;
}
# We assume that if ID numbers are passed in, that they will
# be correct. This will get checked anyways by GT::SQL::Table,
# so no point doing it twice.
else {
my @ids = ref $arg ? @$arg : ($arg);
return \@ids;
}
}
sub get_categories {
# -------------------------------------------------------------------
# Takes a link id and returns a hash of category id => category name.
#
my $self = shift;
my $id = shift;
my $db = $DB->table('Category', 'CatLinks');
my $sth = $db->select( { 'CatLinks.LinkID' => $id }, [ 'Category.ID', 'Category.Full_Name' ] );
my %res = ();
while (my ($id, $name) = $sth->fetchrow_array) {
$res{$id} = $name;
}
return \%res;
}
sub set_date_flags {
# -------------------------------------------------------------------
# Takes a link hash ref and sets the date flags properly.
#
my ($self, $p) = @_;
Links::init_date();
my $today = GT::Date::date_get();
if (GT::Date::date_diff($today, $p->{Add_Date}) <= $CFG->{build_new_cutoff}) {
$p->{isNew} = 'Yes';
$p->{isChanged} = 'No';
}
elsif (GT::Date::date_diff($today, $p->{Mod_Date}) <= $CFG->{build_new_cutoff}) {
$p->{isChanged} = 'Yes';
$p->{isNew} = 'No';
}
else {
$p->{isNew} = 'No';
$p->{isChanged} = 'No';
}
# Possible ExpiryDate values that have to be handled here:
# -1 (unpaid link) - leave it as is, does not need to be converted
# \d (unixtime) - leave it as is, does not need to be converted
# >=\d (doesn't actually occur here, but in _query) - leave it as is, does not need to be converted
# YYYY-MM-DD
# YYYY/MM/DD
# YYYY/MM/DD HH::MM::SS
# The purpose of this bit of code is to convert any human readable dates into
# unixtime and leave everything else as is.
if ($p->{ExpiryDate} and $p->{ExpiryDate} !~ /^\s*-?\d+\s*$/) {
my $converted = Links::date_to_time($p->{ExpiryDate});
$p->{ExpiryDate} = $converted if defined $converted;
}
}
sub add_reviews {
# -------------------------------------------------------------------
# Adds review information, but passes through the plugin system.
#
my ($self, $link) = @_;
$PLG->dispatch('add_reviews', sub { return $self->_plg_add_reviews(@_) }, $link);
}
sub _plg_add_reviews {
# -------------------------------------------------------------------
# Adds review information to an array ref of hash refs of links passed in
# in one query.
#
my $self = shift;
my $links = shift;
if (ref $links eq 'HASH') {
$links = [ $links ];
}
my $review_db = $DB->table('Reviews');
my @ids = map { $_->{ID} } @$links;
return unless (@ids);
my $sth = $review_db->select({ Review_Validated => 'Yes' }, { Review_LinkID => \@ids });
my %reviews;
my %review_count;
while (my $review = $sth->fetchrow_hashref) {
push @{$reviews{$review->{Review_LinkID}}}, $review;
$review_count{$review->{Review_LinkID}}++;
}
for my $link (@$links) {
$link->{Review_Count} = $review_count{$link->{ID}};
$link->{Review_Loop} = $reviews{$link->{ID}};
}
return $links;
}
1;

93
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Reviews.pm Normal file
View File

@ -0,0 +1,93 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: Reviews.pm,v 1.1 2007/11/16 07:15:00 brewt Exp $
#
# Copyright (c) 2007 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
package Links::Table::Reviews;
# ==================================================================
use strict;
use Links qw/:objects/;
use GT::SQL;
use GT::SQL::Table;
use vars qw/@ISA $ERROR_MESSAGE/;
@ISA = qw/GT::SQL::Table/;
$ERROR_MESSAGE = 'GT::SQL';
sub add {
# -----------------------------------------------------------------------------
# Add a review.
#
my $self = shift;
my $rec = (ref $_[0] eq 'HASH') ? shift : { @_ };
my $id = $self->SUPER::add($rec) or return;
# Update the link/category timestamp if the review is validated.
_update_timestamp($rec->{Review_LinkID}) if $rec->{Review_Validated} eq 'Yes';
$id;
}
sub modify {
# -----------------------------------------------------------------------------
# Modify a review.
#
my $self = shift;
my $set = shift or return $self->fatal(BADARGS => 'Usage: $reviews->modify({ col => value ... }).');
my $id = $set->{ReviewID} or return $self->fatal(BADARGS => 'No primary key passed to modify!');
my ($old, $link_id) = $self->select('Review_Validated', 'Review_LinkID', { ReviewID => $id })->fetchrow;
my $ret = $self->SUPER::modify($set) or return;
# Only update the timestamp if it was unvalidated and still is - this is the
# only case where the pages shouldn't be rebuilt.
my $new = $set->{Review_Validated} || $old;
_update_timestamp($link_id) unless $old eq 'No' and $new eq 'No';
$ret;
}
sub delete {
# -----------------------------------------------------------------------------
# Delete one or more reviews.
#
my ($self, $cond) = @_;
ref $cond or return $self->fatal(BADARGS => '$reviews->delete(condition)');
# Get the link ids of the reviews that are about to be deleted and are
# validated (as only those pages need to be rebuilt).
my @link_ids = $self->select('Review_LinkID', $cond, { Review_Validated => 'Yes' })->fetchall_list;
my $ret = $self->SUPER::delete($cond) or return;
_update_timestamp(\@link_ids) if @link_ids;
$ret;
}
sub _update_timestamp {
# -----------------------------------------------------------------------------
# Given a link ID (or an array ref if you want to update more than one link),
# update the Timestmp columns of the link as well as all the categories that
# the link is in. This ensures that these pages will be rebuilt on "Build
# Changed".
#
my $link_id = shift;
return unless $link_id;
my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link_id })->fetchall_list;
$DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats }) if @cats;
$DB->table('Links')->update({ Timestmp => \'NOW()' }, { ID => $link_id });
}
1;

162
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Users.pm Normal file
View File

@ -0,0 +1,162 @@
# ==================================================================
# Gossamer Links - enhanced directory management system
#
# Website : http://gossamer-threads.com/
# Support : http://gossamer-threads.com/scripts/support/
# CVS Info : 087,071,086,086,085
# Revision : $Id: Users.pm,v 1.5 2005/05/12 20:51:24 brewt Exp $
#
# Copyright (c) 2001 Gossamer Threads Inc. All Rights Reserved.
# Redistribution in part or in whole strictly prohibited. Please
# see LICENSE file for full details.
# ==================================================================
package Links::Table::Users;
# ==================================================================
use strict;
use GT::SQL;
use GT::SQL::Table;
use Links qw/$CFG $PLG/;
use vars qw/@ISA $ERRORS $ERROR_MESSAGE $AUTH/;
@ISA = qw/GT::SQL::Table/;
$ERROR_MESSAGE = 'GT::SQL';
$ERRORS = {
AUTHERROR => "Authentication Error: %s",
INVALIDFORMAT => "Invalid format for username: %s"
};
sub init {
# -------------------------------------------------------------------
# Load the authentication module.
#
require Links::Authenticate;
Links::Authenticate::auth('init', {});
return 1;
}
sub add {
# -------------------------------------------------------------------
my ($self, @args) = @_;
return $PLG->dispatch('add_user', sub { return $self->_plg_add(@_); }, @args );
}
sub _plg_add {
# -------------------------------------------------------------------
init();
my $self = shift;
my $p = ref $_[0] eq 'HASH' ? shift : {@_};
if (! Links::Authenticate::auth('valid_format', { Username => $p->{Username} })) {
$ERRORS->{INVALIDFORMAT} = Links::language('USER_INVALIDUSERNAME');
return $self->error('INVALIDFORMAT', 'WARN', $p->{Username});
}
my $h = Links::Authenticate::auth('add_user', { Username => $p->{Username}, Password => $p->{Password} });
unless ($h) {
$ERRORS->{AUTHERROR} = Links::language('USER_AUTHERROR');
return $self->error('AUTHERROR', 'WARN', $Links::Authenticate::error);
}
$p->{Username} = $h->{Username};
$p->{Password} = $h->{Password};
return $self->SUPER::add($p);
}
sub delete {
# -------------------------------------------------------------------
my ($self, @args) = @_;
return $PLG->dispatch('delete_user', sub { return $self->_plg_delete(@_); }, @args );
}
sub _plg_delete {
# -------------------------------------------------------------------
init();
my ($self, $cond) = @_;
if (! ref $cond) {
$cond = { Username => $cond };
}
my $count = 0;
my $link_db = $Links::DB->table('Links');
my $sth = $self->select('Username', $cond);
while (my ($user) = $sth->fetchrow_array) {
my @links = $link_db->select('ID', { LinkOwner => $user })->fetchall_list;
for my $link_id (@links) {
$link_db->delete($link_id);
}
if (Links::Authenticate::auth('del_user', { Username => $user })) {
my $ret = $self->SUPER::delete($user);
$count++ if $ret;
}
}
return $count;
}
sub modify {
# -------------------------------------------------------------------
my ($self, @args) = @_;
return $PLG->dispatch('modify_user', sub { return $self->_plg_modify(@_); }, @args );
}
sub _plg_modify {
# -------------------------------------------------------------------
init();
my $self = shift;
my $input = $self->common_param(@_) or return $self->error('BADARGS', 'FATAL', '$obj->insert(HASH or HASH_REF or CGI) only.');
my $id = $input->{Username} or return $self->error("BADARGS", "FATAL", "No primary key passed to modify!");
my $sth = $self->select('Username', 'Password', { Username => $id });
my $rec = $sth->fetchrow_hashref;
if ($rec) {
if ($input->{Password} ne $rec->{Password}) {
Links::Authenticate::auth('change_pass', { Username => $rec->{Username}, Password => $rec->{Password}, New_Password => $input->{Password} })
or return $self->error('AUTHERROR', 'WARN', $Links::Authenticate::error);
}
}
# Connect to the database if we are not already connected
$self->connect;
# Copy the data and remove anything that doesn't make sense here.
my $c = $self->{schema}->{cols};
my $set = {};
for (keys %$c) {
$set->{$_} = $input->{$_} if exists $input->{$_};
}
# Remove primary keys from update clause.
my $where;
if ($input->{orig_username}) {
$where->{Username} = $input->{orig_username};
}
else {
foreach my $key (@{$self->{schema}->{pk}}) {
$where->{$key} = delete $set->{$key} if exists $set->{$key};
}
}
return $self->error("NOPKTOMOD", "WARN") unless keys %$where == @{$self->{schema}->{pk}};
# Remove timestamps - no sense updating.
$self->_check_timestamp($where, $set) or return;
foreach my $col (keys %$c) {
delete $set->{$col} if $c->{$col}->{type} eq 'TIMESTAMP';
}
# Execute the update
$self->update($set, $where) or return;
return 1;
}
sub random_pass {
# -------------------------------------------------------------------
# Returns a random password.
#
my $self = shift;
my $pass = '';
for (1 .. 8) { $pass .= chr(65 + int rand 57); }
return $pass;
}
1;