First pass at adding key files
This commit is contained in:
dsainty
437
site/slowtwitch.com/cgi-bin/articles/admin/Links/Admin.pm
Normal file
437
site/slowtwitch.com/cgi-bin/articles/admin/Links/Admin.pm
Normal file
@@ -0,0 +1,437 @@
|
||||
# ==================================================================
|
||||
# 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: Admin.pm,v 1.16 2005/03/05 01:29:09 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::Admin;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use GT::SQL::Admin;
|
||||
use Links qw/$DB/;
|
||||
use GT::AutoLoader;
|
||||
use vars qw/@ISA $ERROR_MESSAGE $FONT $DEBUG/;
|
||||
|
||||
@ISA = qw/GT::SQL::Admin/;
|
||||
$DEBUG = 0;
|
||||
$ERROR_MESSAGE = 'GT::SQL';
|
||||
$FONT = $GT::SQL::Admin::FONT;
|
||||
|
||||
# Make sure AUTOLOAD does not catch destroyed objects.
|
||||
sub DESTROY {}
|
||||
|
||||
$COMPILE{modify_multi_records} = __LINE__ . <<'END_OF_SUB';
|
||||
sub modify_multi_records {
|
||||
# -------------------------------------------------------------------
|
||||
# Overrides the Links table to format the category name properly.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $prefix = $DB->prefix;
|
||||
return $self->SUPER::modify_multi_records(@_) unless ( $name eq $prefix . 'Links');
|
||||
|
||||
if (! exists $self->{cgi}->{modify}) {
|
||||
return $self->modify_error("Please select a record to modify before continuing.");
|
||||
}
|
||||
# If they selected only one record to modify we still need an array ref
|
||||
ref $self->{cgi}->{modify} eq 'ARRAY' or $self->{cgi}->{modify} = [$self->{cgi}->{modify}];
|
||||
|
||||
# Format the cgi for inserting
|
||||
$self->format_insert_cgi;
|
||||
|
||||
# Hash to handle errors if there are any errors.
|
||||
my $errors = {};
|
||||
my $errcode = {};
|
||||
|
||||
# Need to know the names of the columns for this Table.
|
||||
my @columns = keys %{$self->{table}->cols};
|
||||
push @columns, 'CatLinks.CategoryID';
|
||||
|
||||
# Need to know the number of records modified
|
||||
my $rec_modified = 0;
|
||||
|
||||
# For through the record numbers. These are the values of the
|
||||
# check boxes
|
||||
foreach my $rec_num (@{$self->{cgi}->{modify}}) {
|
||||
my $change = {};
|
||||
foreach my $column (@columns) {
|
||||
$change->{$column} = $self->{cgi}->{"$rec_num-$column"} if exists $self->{cgi}->{"$rec_num-$column"};
|
||||
}
|
||||
|
||||
# Make the changes and capture any errors.
|
||||
my $ret = $self->{table}->modify($change);
|
||||
if (defined $ret) {
|
||||
$rec_modified++;
|
||||
}
|
||||
else {
|
||||
if ($self->{table}->error) {
|
||||
my $error = $self->{table}->error;
|
||||
$error =~ s/\n/<br>\n<li>/g;
|
||||
$errors->{$rec_num} = "<li>$error";
|
||||
}
|
||||
$errcode->{$rec_num} = $GT::SQL::errcode if ($GT::SQL::errcode);
|
||||
}
|
||||
}
|
||||
|
||||
# Return the results page with the proper arguments depending on if we got an error or not.
|
||||
return (keys %$errors) ? $self->modify_multi_results($rec_modified, $errors, $errcode) : $self->modify_multi_results($rec_modified);
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{editor_import_data_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor_import_data_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Allow the import to import category/link data. Only used if called with the
|
||||
# Links database.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $prefix = $DB->prefix;
|
||||
return $self->SUPER::editor_import_data_form(@_) unless ( $name eq $prefix . 'Links');
|
||||
|
||||
my $msg = shift;
|
||||
print $self->{in}->header;
|
||||
$msg &&= qq|<FONT COLOR="red"><B>$msg</B></FONT>|;
|
||||
my $table = $self->{record};
|
||||
|
||||
|
||||
print $self->_start_html ( { title => "Links Table Editor: $table" });
|
||||
print $self->_header ("Links Table Editor", $msg || "Import Data to $table.");
|
||||
print $self->_start_form ( { do => 'editor_import_data', db => $self->{cgi}->{db} }, { name => 'ImportForm'});
|
||||
|
||||
print qq~
|
||||
<table border=0 width=500><tr><td>
|
||||
<p><font $FONT>You can either import from a file or you can cut and paste the contents into a textarea box. If you
|
||||
have a large number of records, you should really import from a file. The first row of your input should be the
|
||||
fully qualified column names. You must also include the Category ID and Category Name of the category the link
|
||||
will be imported to.<br>
|
||||
|
||||
</td></tr></table>
|
||||
<br>
|
||||
<table border=0 width=500><tr><td>
|
||||
<p><font $FONT>
|
||||
Import data from file: <input type=text name="import-file" size=10> or from textarea box:<br>
|
||||
<textarea name="import-text" rows=3 cols=40></textarea><br>
|
||||
Use <input type=text name="import-delim" value="|" size=1> as delimiter.
|
||||
<input type=checkbox name="import-delete" value=1> Delete old data first
|
||||
<br>
|
||||
</tr></td></table>
|
||||
~;
|
||||
print $self->_buttons ("Import Data into");
|
||||
print "<P>";
|
||||
print $self->_end_form;
|
||||
print $self->_prop_navbar;
|
||||
print "<P>";
|
||||
print $self->_footer;
|
||||
print $self->_end_html;
|
||||
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{editor_import_data} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor_import_data {
|
||||
# -------------------------------------------------------------------
|
||||
# Allow the import to import category/link data. Only used if called with the
|
||||
# Links database.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $prefix = $DB->prefix;
|
||||
return $self->SUPER::editor_import_data(@_) unless ( $name eq $prefix . 'Links');
|
||||
|
||||
my $delim = $self->{cgi}->{'import-delim'} or return $self->editor_import_data_form ("No import delimiter specified!");
|
||||
my $file = $self->{cgi}->{'import-file'};
|
||||
my $text = $self->{cgi}->{'import-text'};
|
||||
|
||||
# Make sure there is some data to import
|
||||
$file or $text or return $self->editor_import_data_form ("You must enter in at least a filename or data in the textarea box.");
|
||||
$file and $text and return $self->editor_import_data_form ("Please only enter either a filename or data in the textarea box, not both.");
|
||||
|
||||
$delim =~ s/\\t/\t/g;
|
||||
$delim =~ /%/ and $self->editor_import_data_form("% may not be used as a delimited.");
|
||||
|
||||
# Store the lines to import in @lines and the header in $header.
|
||||
my ($good_cnt, $err_cnt, $line, $line_num, @lines, @data, $error, %record, $i);
|
||||
if ($file) {
|
||||
local *FILE;
|
||||
open (FILE, "<$file") or return $self->editor_import_data_form ("Unable to open file: '$file'. Reason: $!");
|
||||
local $/;
|
||||
@lines = split /[\r\n]+/, scalar <FILE>;
|
||||
close FILE;
|
||||
}
|
||||
else {
|
||||
@lines = split /[\r\n]+/, $text;
|
||||
}
|
||||
|
||||
# Fetch the header.
|
||||
my @header = split /\Q$delim\E/, shift @lines;
|
||||
unless (grep { $_ eq ($prefix . 'Category.ID')} @header) {
|
||||
return $self->editor_import_data_form ("Unable to find Category ID column in header!");
|
||||
}
|
||||
|
||||
# Remove Links table prefix.
|
||||
my $full_name = $prefix . 'Links';
|
||||
@header = map { s/\Q$full_name\E\.//; $_; } @header;
|
||||
|
||||
my $Links = $DB->table('Links');
|
||||
my $CatLinks = $DB->table('CatLinks');
|
||||
my $Category = $DB->table('Category');
|
||||
|
||||
# Remove old data if requested.
|
||||
my $delete = $self->{cgi}->{'import-delete'};
|
||||
if ($delete) {
|
||||
$Links->delete_all or die $GT::SQL::error;
|
||||
$CatLinks->delete_all or die $GT::SQL::error;
|
||||
}
|
||||
|
||||
# Do the import.
|
||||
$good_cnt = $err_cnt = 0;
|
||||
|
||||
my %link_map;
|
||||
|
||||
LINE: for my $line_num (0 .. $#lines) {
|
||||
($err_cnt > 10) and last LINE;
|
||||
$line = $lines[$line_num];
|
||||
@data = split /\Q$delim/, $line, -1;
|
||||
if ($#data != $#header) {
|
||||
$error .= "<li>" . ($line_num+2) . ": Row count: " . ($#data+1) .
|
||||
" does not match header count: (@data) (@header)" . ($#header+1) . "\n";
|
||||
$err_cnt++;
|
||||
next LINE;
|
||||
}
|
||||
for (@data) {
|
||||
s/%([0-9a-fA-F]{2})/chr hex $1/eg;
|
||||
}
|
||||
$i = 0;
|
||||
%record = map { $data[$i] =~ s,^"|"$,,g; $header[$i] => $data[$i++] } @data;
|
||||
my $cat_id = delete $record{$prefix . 'Category.ID'};
|
||||
my $cat_name = delete $record{$prefix . 'Category.Name'};
|
||||
unless ($Category->count({ ID => $cat_id })) {
|
||||
$cat_id = $Category->insert({ Name => $cat_name })->insert_id;
|
||||
}
|
||||
my $link_id = delete $record{ID};
|
||||
if ($link_id and $link_map{$link_id}) {
|
||||
$link_id = $link_map{$link_id};
|
||||
}
|
||||
else {
|
||||
my $count = $Links->count({ ID => $link_id });
|
||||
if ($link_id and $count) {
|
||||
if ($count) {
|
||||
unless ($Links->update(\%record, { ID => $link_id })) {
|
||||
$error .= "<li>" . ($line_num+2) . ": Failed to update record. Error <ul>$GT::SQL::error</ul>\n";
|
||||
$err_cnt++;
|
||||
next LINE;
|
||||
}
|
||||
$link_map{$link_id} = $link_id;
|
||||
}
|
||||
else {
|
||||
my $old_id = $link_id;
|
||||
my $sth = $Links->insert(\%record);
|
||||
unless ($sth and ($link_id = $sth->insert_id)) {
|
||||
$error .= "<li>" . ($line_num+2) . ": Failed to add new record. Error <ul>$GT::SQL::error</ul>\n";
|
||||
$err_cnt++;
|
||||
next LINE;
|
||||
}
|
||||
$link_map{$old_id} = $link_id;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $old_id = $link_id;
|
||||
my $sth = $Links->insert(\%record);
|
||||
unless ($sth and ($link_id = $sth->insert_id)) {
|
||||
$error .= "<li>" . ($line_num+2) . ": Failed to add new record. Error <ul>$GT::SQL::error</ul>\n";
|
||||
$err_cnt++;
|
||||
next LINE;
|
||||
}
|
||||
$link_map{$old_id} = $link_id;
|
||||
}
|
||||
}
|
||||
unless ($CatLinks->count ( { LinkID => $link_id, CategoryID => $cat_id })) {
|
||||
$CatLinks->insert({ LinkID => $link_id, CategoryID => $cat_id });
|
||||
}
|
||||
$good_cnt++;
|
||||
last if ($err_cnt > 100);
|
||||
}
|
||||
|
||||
# Return the results.
|
||||
if ($error) {
|
||||
return $self->editor_import_data_form (($err_cnt >= 100) ?
|
||||
"Aborting, too many errors!<br><br>Rows imported: $good_cnt<br>Errors with the following rows:
|
||||
<font size=-1><ul>$error</ul></font><br>" :
|
||||
"Rows imported: $good_cnt<br>Errors with the following rows: <font size=-1><ul>$error</ul></font><br>");
|
||||
}
|
||||
return $self->editor_import_data_form ("Rows imported: $good_cnt.");
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{editor_export_data_form} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor_export_data_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Allow the export to export category/link data. Only used if called with the
|
||||
# Links database.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $prefix = $DB->prefix;
|
||||
return $self->SUPER::editor_export_data_form(@_) unless ( $name eq $prefix . 'Links');
|
||||
|
||||
my $msg = shift;
|
||||
|
||||
print $self->{in}->header;
|
||||
|
||||
$msg &&= qq|<FONT COLOR="red"><B>$msg</B></FONT>|;
|
||||
my $table = $self->{record};
|
||||
print $self->_start_html ( { title => "Table Editor: $table" });
|
||||
print $self->_header ("Table Editor", $msg || "Export Data from $table.");
|
||||
print $self->_start_form ( { do => 'editor_export_data', db => $self->{cgi}->{db} }, {name => 'ExportForm'});
|
||||
|
||||
print qq~
|
||||
<table border=0 width=500><tr><td>
|
||||
<p><font $FONT>From here you can export your Links to either the screen or to
|
||||
a file on your server. The first line of the export will be a list of the column
|
||||
headers. The last two fields is the Category ID the link is in, and the Category Name.
|
||||
If a link is in more then one category, you will get one row for each occurrence.
|
||||
</font>
|
||||
</td></tr></table>
|
||||
<br>
|
||||
<table border=0 width=500><tr><td><font $FONT>
|
||||
Export data to: <select name="export-mode"><option>file<option>screen</select>
|
||||
filename: <input type=text name="export-file" size=10><br>
|
||||
Use <input type=text name="export-delim" value="|" size=1> as delimiter.
|
||||
</font>
|
||||
</td></tr></table>
|
||||
<br>
|
||||
~;
|
||||
print $self->_buttons ("Export Data from");
|
||||
print "<P>";
|
||||
print $self->_end_form;
|
||||
print $self->_prop_navbar;
|
||||
print "<P>";
|
||||
print $self->_footer;
|
||||
print $self->_end_html;
|
||||
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
$COMPILE{editor_export_data} = __LINE__ . <<'END_OF_SUB';
|
||||
sub editor_export_data {
|
||||
# -------------------------------------------------------------------
|
||||
# Allow the export to export category/link data. Only used if called with the
|
||||
# Links database.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = $self->{table}->name;
|
||||
my $prefix = $DB->prefix;
|
||||
return $self->SUPER::editor_export_data(@_) unless ( $name eq $prefix . 'Links');
|
||||
|
||||
print $self->{in}->header;
|
||||
|
||||
ref $self->{cgi}->{db} and return $self->error('BADARGS','FATAL', "Editor can only be called with one table, not a relation.");
|
||||
|
||||
my @order = $self->{table}->ordered_columns;
|
||||
@order or return $self->editor_export_data_form("No fields selected to export (@order).");
|
||||
|
||||
# Add on the prefix.
|
||||
for (@order) { $_ = $prefix . 'Links.' . $_; }
|
||||
|
||||
# Add the ID and Category Name.
|
||||
push @order, $prefix . 'Category.ID', $prefix .'Category.Name';
|
||||
|
||||
my $delim = $self->{cgi}->{'export-delim'};
|
||||
$delim = "\t" if $delim eq '\t';
|
||||
length $delim or $self->editor_export_data_form("No delimiter entered.");
|
||||
$delim =~ /%/ and $self->editor_export_data_form("% may not be used as a delimited.");
|
||||
|
||||
my $screen = $self->{cgi}->{'export-mode'} ne 'file';
|
||||
|
||||
local *FILE;
|
||||
if ($screen) {
|
||||
open FILE, ">&STDOUT";
|
||||
print FILE $self->{in}->header(); # print FILE to avoid STDOUT vs. FILE buffering issues
|
||||
print FILE "<html><head><title>Links Export</title></head><body><pre>";
|
||||
}
|
||||
else {
|
||||
my $filename = $self->{cgi}->{'export-file'} or return $self->editor_export_data_form("Please enter a file name!");
|
||||
open FILE, "> $filename" or return $self->editor_export_data_form("Unable to open file '$filename': $!");
|
||||
}
|
||||
|
||||
# Print the row header.
|
||||
print FILE join ($delim, @order), "\n";
|
||||
|
||||
# Print the data.
|
||||
my $db = $DB->table(qw/Links CatLinks Category/);
|
||||
my $sth = $db->select(\@order) or return $self->editor_export_data_form($GT::SQL::error);
|
||||
my $delim_re = quotemeta $delim;
|
||||
my $delim_str = join '', map sprintf("%%%02x", ord($_)), split '', $delim;
|
||||
{
|
||||
local $, = $delim;
|
||||
local $\ = "\n";
|
||||
while (my $row = $sth->fetchrow_arrayref) {
|
||||
for (@$row) {
|
||||
s{$delim_re}{$delim_str}g;
|
||||
s{%} {%25}g;
|
||||
s{\r} {}g;
|
||||
s{\n} {%0a}g;
|
||||
$_ = $self->{in}->html_escape($_) if $screen;
|
||||
}
|
||||
print FILE @$row;
|
||||
}
|
||||
}
|
||||
print FILE "</pre></body></html>" if $screen;
|
||||
return $self->editor_export_data_form("Data has been exported to: $self->{cgi}->{'export-file'}") unless $screen;
|
||||
return;
|
||||
}
|
||||
END_OF_SUB
|
||||
|
||||
sub _check_opts {
|
||||
# -------------------------------------------------------------------
|
||||
# Need to override this so searching for categories works.
|
||||
#
|
||||
my $self = shift;
|
||||
my $sel = 0;
|
||||
|
||||
# Relation does not plat fare :(
|
||||
my $cols = $self->{table}->cols;
|
||||
for (keys %{$self->{cgi}}) { $sel = 1 if (($self->{cgi}->{$_} =~ /\S/) and exists $cols->{$_}) }
|
||||
if ((exists $self->{cgi}->{query} and $self->{cgi}->{query} =~ /\S/) or
|
||||
(exists $self->{cgi}->{keyword} and $self->{cgi}->{keyword} =~ /\S/)) {
|
||||
$sel = 1;
|
||||
}
|
||||
my $prefix = $DB->prefix;
|
||||
if (! $sel and ($self->{table}->name eq $prefix . 'Links') and (exists $self->{cgi}->{'CatLinks.CategoryID'})) {
|
||||
$sel = 1;
|
||||
}
|
||||
$sel or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _buttons {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds a warning message to delete Users and Categories.
|
||||
#
|
||||
my $self = shift;
|
||||
my $name = shift;
|
||||
my $prefix = GT::SQL->prefix();
|
||||
my $msg = '';
|
||||
if (($self->{table}->name eq $prefix . "Users") and ($name eq 'Delete')) {
|
||||
$msg = qq~<p><font face="Tahoma,Arial,Helvetica" size="2"><font color="red"><b>Warning:</b></font> deleting a user will also delete all links associated with that user!</font></p>~;
|
||||
}
|
||||
if (($self->{table}->name eq $prefix . "Category") and ($name eq 'Delete')) {
|
||||
$msg = qq~<p><font face="Tahoma,Arial,Helvetica" size="2"><font color="red"><b>Warning:</b></font> deleting a category will also delete all sub categories and links in those categories!</font></p>~;
|
||||
}
|
||||
|
||||
return qq~
|
||||
<table border=1 cellpadding=0 cellspacing=0><tr><td align=center>
|
||||
<table border=0 width=500><tr><td align=center>$msg<center><font face="Tahoma,Arial,Helvetica" size="2"><input type=submit value="$name $self->{record}"></font></center></td></tr></table>
|
||||
</td></tr></table>
|
||||
~;
|
||||
}
|
||||
|
||||
1;
|
||||
244
site/slowtwitch.com/cgi-bin/articles/admin/Links/Authenticate.pm
Normal file
244
site/slowtwitch.com/cgi-bin/articles/admin/Links/Authenticate.pm
Normal file
@@ -0,0 +1,244 @@
|
||||
# ==================================================================
|
||||
# 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: Authenticate.pm,v 1.34 2008/10/06 17:41:18 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::Authenticate;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use GT::Session::SQL;
|
||||
|
||||
# This package lets you integrate Gossamer Links into another authentication
|
||||
# system. You can do this by replacing the functions with your own
|
||||
# code. Note: to return error results, simply set error => message in
|
||||
# the passed in hash.
|
||||
|
||||
sub auth {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Runs the request auth function through the plugin system.
|
||||
#
|
||||
shift if UNIVERSAL::isa($_[0], 'Links::Authenticate');
|
||||
my ($auth, $args) = @_;
|
||||
my $code = exists $Links::Authenticate::{"auth_$auth"}
|
||||
? $Links::Authenticate::{"auth_$auth"}
|
||||
: die "Invalid Authenticate method 'auth_$auth' called";
|
||||
$PLG->dispatch("auth_$auth", $code, $args);
|
||||
}
|
||||
|
||||
sub auth_init {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function is guaranteed to be called before any other authentication
|
||||
# function, but may be called multiple times during one request.
|
||||
#
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_add_user {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function is called whenever a user is added to the database. It takes a
|
||||
# hash reference with Username and Password as input. If there is an error, set
|
||||
# $args->{error} to the message.
|
||||
#
|
||||
my $args = shift;
|
||||
return { Username => $args->{Username}, Password => $args->{Password} };
|
||||
}
|
||||
|
||||
sub auth_del_user {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function is called whenever a user is trying to be deleted. It returns
|
||||
# the username on success, or undef on failure.
|
||||
#
|
||||
my $args = shift;
|
||||
return $args->{Username};
|
||||
}
|
||||
|
||||
sub auth_valid_user {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function returns true if the user/pass combo is valid, 0/undef
|
||||
# otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
return int $DB->table('Users')->count({ Username => $args->{Username}, Password => $args->{Password} });
|
||||
}
|
||||
|
||||
sub auth_valid_format {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function returns 1 if the user format is valid, undef otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $args->{Username};
|
||||
return if length $user > 50 or $user !~ /^[\w\s\-\@\.]+$/;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_change_pass {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function takes the username, old pass and new pass and returns 1 if
|
||||
# successful, false otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub auth_get_pass {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function returns the password (if available) of a given user, undef
|
||||
# otherwise.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $args->{Username};
|
||||
my $pass = $DB->table('Users')->select(Password => { Username => $user })->fetchrow;
|
||||
return $pass;
|
||||
}
|
||||
|
||||
sub auth_get_user {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function returns user information for a given user, auto creating if it
|
||||
# doesn't exist.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $args->{Username};
|
||||
my $pass = $args->{Password};
|
||||
my $db = $DB->table('Users');
|
||||
my $user_r = $db->get($user);
|
||||
if (!$user_r and $args->{auto_create}) {
|
||||
$user_r->{Username} = $user;
|
||||
$user_r->{Password} = defined $pass ? $pass : Links::Authenticate::auth('get_pass', { Username => $user });
|
||||
$user_r->{Email} = $user . '@noemail.nodomain';
|
||||
$user_r->{ReceiveMail} = 'No';
|
||||
$user_r->{Password} = '' unless defined $user_r->{Password};
|
||||
my $defaults = $db->default();
|
||||
for (keys %$defaults) {
|
||||
$user_r->{$_} = $defaults->{$_} unless exists $user_r->{$_};
|
||||
}
|
||||
$db->insert($user_r) or die "Unable to auto-create user: $user. Reason: $GT::SQL::error";
|
||||
}
|
||||
return $user_r;
|
||||
}
|
||||
|
||||
sub auth_valid_session {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This functions checks to see if the session is valid, and returns the
|
||||
# username.
|
||||
#
|
||||
my $args = shift;
|
||||
my $session_id = $IN->param('s') || $IN->cookie($CFG->{user_cookie_prefix} . 's') || return;
|
||||
my $session;
|
||||
unless ($session = GT::Session::SQL->new({
|
||||
_debug => $CFG->{debug_level},
|
||||
tb => $DB->table('Sessions'),
|
||||
session_id => $session_id,
|
||||
expires => $CFG->{user_session_length},
|
||||
session_data => { sessions => $CFG->{user_sessions}, d => scalar($IN->param('d')) },
|
||||
})) { # Possibly an expired session
|
||||
GT::Session::SQL->new({
|
||||
tb => $DB->table('Sessions'),
|
||||
expires => $CFG->{user_session_length}
|
||||
})->cleanup; # Clear out old sessions
|
||||
return;
|
||||
}
|
||||
|
||||
return $session->{info}->{session_user_id};
|
||||
}
|
||||
|
||||
sub auth_create_session {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function creates a session, and prints the header and returns a hash
|
||||
# reference with session => $id, and redirect => 0/1.
|
||||
#
|
||||
my $args = shift;
|
||||
my $user = $args->{Username};
|
||||
my $remember = ($CFG->{user_sessions} eq 'Cookies' and ($args->{Remember} or $IN->param('Remember')));
|
||||
|
||||
# Create a new session.
|
||||
my $session = GT::Session::SQL->new({
|
||||
_debug => $CFG->{debug_level},
|
||||
tb => $DB->table('Sessions'),
|
||||
session_user_id => $user,
|
||||
session_data => { sessions => $CFG->{user_sessions}, d => scalar($IN->param('d')) },
|
||||
expires => ($remember ? 0 : $CFG->{user_session_length}),
|
||||
});
|
||||
|
||||
# Clear out old sessions.
|
||||
$session->cleanup;
|
||||
|
||||
# Get session id
|
||||
my $session_id = $session->{info}->{session_id};
|
||||
|
||||
# Now redirect to another URL and set cookies, or set URL string.
|
||||
my $url = $IN->param('url');
|
||||
my $redirect = 0;
|
||||
if ($CFG->{user_sessions} eq 'Cookies') {
|
||||
my $session_cookie = $IN->cookie(
|
||||
-name => $CFG->{user_cookie_prefix} . 's',
|
||||
-value => $session_id,
|
||||
-path => '/',
|
||||
-domain => $CFG->{user_cookie_domain},
|
||||
-expires => ($remember ? '+10y' : '')
|
||||
);
|
||||
if ($url) {
|
||||
print $IN->redirect(-force => 1, -cookie => [$session_cookie], -url => $url);
|
||||
$redirect = 1;
|
||||
}
|
||||
else {
|
||||
print $IN->header(-force => 1, -cookie => [$session_cookie]);
|
||||
}
|
||||
}
|
||||
else {
|
||||
# If URL sessions are used, then the user will be forced into dynamic mode
|
||||
# since there's no way to pass around the session id with the static URLs.
|
||||
if ($url) {
|
||||
unless ($url =~ s/([;&\?]s=)([^&;]+)/$1$session_id/) {
|
||||
$url .= ($url =~ /\?/ ? ';' : '?') . "s=$session_id";
|
||||
}
|
||||
unless ($url =~ /([;&\?]d=)([^&;]+)/) {
|
||||
$url .= ($url =~ /\?/ ? ';' : '?') . "d=1";
|
||||
}
|
||||
print $IN->redirect($url);
|
||||
$redirect = 1;
|
||||
}
|
||||
else {
|
||||
$IN->param(s => $session_id);
|
||||
$IN->param(d => 1);
|
||||
print $IN->header();
|
||||
}
|
||||
}
|
||||
return { session => $session_id, redirect => $redirect };
|
||||
}
|
||||
|
||||
sub auth_delete_session {
|
||||
# -----------------------------------------------------------------------------
|
||||
# This function removes a session, returns 1 on success, undef on failure.
|
||||
#
|
||||
print $IN->header(
|
||||
-cookie => $IN->cookie(
|
||||
-name => $CFG->{user_cookie_prefix} . 's',
|
||||
-value => '',
|
||||
-path => '/',
|
||||
-domain => $CFG->{user_cookie_domain},
|
||||
-expires => '-1y'
|
||||
)
|
||||
);
|
||||
my $session_id = $IN->cookie($CFG->{user_cookie_prefix} . 's') || $IN->param('s') || return;
|
||||
|
||||
my $session = GT::Session::SQL->new({
|
||||
_debug => $CFG->{debug_level},
|
||||
tb => $DB->table('Sessions'),
|
||||
session_id => $session_id
|
||||
}) or return;
|
||||
|
||||
# Delete the cookie
|
||||
$session->delete or return;
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
753
site/slowtwitch.com/cgi-bin/articles/admin/Links/Bookmark.pm
Normal file
753
site/slowtwitch.com/cgi-bin/articles/admin/Links/Bookmark.pm
Normal file
@@ -0,0 +1,753 @@
|
||||
# ==================================================================
|
||||
# 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: Bookmark.pm,v 1.35 2007/08/28 22:57:14 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::Bookmark;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my $action = $IN->param('action');
|
||||
my %valid = (
|
||||
map { $_ => 1 } qw(
|
||||
show_folders
|
||||
show_links
|
||||
folder_add
|
||||
folder_edit
|
||||
folder_remove
|
||||
folder_view
|
||||
edit_preferences
|
||||
link_add
|
||||
edit_bookmark
|
||||
links_manage
|
||||
users_list
|
||||
users_folder
|
||||
users_links
|
||||
)
|
||||
);
|
||||
|
||||
if ($action !~ /^users_/ and !$USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('bookmark'));
|
||||
return;
|
||||
}
|
||||
|
||||
no strict 'refs';
|
||||
if ($action eq 'folder_manage') {
|
||||
return $PLG->dispatch("bookmark_$action", \&show_links);
|
||||
}
|
||||
if ($action eq 'users_links') {
|
||||
return $PLG->dispatch("bookmark_$action", \&folder_view);
|
||||
}
|
||||
if (defined &$action and $valid{$action}) {
|
||||
return $PLG->dispatch("bookmark_$action", \&$action);
|
||||
}
|
||||
|
||||
# Otherwise display the modify form.
|
||||
$PLG->dispatch("bookmark_show_folders", \&show_folders);
|
||||
}
|
||||
|
||||
sub show_folders {
|
||||
# --------------------------------------------------------
|
||||
# Show Folders
|
||||
#
|
||||
my $username = $USER->{Username};
|
||||
my $folders = _folder_list($username);
|
||||
if (exists $folders->{paging} and exists $folders->{paging}->{url}) {
|
||||
$folders->{paging}->{url} .= (index($folders->{paging}->{url}, '?') != -1 ? ';' : '?') . "action=show_folders";
|
||||
}
|
||||
|
||||
$folders->{link_count} ||= $DB->table('Bookmark_Links', 'Links')->count({ my_user_username_fk => $username }, VIEWABLE);
|
||||
$folders->{message} = shift;
|
||||
$folders->{error} = shift;
|
||||
$folders->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_list', $folders);
|
||||
}
|
||||
|
||||
sub users_list {
|
||||
# --------------------------------------------------------
|
||||
# Display the users list with public folders
|
||||
#
|
||||
my $error = shift || "";
|
||||
my $db = $DB->table('Users', 'Bookmark_Folders');
|
||||
|
||||
# Get our options.
|
||||
my ($limit, $offset, $nh) = Links::limit_offset($CFG->{bookmark_users_per_page});
|
||||
|
||||
$db->select_options("GROUP BY my_folder_user_username_fk");
|
||||
$db->select_options("ORDER BY my_folder_user_username_fk ASC");
|
||||
$db->select_options("LIMIT $limit OFFSET $offset");
|
||||
|
||||
my @users;
|
||||
my $sth = $db->select('my_folder_user_username_fk', { my_folder_public => 1 });
|
||||
my $total = $db->select('COUNT(DISTINCT(my_folder_user_username_fk))', { my_folder_public => 1 })->fetchrow;
|
||||
|
||||
while (my $row = $sth->fetchrow_hashref()) {
|
||||
$row->{public_folders} = $db->count({ my_folder_user_username_fk => $row->{my_folder_user_username_fk}, my_folder_public => 1 });
|
||||
$row->{public_links} = _total_pub_links($row->{my_folder_user_username_fk});
|
||||
push @users, $row;
|
||||
}
|
||||
|
||||
my ($toolbar, %paging);
|
||||
if ($total > $limit) {
|
||||
my $url = _bookmark_url();
|
||||
$url .= (index($url, '?') != -1 ? ';' : '?') . 'action=users_list';
|
||||
$toolbar = $DB->html($db, $IN)->toolbar($nh, $limit, $total, $url);
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $total,
|
||||
max_hits => $limit,
|
||||
current_page => $nh
|
||||
);
|
||||
}
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_users', {
|
||||
users => \@users,
|
||||
total_users => $total,
|
||||
error => $error,
|
||||
toolbar => $toolbar,
|
||||
paging => \%paging,
|
||||
main_title_loop => Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi")
|
||||
});
|
||||
}
|
||||
|
||||
sub users_folder {
|
||||
# --------------------------------------------------------
|
||||
# Display user's public folders
|
||||
#
|
||||
my $username = $IN->param('my_folder_username');
|
||||
|
||||
unless ($DB->table('Users')->get($username)) {
|
||||
return users_list(Links::language('BOOKMARK_USER_NOTEXISTS', $username));
|
||||
}
|
||||
my $folders = _folder_list($username);
|
||||
if (exists $folders->{paging} and exists $folders->{paging}->{url}) {
|
||||
$folders->{paging}->{url} .= (index($folders->{paging}->{url}, '?') != -1 ? ';' : '?') . "action=users_folder;my_folder_username=" . $IN->escape($username);
|
||||
}
|
||||
|
||||
$folders->{link_count} ||= $DB->table('Bookmark_Links', 'Bookmark_Folders', 'Links')->count({ my_user_username_fk => $username, my_folder_public => 1 }, VIEWABLE);
|
||||
$folders->{message} = shift;
|
||||
$folders->{error} = shift;
|
||||
$folders->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
if ($folders->{link_count} == 0 and $folders->{folder_count} == 0) {
|
||||
my $error = Links::language('BOOKMARK_PUBLIC_USER', $username);
|
||||
return users_list($error);
|
||||
}
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_view', $folders);
|
||||
}
|
||||
|
||||
sub folder_view {
|
||||
# --------------------------------------------------------
|
||||
# View the links in the folder
|
||||
#
|
||||
my $message = shift;
|
||||
my $error = shift;
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
my $folderid = $IN->param('my_folder_id') || $IN->param('my_folder_id_fk');
|
||||
my $folder = $DB->table('Bookmark_Folders')->get($folderid);
|
||||
unless ($folder) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BOOKMARK_FOLDER_NOTEXISTS'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
if ($USER->{Username} ne $folder->{my_folder_user_username_fk} and not $folder->{my_folder_public}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BOOKMARK_FOLDER_NOTPUBLIC'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my $username = $folder->{my_folder_user_username_fk};
|
||||
my $links = _links_list($username, $folderid);
|
||||
if (exists $links->{paging} and exists $links->{paging}->{url}) {
|
||||
my $action = $IN->param('action') eq 'users_links' ? 'users_links' : 'folder_view';
|
||||
$links->{paging}->{url} .= (index($links->{paging}->{url}, '?') != -1 ? ';' : '?') . "action=$action;my_folder_id=$folderid";
|
||||
}
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_view', {
|
||||
%$links,
|
||||
my_folder_username => $username,
|
||||
message => $message,
|
||||
error => $error,
|
||||
main_title_loop => $mtl
|
||||
});
|
||||
}
|
||||
|
||||
sub show_links {
|
||||
# --------------------------------------------------------
|
||||
# Show user's link for the user to manage
|
||||
#
|
||||
my $message = shift;
|
||||
my $error = shift;
|
||||
my $username = shift || $USER->{Username};
|
||||
my $folderid = $IN->param('my_folder_id') || $IN->param('my_folder_id_fk');
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
my $folder = $DB->table('Bookmark_Folders')->get($folderid);
|
||||
if (not $error and $username ne $folder->{my_folder_user_username_fk} and not $folder->{my_folder_public}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BOOKMARK_FOLDER_NOTPUBLIC'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my $links = _links_list($username, $folderid);
|
||||
if (exists $links->{paging} and exists $links->{paging}->{url}) {
|
||||
$links->{paging}->{url} .= (index($links->{paging}->{url}, '?') != -1 ? ';' : '?') . "action=folder_manage;my_folder_id=$folderid";
|
||||
}
|
||||
|
||||
my $folders = _folder_list($username, $folderid, 1);
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_list', {
|
||||
%$links,
|
||||
folder_select => $folders->{Folders},
|
||||
message => $message,
|
||||
error => $error,
|
||||
main_title_loop => $mtl
|
||||
});
|
||||
}
|
||||
|
||||
sub _folder_list {
|
||||
# --------------------------------------------------------
|
||||
# Generate folder lists
|
||||
#
|
||||
my $username = shift;
|
||||
my $exclude = shift;
|
||||
my $dropdown = shift;
|
||||
my $bf = $DB->table('Bookmark_Folders');
|
||||
return unless $username;
|
||||
|
||||
# Get our options.
|
||||
my ($limit, $offset, $nh) = Links::limit_offset($CFG->{bookmark_folders_per_page});
|
||||
|
||||
$bf->select_options("ORDER BY my_folder_name ASC");
|
||||
unless ($dropdown) {
|
||||
$bf->select_options("LIMIT $limit OFFSET $offset");
|
||||
}
|
||||
|
||||
my $cond = GT::SQL::Condition->new(my_folder_user_username_fk => '=' => $username);
|
||||
if ($USER->{Username} ne $username) {
|
||||
$cond->add(my_folder_public => '=' => 1);
|
||||
}
|
||||
if ($exclude > 0) {
|
||||
$cond->add(my_folder_id => '!=' => $exclude);
|
||||
}
|
||||
my $sth = $bf->select($cond);
|
||||
my $total = $bf->hits;
|
||||
my $folder = [];
|
||||
if ($sth->rows) {
|
||||
my $i = 0;
|
||||
while (my $row = $sth->fetchrow_hashref) {
|
||||
$row->{num_links} = _count_links($username, $row->{my_folder_id});
|
||||
$row->{my_folder_name} = $IN->html_escape($row->{my_folder_name});
|
||||
$row->{my_folder_description} = $IN->html_escape($row->{my_folder_description});
|
||||
push @$folder, $row;
|
||||
$i++;
|
||||
}
|
||||
my ($toolbar, %paging);
|
||||
if (!$dropdown and $total > $limit) {
|
||||
my $url = _bookmark_url();
|
||||
$toolbar = $DB->html($bf, $IN)->toolbar($nh, $limit, $total, $url);
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $total,
|
||||
max_hits => $limit,
|
||||
current_page => $nh
|
||||
);
|
||||
}
|
||||
|
||||
return { Folders => $folder, folder_count => $total, toolbar => $toolbar, paging => \%paging };
|
||||
}
|
||||
return { Folders => '', folder_count => 0 };
|
||||
}
|
||||
|
||||
sub _count_links {
|
||||
# --------------------------------------------------------
|
||||
# Return the number of links in folder
|
||||
#
|
||||
my ($username, $folderid) = @_;
|
||||
return $DB->table('Bookmark_Links', 'Links')->count({ my_folder_id_fk => $folderid }, VIEWABLE);
|
||||
}
|
||||
|
||||
sub _total_pub_links {
|
||||
# --------------------------------------------------------
|
||||
# Return the number of public links for a user
|
||||
#
|
||||
my $username = shift;
|
||||
my $links_db = $DB->table('Bookmark_Folders', 'Bookmark_Links', 'Links');
|
||||
return $links_db->count({ my_folder_public => 1, my_user_username_fk => $username }, VIEWABLE);
|
||||
}
|
||||
|
||||
sub _links_list {
|
||||
# --------------------------------------------------------
|
||||
# Generate links list
|
||||
#
|
||||
my ($username, $folderid) = @_;
|
||||
my $db = $DB->table('Bookmark_Links', 'Links');
|
||||
my $html = $DB->html($db, $IN);
|
||||
return unless $username;
|
||||
|
||||
if ($username eq $USER->{Username}) {
|
||||
$db->select_options("ORDER BY $USER->{SortField} $USER->{SortOrd}");
|
||||
}
|
||||
else {
|
||||
$db->select_options("ORDER BY $CFG->{bookmark_links_sort} $CFG->{bookmark_links_sort_order}");
|
||||
}
|
||||
|
||||
my ($limit, $offset, $nh) = Links::limit_offset(
|
||||
($USER->{Username} eq $username and $USER->{PerPage})
|
||||
? $USER->{PerPage}
|
||||
: $CFG->{bookmark_links_per_page}
|
||||
);
|
||||
|
||||
$db->select_options("LIMIT $limit OFFSET $offset");
|
||||
|
||||
my $sth = $db->select({ my_user_username_fk => $username, my_folder_id_fk => $folderid }, VIEWABLE);
|
||||
my $link_count = $db->hits;
|
||||
my $links = [];
|
||||
my $folder = $DB->table('Bookmark_Folders')->get($folderid);
|
||||
|
||||
# Generate a toolbar if requested.
|
||||
my ($toolbar, %paging);
|
||||
if ($link_count > $limit) {
|
||||
my $url = _bookmark_url();
|
||||
$toolbar = $html->toolbar($nh, $limit, $link_count, $url);
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $link_count,
|
||||
max_hits => $limit,
|
||||
current_page => $nh
|
||||
);
|
||||
}
|
||||
|
||||
my @link_results_loop;
|
||||
my ($link_results, %link_output);
|
||||
if ($link_count) {
|
||||
my $results = $sth->fetchall_hashref;
|
||||
my $links_tb = $DB->table('Links');
|
||||
for (@$results) {
|
||||
$_->{my_comment} = $IN->html_escape($_->{my_comment});
|
||||
$links_tb->add_reviews($_);
|
||||
}
|
||||
if ($USER->{Grouping}) {
|
||||
my @ids = map { $_->{ID} } @$results;
|
||||
my $catlink = $DB->table('CatLinks', 'Category');
|
||||
my %names = $catlink->select('LinkID', 'Full_Name', { LinkID => \@ids })->fetchall_list;
|
||||
foreach my $link (@$results) {
|
||||
push @{$link_output{$names{$link->{ID}}}}, $link;
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @{$link_output{none}}, @$results;
|
||||
}
|
||||
}
|
||||
$folder ||= {};
|
||||
$folder->{my_folder_name} = $IN->html_escape($folder->{my_folder_name});
|
||||
$folder->{my_folder_description} = $IN->html_escape($folder->{my_folder_description});
|
||||
|
||||
if ($link_count) {
|
||||
my $i = 0;
|
||||
if ($USER->{Grouping}) {
|
||||
foreach my $cat (sort keys %link_output) {
|
||||
$link_output{$cat}->[0]->{title_linked} = sub { Links::Build::build('title_linked', { name => $cat, complete => 1, home => 0 }) };
|
||||
$link_output{$cat}->[0]->{title_loop} = Links::Build::build('title', $cat);
|
||||
push @link_results_loop, @{$link_output{$cat}};
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @link_results_loop, @{$link_output{none}};
|
||||
}
|
||||
|
||||
return { Bookmarks => \@link_results_loop, link_count => $link_count, %$folder, toolbar => $toolbar, paging => \%paging };
|
||||
}
|
||||
return { Bookmarks => "", link_count => 0, %$folder, toolbar => $toolbar };
|
||||
}
|
||||
|
||||
sub folder_add {
|
||||
# --------------------------------------------------------
|
||||
# Add Folder
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $bf = $DB->table('Bookmark_Folders');
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
if ($IN->param('add')) {
|
||||
unless ($args->{my_folder_name}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_add', { error => Links::language('BOOKMARK_BAD_FOLDER'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
if ($bf->count({ my_folder_user_username_fk => $USER->{Username} }) >= $CFG->{bookmark_folder_limit}) {
|
||||
return show_folders('', Links::language('BOOKMARK_FOLDER_LIMIT'));
|
||||
}
|
||||
if ($bf->count({ my_folder_name => $args->{my_folder_name}, my_folder_user_username_fk => $USER->{Username} })) {
|
||||
$args->{error} = Links::language('BOOKMARK_FOLDER_DUPLICATE', $args->{my_folder_name});
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_add', { %$args, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$args->{my_folder_user_username_fk} = $USER->{Username};
|
||||
$args->{my_folder_public} = $args->{my_folder_public} ? 1 : 0;
|
||||
$args->{my_folder_default} = $args->{my_folder_default} ? 1 : 0;
|
||||
if ($args->{my_folder_default}) {
|
||||
$bf->update({ my_folder_default => 0 }, { my_folder_user_username_fk => $USER->{Username}, my_folder_default => 1 });
|
||||
}
|
||||
my $fid = $bf->add($args);
|
||||
if ($fid) {
|
||||
return show_folders();
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_add', { error => Links::language('BOOKMARK_BAD_FOLDER', $GT::SQL::error), main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_add', { main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub folder_edit {
|
||||
# --------------------------------------------------------
|
||||
# Edit Folder
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $bf = $DB->table('Bookmark_Folders');
|
||||
my $folderid = $args->{my_folder_id};
|
||||
my $folder = $bf->get($folderid);
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
if (!$folder or $folder->{my_folder_user_username_fk} ne $USER->{Username}) {
|
||||
return show_folders('', Links::language('BOOKMARK_BAD_FOLDER_ID', $folderid));
|
||||
}
|
||||
if ($IN->param('modify')) {
|
||||
unless ($args->{my_folder_name}) {
|
||||
$args->{error} = Links::language('BOOKMARK_BAD_FOLDER');
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_edit', { %$args, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
if ($args->{my_folder_name} ne $folder->{my_folder_name} and $bf->count({ my_folder_name => $args->{my_folder_name}, my_folder_user_username_fk => $USER->{Username} })) {
|
||||
$args->{error} = Links::language('BOOKMARK_FOLDER_DUPLICATE', $args->{my_folder_name});
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_edit', { %$args, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$args->{my_folder_user_username_fk} = $USER->{Username};
|
||||
$args->{my_folder_public} = $args->{my_folder_public} ? 1 : 0;
|
||||
$args->{my_folder_default} = $args->{my_folder_default} ? 1 : 0;
|
||||
if ($args->{my_folder_default}) {
|
||||
$bf->update({ my_folder_default => 0 }, { my_folder_user_username_fk => $USER->{Username}, my_folder_default => 1 });
|
||||
}
|
||||
my $rec = $bf->modify($args);
|
||||
if ($rec) {
|
||||
$IN->param('my_folder_name', '');
|
||||
show_folders(Links::language('BOOKMARK_FOLDER_MODIFIED', $folderid));
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_edit', { error => Links::language('BOOKMARK_BAD_FOLDER', $GT::SQL::error), main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_folder_edit', { %$folder, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub folder_remove {
|
||||
# -------------------------------------------------------------------
|
||||
# Remove folder and the links in it
|
||||
#
|
||||
my $folderid = $IN->param('my_folder_id');
|
||||
my $bf = $DB->table('Bookmark_Folders');
|
||||
my $folder = $bf->get($folderid);
|
||||
my $error;
|
||||
if ($folder->{my_folder_default}) {
|
||||
$error = Links::language('BOOKMARK_FOLDER_DEFAULT');
|
||||
}
|
||||
elsif ($bf->count({ my_folder_id => $folderid, my_folder_user_username_fk => $USER->{Username} })) {
|
||||
my $rc = $bf->delete({ my_folder_id => $folderid, my_folder_user_username_fk => $USER->{Username} });
|
||||
unless ($rc) {
|
||||
$error = $GT::SQL::error;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$error = Links::language('BOOKMARK_FOLDER_NOTEXISTS', $folderid);
|
||||
}
|
||||
if ($error) {
|
||||
return show_folders('', $error);
|
||||
}
|
||||
else {
|
||||
return show_folders(Links::language('BOOKMARK_FOLDER_REMOVED', $folder->{my_folder_name}));
|
||||
}
|
||||
}
|
||||
|
||||
sub edit_bookmark {
|
||||
# -------------------------------------------------------------------
|
||||
# edit Bookmark Comments
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $id = $args->{my_id} || shift;
|
||||
my $bl = $DB->table('Bookmark_Links');
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
|
||||
# <=3.2 template backwards compatibility
|
||||
# Previously the link id was passed to edit, but the ability to bookmark a link
|
||||
# multiple times was added in 3.2.
|
||||
my $lid = $args->{id} || shift;
|
||||
if (!$id and $lid) {
|
||||
$bl->select_options('ORDER BY my_id');
|
||||
$id = $bl->select('my_id', { my_link_id_fk => $lid, my_user_username_fk => $USER->{Username} })->fetchrow;
|
||||
}
|
||||
|
||||
if (not $bl->count({ my_id => $id, my_user_username_fk => $USER->{Username} })) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_edit', { error => Links::language('BOOKMARK_LINK_NOTEXISTS', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
my $link = $DB->table('Bookmark_Links', 'Links')->select({ my_id => $id, my_user_username_fk => $USER->{Username} })->fetchrow_hashref;
|
||||
my $folders = _folder_list($USER->{Username}, undef, 1);
|
||||
|
||||
if ($args->{edit}) {
|
||||
my %set = (my_comment => $args->{my_comment});
|
||||
if ($link->{my_folder_id_fk} != $args->{my_folder_id_fk} and $bl->count({ my_link_id_fk => $link->{my_link_id_fk}, my_folder_id_fk => $args->{my_folder_id_fk}, my_user_username_fk => $USER->{Username} })) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_edit', { error => Links::language('BOOKMARK_LINK_EXISTS', $id), %$folders, %$link, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
if ($DB->table('Bookmark_Folders')->count({ my_folder_id => $args->{my_folder_id_fk}, my_folder_user_username_fk => $USER->{Username} })) {
|
||||
$set{my_folder_id_fk} = $args->{my_folder_id_fk};
|
||||
}
|
||||
my $rec = $bl->update(\%set, { my_id => $id, my_user_username_fk => $USER->{Username} });
|
||||
if ($rec) {
|
||||
$IN->param(my_folder_id_fk => $args->{my_folder_id_fk});
|
||||
$IN->param(id => '');
|
||||
$IN->param(my_comment => '');
|
||||
show_links(Links::language('BOOKMARK_COMMENTS_EDITED'));
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_edit', { error => $GT::SQL::error, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
$link->{my_comment} = $IN->html_escape($link->{my_comment});
|
||||
print Links::SiteHTML::display('bookmark_link_edit', { %$folders, %$link, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub edit_preferences {
|
||||
# -------------------------------------------------------------------
|
||||
# edit Bookmark Preferences
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $username = $USER->{Username} || shift;
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
|
||||
if ($args->{modify}) {
|
||||
if ($args->{PerPage} <= 0) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_preferences', { error => Links::language('BOOKMARK_PREF_INVALIDPERPAGE'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my $rec = $DB->table('Users')->update({
|
||||
SortField => $args->{SortField},
|
||||
SortOrd => $args->{SortOrd},
|
||||
PerPage => $args->{PerPage},
|
||||
Grouping => $args->{Grouping}
|
||||
}, { Username => $username });
|
||||
if ($rec) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_preferences', { %$args, message => Links::language('BOOKMARK_PREFERENCES'), main_title_loop => $mtl });
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_preferences', { error => $GT::SQL::error, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_preferences', { main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub link_add {
|
||||
# -------------------------------------------------------------------
|
||||
# add a link to a folder
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $linkid = $args->{ID} || $args->{my_link_id_fk};
|
||||
my $username = $USER->{Username} || shift;
|
||||
my $bl = $DB->table('Bookmark_Links');
|
||||
my $bf = $DB->table('Bookmark_Folders');
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_BOOKMARK'), "$CFG->{db_cgi_url}/bookmark.cgi");
|
||||
|
||||
# check if they've reached the limit of number of bookmarks
|
||||
if ($bl->count({ my_user_username_fk => $username }) >= $CFG->{bookmark_links_limit}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BOOKMARK_LINK_LIMIT'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
# check to make sure the link exists
|
||||
my $link = $DB->table('Links')->get($linkid);
|
||||
unless ($link) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_add', { error => Links::language('RATE_INVALIDID', $linkid), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
# check if the user has any folder, if not, create one default for them.
|
||||
unless ($DB->table('Bookmark_Folders')->count({ my_folder_user_username_fk => $username })) {
|
||||
my $rc = $bf->insert({
|
||||
my_folder_user_username_fk => $username,
|
||||
my_folder_name => $CFG->{bookmark_folder_default_name},
|
||||
my_folder_default => 1,
|
||||
my_folder_public => 0,
|
||||
});
|
||||
unless ($rc) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => $GT::SQL::error, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
else {
|
||||
$args->{my_folder_id_fk} = $rc->insert_id;
|
||||
}
|
||||
}
|
||||
|
||||
my $folders = _folder_list($username, undef, 1);
|
||||
if ($args->{add}) {
|
||||
my $error;
|
||||
if (!$bf->count({ my_folder_id => $args->{my_folder_id_fk}, my_folder_user_username_fk => $username })) {
|
||||
$error = Links::language('BOOKMARK_FOLDER_INVALID');
|
||||
}
|
||||
# Don't allow duplicate links in a folder
|
||||
elsif ($bl->count({ my_link_id_fk => $linkid, my_folder_id_fk => $args->{my_folder_id_fk}, my_user_username_fk => $username })) {
|
||||
$error = Links::language('BOOKMARK_LINK_EXISTS', $linkid);
|
||||
}
|
||||
|
||||
if ($error) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_add', { error => $error, %$folders, %$link, main_title_loop => $mtl });
|
||||
}
|
||||
else {
|
||||
$args->{my_user_username_fk} = $username;
|
||||
my $rec = $bl->add($args);
|
||||
if ($rec) {
|
||||
folder_view(Links::language('BOOKMARK_LINK_ADDED'));
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => $GT::SQL::error, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('bookmark_link_add', { %$folders, %$link, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub links_manage {
|
||||
# -------------------------------------------------------------------
|
||||
# manage links, such as move or delete
|
||||
#
|
||||
my $folderid = $IN->param('move_folderid');
|
||||
my $old_folderid = $IN->param('my_folder_id');
|
||||
my $username = $USER->{Username};
|
||||
my $db = $DB->table('Bookmark_Links');
|
||||
my ($i, $error, $message) = 0;
|
||||
my @ids = $IN->param('my_id');
|
||||
my @lids = $IN->param('m-id');
|
||||
# <=3.2 template backwards compatibility
|
||||
if (!@ids and @lids) {
|
||||
$db->select_options('GROUP BY my_link_id_fk');
|
||||
@ids = $db->select('my_id', { my_link_id_fk => \@lids, my_folder_id_fk => $old_folderid, my_user_username_fk => $username })->fetchall_list;
|
||||
}
|
||||
if ($IN->param('move')) {
|
||||
if (not $DB->table('Bookmark_Folders')->count({ my_folder_id => $folderid, my_folder_user_username_fk => $username })) {
|
||||
$error .= Links::language('BOOKMARK_FOLDER_NO_MOVE', $folderid);
|
||||
}
|
||||
else {
|
||||
for my $id (@ids) {
|
||||
my $link = $db->select({ my_id => $id, my_user_username_fk => $username })->fetchrow_hashref;
|
||||
if (!$link or $db->count({ my_link_id_fk => $link->{my_link_id_fk}, my_folder_id_fk => $folderid, my_user_username_fk => $username })) {
|
||||
$error .= Links::language('BOOKMARK_LINK_EXISTS', $id);
|
||||
next;
|
||||
}
|
||||
my $rc = $db->update({ my_folder_id_fk => $folderid }, { my_id => $id, my_user_username_fk => $username });
|
||||
unless ($rc) {
|
||||
$error .= $GT::SQL::error;
|
||||
}
|
||||
else {
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
my $folder = $DB->table('Bookmark_Folders')->get($folderid);
|
||||
$message = Links::language('BOOKMARK_LINK_MOVED', $i, $folder->{my_folder_name});
|
||||
}
|
||||
}
|
||||
elsif ($IN->param('remove')) {
|
||||
foreach my $id (@ids) {
|
||||
if ($db->count({ my_id => $id, my_folder_id_fk => $old_folderid, my_user_username_fk => $username })) {
|
||||
my $rc = $db->delete({ my_id => $id, my_folder_id_fk => $old_folderid, my_user_username_fk => $username });
|
||||
unless ($rc) {
|
||||
$error = $GT::SQL::error;
|
||||
}
|
||||
else {
|
||||
$i++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$error .= Links::language('BOOKMARK_LINK_NOTEXISTS', $id);
|
||||
}
|
||||
}
|
||||
$message = Links::language('BOOKMARK_LINK_REMOVED', $i);
|
||||
}
|
||||
else {
|
||||
$error .= Links::language('BOOKMARK_NO_ACTION');
|
||||
}
|
||||
|
||||
if ($error) {
|
||||
return show_links("", $error);
|
||||
}
|
||||
else {
|
||||
return show_links($message);
|
||||
}
|
||||
}
|
||||
|
||||
sub _bookmark_url {
|
||||
# -------------------------------------------------------------------
|
||||
# Generate a bookmark.cgi url (mainly used by paging).
|
||||
#
|
||||
my $url = $CFG->{db_cgi_url} . "/bookmark.cgi";
|
||||
my $in_hash = $IN->get_hash(0);
|
||||
my @url_hidden;
|
||||
foreach (@{$CFG->{dynamic_preserve}}) {
|
||||
next unless defined $in_hash->{$_} and $in_hash->{$_} =~ /\S/;
|
||||
push @url_hidden, $IN->escape($_) . "=" . $IN->escape($in_hash->{$_});
|
||||
}
|
||||
if (@url_hidden) {
|
||||
$url .= "?" . join ';', @url_hidden;
|
||||
}
|
||||
return $url;
|
||||
}
|
||||
|
||||
1;
|
||||
2369
site/slowtwitch.com/cgi-bin/articles/admin/Links/Browser.pm
Normal file
2369
site/slowtwitch.com/cgi-bin/articles/admin/Links/Browser.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,499 @@
|
||||
# ==================================================================
|
||||
# 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: Controller.pm,v 1.9 2009/07/09 23:13:41 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::Browser::Controller;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use vars qw/@ISA $AUTOLOAD $ATTRIBS/;
|
||||
use GT::Base;
|
||||
use Links qw/$CFG $IN $DB/;
|
||||
use Links::Browser;
|
||||
|
||||
@ISA = qw/GT::Base/;
|
||||
$ATTRIBS = {
|
||||
user_base_node => [],
|
||||
load_tree => 0,
|
||||
perms => {},
|
||||
admin => 0,
|
||||
user => {},
|
||||
admin_templates => 0
|
||||
};
|
||||
|
||||
sub can_run {
|
||||
# -------------------------------------------------------------------
|
||||
# Determines whether or not the user can run the requested function.
|
||||
#
|
||||
my $self = shift;
|
||||
my $action = $IN->param ("action") || return "main_panel_init";
|
||||
|
||||
if (exists $Links::Browser::COMPILE{$action}) {
|
||||
if ($self->{admin}) {
|
||||
return $action;
|
||||
}
|
||||
if ($self->$action()) { return $action }
|
||||
else { return }
|
||||
}
|
||||
else { return }
|
||||
return $action;
|
||||
}
|
||||
|
||||
# Everyone can load the browser.
|
||||
sub main_panel_init { return 1 }
|
||||
sub tree_panel_init { return 1 }
|
||||
sub info_panel_init { return 1 }
|
||||
sub code_panel_init { return 1 }
|
||||
sub code_panel_reload_empty { return 1 }
|
||||
sub code_panel_reload_full { return 1 }
|
||||
|
||||
sub category_click {
|
||||
# -------------------------------------------------------------------
|
||||
# Determine whether the user can view a category.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->is_in_subtree ($IN->param ('category_id'));
|
||||
}
|
||||
|
||||
sub code_panel_category_expand {
|
||||
# -------------------------------------------------------------------
|
||||
# Expand a section of the tree.
|
||||
#
|
||||
my $self = shift;
|
||||
return $self->is_in_subtree ($IN->param ('category_id'));
|
||||
}
|
||||
|
||||
sub category_add_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display add form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanAddCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub category_add {
|
||||
# -------------------------------------------------------------------
|
||||
# Determines whether you can actually add a category.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('FatherID')) or return;
|
||||
return ($self->{perms}->{$base}->{CanAddCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub category_del_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display category delete form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanDelCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
sub category_del { return shift->category_del_form (@_); }
|
||||
|
||||
sub category_modify_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display category modify form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub category_modify {
|
||||
# -------------------------------------------------------------------
|
||||
# Determines whether you can actually modify the given category.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('ID')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub category_move_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display category move form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanMoveCat} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub category_move {
|
||||
# -------------------------------------------------------------------
|
||||
# Display category move form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base1 = $self->is_in_subtree ($IN->param ('category_from')) or return;
|
||||
my $base2 = $self->is_in_subtree ($IN->param ('category_to')) or return;
|
||||
$self->{perms}->{$base1}->{CanMoveCat} eq 'Yes' or return;
|
||||
$self->{perms}->{$base2}->{CanMoveCat} eq 'Yes' or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub category_editors_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display category editors form and process edits.
|
||||
#
|
||||
my $self = shift;
|
||||
return if (defined $self->{perms}->{CanAddEdit} and $self->{perms}->{CanAddEdit} eq 'No');
|
||||
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
$self->{perms}->{$base}->{CanAddEdit} eq 'Yes' or return;
|
||||
|
||||
foreach my $key ($IN->param('to_delete')) {
|
||||
my ($name, $id) = split /\|/, $key;
|
||||
$base = $self->is_in_subtree ($id) or return;
|
||||
$self->{perms}->{$base}->{CanAddEdit} eq 'Yes' or return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub category_related_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display related categories form and process relations.
|
||||
#
|
||||
my $self = shift;
|
||||
return if (defined $self->{perms}->{CanAddRel} and $self->{perms}->{CanAddRel} eq 'No');
|
||||
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
$self->{perms}->{$base}->{CanAddRel} eq 'Yes' or return;
|
||||
|
||||
foreach my $id ($IN->param('to_delete')) {
|
||||
$base = $self->is_in_subtree ($id) or return;
|
||||
$self->{perms}->{$base}->{CanAddRel} eq 'Yes' or return;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub link_user_list {
|
||||
# -------------------------------------------------------------------
|
||||
# Display list of links this user owns.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param('category_id')) or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub link_add_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display add link form.
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanAddLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_add {
|
||||
# -------------------------------------------------------------------
|
||||
# Display add link form.
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('CatLinks.CategoryID')) or return;
|
||||
return ($self->{perms}->{$base}->{CanAddLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_modify_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display modify link form.
|
||||
#
|
||||
my $self = shift;
|
||||
|
||||
my $catlinks = $DB->table('CatLinks');
|
||||
my $q = $catlinks->select({ LinkID => $IN->param("link_id") || $IN->param('ID') });
|
||||
my $allowed = 0;
|
||||
while (my $h = $q->fetchrow_hashref) {
|
||||
my $base = $self->is_in_subtree ($h->{CategoryID}) or next;
|
||||
if ($self->{perms}->{$base}->{CanModLink} eq 'Yes') {
|
||||
$allowed = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $allowed;
|
||||
}
|
||||
sub link_modify {
|
||||
# -------------------------------------------------------------------
|
||||
# Display modify link form.
|
||||
#
|
||||
my $self = shift;
|
||||
$self->link_modify_form(@_);
|
||||
}
|
||||
|
||||
sub link_del_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display delete link form.
|
||||
#
|
||||
my $self = shift;
|
||||
return if (defined $self->{perms}->{CanDelLink} and $self->{perms}->{CanDelLink} eq 'No');
|
||||
my $catlinks = $DB->table (qw /CatLinks/);
|
||||
my $q = $catlinks->select ( { LinkID => scalar $IN->param ("link_id") } );
|
||||
my $allowed = 0;
|
||||
while (my $h = $q->fetchrow_hashref) {
|
||||
my $base = $self->is_in_subtree ($h->{CategoryID}) or next;
|
||||
if ($self->{perms}->{$base}->{CanDelLink} eq 'Yes') {
|
||||
$allowed = 1;
|
||||
last;
|
||||
}
|
||||
}
|
||||
return $allowed;
|
||||
}
|
||||
sub link_del { shift->link_del_form (@_); }
|
||||
|
||||
sub link_move_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display form to move link.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanMoveLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_move {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether the link can be moved into the requested category.
|
||||
#
|
||||
my $self = shift;
|
||||
my $old_category_id = $IN->param ("old_category_id");
|
||||
my $new_category_id = $IN->param ("new_category_id");
|
||||
my $base1 = $self->is_in_subtree ($old_category_id) or return;
|
||||
my $base2 = $self->is_in_subtree ($new_category_id) or return;
|
||||
$self->{perms}->{$base1}->{CanMoveLink} eq 'Yes' or return;
|
||||
$self->{perms}->{$base2}->{CanMoveLink} eq 'Yes' or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub link_copy_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display form to copy a link.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanCopyLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_copy {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a link can be moved into requested category.
|
||||
#
|
||||
my $self = shift;
|
||||
my $old_category_id = $IN->param ("old_category_id");
|
||||
my $new_category_id = $IN->param ("new_category_id");
|
||||
my $base1 = $self->is_in_subtree ($old_category_id) or return;
|
||||
my $base2 = $self->is_in_subtree ($new_category_id) or return;
|
||||
$self->{perms}->{$base1}->{CanCopyLink} eq 'Yes' or return;
|
||||
$self->{perms}->{$base2}->{CanCopyLink} eq 'Yes' or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub link_validate_list {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display links awaiting validation.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanValLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_validate_detailed {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display links awaiting validation.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
|
||||
# Let's parse out the form, and group our links together.
|
||||
my $args = $IN->get_hash();
|
||||
my $catlinks_db = $DB->table( 'CatLinks' );
|
||||
my ( @denied, @allowed );
|
||||
while (my ($key, $param) = each %$args) {
|
||||
if ($key =~ /^validate-(\d+)/) {
|
||||
my $id = $1;
|
||||
my $q = $catlinks_db->select ( { LinkID => $id } );
|
||||
my $base;
|
||||
while (my $h = $q->fetchrow_hashref ) {
|
||||
if ( $base = $self->is_in_subtree ($h->{CategoryID})
|
||||
and $self->{perms}->{$base}->{CanValLink} eq 'Yes' ) {
|
||||
push @allowed, $id;
|
||||
next;
|
||||
}
|
||||
push @denied, $id;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Remove action verbs for any listings the user is not allowed to validate
|
||||
for my $id ( @denied ) {
|
||||
$IN->param( "validate-$id", undef );
|
||||
}
|
||||
|
||||
return ($self->{perms}->{$base}->{CanValLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_validate_changes_list {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display links awaiting validation.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanValLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_validate_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display links awaiting validation.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanValLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_validate {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether user can actually validate link.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanValLink} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub review_list {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display reviews awaiting validation.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModReview} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub review_del_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can delete reviews.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModReview} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub review_del {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can delete reviews.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModReview} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub review_modify_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether a user can display the review modify form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModReview} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub review_modify {
|
||||
# -------------------------------------------------------------------
|
||||
# Checks whether user can actually validate reviews.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return ($self->{perms}->{$base}->{CanModReview} eq 'Yes') ? 1 : 0;
|
||||
}
|
||||
|
||||
sub link_search_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display search link form.
|
||||
my $self = shift;
|
||||
if (!$IN->param('category_id')) {
|
||||
my @check_ids;
|
||||
if (ref $self->{ctrl}->user_base_node) {
|
||||
@check_ids = @{$self->{ctrl}->user_base_node};
|
||||
}
|
||||
else {
|
||||
$check_ids[0] = $self->{ctrl}->user_base_node;
|
||||
}
|
||||
$IN->param('category_id',$check_ids[0]);
|
||||
}
|
||||
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub link_search_results {
|
||||
# -------------------------------------------------------------------
|
||||
# Display search link form.
|
||||
my $self = shift;
|
||||
if ($IN->param('in_category')) {
|
||||
return if (!$self->is_in_subtree ($IN->param ('in_category')));
|
||||
}
|
||||
if (!$IN->param('category_id')) {
|
||||
my @check_ids;
|
||||
if (ref $self->user_base_node) {
|
||||
@check_ids = @{$self->user_base_node};
|
||||
}
|
||||
else {
|
||||
$check_ids[0] = $self->user_base_node;
|
||||
}
|
||||
$IN->param('category_id',$check_ids[0]);
|
||||
}
|
||||
|
||||
my $base = $self->is_in_subtree ($IN->param ('category_id')) or return;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub is_in_subtree {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns the category ID of the base node this user is in.
|
||||
#
|
||||
my $self = shift;
|
||||
my $base_r = $self->user_base_node();
|
||||
@$base_r || return 1; # Root can do anything, no base specified.
|
||||
my $node = shift or return; # No node specified!
|
||||
|
||||
my $category = $DB->table (qw /Category/);
|
||||
my $info_node = $category->get ( { ID => $node }, 'HASH', ['ID','Full_Name']);
|
||||
defined $info_node or return; # Invalid node requested.
|
||||
|
||||
# Get closest permissions first.
|
||||
$category->select_options ("ORDER BY Full_Name DESC");
|
||||
my $sth = $category->select ( ['ID', 'Full_Name'], { ID => $base_r });
|
||||
while (my ($id, $name) = $sth->fetchrow_array) {
|
||||
($info_node->{Full_Name} =~ m,^\Q$name\E(?:/|$),) and return $id;
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
sub perms {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a list of permissions the user has for a requested category.
|
||||
#
|
||||
my ($self, $category_id) = @_;
|
||||
if ($self->{admin}) {
|
||||
return { CanAddCat => 'Yes', CanDelCat => 'Yes', CanModCat => 'Yes', CanMoveCat => 'Yes',
|
||||
CanAddLink => 'Yes', CanDelLink => 'Yes', CanModLink => 'Yes', CanMoveLink => 'Yes', CanCopyLink => 'Yes',
|
||||
CanValLink => 'Yes', CanModReview => 'Yes',
|
||||
CanAddRel => 'Yes', CanAddEdit => 'Yes' };
|
||||
}
|
||||
my $base = $self->is_in_subtree($category_id) or return {};
|
||||
if (exists $self->{perms}->{$base}) {
|
||||
return $self->{perms}->{$base};
|
||||
}
|
||||
return {};
|
||||
}
|
||||
|
||||
##
|
||||
# $obj->user_base_node;
|
||||
# ---------------------
|
||||
# Returns an array ref of categories the user can edit.
|
||||
##
|
||||
sub user_base_node { return shift->{user_base_node} || [] }
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,212 @@
|
||||
# ==================================================================
|
||||
# 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: JFunction.pm,v 1.16 2005/03/22 01:42:22 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::Browser::JFunction;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/$CFG $IN $DB/;
|
||||
|
||||
##
|
||||
# Path to image urls.
|
||||
##
|
||||
sub node_expand_button_fake { return $CFG->{build_static_url} . "/browser/expandfake.gif"; }
|
||||
sub node_expand_button_plus { return $CFG->{build_static_url} . "/browser/expandplus.gif"; }
|
||||
sub node_expand_button_less { return $CFG->{build_static_url} . "/browser/expandless.gif"; }
|
||||
sub node_unselected_button { return $CFG->{build_static_url} . "/browser/unselected.gif"; }
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_loadnode;
|
||||
# --------------------
|
||||
# This function must return the URL that the Javascript
|
||||
# must point the user to when an unloaded node has been expanded.
|
||||
##
|
||||
sub tree_loadnode
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_category_expand");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_selectnode;
|
||||
# ----------------------
|
||||
# This function must return the URL that the Javascript
|
||||
# must point the user to when a node is selected, i.e
|
||||
# showing a certain category.
|
||||
##
|
||||
sub tree_selectnode
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "category_click");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_panel_url;
|
||||
# ---------------------
|
||||
# This function returns the URL that should be used
|
||||
# in order to display ...
|
||||
##
|
||||
sub tree_panel_url
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "tree_panel_init");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->info_panel_url;
|
||||
# ---------------------
|
||||
# This function returns the URL that should be used
|
||||
# in order to display ...
|
||||
##
|
||||
sub info_panel_url
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "info_panel_init");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->code_panel_url;
|
||||
# ---------------------
|
||||
# This function returns the URL that should be used
|
||||
# in order to display ...
|
||||
##
|
||||
sub code_panel_url
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_init");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_reload_empty;
|
||||
# ------------------------
|
||||
# This method returns the URL that when called in the code
|
||||
# panel empties the Javascript Tree.
|
||||
##
|
||||
sub tree_reload_empty
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_reload_empty");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_reload_full;
|
||||
# -----------------------
|
||||
# This method returns the URL that when called in the code
|
||||
# panel replaces the Javascript tree with a fully loaded
|
||||
# tree (no need to database for requests).
|
||||
##
|
||||
sub tree_reload_full
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_reload_full");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_refreshnode_url;
|
||||
# ---------------------------
|
||||
# This method should return the URL that has to be invoked
|
||||
# when an user has updated a node and wants to refresh the
|
||||
# node's contents.
|
||||
##
|
||||
sub tree_refreshnode_url
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_init");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->user_add_node;
|
||||
# --------------------
|
||||
# This method should return the URL that must be invoked
|
||||
# by the code frame when an user has added a subcategory
|
||||
# and that the javascript tree needs being refreshed.
|
||||
##
|
||||
sub user_add_node
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "code_panel_category_add");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_movenode;
|
||||
# ---------------------
|
||||
# This method should return the URL that must be invoked
|
||||
# by the code frame when an user has added a subcategory
|
||||
# and that the javascript tree needs being refreshed.
|
||||
##
|
||||
sub tree_movenode
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "category_move");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_movelink;
|
||||
# --------------------
|
||||
##
|
||||
sub movelink
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "link_move");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
|
||||
##
|
||||
# $obj->tree_copylink;
|
||||
# --------------------
|
||||
##
|
||||
sub copylink
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "link_copy");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
##
|
||||
# $obj->category_related_url;
|
||||
# ---------------------
|
||||
# This function returns the URL that should be used
|
||||
# in order to relate categories ...
|
||||
##
|
||||
sub category_related_url
|
||||
{
|
||||
my $cgix = new GT::CGI ($IN);
|
||||
$cgix->param ("action", "category_related_form");
|
||||
return $cgix->url;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
|
||||
1277
site/slowtwitch.com/cgi-bin/articles/admin/Links/Build.pm
Normal file
1277
site/slowtwitch.com/cgi-bin/articles/admin/Links/Build.pm
Normal file
File diff suppressed because it is too large
Load Diff
365
site/slowtwitch.com/cgi-bin/articles/admin/Links/Config.pm
Normal file
365
site/slowtwitch.com/cgi-bin/articles/admin/Links/Config.pm
Normal file
@@ -0,0 +1,365 @@
|
||||
# ==================================================================
|
||||
# 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: Config.pm,v 1.117 2009/05/12 02:24:18 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::Config;
|
||||
# ======================================================================
|
||||
# Sets up our config variables -- the data itself is stored in
|
||||
# Links/Config/Data.pm, but you shouldn't need to edit it directly!
|
||||
#
|
||||
use GT::Config;
|
||||
use strict;
|
||||
use vars qw/@ISA $BIN %FILE_CACHE/;
|
||||
@ISA = 'GT::Config';
|
||||
|
||||
sub new {
|
||||
# --------------------------------------------------------------------
|
||||
# Takes one optional argument, the path to the admin directory.
|
||||
#
|
||||
my $class = ref $_[0] ? ref shift : shift;
|
||||
my $path = shift || '.';
|
||||
my $file = $path . '/Links/Config/Data.pm';
|
||||
my $header = <<END_OF_CONFIG;
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/support/
|
||||
# Updated : [localtime]
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
END_OF_CONFIG
|
||||
|
||||
my $self = $class->load($file, { inheritance => 0, cache => 1, header => $header });
|
||||
exists $self->{admin_root_path} or ($self->{admin_root_path} = $path || '.');
|
||||
exists $self->{version} or ($self->{version} = $Links::VERSION);
|
||||
exists $self->{setup} or ($self->{setup} = 0);
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub textarea {
|
||||
# ------------------------------------------------------------------
|
||||
# Taken from gforum. This takes a string of a config hash key whose value is an array reference.
|
||||
# Returns the array elements separated by \n's
|
||||
#
|
||||
my $want = shift;
|
||||
if (ref $Links::CFG->{$want} eq 'ARRAY') {
|
||||
return join "\n", @{$Links::CFG->{$want}};
|
||||
}
|
||||
elsif (ref $Links::CFG->{$want} eq 'HASH') {
|
||||
return join "\n", map "$_ => $Links::CFG->{$want}->{$_}", sort { $a <=> $b } keys %{$Links::CFG->{$want}};
|
||||
}
|
||||
else {
|
||||
return $Links::CFG->{$want};
|
||||
}
|
||||
}
|
||||
|
||||
sub load_vars {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns a hash of config variables for use in templates.
|
||||
#
|
||||
my $t = {};
|
||||
while (my ($key, $val) = each %{$Links::CFG}) {
|
||||
if (ref $val eq 'ARRAY') { $val = join ", ", @$val }
|
||||
elsif (ref $val eq 'HASH') { $val = join ", ", map "$_ = $val->{$_}", keys %$val }
|
||||
$t->{"cfg_$key"} = $Links::IN->html_escape($val);
|
||||
}
|
||||
return $t;
|
||||
}
|
||||
|
||||
sub set_defaults {
|
||||
# ------------------------------------------------------------------
|
||||
# Set sensible defaults for the config values, overwriting old values.
|
||||
#
|
||||
my ($self, $val) = @_;
|
||||
|
||||
$self->{setup} = 1;
|
||||
$self->default_path($val);
|
||||
$self->default_build($val);
|
||||
$self->default_search($val);
|
||||
$self->default_review($val);
|
||||
$self->default_user($val);
|
||||
$self->default_email($val);
|
||||
$self->default_misc($val);
|
||||
$self->default_date($val);
|
||||
$self->default_other($val);
|
||||
}
|
||||
sub default { shift->set_defaults(1); } # Overwrite
|
||||
sub create_defaults { shift->set_defaults(0); } # Don't Overwrite
|
||||
|
||||
sub set {
|
||||
# ------------------------------------------------------------------
|
||||
# Sets a value.
|
||||
#
|
||||
my ($self, $key, $val, $overwrite) = @_;
|
||||
if ($overwrite or ! exists $self->{$key}) { $self->{$key} = $val; }
|
||||
}
|
||||
|
||||
sub default_path {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the path settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('admin_root_url', _find_admin_url(), $overwrite);
|
||||
$self->set('db_cgi_url', _find_cgi_url(), $overwrite);
|
||||
$self->set('db_cgi_url_https', '', $overwrite);
|
||||
$self->set('build_root_url', _find_pages_url(), $overwrite);
|
||||
$self->set('path_to_perl', _find_perl(), $overwrite);
|
||||
$self->set('build_static_path', "$self->{build_root_path}/static", $overwrite);
|
||||
$self->set('build_static_url', "$self->{build_root_url}/static", $overwrite);
|
||||
$self->set('fileman_root_dir', $self->{admin_root_path}, $overwrite);
|
||||
$self->set('build_images_url', "$self->{build_root_url}/images", $overwrite);
|
||||
$self->set('build_css_url', "$self->{build_root_url}/links.css", $overwrite);
|
||||
$self->set('build_new_path', "$self->{build_root_path}/New", $overwrite);
|
||||
$self->set('build_new_url', "$self->{build_root_url}/New", $overwrite);
|
||||
$self->set('build_cool_path', "$self->{build_root_path}/Cool", $overwrite);
|
||||
$self->set('build_cool_url', "$self->{build_root_url}/Cool", $overwrite);
|
||||
$self->set('build_ratings_path', "$self->{build_root_path}/Ratings", $overwrite);
|
||||
$self->set('build_ratings_url', "$self->{build_root_url}/Ratings", $overwrite);
|
||||
$self->set('build_detail_path', "$self->{build_root_path}/Detailed", $overwrite);
|
||||
$self->set('build_detail_url', "$self->{build_root_url}/Detailed", $overwrite);
|
||||
}
|
||||
|
||||
sub default_build {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the build settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('build_default_tpl', 'luna', $overwrite);
|
||||
$self->set('build_new_cutoff', 7, $overwrite);
|
||||
$self->set('build_pop_cutoff', 0.01, $overwrite);
|
||||
$self->set('build_use_backup', 1, $overwrite);
|
||||
$self->set('db_gen_category_list', 2, $overwrite);
|
||||
$self->set('add_system_fields', { Hits => 0, isNew => 'No', isPopular => 'No', isChanged => 'No', Status => 0, Rating => 0, Votes => 0 }, $overwrite);
|
||||
$self->set('build_auto_validate', 0, $overwrite);
|
||||
$self->set('db_referers', [], $overwrite);
|
||||
$self->set('links_cols_update_category', 'isPopular, Rating, Votes', $overwrite);
|
||||
$self->set('protected_vars', [qw/error message secondarynav Meta_Description Meta_Keywords/], $overwrite);
|
||||
|
||||
$self->set('build_sort_order_category', "isNew DESC,isPopular DESC,Title", $overwrite);
|
||||
$self->set('build_sort_paid_first', 1, $overwrite);
|
||||
$self->set('build_sort_order_new', "Add_Date DESC,Title", $overwrite);
|
||||
$self->set('build_sort_order_cool', "Title", $overwrite);
|
||||
$self->set('build_sort_order_editor', "isValidated DESC, Title ASC", $overwrite);
|
||||
$self->set('build_span_pages', 1, $overwrite);
|
||||
$self->set('build_links_per_page', 25, $overwrite);
|
||||
$self->set('build_new_date_span_pages', 1, $overwrite);
|
||||
$self->set('build_new_gb', 1, $overwrite);
|
||||
$self->set('build_cool_gb', 1, $overwrite);
|
||||
$self->set('build_category_sort', 'Name', $overwrite);
|
||||
$self->set('build_category_yahoo', 1, $overwrite);
|
||||
$self->set('build_category_columns', 2, $overwrite);
|
||||
$self->set('build_category_table', 'border=0 width="100%"', $overwrite);
|
||||
$self->set('dynamic_no_url_transform', ['<%build_static_url%>'], $overwrite);
|
||||
$self->set('dynamic_pages', 1, $overwrite);
|
||||
$self->set('dynamic_preserve', ['t', 'd', 's'], $overwrite);
|
||||
$self->set('dynamic_preserve_sort_pages', ['category', 'detailed'], $overwrite);
|
||||
$self->set('compress', 0, $overwrite);
|
||||
|
||||
$self->set('build_detailed', 0, $overwrite);
|
||||
$self->set('build_home', '', $overwrite);
|
||||
$self->set('build_index', 'index.html', $overwrite);
|
||||
$self->set('build_index_include', 1, $overwrite);
|
||||
$self->set('build_more', 'more', $overwrite);
|
||||
$self->set('build_extension', '.html', $overwrite);
|
||||
$self->set('build_detail_format', '%ID%', $overwrite);
|
||||
$self->set('build_category_format', '%Full_Name%', $overwrite);
|
||||
$self->set('build_format_compat', 0, $overwrite);
|
||||
$self->set('build_category_dynamic', 'Full_Name', $overwrite);
|
||||
$self->set('build_dir_per', '0777', $overwrite);
|
||||
$self->set('build_file_per', '0666', $overwrite);
|
||||
}
|
||||
|
||||
sub default_user {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the user settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('user_validation', 1, $overwrite);
|
||||
$self->set('user_required', 1, $overwrite);
|
||||
$self->set('user_rate_required', 1, $overwrite);
|
||||
$self->set('user_direct_mod', 0, $overwrite);
|
||||
$self->set('user_allow_pass', 1, $overwrite);
|
||||
$self->set('user_sessions', 'Cookies', $overwrite);
|
||||
$self->set('user_session_length', 3, $overwrite);
|
||||
|
||||
$self->set('framed_jump', 0, $overwrite);
|
||||
|
||||
$self->set('bookmark_enabled', 1, $overwrite);
|
||||
$self->set('bookmark_folder_default_name', 'Default', $overwrite);
|
||||
$self->set('bookmark_folder_limit', 5, $overwrite);
|
||||
$self->set('bookmark_folders_per_page', 10, $overwrite);
|
||||
$self->set('bookmark_links_limit', 25, $overwrite);
|
||||
$self->set('bookmark_links_per_page', 25, $overwrite);
|
||||
$self->set('bookmark_links_sort', 'Title', $overwrite);
|
||||
$self->set('bookmark_links_sort_order', 'ASC', $overwrite);
|
||||
$self->set('bookmark_users_per_page', 25, $overwrite);
|
||||
|
||||
$self->set('newsletter_enabled', 0, $overwrite);
|
||||
$self->set('newsletter_global_subscribe', 0, $overwrite);
|
||||
$self->set('newsletter_max_depth', 2, $overwrite);
|
||||
}
|
||||
|
||||
sub default_email {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the email settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('db_admin_email', '', $overwrite);
|
||||
$self->set('db_smtp_server', '', $overwrite);
|
||||
$self->set('db_mail_path', _find_sendmail(), $overwrite);
|
||||
$self->set('email_add', 1, $overwrite);
|
||||
$self->set('email_mod', 1, $overwrite);
|
||||
$self->set('email_review_add', 1, $overwrite);
|
||||
$self->set('email_payment', 1, $overwrite);
|
||||
$self->set('admin_email_add', 1, $overwrite);
|
||||
$self->set('admin_email_mod', 1, $overwrite);
|
||||
$self->set('admin_email_review_add', 1, $overwrite);
|
||||
$self->set('admin_email_review_mod', 1, $overwrite);
|
||||
}
|
||||
|
||||
sub default_date {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the default settings for any date routines.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('date_db_format', '%yyyy%-%mm%-%dd%', $overwrite);
|
||||
$self->set('date_review_format', '%mmm% %d% %yyyy% %h%:%MM%%tt%', $overwrite);
|
||||
$self->set('date_user_format', '%ddd% %mmm% %dd% %yyyy%', $overwrite);
|
||||
$self->set('date_long_format', '%dddd%, %mmmm% %dd% %yyyy%', $overwrite);
|
||||
$self->set('date_expiry_format', '%dddd% %mmm% %d% %yyyy% %h%:%MM% %tt%', $overwrite);
|
||||
$self->set('date_offset', 0, $overwrite);
|
||||
$self->set('date_days_short', [qw/Sun Mon Tue Wed Thu Fri Sat/], $overwrite);
|
||||
$self->set('date_days_long', [qw/Sunday Monday Tuesday Wednesday Thursday Friday Saturday/], $overwrite);
|
||||
$self->set('date_month_short', [qw/Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec/], $overwrite);
|
||||
$self->set('date_month_long', [qw/January February March April May June July August September October November December/], $overwrite);
|
||||
}
|
||||
|
||||
sub default_search {
|
||||
# ------------------------------------------------------------------
|
||||
# Update the search settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('search_maxhits', 25, $overwrite);
|
||||
$self->set('search_bool', 'AND', $overwrite);
|
||||
$self->set('search_substring', 0, $overwrite);
|
||||
$self->set('build_sort_order_search', "score", $overwrite);
|
||||
$self->set('build_sort_order_search_cat', "score", $overwrite);
|
||||
$self->set('build_search_gb', 1, $overwrite);
|
||||
$self->set('search_blocked', [], $overwrite);
|
||||
$self->set('search_highlighting', 1, $overwrite);
|
||||
$self->set('search_highlight_colors', 5, $overwrite);
|
||||
}
|
||||
|
||||
sub default_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Update the review settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('user_review_required', 1, $overwrite);
|
||||
$self->set('review_auto_validate', 0, $overwrite);
|
||||
$self->set('review_allow_modify', 1, $overwrite);
|
||||
$self->set('review_modify_timeout', 0, $overwrite);
|
||||
$self->set('review_max_reviews', 1, $overwrite);
|
||||
$self->set('reviews_per_page', 5, $overwrite);
|
||||
$self->set('review_sort_by', 'Review_Date', $overwrite);
|
||||
$self->set('review_sort_order', 'desc', $overwrite);
|
||||
$self->set('review_convert_br_tags', 1, $overwrite);
|
||||
$self->set('review_days_old', 7, $overwrite);
|
||||
}
|
||||
|
||||
|
||||
sub default_misc {
|
||||
# ------------------------------------------------------------------
|
||||
# Set the misc settings to default values.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('reg_number', '', $overwrite);
|
||||
$self->set('nph_headers', 1, $overwrite);
|
||||
$self->set('header_charset', 'ISO-8859-1', $overwrite);
|
||||
$self->set('debug_level', 0, $overwrite);
|
||||
$self->set('error_message', '', $overwrite);
|
||||
$self->set('disabled', 0, $overwrite);
|
||||
$self->set('bans', [], $overwrite);
|
||||
$self->set('link_validate_date', 1, $overwrite);
|
||||
}
|
||||
|
||||
sub default_other {
|
||||
# ------------------------------------------------------------------
|
||||
# Update settings not available throught the web.
|
||||
#
|
||||
my ($self, $overwrite) = @_;
|
||||
$self->set('private_sessions', 1, $overwrite);
|
||||
$self->set('db_hit_expire', 2, $overwrite);
|
||||
$self->set('db_rate_expire', 2, $overwrite);
|
||||
$self->set('quick_links', {
|
||||
'admin.cgi?do=page&page=tools_validate.html' => 'Validate Links',
|
||||
'admin.cgi?do=page&page=tools_validate_changes.html' => 'Validate Changes',
|
||||
'admin.cgi?do=page&page=tools_validate_reviews.html' => 'Validate Reviews'
|
||||
}, $overwrite);
|
||||
}
|
||||
|
||||
sub _find_admin_url {
|
||||
# ------------------------------------------------------------------
|
||||
# Return base url of current script.
|
||||
#
|
||||
my $url = GT::CGI->url({ absolute => 1, query_string => 0 });
|
||||
$url =~ s,/[^/]*$,,;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_cgi_url {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns base url of one level back.
|
||||
#
|
||||
my $url = _find_admin_url();
|
||||
$url =~ s,/admin$,,;
|
||||
return $url;
|
||||
}
|
||||
|
||||
sub _find_pages_url {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns pages url.
|
||||
#
|
||||
return _find_cgi_url();
|
||||
}
|
||||
|
||||
sub _find_perl {
|
||||
# ------------------------------------------------------------------
|
||||
# Returns path to perl.
|
||||
#
|
||||
my @poss_perls = qw!
|
||||
/usr/local/bin/perl /usr/bin/perl /bin/perl
|
||||
/usr/local/bin/perl5 /usr/bin/perl5 /bin/perl
|
||||
/perl/bin/perl.exe c:/perl/bin/perl.exe d:/perl/bin/perl.exe
|
||||
!;
|
||||
foreach my $perl_path (@poss_perls) {
|
||||
return $perl_path if -f $perl_path and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
sub _find_sendmail {
|
||||
# ------------------------------------------------------------------
|
||||
# Looks for sendmail.
|
||||
#
|
||||
for my $sendmail (qw|/usr/sbin/sendmail /usr/lib/sendmail /usr/bin/sendmail /bin/sendmail|) {
|
||||
return $sendmail if -f $sendmail and -x _;
|
||||
}
|
||||
return '';
|
||||
}
|
||||
|
||||
1;
|
||||
356
site/slowtwitch.com/cgi-bin/articles/admin/Links/Config/Data.pm
Normal file
356
site/slowtwitch.com/cgi-bin/articles/admin/Links/Config/Data.pm
Normal file
@@ -0,0 +1,356 @@
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/support/
|
||||
# Updated : Sun May 19 21:05:55 2024
|
||||
#
|
||||
# Copyright (c) 2004 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
{
|
||||
'add_system_fields' => {
|
||||
'Hits' => '0',
|
||||
'Rating' => '0',
|
||||
'SlideShowCache' => '{}',
|
||||
'Status' => '0',
|
||||
'Votes' => '0',
|
||||
'isChanged' => 'No',
|
||||
'isNew' => 'No',
|
||||
'isPopular' => 'No'
|
||||
},
|
||||
'admin_email_add' => '1',
|
||||
'admin_email_mod' => '1',
|
||||
'admin_email_review_add' => '1',
|
||||
'admin_email_review_mod' => '1',
|
||||
'admin_root_path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'admin_root_url' => '/cgi-bin/articles/admin',
|
||||
'bans' => [],
|
||||
'bookmark_enabled' => '0',
|
||||
'bookmark_folder_default_name' => 'Default',
|
||||
'bookmark_folder_limit' => '5',
|
||||
'bookmark_folders_per_page' => '25',
|
||||
'bookmark_links_limit' => '100',
|
||||
'bookmark_links_per_page' => '25',
|
||||
'bookmark_links_sort' => 'Title',
|
||||
'bookmark_links_sort_order' => 'ASC',
|
||||
'bookmark_users_per_page' => '25',
|
||||
'build_auto_validate' => '1',
|
||||
'build_category_columns' => '2',
|
||||
'build_category_dynamic' => 'Full_Name',
|
||||
'build_category_format' => '%Full_Name%',
|
||||
'build_category_sort' => 'Name',
|
||||
'build_category_table' => 'border=0 width="100%"',
|
||||
'build_category_yahoo' => '1',
|
||||
'build_cool_gb' => '1',
|
||||
'build_cool_path' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'build_cool_url' => '/Cool',
|
||||
'build_css_url' => '/articles/static/css/links.css',
|
||||
'build_default_tpl' => 'twitch',
|
||||
'build_detail_format' => '%Full_Name%/%Title%_%ID%',
|
||||
'build_detail_path' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'build_detail_url' => 'https://www.slowtwitch.com',
|
||||
'build_detailed' => '1',
|
||||
'build_dir_per' => '0777',
|
||||
'build_extension' => '.html',
|
||||
'build_file_per' => '0666',
|
||||
'build_format_compat' => '2',
|
||||
'build_home' => '',
|
||||
'build_images_url' => '/images',
|
||||
'build_index' => 'index.html',
|
||||
'build_index_include' => '1',
|
||||
'build_links_per_page' => '25',
|
||||
'build_more' => 'more',
|
||||
'build_new_cutoff' => '7',
|
||||
'build_new_date_span_pages' => '1',
|
||||
'build_new_gb' => '1',
|
||||
'build_new_path' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'build_new_url' => '/New',
|
||||
'build_pop_cutoff' => '0.01',
|
||||
'build_ratings_path' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'build_ratings_url' => '/Ratings',
|
||||
'build_root_path' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'build_root_url' => 'https://www.slowtwitch.com',
|
||||
'build_search_gb' => '0',
|
||||
'build_sort_order_category' => 'Mod_Date DESC, Add_Date DESC,Title ASC',
|
||||
'build_sort_order_cool' => 'Title',
|
||||
'build_sort_order_editor' => 'isValidated DESC, Title ASC',
|
||||
'build_sort_order_new' => 'Add_Date DESC,Title',
|
||||
'build_sort_order_search' => 'Mod_Date DESC',
|
||||
'build_sort_order_search_cat' => 'score',
|
||||
'build_sort_paid_first' => '1',
|
||||
'build_span_pages' => '1',
|
||||
'build_static_path' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static',
|
||||
'build_static_url' => '/articles/static',
|
||||
'build_use_backup' => '0',
|
||||
'compress' => '1',
|
||||
'date_days_long' => [
|
||||
'Sunday',
|
||||
'Monday',
|
||||
'Tuesday',
|
||||
'Wednesday',
|
||||
'Thursday',
|
||||
'Friday',
|
||||
'Saturday'
|
||||
],
|
||||
'date_days_short' => [
|
||||
'Sun',
|
||||
'Mon',
|
||||
'Tue',
|
||||
'Wed',
|
||||
'Thu',
|
||||
'Fri',
|
||||
'Sat'
|
||||
],
|
||||
'date_db_format' => '%yyyy%-%mm%-%dd%',
|
||||
'date_expiry_format' => '%dddd% %mmm% %d% %yyyy% %h%:%MM% %tt%',
|
||||
'date_long_format' => '%dddd%, %mmmm% %dd% %yyyy%',
|
||||
'date_month_long' => [
|
||||
'January',
|
||||
'February',
|
||||
'March',
|
||||
'April',
|
||||
'May',
|
||||
'June',
|
||||
'July',
|
||||
'August',
|
||||
'September',
|
||||
'October',
|
||||
'November',
|
||||
'December'
|
||||
],
|
||||
'date_month_short' => [
|
||||
'Jan',
|
||||
'Feb',
|
||||
'Mar',
|
||||
'Apr',
|
||||
'May',
|
||||
'Jun',
|
||||
'Jul',
|
||||
'Aug',
|
||||
'Sep',
|
||||
'Oct',
|
||||
'Nov',
|
||||
'Dec'
|
||||
],
|
||||
'date_offset' => '0',
|
||||
'date_review_format' => '%mmm% %d% %yyyy% %h%:%MM%%tt%',
|
||||
'date_user_format' => '%ddd% %mmm% %dd% %yyyy%',
|
||||
'db_admin_email' => 'webmaster@slowtwitch.com',
|
||||
'db_cgi_url' => '/cgi-bin/articles',
|
||||
'db_cgi_url_https' => '/cgi-bin/articles',
|
||||
'db_gen_category_list' => '2',
|
||||
'db_hit_expire' => '2',
|
||||
'db_mail_path' => '/usr/sbin/sendmail',
|
||||
'db_rate_expire' => '2',
|
||||
'db_referers' => [],
|
||||
'db_smtp_server' => '',
|
||||
'debug_level' => '0',
|
||||
'disabled' => '0',
|
||||
'dynamic_404_status' => '0',
|
||||
'dynamic_no_url_transform' => [
|
||||
'<%build_static_url%>'
|
||||
],
|
||||
'dynamic_pages' => '1',
|
||||
'dynamic_preserve' => [
|
||||
't',
|
||||
'd',
|
||||
's'
|
||||
],
|
||||
'dynamic_preserve_sort_pages' => [
|
||||
'category',
|
||||
'detailed'
|
||||
],
|
||||
'email_add' => '1',
|
||||
'email_mod' => '1',
|
||||
'email_payment' => '1',
|
||||
'email_review_add' => '1',
|
||||
'error_message' => '',
|
||||
'featured_articles' => [
|
||||
'8954',
|
||||
'8953',
|
||||
'8951',
|
||||
'8950'
|
||||
],
|
||||
'featured_photos' => [
|
||||
'8823',
|
||||
'8822'
|
||||
],
|
||||
'fileman_root_dir' => '/var/home/slowtwitch/slowtwitch.com',
|
||||
'framed_jump' => '0',
|
||||
'header_charset' => 'utf-8',
|
||||
'last_build' => '1598637754.56255',
|
||||
'last_clicktrack_cleanup' => '2024-05-17',
|
||||
'link_validate_date' => '1',
|
||||
'links_cols_update_category' => 'isPopular, Rating, Votes',
|
||||
'newsletter_enabled' => '0',
|
||||
'newsletter_global_subscribe' => '0',
|
||||
'newsletter_max_depth' => '2',
|
||||
'nph_headers' => '1',
|
||||
'path_to_perl' => '/usr/local/bin/perl',
|
||||
'payment' => {
|
||||
'auto_validate' => '1',
|
||||
'description' => '',
|
||||
'direct' => {
|
||||
'methods' => {
|
||||
'AuthorizeDotNet' => {
|
||||
'module' => 'Links/Payment/Direct/AuthorizeDotNet.pm',
|
||||
'package' => 'Links::Payment::Direct::AuthorizeDotNet',
|
||||
'types' => [
|
||||
'AMEX',
|
||||
'DINERS',
|
||||
'DISC',
|
||||
'JCB',
|
||||
'MC',
|
||||
'VISA'
|
||||
]
|
||||
},
|
||||
'Moneris' => {
|
||||
'module' => 'Links/Payment/Direct/Moneris.pm',
|
||||
'package' => 'Links::Payment::Direct::Moneris',
|
||||
'types' => [
|
||||
'AMEX',
|
||||
'MC',
|
||||
'VISA',
|
||||
'DISC',
|
||||
'NOVA',
|
||||
'DINERS'
|
||||
]
|
||||
}
|
||||
},
|
||||
'used' => {}
|
||||
},
|
||||
'discounts' => {},
|
||||
'enabled' => '0',
|
||||
'expired_is_free' => '0',
|
||||
'expiry_notify' => '7',
|
||||
'mode' => '3',
|
||||
'postback' => [
|
||||
{
|
||||
'method' => 'PayPal',
|
||||
'type' => 'remote',
|
||||
'var' => 'txn_type'
|
||||
},
|
||||
{
|
||||
'method' => 'WorldPay',
|
||||
'type' => 'remote',
|
||||
'var' => 'transStatus'
|
||||
},
|
||||
{
|
||||
'method' => '2CheckOut',
|
||||
'type' => 'remote',
|
||||
'var' => 'cart_order_id'
|
||||
}
|
||||
],
|
||||
'remote' => {
|
||||
'methods' => {
|
||||
'2CheckOut' => {
|
||||
'module' => 'Links/Payment/Remote/2CheckOut.pm',
|
||||
'package' => 'Links::Payment::Remote::2CheckOut',
|
||||
'recurring' => '0',
|
||||
'types' => [
|
||||
'VISA',
|
||||
'MC',
|
||||
'AMEX',
|
||||
'DISC',
|
||||
'DINERS',
|
||||
'JCB'
|
||||
]
|
||||
},
|
||||
'Manual' => {
|
||||
'module' => 'Links/Payment/Remote/Manual.pm',
|
||||
'package' => 'Links::Payment::Remote::Manual',
|
||||
'recurring' => '0',
|
||||
'types' => [
|
||||
'MANUAL'
|
||||
]
|
||||
},
|
||||
'PayPal' => {
|
||||
'module' => 'Links/Payment/Remote/PayPal.pm',
|
||||
'package' => 'Links::Payment::Remote::PayPal',
|
||||
'recurring' => '1',
|
||||
'types' => [
|
||||
'PAYPAL'
|
||||
]
|
||||
},
|
||||
'WorldPay' => {
|
||||
'module' => 'Links/Payment/Remote/WorldPay.pm',
|
||||
'package' => 'Links::Payment::Remote::WorldPay',
|
||||
'recurring' => '1',
|
||||
'types' => [
|
||||
'VISA',
|
||||
'MC',
|
||||
'EURO',
|
||||
'VISA_DEBIT',
|
||||
'SWITCH',
|
||||
'SOLO',
|
||||
'DELTA',
|
||||
'JCB',
|
||||
'AMEX',
|
||||
'DINERS'
|
||||
]
|
||||
}
|
||||
},
|
||||
'used' => {}
|
||||
},
|
||||
'term' => {}
|
||||
},
|
||||
'private_sessions' => '1',
|
||||
'protected_vars' => [
|
||||
'error',
|
||||
'message',
|
||||
'secondarynav',
|
||||
'Meta_Description',
|
||||
'Meta_Keywords'
|
||||
],
|
||||
'quick_links' => {
|
||||
'admin.cgi?do=page&page=tools_validate.html' => 'Validate Links',
|
||||
'admin.cgi?do=page&page=tools_validate_changes.html' => 'Validate Changes',
|
||||
'admin.cgi?do=page&page=tools_validate_reviews.html' => 'Validate Reviews',
|
||||
'https://forum.slowtwitch.com/admin/delete_spam_comments.php' => 'Delete Spam',
|
||||
'https://www.slowtwitch.com/cgi-bin/articles/admin/cullGlist.php' => 'Cull gList',
|
||||
'https://www.slowtwitch.com/cgi-bin/articles/admin/nph-build.cgi?do=all' => 'Build All',
|
||||
'https://www.slowtwitch.com/cgi-bin/articles/admin/nph-build.cgi?do=changed' => 'Build Changed',
|
||||
'https://www.slowtwitch.com/myadminphp/index.php?token=b521b01fa6ed8c9f890b24b148ac74cb' => 'PHPMyAdmin'
|
||||
},
|
||||
'reg_number' => 'GL0807-06828-37',
|
||||
'review_allow_modify' => '1',
|
||||
'review_auto_validate' => '0',
|
||||
'review_convert_br_tags' => '1',
|
||||
'review_days_old' => '7',
|
||||
'review_max_reviews' => '1',
|
||||
'review_modify_timeout' => '0',
|
||||
'review_sort_by' => 'Review_Date',
|
||||
'review_sort_order' => 'desc',
|
||||
'reviews_per_page' => '25',
|
||||
'search_blocked' => [],
|
||||
'search_bool' => 'AND',
|
||||
'search_highlight_colors' => '5',
|
||||
'search_highlighting' => '1',
|
||||
'search_logging' => '0',
|
||||
'search_maxhits' => '25',
|
||||
'search_substring' => '0',
|
||||
'setup' => '1',
|
||||
'show_upgrade_rerun' => '0',
|
||||
'treecats_enabled' => '0',
|
||||
'updates' => {},
|
||||
'updates_check_on_home' => '1',
|
||||
'user_allow_pass' => '1',
|
||||
'user_cookie_domain' => '',
|
||||
'user_cookie_prefix' => '',
|
||||
'user_direct_mod' => '1',
|
||||
'user_link_validation' => '0',
|
||||
'user_rate_required' => '1',
|
||||
'user_required' => '1',
|
||||
'user_review_required' => '1',
|
||||
'user_session_length' => '3',
|
||||
'user_sessions' => 'Cookies',
|
||||
'user_validation' => '1',
|
||||
'verify_chunk' => '10',
|
||||
'verify_max_children' => '3',
|
||||
'version' => '3.3.0'
|
||||
};
|
||||
|
||||
# vim:syn=perl:ts=4:noet
|
||||
@@ -0,0 +1,701 @@
|
||||
{
|
||||
'cache' => {
|
||||
'time' => '1672499734',
|
||||
'updates' => [
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug in GT::WWW where it would cause link verify to fail with a -4 (Could not connect) error.',
|
||||
'files' => [
|
||||
[
|
||||
'186',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/WWW.pm'
|
||||
]
|
||||
],
|
||||
'id' => '132',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '2',
|
||||
'title' => 'GT::WWW unresolvable host error fix',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes an error where editors using browser.cgi get an error, "You are not authorized to perform this action," when attempting to modify a link that they should be able to modify.',
|
||||
'files' => [
|
||||
[
|
||||
'187',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'Links/Browser/Controller.pm'
|
||||
]
|
||||
],
|
||||
'id' => '133',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Editor browser error on link modify',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes "ColumnName cannot contain the value \'\'" error when attempting to modify a link with an INT column (null = yes, no default).',
|
||||
'files' => [
|
||||
[
|
||||
'188',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'Links/User/Modify.pm'
|
||||
]
|
||||
],
|
||||
'id' => '134',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'INT validation error on modify',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes two bugs in the category browser: 1) Error deleting a link on the user side category browser (ie. not the admin one) from search results when the category depth is greater than 1. 2) When the link_validate_date option was turned on, Add_Date was getting set to the current date on modify.',
|
||||
'files' => [
|
||||
[
|
||||
'189',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'Links/Browser.pm'
|
||||
]
|
||||
],
|
||||
'id' => '135',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [
|
||||
'140'
|
||||
],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Category Browser fixes',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug in the payment code where the name and e-mail address of the user aren\'t correctly passed to the link_expired.eml and link_expiry_notify.eml e-mail templates.',
|
||||
'files' => [
|
||||
[
|
||||
'190',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'Links/Payment.pm'
|
||||
]
|
||||
],
|
||||
'id' => '136',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Broken payment link expiry e-mails',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes the "defined(%hash) is deprecated" warnings that occur when using Gossamer Links with Perl 5.12 and higher.',
|
||||
'files' => [
|
||||
[
|
||||
'191',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'bases.pm'
|
||||
],
|
||||
[
|
||||
'192',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/MIMETypes.pm'
|
||||
],
|
||||
[
|
||||
'194',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/SQL/Base.pm'
|
||||
],
|
||||
[
|
||||
'193',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/Template.pm'
|
||||
]
|
||||
],
|
||||
'id' => '137',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => '"defined(%hash) is deprecated" warning',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes an issue with the template parser if there were extra spaces after the "and" in an "if" condition.',
|
||||
'files' => [
|
||||
[
|
||||
'195',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/Template/Parser.pm'
|
||||
]
|
||||
],
|
||||
'id' => '138',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Template parser syntax error',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug where some files (eg. ones with parenthesis in them) uploaded to FILE columns would trigger an ILLEGALCHARS error.',
|
||||
'files' => [
|
||||
[
|
||||
'196',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'GT/SQL/File.pm'
|
||||
]
|
||||
],
|
||||
'id' => '139',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Filename errors with uploaded files',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
),
|
||||
bless(
|
||||
{
|
||||
'deps' => [
|
||||
'135'
|
||||
],
|
||||
'description' => 'This update fixes a bug in the last category browser update where deleting a link that\'s in multiple categories deletes the link from all categories.',
|
||||
'files' => [
|
||||
[
|
||||
'197',
|
||||
'library',
|
||||
'',
|
||||
'0644',
|
||||
'Links/Browser.pm'
|
||||
]
|
||||
],
|
||||
'id' => '140',
|
||||
'installed' => '1',
|
||||
'paths' => {
|
||||
'fixed' => {
|
||||
'build' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'cool' => '/var/home/slowtwitch/slowtwitch.com/www/Cool',
|
||||
'detail' => '/var/home/slowtwitch/slowtwitch.com/www',
|
||||
'new' => '/var/home/slowtwitch/slowtwitch.com/www/New',
|
||||
'ratings' => '/var/home/slowtwitch/slowtwitch.com/www/Ratings',
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'library' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
},
|
||||
'script' => {
|
||||
'admin' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin',
|
||||
'cgi' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles'
|
||||
},
|
||||
'static' => {
|
||||
'static' => '/var/home/slowtwitch/slowtwitch.com/www/articles/static'
|
||||
},
|
||||
'template' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/templates'
|
||||
},
|
||||
'version' => {
|
||||
'' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin'
|
||||
}
|
||||
},
|
||||
'revdeps' => [],
|
||||
'reversible' => '1',
|
||||
'severity' => '2',
|
||||
'title' => 'Category Browser fixes fix',
|
||||
'unique' => '0'
|
||||
},
|
||||
'GT::Update::Update'
|
||||
)
|
||||
],
|
||||
'version' => '1.1'
|
||||
},
|
||||
'installed' => {
|
||||
'3.3.0' => {
|
||||
'132' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug in GT::WWW where it would cause link verify to fail with a -4 (Could not connect) error.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/132-1254088697-library--GT-WWW.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/WWW.pm',
|
||||
'id' => '186',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/WWW.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1254088697',
|
||||
'reversible' => '1',
|
||||
'severity' => '2',
|
||||
'title' => 'GT::WWW unresolvable host error fix',
|
||||
'unique' => '0'
|
||||
},
|
||||
'133' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes an error where editors using browser.cgi get an error, "You are not authorized to perform this action," when attempting to modify a link that they should be able to modify.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/133-1254088697-library--Links-Browser-Controller.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'Links/Browser/Controller.pm',
|
||||
'id' => '187',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/Links/Browser/Controller.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1254088697',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Editor browser error on link modify',
|
||||
'unique' => '0'
|
||||
},
|
||||
'134' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes "ColumnName cannot contain the value \'\'" error when attempting to modify a link with an INT column (null = yes, no default).',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/134-1362433281-library--Links-User-Modify.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'Links/User/Modify.pm',
|
||||
'id' => '188',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'INT validation error on modify',
|
||||
'unique' => '0'
|
||||
},
|
||||
'135' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes two bugs in the category browser: 1) Error deleting a link on the user side category browser (ie. not the admin one) from search results when the category depth is greater than 1. 2) When the link_validate_date option was turned on, Add_Date was getting set to the current date on modify.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/135-1362433281-library--Links-Browser.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'Links/Browser.pm',
|
||||
'id' => '189',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/Links/Browser.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Category Browser fixes',
|
||||
'unique' => '0'
|
||||
},
|
||||
'136' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug in the payment code where the name and e-mail address of the user aren\'t correctly passed to the link_expired.eml and link_expiry_notify.eml e-mail templates.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/136-1362433281-library--Links-Payment.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'Links/Payment.pm',
|
||||
'id' => '190',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Broken payment link expiry e-mails',
|
||||
'unique' => '0'
|
||||
},
|
||||
'137' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes the "defined(%hash) is deprecated" warnings that occur when using Gossamer Links with Perl 5.12 and higher.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/137-1362433281-library--bases.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'bases.pm',
|
||||
'id' => '191',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/bases.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
},
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/137-1362433281-library--GT-MIMETypes.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/MIMETypes.pm',
|
||||
'id' => '192',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/MIMETypes.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
},
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/137-1362433281-library--GT-SQL-Base.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/SQL/Base.pm',
|
||||
'id' => '194',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/Base.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
},
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/137-1362433281-library--GT-Template.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/Template.pm',
|
||||
'id' => '193',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/Template.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => '"defined(%hash) is deprecated" warning',
|
||||
'unique' => '0'
|
||||
},
|
||||
'138' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes an issue with the template parser if there were extra spaces after the "and" in an "if" condition.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/138-1362433281-library--GT-Template-Parser.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/Template/Parser.pm',
|
||||
'id' => '195',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/Template/Parser.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Template parser syntax error',
|
||||
'unique' => '0'
|
||||
},
|
||||
'139' => {
|
||||
'deps' => [],
|
||||
'description' => 'This update fixes a bug where some files (eg. ones with parenthesis in them) uploaded to FILE columns would trigger an ILLEGALCHARS error.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/139-1362433281-library--GT-SQL-File.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'GT/SQL/File.pm',
|
||||
'id' => '196',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/GT/SQL/File.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '1',
|
||||
'title' => 'Filename errors with uploaded files',
|
||||
'unique' => '0'
|
||||
},
|
||||
'140' => {
|
||||
'deps' => [
|
||||
'135'
|
||||
],
|
||||
'description' => 'This update fixes a bug in the last category browser update where deleting a link that\'s in multiple categories deletes the link from all categories.',
|
||||
'files' => [
|
||||
{
|
||||
'backup' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/updates/140-1362433281-library--Links-Browser.pm.backup',
|
||||
'dir' => '',
|
||||
'file' => 'Links/Browser.pm',
|
||||
'id' => '197',
|
||||
'mode' => '0644',
|
||||
'path' => '/var/home/slowtwitch/slowtwitch.com/cgi-bin/articles/admin/Links/Browser.pm',
|
||||
'subtype' => '',
|
||||
'type' => 'library'
|
||||
}
|
||||
],
|
||||
'installed' => '1362433281',
|
||||
'reversible' => '1',
|
||||
'severity' => '2',
|
||||
'title' => 'Category Browser fixes fix',
|
||||
'unique' => '0'
|
||||
}
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
# vim:syn=perl:ts=4:noet
|
||||
30
site/slowtwitch.com/cgi-bin/articles/admin/Links/Custom.pm
Normal file
30
site/slowtwitch.com/cgi-bin/articles/admin/Links/Custom.pm
Normal file
@@ -0,0 +1,30 @@
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# CVS Info : 087,068,085,094,083
|
||||
# Revision : $Id: Custom.pm,v 1.3 2005/03/05 01:29:09 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.
|
||||
# ==================================================================
|
||||
#
|
||||
# Description:
|
||||
# By default, this file is empty, however it is here to allow installations
|
||||
# to perform special operations required to make Gossamer Links load.
|
||||
# For example, some installations might need a 'use lib' line to work
|
||||
# properly.
|
||||
#
|
||||
# This file will NOT be overwritten when upgrading your installation, so you
|
||||
# do not need to worry about additions made here being overwritten. This is
|
||||
# generally loaded after Links.pm has started loading, but before any other
|
||||
# modules are loaded.
|
||||
#
|
||||
package Links::Custom;
|
||||
|
||||
|
||||
|
||||
|
||||
1; # This must remain at the bottom of the file.
|
||||
@@ -0,0 +1,170 @@
|
||||
# ==================================================================
|
||||
# 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.14 2007/09/25 06:19:32 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::HTML::Category;
|
||||
# ==================================================================
|
||||
# Handles displaying of forms and HTML.
|
||||
#
|
||||
use strict;
|
||||
use vars qw/@ISA/;
|
||||
use Links qw/:payment :objects/;
|
||||
use GT::SQL::Display::HTML::Table;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML::Table/;
|
||||
|
||||
my $FORM_HIDE = 'add_form|modify_form|modify_multi_search_results|modify_multi_result_changed|modify_multi_results_err';
|
||||
my $FORM_HIDE_FIELDS = [qw/Full_Name Number_of_Links Direct_Links Has_New_Links Has_Changed_Links Newest_Link Timestmp/];
|
||||
|
||||
sub display {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a category, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('display_category', sub { return $self->_plg_display(@_); }, $p);
|
||||
}
|
||||
|
||||
sub form {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a category form, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('form_category', sub { return $self->_plg_form(@_); }, $p);
|
||||
}
|
||||
|
||||
sub _plg_display {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a record.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{hide} ||= [];
|
||||
|
||||
if (!exists $opts->{code}->{FatherID} and !grep { $_ eq 'FatherID' } @{$opts->{hide}}) {
|
||||
$opts->{code}->{FatherID} = \&disp_fatherid_html
|
||||
}
|
||||
|
||||
push @{$opts->{hide}}, qw/Full_Name/;
|
||||
$CFG->{payment}->{enabled} or push @{$opts->{hide}}, 'Payment_Mode';
|
||||
|
||||
my $out = $self->SUPER::display($opts);
|
||||
|
||||
my $id = $opts->{values}->{ID};
|
||||
if ($CFG->{payment}->{enabled} and $id and $opts->{values}->{Payment_Mode} >= OPTIONAL) {
|
||||
my $font = $self->{font};
|
||||
$out .= qq~
|
||||
<p><table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0 width="500"><tr><td>
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td width="100%" valign="top" align="center"><font $font><a href="admin.cgi?do=page;page=payment_cat_price.html;ID=$id;not_global=1">Add/Update payment terms for this category</a></td>
|
||||
</tr></table>
|
||||
</td></tr></table>
|
||||
~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub _plg_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a form.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{hide} ||= [];
|
||||
|
||||
if ($opts->{mode} and $opts->{mode} =~ /$FORM_HIDE/o) {
|
||||
push @{$opts->{hide}}, @{$FORM_HIDE_FIELDS};
|
||||
}
|
||||
|
||||
if (!exists $opts->{code}->{FatherID} and !grep { $_ eq 'FatherID' } @{$opts->{hide}}) {
|
||||
$opts->{code}->{FatherID} = \&disp_fatherid_form;
|
||||
}
|
||||
|
||||
$CFG->{payment}->{enabled} or push @{$opts->{hide}}, 'Payment_Mode';
|
||||
|
||||
return $self->SUPER::form($opts);
|
||||
}
|
||||
|
||||
sub select {
|
||||
# -------------------------------------------------------------------
|
||||
# Override Payment_Mode select field in add form.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$CFG->{payment}->{enabled} and $opts->{name} eq 'Payment_Mode'
|
||||
and $self->{input}->{do} and ($self->{input}->{do} eq 'add_form' or $self->{input}->{do} eq 'modify_form')
|
||||
and $opts->{blank} = 0;
|
||||
return $self->SUPER::select($opts);
|
||||
}
|
||||
|
||||
sub disp_fatherid_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Display the list of subcategories as either a drop down list of a text box.
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
my $font = $self->{font};
|
||||
my $out;
|
||||
my $form_name = $self->{multiple} ? "$self->{multiple}-FatherID" : 'FatherID';
|
||||
|
||||
if ($CFG->{db_gen_category_list} == 2) {
|
||||
if ($rec->{FatherID}) {
|
||||
$out .= qq|<input type="hidden" name="FatherID" value="$rec->{FatherID}" />|;
|
||||
}
|
||||
$out .= qq|<script type="text/javascript" src="$CFG->{build_static_url}/treecats.js"></script>
|
||||
<link type="text/css" rel="stylesheet" href="$CFG->{build_static_url}/admin/treecats.css" />
|
||||
<input type="hidden" name="FatherID-opt" value="=" />
|
||||
<tr><td valign="top"><font $font>Subcategory of</font></td><td><font $font><div id="treecats"></div></font></td></tr>
|
||||
<script type="text/javascript">var tc = new treecats({ selectionRequired : false, inputName : 'FatherID', cgiURL : '$CFG->{db_cgi_url}', imageURL : '$CFG->{build_static_url}/admin' }, { noSelection : 'Root', rootText : 'Root' }); tc.load();</script>\n|;
|
||||
}
|
||||
elsif ($CFG->{db_gen_category_list}) {
|
||||
my $sth = $self->{db}->select(["DISTINCT Full_Name, ID"]);
|
||||
my %names;
|
||||
if ($sth) {
|
||||
while (my ($name, $id) = $sth->fetchrow_array) {
|
||||
$names{$id} = $name;
|
||||
}
|
||||
}
|
||||
$names{0} = '--Root--';
|
||||
my $select = $self->select({ name => $form_name, values => \%names, blank => 1, sort => sub { lc $_[0] cmp lc $_[1] }, value => defined $rec->{FatherID} ? $rec->{FatherID} : "" });
|
||||
$out = qq~
|
||||
<tr><td valign=top><font $font>Subcategory of</font></td><td><font $font>$select<input type=hidden name="FatherID-opt" value="="></td></tr>
|
||||
~;
|
||||
}
|
||||
else {
|
||||
my $value = $rec->{FatherID} || '';
|
||||
if ($value =~ /^\d+$/) {
|
||||
my $sth = $self->{db}->select('Full_Name', { ID => $value });
|
||||
if ($sth) {
|
||||
($value) = $sth->fetchrow_array;
|
||||
}
|
||||
}
|
||||
$out = qq~
|
||||
<tr><td><font $font>Full Sub Category<br><font size=1>Separated with /'s</font></font></td><td><input type=text size="40" name="$form_name" value="$value"></td></tr>
|
||||
~;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub disp_fatherid_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Display the father.
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
my ($parent) = $rec->{Full_Name} =~ m,^(.*)/[^/]+$,;
|
||||
my $font = $self->{font};
|
||||
$parent ||= 'Root';
|
||||
return qq~
|
||||
<tr><td><font $font>Subcategory of</font></td><td><font $font>$parent</td></tr>
|
||||
~;
|
||||
}
|
||||
|
||||
1;
|
||||
409
site/slowtwitch.com/cgi-bin/articles/admin/Links/HTML/Links.pm
Normal file
409
site/slowtwitch.com/cgi-bin/articles/admin/Links/HTML/Links.pm
Normal file
@@ -0,0 +1,409 @@
|
||||
# ==================================================================
|
||||
# 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.25 2007/11/14 02:40:26 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::HTML::Links;
|
||||
# ==================================================================
|
||||
# Handles displaying of forms and HTML.
|
||||
#
|
||||
use strict;
|
||||
use vars qw/@ISA/;
|
||||
use GT::SQL::Display::HTML::Table;
|
||||
use Links qw/:payment :objects/;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML::Table/;
|
||||
|
||||
my $FORM_HIDE = '^(add_form|modify_form|modify_multi_search_results|modify_multi_result_changed|modify_multi_results_err|validate)$';
|
||||
my $FORM_HIDE_FIELDS = [qw/isNew isChanged isPopular Status Date_Checked/];
|
||||
my $SHOW_CAT_LIST = '^(search_results|add_success|delete_search_results|modify_search_results|modify_success|modify_multi_search_results|modify_multi_results_norec)$';
|
||||
my $SHOW_CAT_FORM = '^(search_form|add_form|delete_search_form|modify_form|modify_search_form|modify_multi_search_results|modify_multi_result_changed|modify_multi_results_err|validate)$';
|
||||
|
||||
sub display {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a link, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('display_link', sub { return $self->_plg_display (@_); }, $p );
|
||||
}
|
||||
|
||||
sub form {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a link form, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('form_link', sub { return $self->_plg_form (@_); }, $p );
|
||||
}
|
||||
|
||||
sub _plg_display {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a record.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
$opts->{code}->{LinkOwner} ||= \&disp_username;
|
||||
$opts->{code}->{ExpiryDate} ||= \&disp_expiry;
|
||||
|
||||
my $hidden = sub { '' };
|
||||
$opts->{code}->{ExpiryCounted} ||= $hidden;
|
||||
$opts->{code}->{ExpiryNotify} ||= $hidden;
|
||||
$opts->{code}->{LinkExpired} ||= $hidden;
|
||||
|
||||
my $out = $self->SUPER::display($opts);
|
||||
if ($opts->{mode} =~ /$SHOW_CAT_LIST/o) {
|
||||
my $id = $opts->{values}->{ID};
|
||||
if ($id) {
|
||||
my $font = $self->{font};
|
||||
my $output = $self->disp_categories($id);
|
||||
$out .= qq~
|
||||
<p><table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0 width="500"><tr><td>
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td width="20%" valign="top"><font $font>Categories</td>
|
||||
<td width="80%"><font $font>$output</td>
|
||||
</tr></table>
|
||||
</td></tr></table>
|
||||
~;
|
||||
}
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub _plg_form {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a form.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
|
||||
my $link_id = $opts->{values}->{ID} || $self->{input}->{ID};
|
||||
|
||||
# Hide fields we don't want to show on add/modify forms.
|
||||
if ($opts->{mode} and $opts->{mode} =~ /$FORM_HIDE/o) {
|
||||
$opts->{hide} ||= [];
|
||||
push @{$opts->{hide}}, @{$FORM_HIDE_FIELDS};
|
||||
}
|
||||
|
||||
$opts->{code}->{ExpiryDate} ||= \&form_expiry;
|
||||
|
||||
# Add javascript to display the original values for text/textarea columns
|
||||
if ($opts->{show_diff} and $link_id) {
|
||||
my $current = $DB->table('Links')->select({ ID => $link_id })->fetchrow_hashref;
|
||||
my $cols = $DB->table('Links')->cols;
|
||||
my $textarea = sub {
|
||||
my ($self, $opts, $values, $col) = @_;
|
||||
|
||||
my $field_name = $self->{multiple} ? "$self->{multiple}-$col" : $col;
|
||||
my $display_name = (exists $self->{cols}->{$col}->{form_display} and length $self->{cols}->{$col}->{form_display})
|
||||
? $self->{cols}->{$col}->{form_display} : $col;
|
||||
my $value = $values->{$col};
|
||||
my $disp = $opts->{form_type} eq 'TEXT' ? 'text' : 'textarea';
|
||||
|
||||
my $ret = qq|<tr $self->{tr}><td $self->{td} width='30%'><font $self->{col_font}><a href="javascript:toggleOriginal('$field_name-original')" title="Show/Hide original $display_name value">$display_name</a></font></td><td $self->{td} width='70%'><font $self->{val_font}>|;
|
||||
$ret .= $self->$disp({ name => $field_name, def => $opts, value => (defined $value ? $value : '')});
|
||||
$ret .= qq|</font></td></tr>\n<tr id="$field_name-original" style="display: none" $self->{tr}><td $self->{td} width="30%"><font $self->{col_font}>Original $display_name</font></td><td $self->{td} width="70%"><font $self->{val_font}>|;
|
||||
if ($opts->{form_type} eq 'TEXT') {
|
||||
$ret .= qq|<input type="text" value="$current->{$col}" size="| . ($opts->{form_size} || 20) . qq|" readonly="readonly" />|;
|
||||
}
|
||||
else {
|
||||
my ($cols, $rows) = ref $opts->{form_size} ? (@{$opts->{form_size}}) : ($opts->{form_size} || 20, 4);
|
||||
$ret .= qq|<textarea rows="$rows" cols="$cols" readonly="readonly">$current->{$col}</textarea>|
|
||||
}
|
||||
$ret .= "</font></td></tr>\n";
|
||||
};
|
||||
|
||||
COL: for my $col (keys %$current) {
|
||||
next if !$cols->{$col}->{form_type} or ($cols->{$col}->{form_type} ne 'TEXT' and $cols->{$col}->{form_type} ne 'TEXTAREA');
|
||||
# Skip hidden fields
|
||||
for (@{$opts->{hide}}) {
|
||||
next COL if $_ eq $col;
|
||||
}
|
||||
|
||||
if ((not defined $opts->{values}->{$col} or $current->{$col} ne $opts->{values}->{$col}) and not $opts->{code}->{$col}) {
|
||||
$opts->{code}->{$col} = $textarea;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Display the form.
|
||||
my $out = $self->SUPER::form($opts);
|
||||
|
||||
# Display the category select box.
|
||||
if ($opts->{mode} and $opts->{mode} =~ /$SHOW_CAT_FORM/o) {
|
||||
my $name = $opts->{multiple} ? "$opts->{multiple}-CatLinks.CategoryID" : 'CatLinks.CategoryID';
|
||||
my $id = $opts->{values}->{$name} || $self->{input}->{$name};
|
||||
$id = (ref $id eq 'ARRAY') ? $id : $id ? [$id] : [];
|
||||
my $font = $self->{font};
|
||||
my ($output, $h);
|
||||
|
||||
# Add javascript to display the original categories
|
||||
my $cats_modified;
|
||||
if ($opts->{show_diff} and @$id and $link_id) {
|
||||
my $ccl = $DB->table('Category', 'CatLinks');
|
||||
$ccl->select_options("ORDER BY CategoryID");
|
||||
my $sth = $ccl->select('CategoryID', 'Full_Name', { LinkID => $link_id });
|
||||
my (@cid, @cats);
|
||||
while (my $cat = $sth->fetchrow_hashref) {
|
||||
push @cid, $cat->{CategoryID};
|
||||
push @cats, $cat->{Full_Name};
|
||||
}
|
||||
if (@$id == @cid) {
|
||||
my @sorted = sort { $a > $b } @$id;
|
||||
for (my $i = 0; $i < @cid; $i++) {
|
||||
if ($cid[$i] != $sorted[$i]) {
|
||||
$cats_modified = join "\n", sort @cats;
|
||||
last;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$cats_modified = join "\n", sort @cats;
|
||||
}
|
||||
}
|
||||
|
||||
# Display the category using treecats
|
||||
if ($CFG->{db_gen_category_list} == 2) {
|
||||
my $name = $opts->{multiple} ? "$opts->{multiple}-CatLinks.CategoryID" : 'CatLinks.CategoryID';
|
||||
my $jsname = $opts->{multiple} ? "tc$opts->{multiple}" : 'tc';
|
||||
if (!@$id and $link_id) {
|
||||
$h = $self->{db}->get_categories($link_id);
|
||||
for (keys %$h) {
|
||||
push @$id, $_;
|
||||
}
|
||||
}
|
||||
$out .= qq~<p><table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0><tr><td>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
$out .= qq~
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td width="30%" valign="top"><font $font>~;
|
||||
$out .= qq|<a href="javascript:toggleOriginal('$name-original')" title="Show/Hide original Category value">| if $cats_modified;
|
||||
$out .= "Categories";
|
||||
$out .= qq|</a>| if $cats_modified;
|
||||
for (@$id) {
|
||||
$out .= qq|<input type="hidden" name="$name" value="$_" />|;
|
||||
}
|
||||
$out .= qq~</td>
|
||||
<td>
|
||||
<script type="text/javascript" src="$CFG->{build_static_url}/treecats.js"></script>
|
||||
<link type="text/css" rel="stylesheet" href="$CFG->{build_static_url}/admin/treecats.css" />
|
||||
<font $font><div id="$jsname"></div></font>
|
||||
<script type="text/javascript">var $jsname = new treecats({ workspace : '$jsname', objName : '$jsname', inputName : '$name', selectionMode : 'multiple', cgiURL : '$CFG->{db_cgi_url}', imageURL : '$CFG->{build_static_url}/admin' }); $jsname.load();</script>
|
||||
</td>
|
||||
</tr></table>
|
||||
~;
|
||||
$out .= qq~</p></td></tr></table>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
}
|
||||
# Display category as a select box.
|
||||
elsif ($CFG->{db_gen_category_list}) {
|
||||
if (!@$id and $link_id) {
|
||||
$h = $self->{db}->get_categories($link_id);
|
||||
$output = $self->get_categories_with_html([keys %$h], $name);
|
||||
}
|
||||
else {
|
||||
$output = $self->get_categories_with_html($id, $name);
|
||||
}
|
||||
$out .= "<p>";
|
||||
$out .= qq~<table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0><tr><td>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
$out .= qq~
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td width="20%" valign="top"><font $font>~;
|
||||
$out .= qq|<a href="javascript:toggleOriginal('$name-original')" title="Show/Hide original Category value">| if $cats_modified;
|
||||
$out .= "Categories";
|
||||
$out .= qq|</a>| if $cats_modified;
|
||||
$out .= qq~</td>
|
||||
<td width="80%"><font $font>$output</td>
|
||||
</tr></table>
|
||||
~;
|
||||
$out .= qq~</td></tr></table>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
}
|
||||
# Display category as a textarea box.
|
||||
else {
|
||||
my ($vals);
|
||||
if (@$id) {
|
||||
my $db = $DB->table('Category');
|
||||
foreach (@$id) {
|
||||
if (/^\d+$/) {
|
||||
$vals .= $db->get_name_from_id($_) . "\n";
|
||||
}
|
||||
else {
|
||||
$vals .= $_ . "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
elsif ($link_id) {
|
||||
$h = $self->{db}->get_categories($link_id);
|
||||
$vals = join("\n", sort values %$h);
|
||||
}
|
||||
else {
|
||||
$vals = '';
|
||||
}
|
||||
$out .= "<p>";
|
||||
$out .= qq~<table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0><tr><td>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
$out .= qq~
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td width="20%" valign="top"><font $font>~;
|
||||
$out .= qq|<a href="javascript:toggleOriginal('$name-original')" title="Show/Hide original Category value">| if $cats_modified;
|
||||
$out .= "Categories";
|
||||
$out .= qq|</a>| if $cats_modified;
|
||||
$out .= qq~<br><font size=1>One per line</font></td>
|
||||
<td width="80%"><font $font><textarea rows="3" cols="50" name="$name">$vals</textarea></td>
|
||||
</tr></table>
|
||||
~;
|
||||
$out .= qq~</td></tr></table>~ unless exists $opts->{extra_table} and $opts->{extra_table} == 0;
|
||||
|
||||
}
|
||||
|
||||
if ($cats_modified) {
|
||||
$out .= qq~
|
||||
<table border=0 bgcolor="#FFFFFF" width="500" id="$name-original" style="display: none"><tr>
|
||||
<td width="20%" valign="top"><font $font>Original Categories</font></td>
|
||||
<td width="80%"><font $font><textarea rows="3" cols="50" readonly="readonly">$cats_modified</textarea></td>
|
||||
</tr></table>
|
||||
~;
|
||||
}
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub disp_username {
|
||||
# -------------------------------------------------------------------
|
||||
# Display the username with links to edit.
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
my $val = $rec->{LinkOwner};
|
||||
my $val_e = GT::CGI->escape($val);
|
||||
my $font = $self->{font};
|
||||
return qq~
|
||||
<tr><td><font $font>$col->{form_display}</font></td><td><font $font>$val <font size=1><a href="admin.cgi?db=Users&do=modify_form&modify=1&1-Username=$val_e&ww=1">edit</a></font></font></td></tr>
|
||||
~;
|
||||
}
|
||||
|
||||
sub disp_categories {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a list of categories for the form.
|
||||
#
|
||||
my $self = shift;
|
||||
my $id = shift;
|
||||
my $cat = $self->{db}->get_categories ($id);
|
||||
my $out = '';
|
||||
foreach my $id (sort { lc $cat->{$a} cmp lc $cat->{$b} } keys %$cat) {
|
||||
$out .= "$id: $cat->{$id}<br>\n";
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub disp_expiry {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
my $val = $rec->{ExpiryDate};
|
||||
my $name = $col->{form_display};
|
||||
my $font = $self->{font};
|
||||
my $td = $self->{td};
|
||||
|
||||
my $out = qq|<tr><td $td><font $font>$name</font></td><td $td><font $font>|;
|
||||
if ($val == UNLIMITED) {
|
||||
$out .= "<i>Never</i>";
|
||||
}
|
||||
elsif ($val == UNPAID) {
|
||||
$out .= "<i>Awaiting Payment</i>";
|
||||
}
|
||||
elsif ($val == FREE) {
|
||||
$out .= "<i>No Payment Required (free)";
|
||||
if ($rec->{LinkExpired}) {
|
||||
require GT::Date;
|
||||
$out .= " - Payment Expired " . GT::Date::date_get($rec->{LinkExpired}, '%yyyy%/%m%/%d% %HH%:%MM%:%ss%');
|
||||
}
|
||||
$out .= "</i>";
|
||||
}
|
||||
elsif ($val == 0) {
|
||||
$out .= "<i>Invalid Date (0)!</i>";
|
||||
}
|
||||
else {
|
||||
require GT::Date;
|
||||
$out .= GT::Date::date_get($val, '%yyyy%/%m%/%d% %HH%:%MM%:%ss%');
|
||||
}
|
||||
$out .= qq|</font></td>|;
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub form_expiry {
|
||||
# -------------------------------------------------------------------
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
require GT::Date;
|
||||
my $val = $rec->{ExpiryDate};
|
||||
my $name = $col->{form_display};
|
||||
my $font = $self->{font};
|
||||
my $td = $self->{td};
|
||||
my $got_date = $val && $val < UNLIMITED && $val > 0;
|
||||
($got_date and $val !~ m|^\d+$|) and $val = Links::date_to_time($val);
|
||||
my $multiple = $self->{multiple} ? "$self->{multiple}-" : '';
|
||||
$name .= '<br><i><font size=-2>Dates can be entered in the following formats: YYYY-MM-DD, YYYY/MM/DD, YYYY/MM/DD HH:MM:SS</font></i>';
|
||||
my $out = qq|<tr><td $td><font $font>$name</font></td><td $td><font $font><input type="hidden" name="${multiple}ExpiryDate" value="$val" id="${multiple}ExpiryDate">|;
|
||||
$out .= qq|<input type="radio" name="${multiple}pe_radio" onclick="document.getElementById('${multiple}ExpiryDate').value = document.getElementById('${multiple}pe_date').value"|;
|
||||
$out .= qq| checked| if $got_date;
|
||||
$out .= qq|><input type="text" name="${multiple}pe_date" id="${multiple}pe_date" onchange="document.getElementById('${multiple}ExpiryDate').value = document.getElementById('${multiple}pe_date').value"|;
|
||||
$out .= qq| value="| . GT::Date::date_get($val, '%yyyy%/%m%/%d% %HH%:%MM%:%ss%') . qq|"| if $got_date;
|
||||
$out .= qq|><br><input type="radio" name="${multiple}pe_radio" onclick="document.getElementById('${multiple}ExpiryDate').value = | . UNLIMITED . qq|"|;
|
||||
$out .= qq| checked| if $val && $val == UNLIMITED;
|
||||
$out .= qq|> Never<br><input type="radio" name="${multiple}pe_radio" onclick="document.getElementById('${multiple}ExpiryDate').value = | . UNPAID . qq|"|;
|
||||
$out .= qq| checked| if $val && $val == UNPAID;
|
||||
$out .= qq|> Awaiting Payment<br><input type="radio" name="${multiple}pe_radio" onclick="document.getElementById('${multiple}ExpiryDate').value = | . FREE . qq|"|;
|
||||
$out .= qq| checked| if $val && $val == FREE || !$val;
|
||||
$out .= qq|> No Payment Required (free)|;
|
||||
$out .= qq| - Expired | . GT::Date::date_get($rec->{LinkExpired}, '%yyyy%/%m%/%d% %HH%:%MM%:%ss%') if $val and $val == FREE and $rec->{LinkExpired};
|
||||
$out .= qq|</font></td>|;
|
||||
|
||||
if ($self->{mode} =~ /search/ or (exists $self->{input}->{action} and $self->{input}->{action} =~ /search/)) { # Hack to get this to show up on the Browser search
|
||||
$out .= qq|<td $td><select name="${multiple}ExpiryDate-opt"><option value="=">Exact Match</option><option value=">">Greater Than</option><option value="<">Less Than</option><option value="<>">Not Equal</option></select></td>|;
|
||||
}
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub get_all_categories {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns a select box of all categories.
|
||||
#
|
||||
my $self = shift;
|
||||
my $id = shift;
|
||||
my $name = shift || 'CatLinks.CategoryID';
|
||||
my $mult = shift || 5;
|
||||
my $db = $DB->table ('Category');
|
||||
my $sth = $db->select ( ['ID', 'Full_Name'] );
|
||||
my %res = ();
|
||||
while (my ($id, $name) = $sth->fetchrow_array) {
|
||||
$res{$id} = $name;
|
||||
}
|
||||
return $self->select ( { name => $name, values => \%res, value => $id, blank => 0, multiple => $mult, sort => sub { lc $_[0] cmp lc $_[1] } } );
|
||||
}
|
||||
|
||||
sub get_categories_with_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns select list, and adds which categories are selected as text.
|
||||
#
|
||||
my ($self, @param) = @_;
|
||||
my $select = $self->get_all_categories(@param);
|
||||
my $output = '';
|
||||
my @vals = ref $param[0] ? @{$param[0]} : ($param[0]);
|
||||
if (@vals) {
|
||||
my $db = $DB->table ('Category');
|
||||
foreach my $id (@vals) {
|
||||
next unless ($id and $id =~ /^\d+$/);
|
||||
my $name_r = $db->get ($id, 'ARRAY', ['Full_Name']);
|
||||
$output .= $name_r->[0] . "<BR>";
|
||||
}
|
||||
}
|
||||
$output .= $select;
|
||||
return $output;
|
||||
}
|
||||
|
||||
1;
|
||||
101
site/slowtwitch.com/cgi-bin/articles/admin/Links/HTML/Users.pm
Normal file
101
site/slowtwitch.com/cgi-bin/articles/admin/Links/HTML/Users.pm
Normal file
@@ -0,0 +1,101 @@
|
||||
# ==================================================================
|
||||
# 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.4 2007/03/22 22:05:44 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::HTML::Users;
|
||||
# ==================================================================
|
||||
# Handles displaying of forms and HTML.
|
||||
#
|
||||
use strict;
|
||||
use vars qw/@ISA/;
|
||||
use Links qw/:objects/;
|
||||
use GT::SQL::Display::HTML::Table;
|
||||
|
||||
@ISA = qw/GT::SQL::Display::HTML::Table/;
|
||||
|
||||
sub display {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a link, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = ref $_[0] eq 'HASH' ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('display_user', sub { $self->SUPER::display(@_) }, $p);
|
||||
}
|
||||
|
||||
sub form {
|
||||
# -------------------------------------------------------------------
|
||||
# Displays a user form, but passes through the plugin system.
|
||||
#
|
||||
my $self = shift;
|
||||
my $p = (ref $_[0] eq 'HASH') ? shift : {@_};
|
||||
|
||||
$PLG->dispatch('form_user', sub { return $self->SUPER::form(@_) }, $p);
|
||||
}
|
||||
|
||||
sub _display {
|
||||
# -------------------------------------------------------------------
|
||||
# Adds on a box with quick links to the users links.
|
||||
#
|
||||
my ($self, $opts) = @_;
|
||||
my $user = $opts->{values}->{Username};
|
||||
my $output = '';
|
||||
|
||||
# If we are modifying, then add a hidden field for the original record.
|
||||
if ($opts->{mode} eq 'modify_form') {
|
||||
$opts->{code}->{Username} ||= \&disp_username;
|
||||
my $user_q = GT::CGI->html_escape($user);
|
||||
$output .= qq~<input type="hidden" name="orig_username" value="$user_q">~;
|
||||
}
|
||||
else {
|
||||
delete $self->{code}->{Username};
|
||||
}
|
||||
$output .= $self->SUPER::_display($opts);
|
||||
if ($user) {
|
||||
my $link_db = $DB->table('Links');
|
||||
my $count = $link_db->count({ LinkOwner => $user });
|
||||
my $url = GT::CGI->url({ query_string => 0 });
|
||||
my $user_q = GT::CGI->escape($user);
|
||||
$output .= <<HTML;
|
||||
<p>
|
||||
<table border=1 cellpadding=0 bgcolor="#FFFFFF" cellspacing=0 width="500"><tr><td>
|
||||
<table border=0 bgcolor="#FFFFFF" width="500"><tr>
|
||||
<td><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Links ($count):
|
||||
<a href="$url?db=Links&do=search_results&LinkOwner=$user_q&ww=1">View</a> |
|
||||
<a href="$url?db=Links&do=modify_search_results&LinkOwner=$user_q&ww=1">Modify</a> |
|
||||
<a href="$url?db=Links&do=delete_search_results&LinkOwner=$user_q&ww=1">Delete</a>
|
||||
</font></td>
|
||||
</tr></table>
|
||||
</td></tr></table>
|
||||
HTML
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub disp_username {
|
||||
# -------------------------------------------------------------------
|
||||
# Display the username with links to edit.
|
||||
#
|
||||
my ($self, $col, $rec) = @_;
|
||||
my $val = $rec->{Username};
|
||||
my $val_e = GT::CGI->html_escape($val);
|
||||
my $font = $self->{font};
|
||||
return <<HTML;
|
||||
<tr>
|
||||
<td><font $font>Username</font></td>
|
||||
<td><font $font><input type="text" name="Username" value="$val_e" size="20"></font></td>
|
||||
</tr>
|
||||
HTML
|
||||
}
|
||||
|
||||
1;
|
||||
183
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/BKS2.pm
Normal file
183
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/BKS2.pm
Normal file
@@ -0,0 +1,183 @@
|
||||
# ==================================================================
|
||||
# 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: BKS2.pm,v 1.14 2005/03/05 01:46:07 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::Import::BKS2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_) if ref $Critical_Code eq 'CODE';
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_) if ref $Warning_Code eq 'CODE';
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $prefix = $DB->prefix || "";
|
||||
|
||||
my $odbc = 0;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
if ($table->{connect}->{driver} eq 'ODBC') {
|
||||
$odbc = 1;
|
||||
$e_dbh->{LongReadLen} = 1000000;
|
||||
}
|
||||
}
|
||||
|
||||
my $delimiter;
|
||||
|
||||
local (*IMPORT_FH);
|
||||
local $/ = "\0"; # "Lines" are actually delimited by \0 (hex & ascii 0)
|
||||
|
||||
import_print "Verifying table headers ...\n";
|
||||
|
||||
my $all_problems = "";
|
||||
open IMPORT_FH, "<$$opt{source}" or critical "Unable to open $$opt{source}: $!";
|
||||
binmode IMPORT_FH; # Don't want to worry about windows line feeds!
|
||||
while (<IMPORT_FH>) {
|
||||
last if substr($_,0,2) eq '\\\\';
|
||||
} # Eat up until a \\
|
||||
while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $table = $_;
|
||||
import_print "\tChecking $table\n";
|
||||
my $has_problems = 0;
|
||||
TABLE: while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $header = $_;
|
||||
my $delimiter = substr($header,0,1);
|
||||
substr($header,0,1) = '';
|
||||
my @cols = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $header, -1;
|
||||
my %cols = $DB->table($table)->cols;
|
||||
my $problem = "";
|
||||
for (grep !$cols{$_}, @cols) {
|
||||
$problem .= ($problem ? ", " : "") . $_;
|
||||
}
|
||||
if ($problem) {
|
||||
my $plural = $problem =~ /, /;
|
||||
$all_problems .= "\nThe following column".($plural?"s":"")." in the $table table ($$opt{source}) ".($plural?"are":"is")." NOT in the Gossamer Links database: $problem. ".($plural?"They":"It")." will have to be created prior to performing this import.";
|
||||
$has_problems++;
|
||||
}
|
||||
while (<IMPORT_FH>) {
|
||||
last TABLE if substr($_,0,2) eq '\\\\';
|
||||
}
|
||||
}
|
||||
}
|
||||
close IMPORT_FH;
|
||||
critical $all_problems if $all_problems;
|
||||
|
||||
import_print "All tables verified successfully\n\n\n";
|
||||
|
||||
open IMPORT_FH, "<$$opt{source}" or critical "Unable to open $$opt{source}: $!";
|
||||
binmode IMPORT_FH; # Don't want to worry about windows line feeds!
|
||||
while (<IMPORT_FH>) {
|
||||
last if substr($_,0,2) eq '\\\\';
|
||||
} # Eat up until \\
|
||||
while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $table = $_;
|
||||
$e_dbh->do("DELETE FROM $prefix$_");
|
||||
import_print "Importing $prefix$table ... (starting at line ".($.+2)." of $$opt{source})\n";
|
||||
my $imported = 0;
|
||||
TABLE: while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $header = $_;
|
||||
my $delimiter = substr($header,0,1);
|
||||
substr($header,0,1) = '';
|
||||
my @cols = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $header, -1;
|
||||
|
||||
# If this is an ODBC db, we need to turn identity insert on.
|
||||
my $insert = "INSERT INTO $prefix$table (" . join(",", @cols) . ") VALUES (" . join(",",("?") x @cols) . ")";
|
||||
if ($odbc) {
|
||||
if ($DB->table($table)->ai) {
|
||||
$insert = "SET IDENTITY_INSERT $prefix$table ON; $insert";
|
||||
}
|
||||
}
|
||||
my $sth = $e_dbh->prepare($insert) or critical "Unable to prepare query `$insert': ".$e_dbh->errstr;
|
||||
|
||||
import_print "\tStarting import to table $prefix$table ...\n";
|
||||
while (<IMPORT_FH>) {
|
||||
last TABLE if substr($_,0,2) eq '\\\\';
|
||||
chomp;
|
||||
my @data = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $_, -1;
|
||||
$sth->execute(@data) or warning "\tUnable to import `$_' (line $. of $$opt{source}): ".$sth->errstr;
|
||||
import_print "\t$imported imported ...\n" unless ++$imported % 500;
|
||||
}
|
||||
}
|
||||
import_print "\t$imported records imported to $prefix$table.\n",
|
||||
"All records have been imported to $prefix$table.\n\n";
|
||||
}
|
||||
import_print "All tables contained in $$opt{source} have been imported.\n\nNOTE: You must run Repair Tables and Rebuild Search after performing an import!\n";
|
||||
}
|
||||
|
||||
|
||||
# Takes two parameters: The field to escape, and the delimiter. It will return
|
||||
# the field unescaped.
|
||||
sub BK_unescape ($$) {
|
||||
my $field = shift;
|
||||
my $delimiter = shift;
|
||||
$delimiter = "" unless defined $delimiter;
|
||||
critical "Bad delimiter `$delimiter'" unless length $delimiter == 1 and $delimiter ne '\\';
|
||||
critical "An escaped field cannot be undefined. You have data errors!" unless defined $field;
|
||||
return undef if $field eq 'NULL';
|
||||
my $escape_chr = '\\';
|
||||
$field =~ s/\Q$escape_chr\E([0-9A-Fa-f]{2})/chr hex $1/ge;
|
||||
$field;
|
||||
}
|
||||
|
||||
2;
|
||||
@@ -0,0 +1,189 @@
|
||||
# ==================================================================
|
||||
# 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: BKS2.pm,v 1.14 2005/03/05 01:46:07 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::Import::BKS2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_) if ref $Critical_Code eq 'CODE';
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_) if ref $Warning_Code eq 'CODE';
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $prefix = $DB->prefix || "";
|
||||
|
||||
my $odbc = 0;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
if ($table->{connect}->{driver} eq 'ODBC') {
|
||||
$odbc = 1;
|
||||
$e_dbh->{LongReadLen} = 1000000;
|
||||
}
|
||||
}
|
||||
|
||||
my $delimiter;
|
||||
|
||||
local (*IMPORT_FH);
|
||||
local $/ = "\0"; # "Lines" are actually delimited by \0 (hex & ascii 0)
|
||||
|
||||
import_print "Verifying table headers ...\n";
|
||||
|
||||
my $all_problems = "";
|
||||
open IMPORT_FH, "<$$opt{source}" or critical "Unable to open $$opt{source}: $!";
|
||||
binmode IMPORT_FH; # Don't want to worry about windows line feeds!
|
||||
while (<IMPORT_FH>) {
|
||||
last if substr($_,0,2) eq '\\\\';
|
||||
} # Eat up until a \\
|
||||
while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $table = $_;
|
||||
import_print "\tChecking $table\n";
|
||||
my $has_problems = 0;
|
||||
TABLE: while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $header = $_;
|
||||
my $delimiter = substr($header,0,1);
|
||||
substr($header,0,1) = '';
|
||||
my @cols = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $header, -1;
|
||||
my %cols = $DB->table($table)->cols;
|
||||
my $problem = "";
|
||||
for (grep !$cols{$_}, @cols) {
|
||||
$problem .= ($problem ? ", " : "") . $_;
|
||||
}
|
||||
if ($problem) {
|
||||
my $plural = $problem =~ /, /;
|
||||
$all_problems .= "\nThe following column".($plural?"s":"")." in the $table table ($$opt{source}) ".($plural?"are":"is")." NOT in the Gossamer Links database: $problem. ".($plural?"They":"It")." will have to be created prior to performing this import.";
|
||||
$has_problems++;
|
||||
}
|
||||
while (<IMPORT_FH>) {
|
||||
last TABLE if substr($_,0,2) eq '\\\\';
|
||||
}
|
||||
}
|
||||
}
|
||||
close IMPORT_FH;
|
||||
critical $all_problems if $all_problems;
|
||||
|
||||
import_print "All tables verified successfully\n\n\n";
|
||||
|
||||
open IMPORT_FH, "<$$opt{source}" or critical "Unable to open $$opt{source}: $!";
|
||||
binmode IMPORT_FH; # Don't want to worry about windows line feeds!
|
||||
while (<IMPORT_FH>) {
|
||||
last if substr($_,0,2) eq '\\\\';
|
||||
} # Eat up until \\
|
||||
while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $table = $_;
|
||||
#$e_dbh->do("DELETE FROM $prefix$_");
|
||||
import_print "Importing $prefix$table ... (starting at line ".($.+2)." of $$opt{source})\n";
|
||||
my $imported = 0;
|
||||
TABLE: while (<IMPORT_FH>) {
|
||||
chomp;
|
||||
my $header = $_;
|
||||
my $delimiter = substr($header,0,1);
|
||||
substr($header,0,1) = '';
|
||||
my @cols = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $header, -1;
|
||||
|
||||
if ($table =~ /Category$/) {
|
||||
push @cols, 'tmp_col';
|
||||
}
|
||||
# If this is an ODBC db, we need to turn identity insert on.
|
||||
my $insert = "INSERT INTO $prefix$table (" . join(",", @cols) . ") VALUES (" . join(",",("?") x @cols) . ")";
|
||||
if ($odbc) {
|
||||
if ($DB->table($table)->ai) {
|
||||
$insert = "SET IDENTITY_INSERT $prefix$table ON; $insert";
|
||||
}
|
||||
}
|
||||
my $sth = $e_dbh->prepare($insert) or critical "Unable to prepare query `$insert': ".$e_dbh->errstr;
|
||||
|
||||
import_print "\tStarting import to table $prefix$table ...\n";
|
||||
while (<IMPORT_FH>) {
|
||||
last TABLE if substr($_,0,2) eq '\\\\';
|
||||
chomp;
|
||||
if ($table =~ /Category$/) {
|
||||
print $_ . "\n";
|
||||
my @data = map BK_unescape($_,$delimiter), split /\Q$delimiter/, $_, -1;
|
||||
$sth->execute(@data) or warning "\tUnable to import `$_' (line $. of $$opt{source}): ".$sth->errstr;
|
||||
import_print "\t$imported imported ...\n" unless ++$imported % 500;
|
||||
}
|
||||
}
|
||||
}
|
||||
import_print "\t$imported records imported to $prefix$table.\n",
|
||||
"All records have been imported to $prefix$table.\n\n";
|
||||
}
|
||||
import_print "All tables contained in $$opt{source} have been imported.\n\nNOTE: You must run Repair Tables and Rebuild Search after performing an import!\n";
|
||||
}
|
||||
|
||||
|
||||
# Takes two parameters: The field to escape, and the delimiter. It will return
|
||||
# the field unescaped.
|
||||
sub BK_unescape ($$) {
|
||||
my $field = shift;
|
||||
my $delimiter = shift;
|
||||
$delimiter = "" unless defined $delimiter;
|
||||
critical "Bad delimiter `$delimiter'" unless length $delimiter == 1 and $delimiter ne '\\';
|
||||
critical "An escaped field cannot be undefined. You have data errors!" unless defined $field;
|
||||
return undef if $field eq 'NULL';
|
||||
my $escape_chr = '\\';
|
||||
$field =~ s/\Q$escape_chr\E([0-9A-Fa-f]{2})/chr hex $1/ge;
|
||||
$field;
|
||||
}
|
||||
|
||||
2;
|
||||
@@ -0,0 +1,581 @@
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# Revision : $Id: CGI.pm,v 1.17 2005/04/05 08:44:30 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::Import::Interface::CGI;
|
||||
# ==================================================================
|
||||
|
||||
use strict;
|
||||
use Links qw/$IN $CFG/;
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub isin {
|
||||
my $val = shift;
|
||||
for (@_) {
|
||||
return 1 if $val eq $_;
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub html_escape {
|
||||
shift if ref $_[0];
|
||||
my $to_escape = shift;
|
||||
$to_escape = "" unless defined $to_escape;
|
||||
$to_escape =~ s/&/&/g;
|
||||
$to_escape =~ s/ / /g;
|
||||
$to_escape =~ s/</</g;
|
||||
$to_escape =~ s/>/>/g;
|
||||
$to_escape =~ s/"/"/g;
|
||||
$to_escape;
|
||||
}
|
||||
|
||||
sub make_opts {
|
||||
my $self = shift;
|
||||
return if ref $self->{cgi} eq 'HASH';
|
||||
$self->{cgi} = { };
|
||||
$self->{cgi}{help} = 1, return if $IN->param("help");
|
||||
return unless $IN->param("Interface_CGI");
|
||||
|
||||
$self->{cgi}{transfer} = isin($IN->param("transfer"),qw/L1S2 L2S2 S1S2 BKS2 S2BK/)
|
||||
? $IN->param("transfer")
|
||||
: "";
|
||||
|
||||
for ($IN->param) { $self->{cgi}{$_} = $IN->param($_); }
|
||||
}
|
||||
|
||||
sub get_options {
|
||||
my $self = shift;
|
||||
$self->make_opts;
|
||||
return wantarray ? (help => 1) : { help => 1 } if $self->{cgi}{'help'};
|
||||
$self->start_page(),exit unless $IN->param("Interface_CGI");
|
||||
if ($self->{cgi}{'errors_to_browser'}) {
|
||||
if ($self->{cgi}{error_file}) {
|
||||
my $fh = \do { local *FH; *FH };
|
||||
unless (open $fh, "> $self->{cgi}{error_file}") {
|
||||
_print_headers();
|
||||
print "<pre>Unable to open error file @{[html_pre_format(qq($self->{cgi}{error_file}: $!))]}</pre>";
|
||||
exit;
|
||||
}
|
||||
$self->{cgi}{error_file} = sub {
|
||||
for (@_) {
|
||||
print html_pre_format("Import error: $_\n");
|
||||
print $fh "Import error: $_\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{cgi}{error_file} = sub {
|
||||
for (@_) {
|
||||
print html_pre_format("Import error: $_\n");
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self->{cgi}{error_file} = 'STDOUT';
|
||||
}
|
||||
return wantarray ? %{$self->{cgi}} : $self->{cgi};
|
||||
}
|
||||
|
||||
sub usage ($$$) {
|
||||
my $self = shift;
|
||||
push @{$self->{usage_list}}, shift if @_;
|
||||
# Don't care about the third argument; it is exclusively for Interface::Text
|
||||
}
|
||||
|
||||
sub has_usage {
|
||||
my $self = shift;
|
||||
return ref $self->{usage_list} ? scalar @{$self->{usage_list}} : undef;
|
||||
}
|
||||
|
||||
sub show_usage {
|
||||
my $self = shift;
|
||||
$self->start_page(1);
|
||||
}
|
||||
|
||||
sub pre_import {
|
||||
require Links;
|
||||
_print_headers();
|
||||
print "<html>\n<head>\n<title>Import Results</title>\n</head>\n<body bgcolor=#FFFFFF>\n";
|
||||
print Links::header("Import/Export", "Please be patient, this can take a while...");
|
||||
print "<blockquote><pre>";
|
||||
}
|
||||
|
||||
sub finished {
|
||||
print "</pre></blockquote>\n<b><font face='Tahoma,Arial,Helvetica' size=2>Data has been successfully import/exported!</font></b>\n</body>\n</html>";
|
||||
exit;
|
||||
}
|
||||
|
||||
# Takes one optional argument which, if true, will make it print usage messages
|
||||
sub start_page {
|
||||
my $self = shift;
|
||||
$self->make_opts unless ref $self->{cgi} eq 'HASH';
|
||||
_print_headers();
|
||||
$self->_start_page_top;
|
||||
if (shift and ref $self->{usage_list} and @{$self->{usage_list}}) {
|
||||
print "\n\n<ul>\n";
|
||||
for (@{$self->{usage_list}}) {
|
||||
print " <li><font color=red><b>$_ </b></font></li>\n";
|
||||
}
|
||||
print "</ul>\n\n";
|
||||
}
|
||||
$self->_start_page_bottom;
|
||||
exit;
|
||||
}
|
||||
|
||||
sub _start_page_top {
|
||||
print <<'HTML';
|
||||
<html>
|
||||
|
||||
<head>
|
||||
<title>Gossamer Links Import</title>
|
||||
</head>
|
||||
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="3" width="500" valign="top">
|
||||
<tr>
|
||||
<td align="left" bgColor="navy"><b><font color="#ffffff" size="2" face="Tahoma,Arial,Helvetica">Gossamer Links Import/Backup/Restore</font></b></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<p align="center"><b><font color="#000000" size="2" face="Tahoma,Arial,Helvetica">Gossamer Links Import/Backup/Restore</font></b></p>
|
||||
<p><font size="2" face="Tahoma,Arial,Helvetica">This tool will allow you to easily migrate from a previous
|
||||
version of Links, or backup and restore your data. For more information on the specific options, please
|
||||
consult the <b><a href="nph-import.cgi?help=1&Interface_CGI=1">Help</a></b></font></td>
|
||||
</tr>
|
||||
</table>
|
||||
</td></tr>
|
||||
</table>
|
||||
|
||||
HTML
|
||||
}
|
||||
|
||||
sub _start_page_bottom {
|
||||
my $self = shift;
|
||||
print qq[
|
||||
<form action="nph-import.cgi" method="POST">
|
||||
<input type=hidden name="Interface_CGI" value=1>
|
||||
<input type="hidden" name="destination" value="$CFG->{admin_root_path}/defs">
|
||||
<table border="1" cellspacing="0" cellpadding="0"><tr><td>
|
||||
<table border="0" cellspacing="0" cellpadding="3" width=500>
|
||||
<tr>
|
||||
<td colspan="2" bgcolor="#DDDDDD"><b><font face="Tahoma,Arial,Helvetica" size="2">Import Data from previous versions of Links</font></b></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Import From:
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left"><font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<select size="1" name="transfer" style="font-family: Tahoma, Arial, Helvetica; font-size: 10pt; color: #000000">
|
||||
<option ];
|
||||
print "selected " if $self->{cgi}{transfer} and $self->{cgi}{transfer} eq "S1S2";
|
||||
print qq[value="S1S2">Links SQL 1.x</option>
|
||||
<option ];
|
||||
print "selected " if $self->{cgi}{transfer} and $self->{cgi}{transfer} eq "L1S2";
|
||||
print qq[value="L1S2">Links 1.x</option>
|
||||
<option ];
|
||||
print "selected " if $self->{cgi}{transfer} and $self->{cgi}{transfer} eq "L2S2";
|
||||
print qq[value="L2S2">Links 2.x</option>
|
||||
</select></font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Location of def files:
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<input type="text" name="source" size="40" ];
|
||||
print qq[value="].html_escape($self->{cgi}{source}).qq[" ] if $self->{cgi}{source} && ($self->{cgi}{transfer} =~ /^(?:L[12]|S1)S2$/);
|
||||
print qq[style="font-family: Tahoma, Arial, Helvetica; font-size: 10pt">
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Error File (optional):
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<input type="text" name="error_file" size="40" ];
|
||||
print qq[value="].html_escape($self->{cgi}{error_file}).qq[" ] if $self->{cgi}{error_file} && ($self->{cgi}{transfer} =~ /^(?:L[12]|S1)S2$/);
|
||||
print qq[style="font-family: Tahoma, Arial, Helvetica; font-size: 10pt">
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
<table border="0" cellspacing="0" width="100%">
|
||||
<tr>
|
||||
<td valign="top" align="left" colspan="6">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<br><b>Options:</b>
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="show_mild_warnings" value=1];
|
||||
print " checked" if $self->{cgi}{show_mild_warnings};
|
||||
print qq[>
|
||||
Show Mild Warnings
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left" colspan=2>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="critical_warnings" value=1];
|
||||
print " checked" if $self->{cgi}{critical_warnings};
|
||||
print qq[>
|
||||
Critical Warnings
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="data_integrity" value=1];
|
||||
print " checked" if $self->{cgi}{data_integrity};
|
||||
print qq[>
|
||||
Extra Data Integrity
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="clear_tables" value=1];
|
||||
print " checked" if not keys %{$self->{cgi}} or $self->{cgi}{clear_tables} and ($self->{cgi}{transfer} =~ /^(?:L[12]|S1)S2$/);
|
||||
print qq[>
|
||||
Clear Tables
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left" colspan=2>
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="errors_to_browser" value=1];
|
||||
print " checked" if ($self->{cgi}{errors_to_browser} or not keys %{$self->{cgi}});
|
||||
print qq[>
|
||||
Show Errors
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<input type="checkbox" name="straight_import" value=1];
|
||||
print " checked" if $self->{cgi}{straight_import};
|
||||
print qq[>
|
||||
Straight Import
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign=top align=left colspan=2>
|
||||
<font face="Tahoma,Arial,Helvetica" size=2>
|
||||
<input type="checkbox" name="create_columns" value=1];
|
||||
print " checked" if $self->{cgi}{create_columns} or not keys %{$self->{cgi}};
|
||||
print qq[>
|
||||
Recreate Non-standard Columns
|
||||
</font>
|
||||
</td>
|
||||
<td valign=top align=left colspan=2>
|
||||
<font face="Tahoma,Arial,Helvetica" size=2>
|
||||
<input type=checkbox name=create_missing_categories value=1];
|
||||
print " checked" if $self->{cgi}{create_missing_categories} or not keys %{$self->{cgi}};
|
||||
print qq[>
|
||||
Create Missing Categories
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="8"><br><center><input type="submit" value="Import Data"></center><br></td>
|
||||
</tr>
|
||||
</table>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<br>
|
||||
|
||||
<form action="nph-import.cgi" method="POST">
|
||||
<input type=hidden name="Interface_CGI" value=1>
|
||||
<input type="hidden" name="source" value="$CFG->{admin_root_path}/defs">
|
||||
<input type="hidden" name="transfer" value="S2BK">
|
||||
<input type="hidden" name="delimiter" value="|">
|
||||
<table border="1" cellspacing="0" cellpadding="0"><tr><td>
|
||||
<table border="0" cellspacing="0" cellpadding="3" width=500>
|
||||
<tr>
|
||||
<td colspan="2" bgcolor="#DDDDDD"><b><font face="Tahoma,Arial,Helvetica" size="2">Create backup file of all Gossamer Links data</font></b></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Location of Backup File:
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<input type="text" name="destination" size="40" ];
|
||||
print qq[value="].html_escape($self->{cgi}{destination}).qq[" ] if $self->{cgi}{destination} && ($self->{cgi}{transfer} eq 'S2BK');
|
||||
print qq[style="font-family: Tahoma, Arial, Helvetica; font-size: 10pt">
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2"><br><center><input type="submit" value="Backup Data"></center><br></td>
|
||||
</tr>
|
||||
</table>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<br>
|
||||
|
||||
<form action="nph-import.cgi" method="POST">
|
||||
<input type=hidden name="Interface_CGI" value=1>
|
||||
<input type="hidden" name="destination" value="$CFG->{admin_root_path}/defs">
|
||||
<input type="hidden" name="transfer" value="BKS2">
|
||||
<input type="hidden" name="delimiter" value="|">
|
||||
<input type="hidden" name="clear_tables" value="1">
|
||||
<table border="1" cellspacing="0" cellpadding="0"><tr><td>
|
||||
<table border="0" cellspacing="0" cellpadding="3" width=500>
|
||||
<tr>
|
||||
<td colspan="2" bgcolor="#DDDDDD"><b><font face="Tahoma,Arial,Helvetica" size="2">Restore Gossamer Links from backup file</font></b></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Location of Backup File:
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<input type="text" name="source" size="40" ];
|
||||
print qq[value="].html_escape($self->{cgi}{source}).qq[" ] if $self->{cgi}{source} && ($self->{cgi}{transfer} eq 'BKS2');
|
||||
print qq[style="font-family: Tahoma, Arial, Helvetica; font-size: 10pt">
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td colspan="2"><br><center><input type="submit" value="Restore Data"></center><br></td>
|
||||
</tr>
|
||||
</table>
|
||||
</td></tr></table>
|
||||
</form>
|
||||
<br><br>
|
||||
|
||||
</form>
|
||||
</body>
|
||||
|
||||
</html>
|
||||
];
|
||||
}
|
||||
|
||||
sub show_help {
|
||||
my $self = shift;
|
||||
_print_headers();
|
||||
print <<'HTML';
|
||||
<html>
|
||||
|
||||
<head>
|
||||
<title>Gossamer Links Import Help</title>
|
||||
</head>
|
||||
|
||||
<body bgcolor="#FFFFFF">
|
||||
<table border="1" cellpadding="0" cellspacing="0"><tr><td>
|
||||
<table bgColor="#ffffff" border="0" cellPadding="3" cellSpacing="3" width="500" valign="top">
|
||||
<tr>
|
||||
<td align="left" bgColor="navy"><b><font color="#ffffff" size="2" face="Tahoma,Arial,Helvetica">Links
|
||||
SQL Import Help</font></b></td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td>
|
||||
<p align="center"><b><font color="#000000" size="2" face="Tahoma,Arial,Helvetica">Links SQL Import Help</font></b></p>
|
||||
<p><font size="2" face="Tahoma,Arial,Helvetica">Below is a list of all the options available to you when importing
|
||||
data into Gossamer Links.</font></td>
|
||||
</tr>
|
||||
</table>
|
||||
</td></tr>
|
||||
</table>
|
||||
<br><br>
|
||||
<table cellpadding="3" cellspacing="0" border="1" width="500">
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<b><u>Column</u></b>
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="center">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
<b><u>Description</u></b>
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Error File:
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
If present, all errors will be written to the filename provided. The
|
||||
errors will be appended to the end, with a header including the date
|
||||
written before any errors.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Show Mild Warnings
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
If this option is selected, 'mild' warnings (indicating minor errors
|
||||
such as setting the username associated with a link to 'admin' because
|
||||
of insufficient information to create a user) will be displayed in the
|
||||
error file. If unchecked, such errors are never displayed.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Critical Warnings
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
If this option is enabled, all warnings (such as not being able to
|
||||
import a Category or Link for whatever reason) will be promoted to
|
||||
critical errors, stopping the import. This field has NO effect on mild
|
||||
warnings - this is, mild warnings will NOT cause the script to abort.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Clear Tables
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
With this option enabled, all tables will be cleared before importing.
|
||||
This has no effect when exporting to a delimited text file.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Straight Import
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
With this option enabled, Link IDs will not be changed for the new
|
||||
database. That is, a Link with ID 12 in the old database will still be
|
||||
12 in the new Gossamer Links database. This option is not recommended unless
|
||||
you are linking directly to a link using its ID and must preserve the
|
||||
existing link numbering. This option <b>requires</b> that the <i>Clear
|
||||
Tables</i> option be enabled.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Show Warnings
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
With this option enabled, all warnings will be displayed to the
|
||||
browser (as well as the log if a log is specified). This option is
|
||||
automatically enabled if no log file is specified.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Recreate Non-standard Columns
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
If this option is enabled, when the import finds extra (custom) columns
|
||||
in the source database that do not have an equivelant extra column in
|
||||
the destination table, they will be created in the destination table so
|
||||
that all data will be imported.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Create Missing Categories
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
This option, if enabled, causes the import to create any categories
|
||||
that are "missing". A category can be missing when a category such as
|
||||
"A/B/C" exists, but the category "A/B" does not. This option will make
|
||||
the import create the "A/B" category, as well as the "A" category (if
|
||||
necessary (i.e. it doesn't exist)).<br>
|
||||
A category is also considered "missing" if a link refers to a category
|
||||
that does not exist (Links 1.x and 2.x only).
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
<tr>
|
||||
<td valign="top" align="left" width="25%">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
Extra Data Integrity
|
||||
</font>
|
||||
</td>
|
||||
<td valign="top" align="left">
|
||||
<font face="Tahoma,Arial,Helvetica" size="2">
|
||||
This option makes the import check each time a category is imported to
|
||||
ensure that no duplicate categories will be created by the import. If a
|
||||
duplicate is identified, the duplicated category will only be inserted
|
||||
once. Note that this option will most likely make the script take
|
||||
several times longer to import data, and should only be used if you
|
||||
suspect that there may be duplicate categories.
|
||||
</font>
|
||||
</td>
|
||||
</tr>
|
||||
</table>
|
||||
</body>
|
||||
|
||||
</html>
|
||||
HTML
|
||||
}
|
||||
|
||||
sub html_pre_format {
|
||||
local $_ = shift;
|
||||
s/&/&/g;
|
||||
s/</</g;
|
||||
s/>/>/g;
|
||||
$_;
|
||||
}
|
||||
|
||||
|
||||
sub _print_headers {
|
||||
# ------------------------------------------------------------------
|
||||
# Prints the HTTP headers. Loads Links config file to see if we
|
||||
# should use nph headers or not.
|
||||
#
|
||||
print $IN->header ( -nph => $CFG->{nph_headers} );
|
||||
}
|
||||
|
||||
"Do I *look* like a false value?"
|
||||
@@ -0,0 +1,294 @@
|
||||
# ==================================================================
|
||||
# Links SQL - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# Revision : $Id: Text.pm,v 1.14 2004/05/04 00:50:09 jagerman 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::Import::Interface::Text;
|
||||
# ==================================================================
|
||||
|
||||
use vars qw/%IMPORT_OPT_MAP/;
|
||||
|
||||
use strict;
|
||||
use Getopt::Long;
|
||||
|
||||
%IMPORT_OPT_MAP = (
|
||||
LINKSSQL1 => 'S1S2',
|
||||
LINKSQL1 => 'S1S2',
|
||||
LINKS1 => 'L1S2',
|
||||
LINKS2 => 'L2S2',
|
||||
S1 => 'S1S2',
|
||||
L2 => 'L2S2',
|
||||
L1 => 'L1S2',
|
||||
LINKS => 'L2S2',
|
||||
RDF => 'RDFS2',
|
||||
DMOZ => 'RDFS2'
|
||||
);
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = { };
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
$self->_init();
|
||||
}
|
||||
|
||||
sub get_options {
|
||||
my $self = shift;
|
||||
my %option = ();
|
||||
my ($backup,$restore,$import);
|
||||
GetOptions(
|
||||
"backup" => \$backup,
|
||||
"restore" => \$restore,
|
||||
"import=s" => \$import,
|
||||
"source=s" => \$option{source},
|
||||
"destination=s" => \$option{destination},
|
||||
"help" => \$option{help},
|
||||
"error-file=s" => \$option{error_file},
|
||||
"critical-warnings" => \$option{critical_warnings},
|
||||
"mild-warnings" => \$option{show_mild_warnings},
|
||||
"data-integrity" => \$option{data_integrity},
|
||||
"create-columns" => \$option{create_columns},
|
||||
"create-missing-categories" => \$option{create_missing_categories},
|
||||
"clear-tables" => \$option{clear_tables},
|
||||
"straight-import" => \$option{straight_import},
|
||||
"rdf-category=s" => \$option{rdf_category},
|
||||
"rdf-destination=s" => \$option{rdf_destination},
|
||||
"rdf-add-date=s" => \$option{rdf_add_date},
|
||||
"with-gzip=s" => \$option{with_gzip},
|
||||
"rdf-update" => \$option{rdf_update},
|
||||
"rdf-user=s" => \$option{rdf_user},
|
||||
"xml-parser!" => \$option{xml_parser}
|
||||
);
|
||||
$option{transfer} = $IMPORT_OPT_MAP{uc $import} || "";
|
||||
unless ($option{from} or $option{to} or $option{source} or $option{destination}) {
|
||||
return wantarray ? () : {};
|
||||
}
|
||||
if (($backup and $restore) or ($backup and $option{transfer}) or ($restore and $option{transfer})) {
|
||||
delete $option{transfer}; # Two options provided!
|
||||
}
|
||||
elsif ($backup) {
|
||||
$option{transfer} = "S2BK";
|
||||
}
|
||||
elsif ($restore) {
|
||||
$option{transfer} = "BKS2";
|
||||
}
|
||||
return wantarray ? %option : \%option;
|
||||
}
|
||||
|
||||
sub start_page {
|
||||
show_help(@_);
|
||||
}
|
||||
|
||||
sub show_help {
|
||||
my $self = shift;
|
||||
print <<HELP;
|
||||
|
||||
Links SQL 2 Importer/Exporter
|
||||
|
||||
Usage:
|
||||
|
||||
perl $0 {--backup|--restore|--import type} --source=<source>
|
||||
--destination=<destination> [any others of the following options]
|
||||
|
||||
Options are (options may be simplified to uniqueness):
|
||||
|
||||
(One of the following three is required)
|
||||
--import Links1|Links2|LinksSQL1|RDF
|
||||
Will do an import from the chosen source.
|
||||
|
||||
--backup
|
||||
This option will perform a Links SQL 2 backup.
|
||||
|
||||
--restore
|
||||
This option will return from a Links SQL 2 backup file created
|
||||
with --backup.
|
||||
|
||||
--source=<input_source> (required)
|
||||
Sets according to the following:
|
||||
--import Links1|Links2
|
||||
the path of the def and db files
|
||||
--import LinksSQL1
|
||||
the path of the def files
|
||||
--import RDF
|
||||
the path and filename of the RDF file to import from.
|
||||
Note that if the file ends in .gz, the import will attempt to run
|
||||
it through gzip decompression trying several standard locations for
|
||||
gzip. You may specify a location for gzip using the --with-gzip
|
||||
option.
|
||||
--restore
|
||||
the path and filename of the backup file created with --backup
|
||||
--backup
|
||||
the path of the Links SQL 2 def files
|
||||
|
||||
--destination=<output_dest> (required)
|
||||
Sets according to the following:
|
||||
--import Links1|Links2|LinksSQL1|RDF
|
||||
--restore
|
||||
the path of the Links SQL 2 def files
|
||||
--backup
|
||||
the path and filename of a file to use for the Links SQL 2 backup.
|
||||
|
||||
--error-file="./error/errors.txt" (not required)
|
||||
Sets a file to which all import errors will be written. If you set it
|
||||
to STDOUT, or if it is not set, it will write all errors to standard
|
||||
output (STDOUT) prepended with "IMPORT ERROR: ".
|
||||
|
||||
--critical-warnings
|
||||
Makes import warnings become fatal errors. Note that relatively minor
|
||||
warnings such as not having enough information to create a new user for
|
||||
a link (therefore setting the link to be owned by admin) are not
|
||||
promoted to fatal errors.
|
||||
|
||||
--mild-warnings
|
||||
Displays mild import warnings. Mild warnings are those that affect a
|
||||
relatively minor portion of the script. Note that mild warnings will
|
||||
NOT cause the script to abort, even if the --critical-warnings option
|
||||
has been enabled.
|
||||
|
||||
--data-integrity
|
||||
Makes the import check every category before inserting it to insure
|
||||
that there are no duplicates. Note that this option will make the
|
||||
import take much longer to complete as each and every category will
|
||||
have to be checked to see if it exists. This option is only recommended
|
||||
if you suspect that your data might contain duplicate categories. It
|
||||
only works when importing data to a Links SQL 2 database from Links
|
||||
1.x, Links 2.x, or Links SQL 1.x (NOT when backing up, restoring, or
|
||||
importing from an RDF).
|
||||
|
||||
--create-columns
|
||||
Makes the import attempt to create any columns which are in the source
|
||||
tables, but NOT in the destination tables. That is, custom tables will
|
||||
be imported into the new Links database. Without this option, existing
|
||||
tables that do not exist in the destination format will cause a
|
||||
warning. If this feature is enabled, a mild warning will occur whenever
|
||||
a table does not exist and is being created.
|
||||
|
||||
--clear-tables
|
||||
(This option is required to use --restore, but optional for --backup
|
||||
and all imports)
|
||||
Makes the current Links SQL tables be cleared (except for the admin
|
||||
user in the Users table) before doing the import. Only takes effect
|
||||
when importing to Links SQL 2. This option allows you to use the
|
||||
--straight-import option below.
|
||||
|
||||
--straight-import
|
||||
(This option can only be used with --clear-tables).
|
||||
Makes the import not recalculate Category/Link ID numbers. That is, a
|
||||
link with ID number 12 in the source will be inserted into the Links
|
||||
SQL 2 database with an ID number of 12. Note that this can leave a
|
||||
fairly large gap in the Links ID fields depending on the usage of the
|
||||
source import. This option does nothing with --backup and --restore
|
||||
|
||||
--create-missing-categories
|
||||
Used with an import. Categories are "missing" when they are required
|
||||
for the database to be complete but do not exist. For example, if
|
||||
category A/B/C existed in the database but A and A/B did not, then both
|
||||
A and A/B would be considered "missing" and would be automatically
|
||||
created if this option is enabled. For Links 1.x and 2.x imports, this
|
||||
will also make the import attempt to create categories that are
|
||||
required for links. For example, if a link exists and thinks it is in
|
||||
category A/B/C but A/B does no exist, A/B and A/B/C will be created to
|
||||
allow the link to be imported.
|
||||
|
||||
--rdf-category="Top/Category/Name"
|
||||
(This option can only be and must be used with `--import RDF')
|
||||
Specifies the RDF category to import such as "Top/Business".
|
||||
|
||||
--rdf-destination="Links SQL2/Category/Name"
|
||||
(This option can only be used with `--import RDF')
|
||||
Specifies a Links SQL 2 category to import the data to. For example,
|
||||
"My Business Links" would import the RDF category specified with
|
||||
--rdf-category into the "My Business Links" category. If this is not
|
||||
specified (or specified as "/" or "") the import will be done into the
|
||||
Links SQL category root.
|
||||
|
||||
--with-gzip="/path/to/gzip"
|
||||
(This option can only be used with `--import RDF')
|
||||
Specifies the location of gzip. This option is only needed if the RDF
|
||||
file has been compressed with gzip (the file will end with ".gz") and
|
||||
the import is unable to locate gzip on its own.
|
||||
|
||||
--rdf-update
|
||||
(This option can only be used with `--import RDF')
|
||||
Specifies that the import should check to see that categories and links
|
||||
do not already exist. For an initial RDF import, this option is not
|
||||
needed, however to update a previous RDF import you MUST use this
|
||||
option; failing to do so would result in duplicate categories and links
|
||||
appearing. It is not recommended that you use this option when
|
||||
performing an initial import from an RDF as it will increase the import
|
||||
time considerably.
|
||||
|
||||
--rdf-user="Username"
|
||||
(This option can only be used with `--import RDF')
|
||||
Specifies a user who all new links should belong to. The user MUST
|
||||
already exist in the Links SQL Users table. If not specified, all links
|
||||
will have `admin' as the LinkOwner. Note that if the --clear-tables
|
||||
option is specified, this user will also be preserved when all tables
|
||||
are wiped.
|
||||
|
||||
--rdf-add-date="2001-01-05"
|
||||
(This option can only be used with `--import RDF' and is required)
|
||||
This sets the date that new link links should have their `Add_Date' and
|
||||
`Mod_Date' fields set to. This should be in the format `YYYY-MM-DD'.
|
||||
NOTE: You should NOT set this to a very recent date as all links would
|
||||
then show up as "New" links.
|
||||
|
||||
--help
|
||||
Displays this screen
|
||||
|
||||
HELP
|
||||
|
||||
# Understood, but often fails as RDF files are commonly malformed:
|
||||
#
|
||||
# --xml-parser
|
||||
# (This option can only be used with `--import RDF')
|
||||
# Attempts to use the new XML::Parser-based code for importing the RDF
|
||||
# file. Although much faster, it requires that the XML::Parser module be
|
||||
# installed, and should be considered an experimental feature.
|
||||
}
|
||||
|
||||
sub pre_import () { }
|
||||
|
||||
sub usage ($$;$) {
|
||||
my $self = shift;
|
||||
$self->{usage_list} = [ ] unless exists $self->{usage_list};
|
||||
my $message = "";
|
||||
if (@_) {
|
||||
$message = shift() . ".";
|
||||
$message .= " See " . shift() . " and --help" if @_;
|
||||
}
|
||||
push @{$self->{usage_list}}, $message if $message;
|
||||
}
|
||||
|
||||
sub has_usage {
|
||||
my $self = shift;
|
||||
return ref($self->{usage_list}) ? scalar @{$self->{usage_list}} : undef;
|
||||
}
|
||||
|
||||
sub show_usage {
|
||||
my $self = shift;
|
||||
for (@{$self->{usage_list}}) { print <<USAGE }
|
||||
|
||||
|
||||
Incorrect usage.
|
||||
|
||||
$_
|
||||
|
||||
USAGE
|
||||
}
|
||||
|
||||
sub finished () {
|
||||
my $self = shift;
|
||||
print "\n\nImport completed successfully\n";
|
||||
exit;
|
||||
}
|
||||
|
||||
"Apparently, I'm true";
|
||||
689
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/L1S2.pm
Normal file
689
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/L1S2.pm
Normal file
@@ -0,0 +1,689 @@
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# Revision : $Id: L1S2.pm,v 1.25 2005/04/16 02:11:50 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::Import::L1S2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_);
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_);
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my ($have_email_db,$have_validate_db);
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $e_prefix = $DB->prefix;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
}
|
||||
|
||||
local (*LINKS,*CATS,*EMAIL,$@,$!,*VALIDATE);
|
||||
|
||||
# Check to see if this should be a Links SQL 1.x import instead of Links 1.x.
|
||||
my $error_msg = "";
|
||||
-e "$$opt{source}/links.cfg" or $error_msg .= "$$opt{source}/links.cfg does not exist.";
|
||||
-e "$$opt{source}/Links.def" and $error_msg .= " $$opt{source}/Links.def DOES exist. Perhaps you meant to import Links SQL 1.x instead of Links 1.x?";
|
||||
critical $error_msg if $error_msg;
|
||||
|
||||
my $did = do {
|
||||
package Links1::Def::Links; # Avoid namespace pollution
|
||||
do "$$opt{source}/links.cfg";
|
||||
};
|
||||
!$did and $! and critical "Cannot open $$opt{source}/links.cfg (This error may result from links.def): $!".($@ ? ", ".substr($@,0,length($@)-1) : "");
|
||||
!$did and $@ and critical "Cannot parse $$opt{source}/links.cfg (This error may result from links.def): $@";
|
||||
$Links1::Def::Links::db_file_name or critical "links.cfg did not load correctly. Import aborted.";
|
||||
|
||||
$did = do {
|
||||
package Links1::Def::Category;
|
||||
local $ENV{PATH_INFO} = "/category";
|
||||
do "$$opt{source}/links.cfg";
|
||||
};
|
||||
!$did and $! and critical "Cannot open $$opt{source}/links.cfg (This error may result from category.def): $!".($@ ? ", ".substr($@,0,length($@)-1) : "");
|
||||
!$did and $@ and critical "Cannot parse $$opt{source}/links.cfg (This error may result from category.def): $@";
|
||||
$Links1::Def::Category::db_file_name or critical "links.cfg did not load correctly. Import aborted.";
|
||||
|
||||
open CATS, "<$Links1::Def::Category::db_file_name" or critical "Unable to open $Links1::Def::Links::db_file_name: $!";
|
||||
open LINKS, "<$Links1::Def::Links::db_file_name" or critical "Unable to open $Links1::Def::Links::db_file_name: $!";
|
||||
if (open VALIDATE, "<$Links1::Def::Links::db_valid_name") {
|
||||
$have_validate_db = 1;
|
||||
}
|
||||
else {
|
||||
warning "Could not open $Links1::Def::Links::db_valid_name: $!. Non-validated links will not be imported.";
|
||||
}
|
||||
|
||||
my %e_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name FatherID Full_Name Description Meta_Description Meta_Keywords Header Footer Category_Template Number_of_Links Has_New_Links Has_Changed_Links Newest_Link Timestmp Payment_Mode/},
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL LinkOwner Add_Date Mod_Date Description Contact_Name Contact_Email Hits isNew isChanged isPopular isValidated Rating Votes Status Date_Checked Timestmp ExpiryDate ExpiryCounted ExpiryNotify/},
|
||||
);
|
||||
|
||||
my %e_non_standard_cols;
|
||||
for my $table (keys %e_standard_cols) {
|
||||
my %cols = $DB->table($table)->cols;
|
||||
for (grep !$e_standard_cols{$table}{$_}, keys %cols) {
|
||||
$e_non_standard_cols{$table}{$_} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my %i_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name Description Related Header Footer/,'Meta Description','Meta Keywords' },
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL Date Category Description Hits isNew isPopular/,'Contact Name','Contact Email'}
|
||||
);
|
||||
|
||||
my %i_non_standard_cols;
|
||||
$i_non_standard_cols{Links} = { map { !$i_standard_cols{Links}{$_} ? ($_ => 1) : () } @Links1::Def::Links::db_cols };
|
||||
$i_non_standard_cols{Category} = { map { !$i_standard_cols{Category}{$_} ? ($_ => 1) : () } @Links1::Def::Category::db_cols };
|
||||
|
||||
my $Links_counter;
|
||||
my $Category_counter;
|
||||
if (($DB->table('Links')->{connect}->{driver} || "") eq "ODBC") {
|
||||
$e_dbh->do("SET IDENTITY_INSERT Links ON");
|
||||
$e_dbh->do("SET IDENTITY_INSERT Category ON");
|
||||
}
|
||||
|
||||
if ($$opt{clear_tables}) {
|
||||
# Delete everything from all tables, EXCEPT for the `admin' user from the Users table
|
||||
$e_dbh->do("DELETE FROM ${e_prefix}Users WHERE Username <> 'admin'") or critical "Unable to delete all existing users: ".$e_dbh->errstr;
|
||||
for (qw/Links Category CatLinks CatRelations Category_Score_List
|
||||
Category_Word_List ClickTrack Editors EmailMailings EmailTemplates
|
||||
Links_Score_List Links_Word_List MailingIndex MailingList
|
||||
MailingListIndex Sessions Verify/) {
|
||||
$e_dbh->do("DELETE FROM $e_prefix$_");
|
||||
}
|
||||
unless ($$opt{straight_import}) {
|
||||
$Links_counter = $Category_counter = 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Links") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$sth->errstr;
|
||||
$Links_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
|
||||
$sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$sth->errstr;
|
||||
$Category_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
|
||||
# Categories
|
||||
my %cat_map; # $cat_map{name} = new_id
|
||||
my @num_of_links; # $num_of_links[category_id] = (the number of links in that category)
|
||||
|
||||
{
|
||||
my @cat_get_cols = ('ID','Name','Related', 'Description','Meta Description','Meta Keywords','Header','Footer');
|
||||
my $cat_ins_cols = "(ID, Name, FatherID, Full_Name, Description, Meta_Description, Meta_Keywords, Header, Footer";
|
||||
my $cat_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
# Build up extra fields that exist in both old and new Category tables
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Category"}}) {
|
||||
if ($i_non_standard_cols{Category}{$_}) {
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
push @cat_get_cols, $_;
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Category.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Category"}{$_}, keys %{$i_non_standard_cols{Category}}) {
|
||||
if ($opt->{create_columns}) {
|
||||
if (/\W/) {
|
||||
critical "Custom import column `Category.$_' cannot be imported because is is not a valid column name. You will need to rename the column name in the def file and in any relevant templates to a new name consisting only of letters, numbers, and the _ character.";
|
||||
next;
|
||||
}
|
||||
mild_warning("Custom import column `Category.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Category");
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => 'TEXT',
|
||||
size => $Links1::Def::Category::db_max_field_length,
|
||||
($Links1::Def::Category::db_not_null{$_} ? (not_null => 1) : ()),
|
||||
($Links1::Def::Category::db_defaults{$_} ? (default => $Links1::Def::Category::db_defaults{$_}) : ()),
|
||||
($Links1::Def::Category::db_valid_types{$_} ? (regex => $Links1::Def::Category::db_valid_types{$_}) : ()),
|
||||
}
|
||||
);
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
push @cat_get_cols, $_;
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Category"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Category.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$cat_ins_cols .= ")";
|
||||
$cat_ins_vals .= ")";
|
||||
|
||||
my $add_cat_relation = $e_dbh->prepare("INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)': ".$e_dbh->errstr;
|
||||
my $count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
my $cat_ins_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals': ".$e_dbh->errstr);
|
||||
my $cat_ins_simple_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr;
|
||||
my $get_id_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
|
||||
my @cat_relations;
|
||||
|
||||
my $cat_imported = 0;
|
||||
import_print "\nImporting Categories ...\n";
|
||||
my @cat_data;
|
||||
while (my $row = get_rec(\*CATS,'Category',\@Links1::Def::Category::db_cols,"|",\@cat_get_cols)) {
|
||||
push @cat_data, $row if ref $row eq 'ARRAY';
|
||||
}
|
||||
|
||||
@cat_data = sort { $a->[1] cmp $b->[1] } @cat_data;
|
||||
|
||||
my @missing_cats;
|
||||
my %missing_cats;
|
||||
for my $row (@cat_data) {
|
||||
$row = [@$row];
|
||||
my $old_id = shift @$row;
|
||||
my $new_id = $$opt{straight_import} ? $old_id : ++$Category_counter;
|
||||
my ($name) = (my $full_name = shift @$row) =~ m[([^/]*)\Z];
|
||||
unless (defined $name and length $name) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Cannot insert Category $full_name because it is an invalid name";
|
||||
next;
|
||||
}
|
||||
my ($father_full_name) = $full_name =~ m[\A(.*)/];
|
||||
my $father_id;
|
||||
if (not defined $father_full_name) {
|
||||
$father_id = 0;
|
||||
}
|
||||
else {
|
||||
$get_id_sth->execute($father_full_name) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_id_sth->errstr;
|
||||
if (my $ar = $get_id_sth->fetchrow_arrayref()) {
|
||||
$father_id = $ar->[0] || 0;
|
||||
}
|
||||
else {
|
||||
if ($$opt{create_missing_categories}) {
|
||||
unless ($missing_cats{$father_full_name}++) {
|
||||
unshift @missing_cats, $father_full_name;
|
||||
mild_warning "$father_full_name is needed for category $full_name and does not exist. It will be created";
|
||||
my $fn = $father_full_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array or $missing_cats{$fn}++) { # It exists
|
||||
last;
|
||||
}
|
||||
else {
|
||||
unshift @missing_cats, $fn;
|
||||
mild_warning "$fn is needed for category $full_name and does not exist. It will be created";
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
mild_warning "$father_full_name is also needed for category $full_name and is already in the queue to be created.";
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning "No father row found for $full_name! This may be a serious error as $full_name should probably have a father category";
|
||||
}
|
||||
$father_id = 0;
|
||||
}
|
||||
}
|
||||
|
||||
$cat_relations[$new_id] = shift @$row; # This has to be dealt with later.
|
||||
|
||||
if ($$opt{data_integrity}) {
|
||||
$count_cats_sth->execute($full_name) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
unless ($count_cats_sth->fetchrow_array) {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr;
|
||||
next;
|
||||
}
|
||||
import_print "$cat_imported\n" unless ++$cat_imported % 500;
|
||||
$cat_map{$full_name} = $new_id;
|
||||
$num_of_links[$new_id] = 0;
|
||||
}
|
||||
else {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
mild_warning("Duplicate category found ($full_name) and skipped");
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
warning("Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr);
|
||||
next;
|
||||
}
|
||||
import_print "$cat_imported\n" unless ++$cat_imported % 500;
|
||||
$cat_map{$full_name} = $new_id;
|
||||
$num_of_links[$new_id] = 0;
|
||||
}
|
||||
}
|
||||
my $missing_cats;
|
||||
if ($$opt{create_missing_categories} and @missing_cats) {
|
||||
my $counter = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category");
|
||||
$counter->execute();
|
||||
my $ins_id = $counter->fetchrow_array();
|
||||
my $update_sub_cats = $e_dbh->prepare("UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?': ".$e_dbh->errstr;
|
||||
for (@missing_cats) {
|
||||
my ($name) = m[([^/]*)\Z];
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$get_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_id_sth->errstr;
|
||||
$father_id = $get_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be a category of root
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$update_sub_cats->execute($ins_id,"$_/%","$_/%/%") or critical "Unable to execute query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? and Full_Name NOT LIKE ?': ".$update_sub_cats->errstr;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
|
||||
import_print "$cat_imported Categories imported";
|
||||
import_print ", $missing_cats missing categories created" if $missing_cats;
|
||||
import_print ".\n";
|
||||
|
||||
# Category Relations
|
||||
import_print "\nImporting Category Relations ...\n";
|
||||
my $cat_rel_imported = 0;
|
||||
for my $cat_id (0..$#cat_relations) {
|
||||
next unless defined $cat_relations[$cat_id];
|
||||
my @cats = split /\|/, $cat_relations[$cat_id];
|
||||
for (@cats) {
|
||||
$get_id_sth->execute($_) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_id_sth->errstr;
|
||||
my $rel_id = $get_id_sth->fetchrow_array;
|
||||
if (defined $rel_id) {
|
||||
unless ($add_cat_relation->execute($cat_id,$rel_id)) {
|
||||
warning "Unable to execute query `INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)': ".$add_cat_relation->errstr;
|
||||
}
|
||||
else {
|
||||
import_print "$cat_rel_imported\n" unless ++$cat_rel_imported % 500;
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning "Unable to add category relation for category with ID $cat_id and `$_'. Reason: Category `$_' not found in database.";
|
||||
}
|
||||
}
|
||||
}
|
||||
import_print "$cat_rel_imported Category Relations imported.\n";
|
||||
}
|
||||
# Links
|
||||
{
|
||||
my @links_get_cols = ('ID','Category','Date','Contact Name','Contact Email', qw/Title URL Description Hits isNew isPopular/);
|
||||
my $links_ins_cols = "(ID, LinkOwner, isValidated, Add_Date, Mod_Date, Contact_Name, Contact_Email, Title, URL, Description, Hits, isNew, isPopular";
|
||||
my $links_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Links"}}) {
|
||||
if ($i_non_standard_cols{Links}{$_}) {
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
push @links_get_cols, $_;
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Links.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep $e_standard_cols{Links}{$_}, keys %{$i_non_standard_cols{Links}}) {
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
push @links_get_cols, $_;
|
||||
}
|
||||
for (grep +(!$e_standard_cols{Links} and !$e_non_standard_cols{"${e_prefix}Links"}{$_}), keys %{$i_non_standard_cols{Links}}) {
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Links.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Links");
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => 'TEXT',
|
||||
size => $Links1::Def::Links::db_max_field_length,
|
||||
($Links1::Def::Links::db_not_null{$_} ? (not_null => 1) : ()),
|
||||
($Links1::Def::Links::db_defaults{$_} ? (default => $Links1::Def::Links::db_defaults{$_}) : ()),
|
||||
($Links1::Def::Links::db_valid_types{$_} ? (regex => $Links1::Def::Links::db_valid_types{$_}) : ()),
|
||||
}
|
||||
) or critical("Unable to add column $_: $GT::SQL::error");
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
push @links_get_cols, $_;
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Links"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Links.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$links_ins_cols .= ")";
|
||||
$links_ins_vals .= ")";
|
||||
my $user_ins_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Registered')") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Registered')': ".$e_dbh->errstr);
|
||||
my $cat_links_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$e_dbh->errstr);
|
||||
my $insert_link_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals': ".$e_dbh->errstr);
|
||||
|
||||
my $user_count_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
my $username_sth = $e_dbh->prepare("SELECT Username FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT Username FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
|
||||
# What other than the Name and ReceiveMail can be updated here?
|
||||
my $user_mod_sth = $e_dbh->prepare("UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$e_dbh->errstr;
|
||||
|
||||
my $num_links_sth = $e_dbh->prepare("UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$e_dbh->errstr;
|
||||
|
||||
my ($count_cats_sth,$get_cat_id_sth,$cat_ins_simple_sth);
|
||||
my $ins_id;
|
||||
if ($$opt{create_missing_categories}) {
|
||||
$count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
$get_cat_id_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
$cat_ins_simple_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr;
|
||||
my $counter = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category");
|
||||
$counter->execute();
|
||||
$ins_id = $counter->fetchrow_array();
|
||||
}
|
||||
|
||||
import_print "\nImporting Links ...\n";
|
||||
my $links_imported = 0;
|
||||
my $missing_cats = 0;
|
||||
my @more_needed; # This will hold any missing categories (such as A/B in A/B/C)
|
||||
LINK: while (my $row = get_rec(\*LINKS,'Links',\@Links1::Def::Links::db_cols,"|",\@links_get_cols)) {
|
||||
$row = [@$row]; # Remove aliasing
|
||||
my ($id, $cat_name, $date, $contact_name, $contact_email) = splice @$row,0,5;
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
$date = convert_date($date) or warning("Invalid date `$date' for link with ID $id. Link skipped."),next;
|
||||
$id = ++$Links_counter unless $$opt{straight_import};
|
||||
my $cat_id = $cat_map{$cat_name};
|
||||
unless (defined $cat_id) {
|
||||
if ($$opt{create_missing_categories} and $cat_name) {
|
||||
my @needed = my $fn = $cat_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
last;
|
||||
}
|
||||
else {
|
||||
unshift @needed, $fn;
|
||||
}
|
||||
}
|
||||
for (@needed) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
unless ($name) {
|
||||
warning "Unable to create category $_ because it is an invalid name. Link ID $id will be skipped as a result.";
|
||||
last;
|
||||
}
|
||||
mild_warning("Creating category $_ as it is needed by link ID $id");
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$get_cat_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_cat_id_sth->errstr;
|
||||
$father_id = $get_cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be a root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$cat_id = $ins_id;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning("Invalid category `$cat_name' for link $$row[0] (ID: $id, line $.). Link skipped"),next unless defined $cat_id;
|
||||
}
|
||||
}
|
||||
next LINK unless defined $cat_id;
|
||||
my $username;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_arrayref()->[0]) { # This e-mail address already exists
|
||||
$user_mod_sth->execute($contact_name, $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
}
|
||||
elsif ($contact_email) {
|
||||
$user_ins_sth->execute(($contact_email) x 2, (defined $contact_name ? $contact_name : ""), 'Yes') or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Registered')': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else {
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
if ($insert_link_sth->execute($id,$username,'Yes',$date,$date,@$row)) {
|
||||
$cat_links_sth->execute($id,$cat_id) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
$num_of_links[$cat_id]++;
|
||||
|
||||
import_print "$links_imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter-- unless $$opt{straight_import};
|
||||
warning("Unable to insert link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals'): ".$insert_link_sth->errstr);
|
||||
}
|
||||
}
|
||||
import_print "$links_imported records from 'Links' imported.\n";
|
||||
|
||||
if ($have_validate_db) {
|
||||
$links_imported = 0;
|
||||
import_print "Importing records from 'Validate'.\n";
|
||||
|
||||
LINK: while(my $row = get_rec(\*VALIDATE,'Links',\@Links1::Def::Links::db_cols,"|",\@links_get_cols)) {
|
||||
$row = [@$row]; # Remove aliasing
|
||||
my ($id, $cat_name, $date, $contact_name, $contact_email) = splice @$row,0,5;
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
$date = convert_date($date) or warning("Invalid date `$date' for link with ID $id. Link skipped."),next;
|
||||
$id = ++$Links_counter unless $$opt{straight_import};
|
||||
my $cat_id = $cat_map{$cat_name};
|
||||
unless (defined $cat_id) {
|
||||
if ($$opt{create_missing_categories} and $cat_name) {
|
||||
my @needed = my $fn = $cat_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
last;
|
||||
}
|
||||
else {
|
||||
unshift @needed, $fn;
|
||||
}
|
||||
}
|
||||
for (@needed) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
unless ($name) {
|
||||
warning "Unable to create category $_ because it is an invalid name. Link ID $id will be skipped as a result.";
|
||||
last;
|
||||
}
|
||||
mild_warning("Creating category $_ as it is needed by link ID $id");
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$get_cat_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_cat_id_sth->errstr;
|
||||
$father_id = $get_cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be a root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$cat_id = $ins_id;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning("Invalid category `$cat_name' for link $$row[0] (ID: $id, line $.). Link skipped"),next unless defined $cat_id;
|
||||
}
|
||||
}
|
||||
next LINK unless defined $cat_id;
|
||||
my $username;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_arrayref()->[0]) { # This e-mail address already exists
|
||||
$user_mod_sth->execute($contact_name, 'Yes', $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
}
|
||||
elsif ($contact_email) {
|
||||
$user_ins_sth->execute(($contact_email) x 2, (defined $contact_name ? $contact_name : ""), 'Yes') or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Registered')': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else {
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
if ($insert_link_sth->execute($id,$username,'No',$date,$date,@$row)) {
|
||||
$cat_links_sth->execute($id,$cat_id) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
$num_of_links[$cat_id]++;
|
||||
|
||||
import_print "$links_imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter-- unless $$opt{straight_import};
|
||||
warning("Unable to insert link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals'): ".$insert_link_sth->errstr);
|
||||
}
|
||||
}
|
||||
import_print "$links_imported records from 'Validate' imported.\n";
|
||||
}
|
||||
|
||||
import_print "$missing_cats categories have been created due to missing categories for links\n" if $missing_cats;
|
||||
|
||||
for (grep $num_of_links[$_], 0..$#num_of_links) {
|
||||
$num_links_sth->execute($num_of_links[$_],$_) or warning "Unable to execute query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$num_links_sth->errstr;
|
||||
}
|
||||
}
|
||||
$e_dbh->disconnect;
|
||||
import_print "\nNOTE: You must run Rebuild Cat. tree, Repair Tables, and Rebuild Search after performing an import!\n";
|
||||
}
|
||||
|
||||
# Takes 4 options: a glob ref containing an opened filehandle, a table name, a
|
||||
# hash ref, a scalar delimiter, and (optionally) an array of fields to return.
|
||||
# The table name should be 'Links', 'CatRelations', 'Category', or 'Sessions'.
|
||||
# If you give it the fields, it will come back with an array (or array ref) of
|
||||
# the values for those fields in the order specified.
|
||||
# Otherwise, it will return a hash ref (or hash in list context) of the fields
|
||||
# in column => value format.
|
||||
#
|
||||
# Call it as %rec = get_rec(\*FH, $table_name, \@db_cols, $delimiter, \@fields);
|
||||
# You can, if you prefer, also make the delimiter a scalar reference.
|
||||
# @db_cols should be the @db_cols from Links 1.x.
|
||||
sub get_rec {
|
||||
defined wantarray or return; # Don't bother doing anything in void context
|
||||
my $fh = shift;
|
||||
my $table_name = shift;
|
||||
my $db_cols = shift;
|
||||
my $delimiter = ref $_[0] eq 'SCALAR' ? ${shift()} : shift;
|
||||
my ($fields,@fields,%fields);
|
||||
if (@_) {
|
||||
$fields = 1;
|
||||
@fields = ref $_[0] eq 'ARRAY' ? @{shift()} : @_;
|
||||
%fields = map { ($_ => 1) } @fields;
|
||||
}
|
||||
defined fileno($fh) or critical "Interal error: File handle passed to get_rec() is not an opened file";
|
||||
|
||||
local $/ = "\n";
|
||||
my $line;
|
||||
until (defined $line) {
|
||||
$line = <$fh>;
|
||||
return unless defined $line; # Catch the end of the file.
|
||||
chomp $line;
|
||||
$line ||= undef; # skip blanks
|
||||
}
|
||||
my $i = 0;
|
||||
my @rec = split /\Q$delimiter/, $line, -1;
|
||||
my %rec;
|
||||
for (@rec) {
|
||||
s/``/\n/g;
|
||||
s/~~/|/g;
|
||||
$_ = undef if $_ eq 'NULL';
|
||||
}
|
||||
for (0..$#rec) {
|
||||
if (defined $db_cols->[$_] and (!$fields or $fields{$db_cols->[$_]})) { # Skip "extra" and unwanted records
|
||||
$rec{$db_cols->[$_]} = $rec[$_];
|
||||
}
|
||||
}
|
||||
if ($table_name eq 'Links') {
|
||||
$rec{Category} =~ y/_/ / if $rec{Category};
|
||||
}
|
||||
elsif ($table_name eq 'Category') {
|
||||
$rec{Name} =~ y/_/ / if $rec{Name};
|
||||
$rec{Related} =~ y/_/ / if $rec{Related};
|
||||
}
|
||||
|
||||
$fields or return wantarray ? %rec : \%rec;
|
||||
my @ret = map $rec{$_}, @fields;
|
||||
return wantarray ? @ret : \@ret;
|
||||
}
|
||||
|
||||
# Converts a date. Returns false if the date is invalid.
|
||||
sub convert_date ($) {
|
||||
my $in = shift;
|
||||
my ($day, $mon, $year) = split /-/, $in, 3;
|
||||
my %months = qw(Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06 Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12);
|
||||
# Any extra fields needed should be set like this:
|
||||
# $months{Okt} = "10";
|
||||
# $months{Mai} = "05";
|
||||
# $months{Dez} = "12";
|
||||
#
|
||||
$day = sprintf "%02d", $day;
|
||||
$year = sprintf "%04d", $year;
|
||||
if ($year and $months{$mon} and $day) {
|
||||
return sprintf("%04d-$months{$mon}-%02d", $year, $day);
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Returns a random password of random length (20-25 characters).
|
||||
sub random_pass () {
|
||||
my @chars = ('a'..'z','A'..'Z',0..9,qw a _ [ ] { } ` ' " ! @ ^ * ( ) - _ = + : ; . / \ a,'#',',');
|
||||
my $pass = join '', map { $chars[rand @chars] } 0..(20+rand(5));
|
||||
}
|
||||
|
||||
"True or not true? That is the question."
|
||||
814
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/L2S2.pm
Normal file
814
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/L2S2.pm
Normal file
@@ -0,0 +1,814 @@
|
||||
# ==================================================================
|
||||
# Gossamer Links - enhanced directory management system
|
||||
#
|
||||
# Website : http://gossamer-threads.com/
|
||||
# Support : http://gossamer-threads.com/scripts/support/
|
||||
# Revision : $Id: L2S2.pm,v 1.39 2005/04/16 02:11:50 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::Import::L2S2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use GT::SQL;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_);
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_);
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my ($have_email_db,$have_validate_db);
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $e_prefix = $DB->prefix;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
}
|
||||
|
||||
local (*LINKS,*CATS,*EMAIL,$@,$!,*VALIDATE);
|
||||
my $did = do {
|
||||
package Links2::Def::Category; # Avoid namespace pollution
|
||||
do "$$opt{source}/category.def";
|
||||
};
|
||||
!$did and $@ and critical "Cannot parse $$opt{source}/category.def: $@";
|
||||
!$did and $! and critical "Cannot open $$opt{source}/category.def: $!";
|
||||
open CATS, "<$$opt{source}/data/categories.db" or critical "Unable to open $$opt{source}/data/categories.db: $!";
|
||||
$did = do {
|
||||
package Links2::Def::Links;
|
||||
do "$$opt{source}/links.def";
|
||||
};
|
||||
!$did and $@ and critical "Cannot parse $$opt{source}/links.def: $@";
|
||||
!$did and $! and critical "Cannot open $$opt{source}/links.def: $!";
|
||||
open LINKS, "<$$opt{source}/data/links.db" or critical "Unable to open $$opt{source}/data/links.db: $!";
|
||||
if (open VALIDATE, "<$$opt{source}/data/validate.db") {
|
||||
$have_validate_db = 1;
|
||||
}
|
||||
else {
|
||||
warning "Could not open $$opt{source}/data/validate.db: $!. Non-validated links will not be imported.";
|
||||
}
|
||||
if (open EMAIL, "$$opt{source}/data/email.db") {
|
||||
$have_email_db = 1;
|
||||
}
|
||||
else {
|
||||
warning "Could not open $$opt{source}/data/email.db: $!. No newsletter users will be imported.";
|
||||
}
|
||||
|
||||
my %e_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name FatherID Full_Name Description Meta_Description Meta_Keywords Header Footer Category_Template Number_of_Links Has_New_Links Has_Changed_Links Newest_Link Timestmp Payment_Mode/},
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL LinkOwner Add_Date Mod_Date Description Contact_Name Contact_Email Hits isNew isChanged isPopular isValidated Rating Votes Status Date_Checked Timestmp ExpiryDate ExpiryCounted ExpiryNotify/},
|
||||
);
|
||||
|
||||
my %e_non_standard_cols;
|
||||
for my $table (keys %e_standard_cols) {
|
||||
my %cols = $DB->table($table)->cols;
|
||||
for (grep !$e_standard_cols{$table}{$_}, keys %cols) {
|
||||
$e_non_standard_cols{$table}{$_} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my %i_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name Description Related Header Footer/,'Meta Description','Meta Keywords' },
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL Date Category Description Hits isNew isPopular Rating Votes ReceiveMail/,'Contact Name','Contact Email'}
|
||||
);
|
||||
|
||||
my %i_non_standard_cols;
|
||||
$i_non_standard_cols{Links} = { map { !$i_standard_cols{Links}{$_} ? ($_ => 1) : () } keys %Links2::Def::Links::db_def };
|
||||
$i_non_standard_cols{Category} = { map { !$i_standard_cols{Category}{$_} ? ($_ => 1) : () } keys %Links2::Def::Category::db_def };
|
||||
|
||||
my $alt_categories = delete $i_non_standard_cols{Links}{AltCategories};
|
||||
|
||||
my $Links_counter;
|
||||
my $Category_counter;
|
||||
my $odbc = 0;
|
||||
if ($DB->table('Links')->{connect}->{driver} eq 'ODBC') {
|
||||
$odbc = 1;
|
||||
}
|
||||
|
||||
if ($$opt{clear_tables}) {
|
||||
# Delete everything from all tables, EXCEPT for the `admin' user from the Users table
|
||||
$e_dbh->do("DELETE FROM ${e_prefix}Users WHERE Username <> 'admin'") or critical "Unable to delete all existing users: ".$e_dbh->errstr;
|
||||
for (qw/Links Category CatLinks CatRelations Category_Score_List
|
||||
Category_Word_List ClickTrack Editors EmailMailings EmailTemplates
|
||||
Links_Score_List Links_Word_List MailingIndex MailingList
|
||||
MailingListIndex Sessions Verify/) {
|
||||
$e_dbh->do("DELETE FROM $e_prefix$_");
|
||||
}
|
||||
unless ($$opt{straight_import}) {
|
||||
$Links_counter = $Category_counter = 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Links") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$sth->errstr;
|
||||
$Links_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
|
||||
$sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$sth->errstr;
|
||||
$Category_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
# Subscribe users - these users receive the newsletter.
|
||||
if ($have_email_db) {
|
||||
my $count_users = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?");
|
||||
my $add_user = $e_dbh->prepare("INSERT INTO ${e_prefix}Users (Name, Username, Password, Email, ReceiveMail) VALUES (?, ?, ?, ?, 'Yes')");
|
||||
my $give_newsletter = $e_dbh->prepare("UPDATE ${e_prefix}Users SET ReceiveMail = 'Yes' WHERE Email = ?");
|
||||
|
||||
my $sub_imported = 0;
|
||||
import_print "\nImporting Subscribe users (newsletter receivers) ...\n";
|
||||
while (<EMAIL>) {
|
||||
chomp;
|
||||
my ($email,$name) = split /\|/;
|
||||
$name ||= "";
|
||||
$count_users->execute($email) or warning("Unable to count users with email $email: ".$count_users->errstr), next;
|
||||
if ($count_users->fetchrow_array) {
|
||||
$give_newsletter->execute($email) or warning("Unable to set ReceiveMail = 'Yes' for user with e-mail $email: ".$give_newsletter->errstr),--$sub_imported;
|
||||
}
|
||||
else { # User doesn't already exist
|
||||
$add_user->execute($name, $email, random_pass(), $email) or warning("Unable to insert user $email: ".$add_user->errstr),--$sub_imported;
|
||||
}
|
||||
import_print "$sub_imported\n" unless ++$sub_imported % 500;
|
||||
}
|
||||
import_print "$sub_imported Subscribed users imported.\n";
|
||||
}
|
||||
|
||||
|
||||
# Categories
|
||||
my %cat_map; # $cat_map{name} = new_id
|
||||
my @num_of_links; # $num_of_links[category_id] = (the number of links in that category)
|
||||
|
||||
{
|
||||
my @cat_get_cols = ('ID','Name','Related', 'Description','Meta Description','Meta Keywords','Header','Footer');
|
||||
my $cat_ins_cols = "(ID, Name, FatherID, Full_Name, Description, Meta_Description, Meta_Keywords, Header, Footer";
|
||||
my $cat_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
# Build up extra fields that exist in both old and new Category tables
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Category"}}) {
|
||||
if ($i_non_standard_cols{Category}{$_}) {
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
push @cat_get_cols, $_;
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Category.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Category"}{$_}, keys %{$i_non_standard_cols{Category}}) {
|
||||
if ($opt->{create_columns}) {
|
||||
if (/\W/) {
|
||||
critical "Custom import column `Category.$_' cannot be imported because is is not a valid column name. You will need to rename the column name in the def file and in any relevant templates to a new name consisting only of letters, numbers, and the _ character.";
|
||||
next;
|
||||
}
|
||||
mild_warning("Custom import column `Category.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Category");
|
||||
my @def = @{$Links2::Def::Category::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'ALPHA' and $def[3] > 255) ? 'TEXT' : 'CHAR'),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ()),
|
||||
}
|
||||
);
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
push @cat_get_cols, $_;
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Category"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Category.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$cat_ins_cols .= ")";
|
||||
$cat_ins_vals .= ")";
|
||||
|
||||
my $add_cat_relation = $e_dbh->prepare("INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)': ".$e_dbh->errstr;
|
||||
my $count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
my $cat_ins_sth = $odbc
|
||||
? ($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals': ".$e_dbh->errstr))
|
||||
: ($e_dbh->prepare("INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals': ".$e_dbh->errstr));
|
||||
|
||||
my $cat_ins_simple_sth = $odbc
|
||||
? ($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr))
|
||||
: ($e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr));
|
||||
|
||||
my $get_id_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
|
||||
{
|
||||
my ($no_warning) = (
|
||||
$Links2::Def::Category::db_delim,
|
||||
$Links2::Def::Links::db_delim
|
||||
)
|
||||
}
|
||||
|
||||
my @cat_relations;
|
||||
|
||||
my $cat_imported = 0;
|
||||
import_print "\nImporting Categories ...\n";
|
||||
my @cat_data;
|
||||
while (my $row = get_rec(\*CATS,'Category',\%Links2::Def::Category::db_def,\$Links2::Def::Category::db_delim,\@cat_get_cols)) {
|
||||
push @cat_data, $row if ref $row eq 'ARRAY';
|
||||
}
|
||||
|
||||
@cat_data = sort { $a->[0] cmp $b->[0] } @cat_data;
|
||||
|
||||
my @missing_cats;
|
||||
my %missing_cats;
|
||||
for my $row (@cat_data) {
|
||||
$row = [@$row];
|
||||
my $old_id = shift @$row;
|
||||
my $new_id = $$opt{straight_import} ? $old_id : ++$Category_counter;
|
||||
my ($name) = (my $full_name = shift @$row) =~ m[([^/]*)\Z];
|
||||
unless (defined $name and length $name) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Cannot insert Category $full_name because it is an invalid name";
|
||||
next;
|
||||
}
|
||||
my ($father_full_name) = $full_name =~ m[\A(.*)/];
|
||||
my $father_id;
|
||||
if (not defined $father_full_name) {
|
||||
$father_id = 0;
|
||||
}
|
||||
else {
|
||||
$get_id_sth->execute($father_full_name) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_id_sth->errstr;
|
||||
if (my $ar = $get_id_sth->fetchrow_arrayref()) {
|
||||
$father_id = $ar->[0] || 0;
|
||||
}
|
||||
else {
|
||||
my $ins_pos = @missing_cats;
|
||||
if ($$opt{create_missing_categories}) {
|
||||
unless ($missing_cats{$father_full_name}++) {
|
||||
splice @missing_cats, $ins_pos, 0, $father_full_name;
|
||||
mild_warning "$father_full_name is needed for category $full_name and does not exist. It will be created";
|
||||
my $fn = $father_full_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array or $missing_cats{$fn}++) { # It exists
|
||||
$count_cats_sth->finish;
|
||||
last;
|
||||
}
|
||||
else {
|
||||
splice @missing_cats, $ins_pos, 0, $fn;
|
||||
mild_warning "$fn is needed for category $full_name and does not exist. It will be created";
|
||||
$count_cats_sth->finish;
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
mild_warning "$father_full_name is also needed for category $full_name and is already in the queue to be created.";
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning "No father row found for $full_name! This may be a serious error as $full_name should probably have a father category";
|
||||
}
|
||||
$father_id = 0;
|
||||
}
|
||||
$get_id_sth->finish;
|
||||
}
|
||||
|
||||
$cat_relations[$new_id] = shift @$row; # This has to be dealt with later.
|
||||
|
||||
if ($$opt{data_integrity}) {
|
||||
$count_cats_sth->execute($full_name) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
unless ($count_cats_sth->fetchrow_array) {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr;
|
||||
$count_cats_sth->finish;
|
||||
next;
|
||||
}
|
||||
import_print "$cat_imported\n" unless ++$cat_imported % 500;
|
||||
$cat_map{$full_name} = $new_id;
|
||||
$num_of_links[$new_id] = 0;
|
||||
$count_cats_sth->finish;
|
||||
}
|
||||
else {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
mild_warning("Duplicate category found ($full_name) and skipped");
|
||||
$count_cats_sth->finish;
|
||||
next;
|
||||
}
|
||||
}
|
||||
elsif (!$cat_map{$full_name}) {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
warning("Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr);
|
||||
next;
|
||||
}
|
||||
import_print "$cat_imported\n" unless ++$cat_imported % 500;
|
||||
$cat_map{$full_name} = $new_id;
|
||||
$num_of_links[$new_id] = 0;
|
||||
}
|
||||
else {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
mild_warning("Duplicate category found ($full_name) and skipped");
|
||||
next;
|
||||
}
|
||||
}
|
||||
my $missing_cats;
|
||||
if ($$opt{create_missing_categories} and @missing_cats) {
|
||||
my $counter = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category");
|
||||
$counter->execute();
|
||||
my $ins_id = $counter->fetchrow_array();
|
||||
my $update_sub_cats = $e_dbh->prepare("UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?': ".$e_dbh->errstr;
|
||||
for (@missing_cats) {
|
||||
if ($cat_map{$_}) { # Already exists
|
||||
$update_sub_cats->execute($cat_map{$_},"$_/%","$_/%/%") or critical "Unable to execute query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? and Full_Name NOT LIKE ?': ".$update_sub_cats->errstr;
|
||||
next;
|
||||
}
|
||||
my ($name) = m[([^/]*)\Z];
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full and exists $cat_map{$father_full}) {
|
||||
$father_id = $cat_map{$father_full};
|
||||
}
|
||||
elsif ($father_full) {
|
||||
$get_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_id_sth->errstr;
|
||||
$father_id = $get_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be a category of root
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$update_sub_cats->execute($ins_id,"$_/%","$_/%/%") or critical "Unable to execute query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? and Full_Name NOT LIKE ?': ".$update_sub_cats->errstr;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
|
||||
import_print "$cat_imported Categories imported";
|
||||
import_print ", $missing_cats missing categories created" if $missing_cats;
|
||||
import_print ".\n";
|
||||
|
||||
# Category Relations
|
||||
import_print "\nImporting Category Relations ...\n";
|
||||
my $cat_rel_imported = 0;
|
||||
for my $cat_id (0..$#cat_relations) {
|
||||
next unless defined $cat_relations[$cat_id];
|
||||
my @cats = split /\Q$Links2::Def::Category::db_delim/, $cat_relations[$cat_id];
|
||||
for (@cats) {
|
||||
$get_id_sth->execute($_) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ? <- $_': ".$get_id_sth->errstr;
|
||||
my $rel_id = $get_id_sth->fetchrow_array;
|
||||
if (defined $rel_id) {
|
||||
unless ($add_cat_relation->execute($cat_id,$rel_id)) {
|
||||
warning "Unable to execute query `INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)': ".$add_cat_relation->errstr;
|
||||
}
|
||||
else {
|
||||
import_print "$cat_rel_imported\n" unless ++$cat_rel_imported % 500;
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning "Unable to add category relation for category with ID $cat_id and `$_'. Reason: Category `$_' not found in database.";
|
||||
}
|
||||
$get_id_sth->finish;
|
||||
}
|
||||
}
|
||||
import_print "$cat_rel_imported Category Relations imported.\n";
|
||||
}
|
||||
# Links
|
||||
{
|
||||
my @links_get_cols = ('ID','Category','Date','Contact Name','Contact Email','ReceiveMail', qw/Title URL Description Hits isNew isPopular Rating Votes/);
|
||||
my $links_ins_cols = "(ID, LinkOwner, isValidated, Add_Date, Mod_Date, Contact_Name, Contact_Email, Title, URL, Description, Hits, isNew, isPopular, Rating, Votes";
|
||||
my $links_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Links"}}) {
|
||||
if ($i_non_standard_cols{Links}{$_}) {
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
push @links_get_cols, $_;
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Links.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Links"}{$_}, keys %{$i_non_standard_cols{Links}}) {
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Links.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Links");
|
||||
my @def = @{$Links2::Def::Links::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'ALPHA' and $def[3] > 255) ? 'TEXT' : 'CHAR'),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ())
|
||||
}
|
||||
);
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
push @links_get_cols, $_;
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Links"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Links.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$links_ins_cols .= ")";
|
||||
$links_ins_vals .= ")";
|
||||
|
||||
unshift @links_get_cols, "AltCategories" if $alt_categories;
|
||||
|
||||
my $user_ins_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Users (Password, Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')': ".$e_dbh->errstr);
|
||||
my $cat_links_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$e_dbh->errstr);
|
||||
my $insert_link_sth = $odbc
|
||||
? ($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Links ON; INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals': ".$e_dbh->errstr))
|
||||
: ($e_dbh->prepare("INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals': ".$e_dbh->errstr));
|
||||
|
||||
|
||||
my $user_count_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
my $username_sth = $e_dbh->prepare("SELECT Username FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT Username FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
|
||||
# What other than the Name and ReceiveMail can be updated here?
|
||||
my $user_mod_sth = $e_dbh->prepare("UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$e_dbh->errstr;
|
||||
|
||||
my $num_links_sth = $e_dbh->prepare("UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$e_dbh->errstr;
|
||||
|
||||
my ($count_cats_sth,$get_cat_id_sth,$cat_ins_simple_sth);
|
||||
my $ins_id;
|
||||
if ($$opt{create_missing_categories}) {
|
||||
$count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
$get_cat_id_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
$cat_ins_simple_sth = $odbc
|
||||
? ($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr)
|
||||
: ($e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr);
|
||||
my $counter = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category");
|
||||
$counter->execute();
|
||||
$ins_id = $counter->fetchrow_array();
|
||||
}
|
||||
|
||||
import_print "\nImporting Links ...\n";
|
||||
my $links_imported = 0;
|
||||
my $missing_cats = 0;
|
||||
my @more_needed; # This will hold any missing categories (such as A/B in A/B/C)
|
||||
LINK: while (my $row = get_rec(\*LINKS,'Links',\%Links2::Def::Links::db_def,\$Links2::Def::Links::db_delim,\@links_get_cols)) {
|
||||
$row = [@$row]; # Remove aliasing
|
||||
my $alt_cats;
|
||||
$alt_cats = shift @$row if $alt_categories;
|
||||
my ($id, $cat_name, $date, $contact_name, $contact_email, $receive_mail) = splice @$row,0,6;
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
$date = convert_date($date) or warning("Invalid date for link with ID $id. Link skipped."),next;
|
||||
$id = ++$Links_counter unless $$opt{straight_import};
|
||||
my @category_alternates;
|
||||
if ($alt_categories) {
|
||||
@category_alternates = split /\Q$Links2::Def::Links::db_delim/, $alt_cats;
|
||||
for (@category_alternates) { y/_/ / }
|
||||
my %dups;
|
||||
# Get rid of duplicates
|
||||
@category_alternates = grep !$dups{$_}++, @category_alternates;
|
||||
}
|
||||
my @cats = ($cat_name,@category_alternates);
|
||||
my @cat_ids = @cat_map{@cats};
|
||||
my $bad_cats = 0;
|
||||
for my $j (0..$#cats) {
|
||||
my $cat_id = $cat_ids[$j];
|
||||
my $cat_name = $cats[$j];
|
||||
unless (defined $cat_id) {
|
||||
if ($$opt{create_missing_categories} and $cat_name) {
|
||||
my @needed = my $fn = $cat_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
$count_cats_sth->finish;
|
||||
last;
|
||||
}
|
||||
else {
|
||||
$count_cats_sth->finish;
|
||||
unshift @needed, $fn;
|
||||
}
|
||||
}
|
||||
for (@needed) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
unless ($name) {
|
||||
warning "Unable to create category $_ because it is an invalid name.";
|
||||
$bad_cats++;
|
||||
last;
|
||||
}
|
||||
mild_warning("Creating category $_ as it is needed by link ID $id");
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$get_cat_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_cat_id_sth->errstr;
|
||||
$father_id = $get_cat_id_sth->fetchrow_array;
|
||||
$get_cat_id_sth->finish;
|
||||
}
|
||||
else { # Must be a root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$cat_ids[$j] = $ins_id;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$bad_cats++;
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($bad_cats == @cat_ids) { # Between the category and the alternate categories, there has to be at least ONE good one.
|
||||
if (@cat_ids == 1) {
|
||||
warning "Invalid category `$cat_ids[0]' for link $$row[0] (ID: $id, line $.). Link skipped";
|
||||
next LINK;
|
||||
}
|
||||
else {
|
||||
warning "No valid categories ($cat_name @category_alternates) for link $$row[0] (ID: $id, line $.). Link skipped";
|
||||
next LINK;
|
||||
}
|
||||
}
|
||||
my $username;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_arrayref()->[0]) { # This e-mail address already exists
|
||||
$user_mod_sth->execute($contact_name, ($receive_mail eq 'Yes' ? 'Yes' : 'No'), $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
$username_sth->finish;
|
||||
}
|
||||
elsif ($contact_email) {
|
||||
$user_ins_sth->execute('', ($contact_email) x 2, (defined $contact_name ? $contact_name : ""), ($receive_mail eq 'Yes' ? 'Yes' : 'No')) or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else {
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
$user_count_sth->finish;
|
||||
if ($insert_link_sth->execute($id,$username,'Yes',$date,$date,@$row)) {
|
||||
for my $cat_id (@cat_ids) {
|
||||
$cat_links_sth->execute($id,$cat_id) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
$num_of_links[$cat_id]++;
|
||||
}
|
||||
import_print "$links_imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter-- unless $$opt{straight_import};
|
||||
warning("Unable to insert link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals'): ".$insert_link_sth->errstr);
|
||||
}
|
||||
}
|
||||
import_print "$links_imported records from 'Links' imported.\n";
|
||||
|
||||
if ($have_validate_db) {
|
||||
$links_imported = 0;
|
||||
import_print "Importing records from 'Validate'.\n";
|
||||
|
||||
LINK: while(my $row = get_rec(\*VALIDATE,'Links',\%Links2::Def::Links::db_def,\$Links2::Def::Links::db_delim,\@links_get_cols)) {
|
||||
$row = [@$row]; # Remove aliasing
|
||||
my $alt_cats;
|
||||
$alt_cats = shift @$row if $alt_categories;
|
||||
my ($id, $cat_name, $date, $contact_name, $contact_email, $receive_mail) = splice @$row,0,6;
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
$date = convert_date($date) or warning("Invalid date `$date' for link with ID $id. Link skipped."),next;
|
||||
$id = ++$Links_counter unless $$opt{straight_import};
|
||||
|
||||
my @category_alternates;
|
||||
if ($alt_categories) {
|
||||
@category_alternates = split /\Q$Links2::Def::Links::db_delim/, $alt_cats;
|
||||
}
|
||||
my @cats = ($cat_name,@category_alternates);
|
||||
my @cat_ids = @cat_map{@cats};
|
||||
my $bad_cats = 0;
|
||||
for (0..$#cats) {
|
||||
my $cat_id = $cat_ids[$_];
|
||||
my $cat_name = $cats[$_];
|
||||
unless (defined $cat_id) {
|
||||
if ($$opt{create_missing_categories} and $cat_name) {
|
||||
my @needed = my $fn = $cat_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
$count_cats_sth->finish;
|
||||
last;
|
||||
}
|
||||
else {
|
||||
$count_cats_sth->finish;
|
||||
unshift @needed, $fn;
|
||||
}
|
||||
}
|
||||
for (@needed) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
unless ($name) {
|
||||
warning "Unable to create category $_ because it is an invalid name.";
|
||||
$bad_cats++;
|
||||
last;
|
||||
}
|
||||
mild_warning("Creating category $_ as it is needed by link ID $id");
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$get_cat_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$get_cat_id_sth->errstr;
|
||||
$father_id = $get_cat_id_sth->fetchrow_array;
|
||||
$get_cat_id_sth->finish;
|
||||
}
|
||||
else { # Must be a root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$ins_id,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$cat_map{$_} = $ins_id;
|
||||
$cat_id = $ins_id;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$bad_cats++;
|
||||
}
|
||||
}
|
||||
}
|
||||
if ($bad_cats == @cat_ids) { # Between the category and the alternate categories, there has to be at least ONE good one.
|
||||
if (@cat_ids == 1) {
|
||||
warning "Invalid category `$cat_ids[0]' for link $$row[0] (ID: $id, line $.). Link skipped";
|
||||
next LINK;
|
||||
}
|
||||
else {
|
||||
warning "No valid categories ($cat_name @category_alternates) for link $$row[0] (ID: $id, line $.). Link skipped";
|
||||
next LINK;
|
||||
}
|
||||
}
|
||||
|
||||
my $username;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_arrayref()->[0]) { # This e-mail address already exists
|
||||
$user_mod_sth->execute($contact_name, ($receive_mail eq 'Yes' ? 'Yes' : 'No'), $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
$username_sth->finish;
|
||||
}
|
||||
elsif ($contact_email) {
|
||||
$user_ins_sth->execute('', ($contact_email) x 2, (defined $contact_name ? $contact_name : ""), ($receive_mail eq 'Yes' ? 'Yes' : 'No')) or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else {
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
$user_count_sth->finish;
|
||||
if ($insert_link_sth->execute($id,$username,'No',$date,$date,@$row)) {
|
||||
for my $cat_id (@cat_ids) {
|
||||
next if (! defined $cat_id);
|
||||
$cat_links_sth->execute($id,$cat_id) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
$num_of_links[$cat_id]++;
|
||||
}
|
||||
import_print "$links_imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter-- unless $$opt{straight_import};
|
||||
warning("Unable to insert link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals'): ".$insert_link_sth->errstr);
|
||||
}
|
||||
}
|
||||
import_print "$links_imported records from 'Validate' imported.\n";
|
||||
}
|
||||
|
||||
import_print "$missing_cats categories have been created due to missing categories for links\n" if $missing_cats;
|
||||
|
||||
for (grep $num_of_links[$_], 0..$#num_of_links) {
|
||||
$num_links_sth->execute($num_of_links[$_],$_) or warning "Unable to execute query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$num_links_sth->errstr;
|
||||
}
|
||||
}
|
||||
$e_dbh->disconnect;
|
||||
import_print "\nNOTE: You must run Rebuild Cat. tree, Repair Tables, and Rebuild Search after performing an import!\n";
|
||||
}
|
||||
|
||||
# Takes 4 options: a glob ref containing an opened filehandle, a table name, a
|
||||
# hash ref, a scalar delimiter, and (optionally) an array of fields to return.
|
||||
# The table name should be 'Links', 'CatRelations', 'Category', or 'Sessions'.
|
||||
# If you give it the fields, it will come back with an array (or array ref) of
|
||||
# the values for those fields in the order specified.
|
||||
# Otherwise, it will return a hash ref (or hash in list context) of the fields
|
||||
# in column => value format.
|
||||
#
|
||||
# Call it as %rec = get_rec(\*FH, $table_name, \%db_def, $delimiter, \@fields);
|
||||
# You can, if you prefer, also make the delimiter a scalar reference.
|
||||
# The hash should be the %db_def used in Links 2.x.
|
||||
sub get_rec {
|
||||
defined wantarray or return; # Don't bother doing anything in void context
|
||||
my $fh = shift;
|
||||
my $table_name = shift;
|
||||
my $db_def = shift;
|
||||
my $delimiter = ref $_[0] eq 'SCALAR' ? ${shift()} : shift;
|
||||
my ($fields,@fields,%fields);
|
||||
if (@_) {
|
||||
$fields = 1;
|
||||
@fields = ref $_[0] eq 'ARRAY' ? @{shift()} : @_;
|
||||
%fields = map { ($_ => 1) } @fields;
|
||||
}
|
||||
defined fileno($fh) or critical "Interal error: File handle passed to get_rec() is not an opened file";
|
||||
|
||||
my @mapping = sort { $db_def->{$a}[0] <=> $db_def->{$b}[0] } keys %$db_def;
|
||||
local $/ = "\n";
|
||||
my $line;
|
||||
until (defined $line) {
|
||||
$line = <$fh>;
|
||||
return unless defined $line; # Catch the end of the file.
|
||||
chomp $line;
|
||||
$line ||= undef;
|
||||
}
|
||||
my $i = 0;
|
||||
my @rec = split /\Q$delimiter/, $line, -1;
|
||||
my %rec;
|
||||
for (@rec) {
|
||||
s/``/\n/g;
|
||||
s/~~/|/g;
|
||||
$_ = undef if $_ eq 'NULL';
|
||||
}
|
||||
for (0..$#rec) {
|
||||
if (defined $mapping[$_] and (!$fields or $fields{$mapping[$_]})) { # Skip "extra" and unwanted records
|
||||
$rec{$mapping[$_]} = $rec[$_];
|
||||
}
|
||||
}
|
||||
if ($table_name eq 'Links') {
|
||||
$rec{Category} =~ y/_/ / if $rec{Category};
|
||||
$rec{Hits} ||= 0 if exists $rec{Hits}; # Fix for Links 2 database having the Hits table removed
|
||||
}
|
||||
elsif ($table_name eq 'Category') {
|
||||
$rec{Name} =~ y/_/ / if $rec{Name};
|
||||
$rec{Related} =~ y/_/ / if $rec{Related};
|
||||
}
|
||||
|
||||
$fields or return wantarray ? %rec : \%rec;
|
||||
my @ret = map $rec{$_}, @fields;
|
||||
return wantarray ? @ret : \@ret;
|
||||
}
|
||||
|
||||
# Converts a date. Returns false if the date is invalid.
|
||||
sub convert_date ($) {
|
||||
my $in = shift;
|
||||
my ($day, $mon, $year) = split /-/, $in, 3;
|
||||
my %months = qw(Jan 01 Feb 02 Mar 03 Apr 04 May 05 Jun 06 Jul 07 Aug 08 Sep 09 Oct 10 Nov 11 Dec 12);
|
||||
# Any extra fields needed should be set like this:
|
||||
# $months{Okt} = "10";
|
||||
# $months{Mai} = "05";
|
||||
# $months{Dez} = "12";
|
||||
#
|
||||
if ($year and $months{$mon} and $day) {
|
||||
return sprintf("%04d-$months{$mon}-%02d", $year, $day);
|
||||
} else {
|
||||
warning "Invalid date `$in' encountered.";
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Returns a random password of random length (20-25 characters).
|
||||
sub random_pass () {
|
||||
my @chars = ('a'..'z','A'..'Z',0..9,qw a _ [ ] { } ` ' " ! @ ^ * ( ) - _ = + : ; . / \ a,'#',',');
|
||||
my $pass = join '', map { $chars[rand @chars] } 0..(20+rand(5));
|
||||
}
|
||||
|
||||
"True or not true? That is the question."
|
||||
533
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/RDFS2.pm
Normal file
533
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/RDFS2.pm
Normal file
@@ -0,0 +1,533 @@
|
||||
# ==================================================================
|
||||
# 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: RDFS2.pm,v 1.20 2005/04/07 19:34:41 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::Import::RDFS2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use DBI;
|
||||
use GT::SQL;
|
||||
use GT::RDF;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_);
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_);
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $e_prefix = $DB->prefix;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
}
|
||||
|
||||
my $Links_counter;
|
||||
my $Category_counter;
|
||||
my $odbc = 0;
|
||||
if (($DB->table('Links')->{connect}{driver} || "") eq "ODBC") {
|
||||
$odbc = 1;
|
||||
# Set max read properties for DBI.
|
||||
$e_dbh->{LongReadLen} = 1000000;
|
||||
}
|
||||
|
||||
if ($$opt{clear_tables}) {
|
||||
# Delete everything from all tables, EXCEPT for the `admin' user from the Users table.
|
||||
# Also ignore --rdf-user if specified.
|
||||
if ($$opt{rdf_user}) {
|
||||
my $sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Username = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Username = ?': ".$e_dbh->errstr;
|
||||
$sth->execute($$opt{rdf_user}) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Username = ?': ".$sth->errstr;
|
||||
if ($sth->fetchrow_array) {
|
||||
$e_dbh->do("DELETE FROM ${e_prefix}Users WHERE Username <> 'admin' AND Username <> ".$e_dbh->quote($$opt{rdf_user}));
|
||||
}
|
||||
else {
|
||||
critical "The rdf username that you specified ($$opt{rdf_user}) does not exist. Please create the user.";
|
||||
}
|
||||
}
|
||||
else {
|
||||
$e_dbh->do("DELETE FROM ${e_prefix}Users WHERE Username <> 'admin'") or critical "Unable to delete all existing users: ".$e_dbh->errstr;
|
||||
}
|
||||
for (qw/Links Category CatLinks CatRelations Category_Score_List
|
||||
Category_Word_List ClickTrack Editors EmailMailings EmailTemplates
|
||||
Links_Score_List Links_Word_List MailingIndex MailingList
|
||||
MailingListIndex Verify/) {
|
||||
$e_dbh->do("DELETE FROM $e_prefix$_");
|
||||
}
|
||||
unless ($$opt{straight_import}) {
|
||||
$Links_counter = $Category_counter = 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Links") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$e_dbh->errstr;
|
||||
$sth->execute() or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$sth->errstr;
|
||||
$Links_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
|
||||
$sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$e_dbh->errstr;
|
||||
$sth->execute() or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$sth->errstr;
|
||||
$Category_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
my $gzip = $$opt{with_gzip};
|
||||
my $need_gz = -B $$opt{source}; # Tests if the file is binary.
|
||||
|
||||
my $is_win = $^O =~ /win/i;
|
||||
|
||||
my $gzip_filename = $is_win ? "gzip.exe" : "gzip";
|
||||
|
||||
if (not $gzip and $need_gz) {
|
||||
# Try to find gzip
|
||||
my $dir_sep = $is_win ? ";" : ":";
|
||||
my @locations = split /$dir_sep/, $ENV{PATH};
|
||||
for (@locations) {
|
||||
-x "$_/$gzip_filename" and $gzip = "$_/$gzip_filename", last;
|
||||
}
|
||||
$gzip or critical "\nUnable to locate gzip (Searched @locations). Please specify with --with-gzip=\"/path/to/gzip\"";
|
||||
}
|
||||
elsif ($gzip and -d $gzip) {
|
||||
if (-x "$gzip/$gzip_filename") {
|
||||
$gzip = "$gzip/$gzip_filename";
|
||||
}
|
||||
else {
|
||||
critical "\nThe directory $gzip does not contain a valid gzip program";
|
||||
}
|
||||
}
|
||||
if ($need_gz) {
|
||||
-x $gzip or critical "\nUnable to find an executable gzip";
|
||||
}
|
||||
|
||||
my $rdf = \do { local *FH; *FH };
|
||||
|
||||
if ($$opt{with_gzip} or $need_gz) {
|
||||
import_print "\nOpening uncompressed stream from gzip compressed file `$$opt{source}' ...\n";
|
||||
open $rdf, " $gzip -c -d $$opt{source} |" or critical "Unable to open `$gzip -c -d $$opt{source} |': $!";
|
||||
}
|
||||
else {
|
||||
import_print "\nOpening stream from non-compressed file `$$opt{source}' ...\n";
|
||||
open $rdf, "<$$opt{source}" or critical "Unable to open $$opt{source}: $!";
|
||||
}
|
||||
|
||||
import_print "Stream opened.\n";
|
||||
# Do the import
|
||||
{
|
||||
my $count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
my $cat_id_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical "Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr;
|
||||
|
||||
my $cat_ins_sth = $odbc
|
||||
? $e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID, Number_of_Links, Has_New_Links, Has_Changed_Links) VALUES (?, ?, ?, ?, 0, 'No', 'No')")
|
||||
: $e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID, Number_of_Links, Has_New_Links, Has_Changed_Links) VALUES (?, ?, ?, ?, 0, 'No', 'No')");
|
||||
$cat_ins_sth or critical "Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr;
|
||||
|
||||
my $sub_cats_sth = $e_dbh->prepare("UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?': ".$e_dbh->errstr;
|
||||
my $get_num_links_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}CatLinks WHERE CategoryID = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}CatLinks WHERE CategoryID = ?': ".$e_dbh->errstr;
|
||||
my $num_links_sth = $e_dbh->prepare("UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$e_dbh->errstr;
|
||||
|
||||
my $insert_link_sth = $odbc
|
||||
? $e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Links ON; INSERT INTO ${e_prefix}Links (ID, Title, URL, Add_Date, Mod_Date, Description, LinkOwner, Status, Votes, Rating, Hits) VALUES (?, ?, ?, ?, ?, ?, ".$e_dbh->quote($$opt{rdf_user} or "admin").",0,0,0,0)")
|
||||
: $e_dbh->prepare("INSERT INTO ${e_prefix}Links (ID, Title, URL, Add_Date, Mod_Date, Description, LinkOwner, Status, Votes, Rating, Hits) VALUES (?, ?, ?, ?, ?, ?, ".$e_dbh->quote($$opt{rdf_user} or "admin").",0,0,0,0)");
|
||||
$insert_link_sth or critical "Unable to prepare query `INSERT INTO ${e_prefix}Links (Title, URL, Add_Date, Mod_Date, Description, LinkOwner) VALUES (?, ?, ?, ?, ?, ?)': ".$e_dbh->errstr;
|
||||
|
||||
my $link_exists_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Links, ${e_prefix}CatLinks WHERE URL = ? AND CategoryID = ? AND ID = LinkID") or critical "Unable to prepare query `SELECT * FROM Links, CatLinks WHERE URL = ? AND CategoryID = ? AND ID = LinkID': ".$e_dbh->errstr;
|
||||
|
||||
my $cat_links_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$e_dbh->errstr;
|
||||
|
||||
my $count_links_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}CatLinks WHERE CategoryID = ?") or critical "Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}CatLinks WHERE CategoryID = ?': ".$e_dbh->errstr;
|
||||
|
||||
import_print "\nImporting from $$opt{source}\n";
|
||||
my $links_imported = 0;
|
||||
my $cats_imported = 0;
|
||||
my %cat_needs_num; # $cat_needs_num{cat_id} = 1 if the category needs to have its Number_Of_Links updated
|
||||
|
||||
my $base_cat = $$opt{rdf_destination};
|
||||
my $base_cat_id;
|
||||
if (defined $base_cat) {
|
||||
$base_cat =~ s|//+|/|g; # Remove doubled (and more) slashes
|
||||
$base_cat =~ s|^/+||; # Remove any leading slashes
|
||||
$base_cat =~ s|/+$||; # And any trailing ones
|
||||
}
|
||||
else {
|
||||
$base_cat = "";
|
||||
}
|
||||
if (length $base_cat) {
|
||||
$count_cats_sth->execute($base_cat) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) {
|
||||
$cat_id_sth->execute($base_cat) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$cat_id_sth->errstr;
|
||||
$base_cat_id = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Category doesn't exist
|
||||
my @missing_cats = $base_cat;
|
||||
mild_warning "$base_cat does not exist and is being created";
|
||||
my $fn = $base_cat;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
last;
|
||||
}
|
||||
else {
|
||||
unshift @missing_cats, $fn;
|
||||
mild_warning "$fn is needed for base category $base_cat and does not exist. It will be created";
|
||||
}
|
||||
}
|
||||
for (@missing_cats) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$cat_id_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$cat_id_sth->errstr;
|
||||
$father_id = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be the root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_sth->execute(++$Category_counter,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_sth->errstr;
|
||||
$cats_imported++;
|
||||
$sub_cats_sth->execute($Category_counter,"$_/%","$_/%/%") or critical "Unable to execute query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? and Full_Name NOT LIKE ?': ".$sub_cats_sth->errstr;
|
||||
}
|
||||
$base_cat_id = $Category_counter; # The last one inserted will be the category import base
|
||||
}
|
||||
}
|
||||
else {
|
||||
$base_cat_id = 0;
|
||||
}
|
||||
my $cat = $$opt{rdf_category};
|
||||
|
||||
|
||||
# -------------------------------------------------------------------
|
||||
# Main code, get a parser object and start parsing!
|
||||
#
|
||||
# New for 2.2.0 - XML::Parser-based code, which should be significantly faster.
|
||||
# It should, however, still be considered experimental.
|
||||
#
|
||||
if ($$opt{xml_parser}) {
|
||||
require XML::Parser;
|
||||
my (%links, %want, %current, @in);
|
||||
my $last_status = -1;
|
||||
my $insert_cat = sub {
|
||||
my $cat_name = $current{category};
|
||||
|
||||
# If we are under ODBC we need to reset the sth handle to avoid a "Invalid Cursor State" error.
|
||||
$odbc and $count_cats_sth->finish;
|
||||
|
||||
# Check to make sure we haven't seen this category before
|
||||
# Set $found to the category ID.
|
||||
$count_cats_sth->execute($cat_name) or critical "Execute: $DBI::errstr";
|
||||
if ($count_cats_sth->fetchrow_array) {
|
||||
$cat_id_sth->finish if ($odbc); # Need to reset cursor under odbc.
|
||||
$cat_id_sth->execute($cat_name) or critical "Execute: $DBI::errstr";
|
||||
$current{cat_id} = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else {
|
||||
my ($father_name, $short_name) = $current{category} =~ m|(?:(.*)/)?([^/]+)$|;
|
||||
my $father_id;
|
||||
if ($father_name) {
|
||||
$cat_id_sth->finish if ($odbc); # Need to reset cursor under odbc.
|
||||
$cat_id_sth->execute($father_name) or critical "Execute: $DBI::errstr";
|
||||
$father_id = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else {
|
||||
$father_id = 0;
|
||||
}
|
||||
|
||||
$cat_ins_sth->execute(++$Category_counter, $short_name, $current{category}, $father_id) or critical "Execute: $DBI::errstr";
|
||||
$cats_imported++;
|
||||
$current{cat_id} = $Category_counter;
|
||||
}
|
||||
|
||||
for my $link (keys %links) {
|
||||
# Either append, or insert new link.
|
||||
if ($$opt{rdf_update}) {
|
||||
$link_exists_sth->execute($link, $current{cat_id}) or critical "Execute: $DBI::errstr";
|
||||
next if $link_exists_sth->fetchrow;
|
||||
}
|
||||
# Title can only be 100 characters (ODBC fatals about data that is too long).
|
||||
my $title = substr($links{$link}->{title} || $link, 0, 100);
|
||||
$insert_link_sth->execute(++$Links_counter, $title, $link, $$opt{rdf_add_date}, $$opt{rdf_add_date}, $links{$link}->{description} || "") or critical "Execute: $DBI::errstr";
|
||||
$cat_links_sth->execute($Links_counter, $current{cat_id}) or critical "Execute: $DBI::errstr";
|
||||
$cat_needs_num{$current{cat_id}} = 1;
|
||||
$links_imported++;
|
||||
}
|
||||
%links = ();
|
||||
return scalar keys %links;
|
||||
};
|
||||
|
||||
my $parser = XML::Parser->new(
|
||||
Handlers => {
|
||||
Start => sub {
|
||||
my ($parser, $tag, %attr) = @_;
|
||||
if ($tag eq 'Topic') {
|
||||
{
|
||||
my $disp_topic = $attr{'r:id'};
|
||||
substr($disp_topic, 30) = '...' if length $disp_topic > 33;
|
||||
my $padding = " " x (33 - length $disp_topic);
|
||||
$disp_topic = "(L:$links_imported, C:$cats_imported) $disp_topic$padding";
|
||||
import_print("\r$disp_topic");
|
||||
}
|
||||
if ($current{category}) {
|
||||
my $cat_count = $insert_cat->();
|
||||
import_print "$cat_count ";
|
||||
}
|
||||
my $dmoz_cat = $attr{'r:id'};
|
||||
if ($dmoz_cat =~ /^\Q$cat\E(.*)/) {
|
||||
my $topic = $base_cat . '/' . $1;
|
||||
$topic =~ s|/{2,}|/|g;
|
||||
$topic =~ s|^/||;
|
||||
$topic =~ s|/$||;
|
||||
$topic =~ y|_| |;
|
||||
$current{category} = $topic;
|
||||
}
|
||||
else {
|
||||
delete $current{category};
|
||||
import_print "skipping";
|
||||
}
|
||||
}
|
||||
elsif ($tag eq 'link' and $in[-1] eq 'Topic' and $current{category} and $attr{'r:resource'}) {
|
||||
$links{$attr{'r:resource'}} = {};
|
||||
}
|
||||
elsif ($tag eq 'ExternalPage' and $current{category} and $attr{about}) {
|
||||
$current{ExternalPage} = $attr{about};
|
||||
}
|
||||
elsif ($tag eq 'd:Title' and $in[-1] eq 'ExternalPage' and $current{ExternalPage}) {
|
||||
$want{title} = \$links{$current{ExternalPage}}->{title};
|
||||
}
|
||||
elsif ($tag eq 'd:Description' and $in[-1] eq 'ExternalPage' and $current{ExternalPage}) {
|
||||
$want{description} = \$links{$current{ExternalPage}}->{description};
|
||||
}
|
||||
|
||||
push @in, $tag;
|
||||
},
|
||||
End => sub {
|
||||
my ($parser, $tag) = @_;
|
||||
pop @in;
|
||||
if ($tag eq 'd:Description') {
|
||||
delete $want{description};
|
||||
}
|
||||
elsif ($tag eq 'd:Title') {
|
||||
delete $want{title};
|
||||
}
|
||||
},
|
||||
Char => sub {
|
||||
my ($parser, $text) = @_;
|
||||
if ($want{title}) {
|
||||
${$want{title}} = $text;
|
||||
}
|
||||
elsif ($want{description}) {
|
||||
${$want{description}} = $text;
|
||||
}
|
||||
}
|
||||
}
|
||||
);
|
||||
|
||||
$parser->parse($rdf, ProtocolEncoding => 'ISO-8859-1');
|
||||
}
|
||||
else {
|
||||
my $parse = GT::RDF->new (io => $rdf);
|
||||
my ($found, $was_found, %links);
|
||||
my $cat_count = 0;
|
||||
my $first = 0;
|
||||
|
||||
while ($parse->parse) {
|
||||
|
||||
# Either we have a topic, external page or unknown.
|
||||
if ($parse->{name} eq 'Topic') {
|
||||
|
||||
# Add extra links that did not have external page info.
|
||||
if (defined $found) {
|
||||
foreach my $link (keys %links) {
|
||||
if ($$opt{rdf_update}) {
|
||||
$link_exists_sth->execute($parse->{attribs}{about},$found) or critical "Execute: $DBI::errstr";
|
||||
unless ($link_exists_sth->fetchrow_array) {
|
||||
$insert_link_sth->execute(++$Links_counter, $link, $link, $$opt{rdf_add_date}, $$opt{rdf_add_date}, "") or critical "Execute: $DBI::errstr";
|
||||
$cat_links_sth->execute($Links_counter, $found) or critical "Execute: $DBI::errstr";
|
||||
$cat_needs_num{$found} = 1;
|
||||
$links_imported++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$insert_link_sth->execute(++$Links_counter, $link, $link, $$opt{rdf_add_date}, $$opt{rdf_add_date}, "") or critical "Execute: $DBI::errstr";
|
||||
$cat_links_sth->execute($Links_counter, $found) or critical "Execute: $DBI::errstr";
|
||||
$cat_needs_num{$found} = 1;
|
||||
$links_imported++;
|
||||
}
|
||||
}
|
||||
import_print "$cat_count ";
|
||||
}
|
||||
else {
|
||||
import_print "skipping" if $first++;
|
||||
}
|
||||
|
||||
# Clear out our links hash, and set found to undef.
|
||||
$cat_count = 0;
|
||||
%links = ();
|
||||
$was_found = $found;
|
||||
$found = undef;
|
||||
|
||||
# We've finished a topic, start a new one.
|
||||
my $dmoz_cat = $parse->{attribs}{'r:id'};
|
||||
if ($dmoz_cat =~ /^\Q$cat\E(.*)/) {
|
||||
my $topic = $base_cat . '/' . $1;
|
||||
$topic =~ s|//+|/|g;
|
||||
$topic =~ s|^/||;
|
||||
$topic =~ s|/$||;
|
||||
$topic =~ s|_| |g;
|
||||
if ($topic) {
|
||||
|
||||
# If we are under ODBC we need to reset the sth handle to avoid a "Invalid Cursor State" error.
|
||||
$odbc and ($count_cats_sth->finish);
|
||||
|
||||
# Check to make sure we haven't seen this category before
|
||||
# Set $found to the category ID.
|
||||
$count_cats_sth->execute($topic) or critical "Execute: $DBI::errstr";
|
||||
if ($count_cats_sth->fetchrow_array) {
|
||||
$cat_id_sth->finish if ($odbc); # Need to reset cursor under odbc.
|
||||
$cat_id_sth->execute($topic) or critical "Execute: $DBI::errstr";
|
||||
$found = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else {
|
||||
my ($short_name) = $topic =~ m|([^/]+)$|;
|
||||
my ($father_name) = $topic =~ m|(.*)/|;
|
||||
my $father_id;
|
||||
if ($father_name) {
|
||||
$cat_id_sth->finish if ($odbc); # Need to reset cursor under odbc.
|
||||
$cat_id_sth->execute($father_name) or critical "Execute: $DBI::errstr";
|
||||
$father_id = $cat_id_sth->fetchrow_array;
|
||||
}
|
||||
else {
|
||||
$father_id = 0;
|
||||
}
|
||||
|
||||
$cat_ins_sth->execute(++$Category_counter, $short_name, $topic, $father_id) or critical "Execute: $DBI::errstr";
|
||||
$cats_imported++;
|
||||
$found = $Category_counter;
|
||||
}
|
||||
}
|
||||
}
|
||||
{
|
||||
my $disp_topic = $parse->{attribs}{'r:id'};
|
||||
substr($disp_topic, 30) = '...' if length $disp_topic > 33;
|
||||
my $padding = " " x (33 - length $disp_topic);
|
||||
$disp_topic = "(L:$links_imported, C:$cats_imported) $disp_topic$padding";
|
||||
import_print("\r$disp_topic");
|
||||
}
|
||||
if (defined $found) {
|
||||
for (@{$parse->{tags}}) {
|
||||
next unless ($_->{attribs}{'r:resource'});
|
||||
$links{$_->{attribs}{'r:resource'}} = 1;
|
||||
$cat_count++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return 1 if $was_found;
|
||||
}
|
||||
}
|
||||
elsif (defined ($found) and $parse->{name} eq 'ExternalPage') {
|
||||
|
||||
# Remove from our simple link list.
|
||||
delete $links{$parse->{attribs}{about}};
|
||||
|
||||
# Insert with description or title if it does not exist and we are not overwritting
|
||||
my ($title, $desc);
|
||||
for (@{$parse->{tags}}) {
|
||||
if ($_->{name} eq 'd:Title' and $_->{data}) { $title = $_->{data} }
|
||||
elsif ($_->{name} eq 'd:Description' and $_->{data}) { $desc = $_->{data} }
|
||||
}
|
||||
$title ||= $parse->{attribs}{about};
|
||||
$desc ||= '';
|
||||
|
||||
# Either append, or insert new link.
|
||||
if ($$opt{rdf_update}) {
|
||||
$link_exists_sth->execute ($parse->{attribs}{about},$found) or critical "Execute: $DBI::errstr";
|
||||
unless ($link_exists_sth->fetchrow_array) {
|
||||
# Title can only be 100 characters (ODBC fatals about data that is too long).
|
||||
$title = substr($title, 0, 100);
|
||||
$insert_link_sth->execute(++$Links_counter, $title, $parse->{attribs}{about}, $$opt{rdf_add_date}, $$opt{rdf_add_date}, $desc) or critical "Execute: $DBI::errstr";
|
||||
$cat_links_sth->execute($Links_counter, $found) or critical "Execute: $DBI::errstr";
|
||||
$cat_needs_num{$found} = 1;
|
||||
$links_imported++;
|
||||
}
|
||||
}
|
||||
else {
|
||||
# Title can only be 100 characters (ODBC fatals about data that is too long).
|
||||
$title = substr($title, 0, 100);
|
||||
$insert_link_sth->execute(++$Links_counter, $title, $parse->{attribs}{about}, $$opt{rdf_add_date}, $$opt{rdf_add_date}, $desc) or critical "Execute: $DBI::errstr";
|
||||
$cat_links_sth->execute($Links_counter, $found) or critical "Execute: $DBI::errstr";
|
||||
$cat_needs_num{$found} = 1;
|
||||
$links_imported++;
|
||||
}
|
||||
}
|
||||
elsif (defined $found) {
|
||||
require GT::Dumper;
|
||||
critical "STRANGE TAG: " . GT::Dumper::Dumper($parse) . "\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Now we have to go through the categories to update each one's Number_Of_Links
|
||||
for (keys %cat_needs_num) {
|
||||
$count_links_sth->execute($_) or critical "Unable to count links for Category ID $_: ".$count_links_sth->errstr;
|
||||
my $links = $count_links_sth->fetchrow_array;
|
||||
$count_links_sth->finish if ($odbc);
|
||||
$num_links_sth->execute($links,$_) or critical "Unable to update number of links for Category ID $_: ".$num_links_sth->errstr;
|
||||
}
|
||||
}
|
||||
import_print "\nNOTE: You must run Rebuild Cat. tree, Repair Tables, and Rebuild Search after performing an import!\n";
|
||||
|
||||
$e_dbh->disconnect;
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
'"I am lying," said the man. Was he?';
|
||||
802
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S1S2.pm
Normal file
802
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S1S2.pm
Normal file
@@ -0,0 +1,802 @@
|
||||
# ==================================================================
|
||||
# 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: S1S2.pm,v 1.32 2005/04/16 02:11:50 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::Import::S1S2;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use DBI;
|
||||
use GT::SQL;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_);
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_);
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
for (qw/Category Links CategoryRelations CategoryAlternates Validate Users Subscribe/) {
|
||||
local ($!,$@);
|
||||
my $did = do "$$opt{source}/$_.def";
|
||||
critical "Error parsing file $$opt{source}/$_: $@" if !$did and $@;
|
||||
critical "Error reading file $$opt{source}/$_: $!" if !$did and $!;
|
||||
}
|
||||
|
||||
# Check that all necessary databases have been loaded from the def files
|
||||
my $DEBUG_counter = 0;
|
||||
for ($Links::DBSQL::Category::db_driver,
|
||||
$Links::DBSQL::Category::db_user,
|
||||
$Links::DBSQL::Category::db_pass,
|
||||
$Links::DBSQL::Category::db_host,
|
||||
$Links::DBSQL::Category::db_table,
|
||||
$Links::DBSQL::Category::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (Category)";
|
||||
}
|
||||
for ($Links::DBSQL::Links::db_driver,
|
||||
$Links::DBSQL::Links::db_user,
|
||||
$Links::DBSQL::Links::db_pass,
|
||||
$Links::DBSQL::Links::db_host,
|
||||
$Links::DBSQL::Links::db_table,
|
||||
$Links::DBSQL::Links::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (Links)";
|
||||
}
|
||||
for ($Links::DBSQL::CategoryRelations::db_driver,
|
||||
$Links::DBSQL::CategoryRelations::db_user,
|
||||
$Links::DBSQL::CategoryRelations::db_pass,
|
||||
$Links::DBSQL::CategoryRelations::db_host,
|
||||
$Links::DBSQL::CategoryRelations::db_table,
|
||||
$Links::DBSQL::CategoryRelations::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (CategoryRelations)";
|
||||
}
|
||||
for ($Links::DBSQL::CategoryAlternates::db_driver,
|
||||
$Links::DBSQL::CategoryAlternates::db_user,
|
||||
$Links::DBSQL::CategoryAlternates::db_pass,
|
||||
$Links::DBSQL::CategoryAlternates::db_host,
|
||||
$Links::DBSQL::CategoryAlternates::db_table,
|
||||
$Links::DBSQL::CategoryAlternates::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (CategoryAlternates)";
|
||||
}
|
||||
for ($Links::DBSQL::Validate::db_driver,
|
||||
$Links::DBSQL::Validate::db_user,
|
||||
$Links::DBSQL::Validate::db_pass,
|
||||
$Links::DBSQL::Validate::db_host,
|
||||
$Links::DBSQL::Validate::db_table,
|
||||
$Links::DBSQL::Validate::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (Validate)";
|
||||
}
|
||||
for ($Links::DBSQL::Users::db_driver,
|
||||
$Links::DBSQL::Users::db_user,
|
||||
$Links::DBSQL::Users::db_pass,
|
||||
$Links::DBSQL::Users::db_host,
|
||||
$Links::DBSQL::Users::db_table,
|
||||
$Links::DBSQL::Users::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (Users)";
|
||||
}
|
||||
for ($Links::DBSQL::Subscribe::db_driver,
|
||||
$Links::DBSQL::Subscribe::db_user,
|
||||
$Links::DBSQL::Subscribe::db_pass,
|
||||
$Links::DBSQL::Subscribe::db_host,
|
||||
$Links::DBSQL::Subscribe::db_table,
|
||||
$Links::DBSQL::Subscribe::db_name) {
|
||||
defined $_ or critical "The source def files did not load correctly (Subscribe)";
|
||||
}
|
||||
|
||||
my %i_dbh;
|
||||
my $i_dbi_opts = { AutoCommit => 1, RaiseError => 0, PrintError => 0 };
|
||||
|
||||
{
|
||||
my ($no_warning) = ($Links::DBSQL::Category::db_port,
|
||||
$Links::DBSQL::Links::db_port,
|
||||
$Links::DBSQL::Validate::db_port,
|
||||
$Links::DBSQL::Users::db_port,
|
||||
$Links::DBSQL::Subscribe::db_port,
|
||||
$Links::DBSQL::CategoryRelations::db_port,
|
||||
$Links::DBSQL::CategoryAlternates::db_port);
|
||||
}
|
||||
|
||||
for ( ['Category', $Links::DBSQL::Category::db_name, $Links::DBSQL::Category::db_driver, $Links::DBSQL::Category::db_host, $Links::DBSQL::Category::db_port, $Links::DBSQL::Category::db_user, $Links::DBSQL::Category::db_pass ],
|
||||
['Links', $Links::DBSQL::Links::db_name, $Links::DBSQL::Links::db_driver, $Links::DBSQL::Links::db_host, $Links::DBSQL::Links::db_port, $Links::DBSQL::Links::db_user, $Links::DBSQL::Links::db_pass ],
|
||||
['Validate', $Links::DBSQL::Validate::db_name, $Links::DBSQL::Validate::db_driver, $Links::DBSQL::Validate::db_host, $Links::DBSQL::Validate::db_port, $Links::DBSQL::Validate::db_user, $Links::DBSQL::Validate::db_pass ],
|
||||
['Users', $Links::DBSQL::Users::db_name, $Links::DBSQL::Users::db_driver, $Links::DBSQL::Users::db_host, $Links::DBSQL::Users::db_port, $Links::DBSQL::Users::db_user, $Links::DBSQL::Users::db_pass ],
|
||||
['Subscribe',$Links::DBSQL::Subscribe::db_name,$Links::DBSQL::Subscribe::db_driver,$Links::DBSQL::Subscribe::db_host,$Links::DBSQL::Subscribe::db_port,$Links::DBSQL::Subscribe::db_user,$Links::DBSQL::Subscribe::db_pass],
|
||||
['CategoryRelations',$Links::DBSQL::CategoryRelations::db_name,$Links::DBSQL::CategoryRelations::db_driver,$Links::DBSQL::CategoryRelations::db_host,$Links::DBSQL::CategoryRelations::db_port,$Links::DBSQL::CategoryRelations::db_user,$Links::DBSQL::CategoryRelations::db_pass],
|
||||
['CategoryAlternates',$Links::DBSQL::CategoryAlternates::db_name,$Links::DBSQL::CategoryAlternates::db_driver,$Links::DBSQL::CategoryAlternates::db_host,$Links::DBSQL::CategoryAlternates::db_port,$Links::DBSQL::CategoryAlternates::db_user,$Links::DBSQL::CategoryAlternates::db_pass]) {
|
||||
my $driver = $$_[2] || "mysql";
|
||||
critical "The source def files did not load correctly (no \$db_name set for $$_[0] table)" unless $$_[1];
|
||||
next if exists $i_dbh{$$_[1]};
|
||||
my $dsn = "DBI:$driver:$$_[1]";
|
||||
if ($driver eq "mysql") {
|
||||
if ($$_[3]) {
|
||||
$dsn .= ":$$_[3]";
|
||||
if ($$_[4]) {
|
||||
$dsn .= ":$$_[4]";
|
||||
}
|
||||
}
|
||||
}
|
||||
$i_dbh{$$_[1]} = DBI->connect($dsn,@$_[5,6],$i_dbi_opts) or critical("Couldn't connect to source $$_[0] db: ".$DBI::errstr);
|
||||
}
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{destination}, subclass => 0);
|
||||
my $e_prefix = $DB->prefix;
|
||||
my $e_dbh;
|
||||
{
|
||||
my $table = $DB->table("Links");
|
||||
$table->connect();
|
||||
$e_dbh = $table->{driver}->connect();
|
||||
}
|
||||
|
||||
my %e_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name FatherID Full_Name Description Meta_Description Meta_Keywords Header Footer Category_Template Number_of_Links Has_New_Links Has_Changed_Links Newest_Link Timestmp Payment_Mode/},
|
||||
Users => { map { ($_ => 1) } qw/Username Password Email Name Validation Status ReceiveMail/},
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL LinkOwner Add_Date Mod_Date Description Contact_Name Contact_Email Hits isNew isChanged isPopular isValidated Rating Votes Status Date_Checked Timestmp ExpiryDate ExpiryCounted ExpiryNotify/},
|
||||
);
|
||||
|
||||
my %e_non_standard_cols;
|
||||
for my $table (keys %e_standard_cols) {
|
||||
my %cols = $DB->table($table)->cols;
|
||||
for (grep !$e_standard_cols{$table}{$_}, keys %cols) {
|
||||
$e_non_standard_cols{$table}{$_} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my %i_standard_cols = (
|
||||
Category => { map { ($_ => 1) } qw/ID Name Description Meta_Description Meta_Keywords Header Footer Number_of_Links Has_New_Links Has_Changed_Links Newest_Link/},
|
||||
Users => { map { ($_ => 1) } qw/Username Password Email Validation Status/},
|
||||
Links => { map { ($_ => 1) } qw/ID Title URL Add_Date Mod_Date CategoryID Description Contact_Name Contact_Email Hits isNew isChanged isPopular Rating Votes ReceiveMail Status Date_Checked/},
|
||||
Validate => { map { ($_ => 1) } qw/ID Title URL Add_Date Mod_Date CategoryID Description Contact_Name Contact_Email Hits isNew isChanged isPopular Rating Votes ReceiveMail Status Date_Checked LinkID Mode/},
|
||||
);
|
||||
|
||||
my %i_non_standard_cols;
|
||||
$i_non_standard_cols{Category} = { map { !$i_standard_cols{Category}{$_} ? ($_ => 1) : () } keys %Links::DBSQL::Category::db_def } if keys %Links::DBSQL::Category::db_def;
|
||||
$i_non_standard_cols{Users} = { map { !$i_standard_cols{Users}{$_} ? ($_ => 1) : () } keys %Links::DBSQL::Users::db_def } if keys %Links::DBSQL::Users::db_def;
|
||||
$i_non_standard_cols{Links} = { map { !$i_standard_cols{Links}{$_} ? ($_ => 1) : () } keys %Links::DBSQL::Links::db_def } if keys %Links::DBSQL::Links::db_def;
|
||||
$i_non_standard_cols{Validate} = { map { !$i_standard_cols{Validate}{$_} ? ($_ => 1) : () } keys %Links::DBSQL::Validate::db_def } if keys %Links::DBSQL::Validate::db_def;
|
||||
|
||||
my $Links_counter;
|
||||
my $Category_counter;
|
||||
|
||||
my $odbc = 0;
|
||||
if ($DB->table('Links')->{connect}->{driver} eq 'ODBC') {
|
||||
$odbc = 1;
|
||||
$i_dbh{$Links::DBSQL::Links::db_name}->{LongReadLen} = 1000000;
|
||||
}
|
||||
|
||||
if ($$opt{clear_tables}) {
|
||||
# Delete everything from all tables, EXCEPT for the `admin' user from the Users table
|
||||
$e_dbh->do("DELETE FROM ${e_prefix}Users WHERE Username <> 'admin'") or critical "Unable to delete all existing users: ".$e_dbh->errstr;
|
||||
for (qw/Links Category CatLinks CatRelations Category_Score_List
|
||||
Category_Word_List ClickTrack Editors EmailMailings EmailTemplates
|
||||
Links_Score_List Links_Word_List MailingIndex MailingList
|
||||
MailingListIndex Sessions Verify/) {
|
||||
$e_dbh->do("DELETE FROM $e_prefix$_");
|
||||
}
|
||||
unless ($$opt{straight_import}) {
|
||||
$Links_counter = $Category_counter = 0;
|
||||
}
|
||||
}
|
||||
else {
|
||||
my $sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Links") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$sth->errstr;
|
||||
$Links_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
|
||||
$sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Category': ".$sth->errstr;
|
||||
$Category_counter = $sth->fetchrow_array;
|
||||
$sth->finish();
|
||||
}
|
||||
|
||||
# Users
|
||||
{
|
||||
my $get_cols = "Username, Password, Email, Validation, Status";
|
||||
my $ins_cols = "(Name, Username, Password, Email, Validation, Status";
|
||||
my $ins_vals = "(?, ?, ?, ?, ?, ?";
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Users"}}) {
|
||||
if ($i_non_standard_cols{Users}{$_}) {
|
||||
$ins_cols .= ", $_";
|
||||
$ins_vals .= ", ?";
|
||||
$get_cols .= ", $_";
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Users.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
for (grep +(not $e_standard_cols{"${e_prefix}Users"}{$_} and not $e_non_standard_cols{"${e_prefix}Users"}{$_}), keys %{$i_non_standard_cols{Users}}) {
|
||||
next if $e_non_standard_cols{"${e_prefix}Users"}{$_};
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Users.$_' had no destination equivelant. A column will be created");
|
||||
my $editor = $DB->editor("Users");
|
||||
my @def = @{$Links::DBSQL::Users::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'CHAR' and $def[3] > 255) ? 'TEXT' : $def[1]),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ()),
|
||||
($def[7] ? (weight => $def[7]) : ())
|
||||
}
|
||||
);
|
||||
$ins_cols .= ", $_";
|
||||
$ins_vals .= ", ?";
|
||||
$get_cols .= ", $_";
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Users"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Users.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$ins_cols .= ")";
|
||||
$ins_vals .= ")";
|
||||
my $sth = $i_dbh{$Links::DBSQL::Users::db_name}->prepare("SELECT $get_cols FROM $Links::DBSQL::Users::db_table") or critical("Unable to prepare query `SELECT $get_cols FROM $Links::DBSQL::Users::db_table': ".$i_dbh{$Links::DBSQL::Users::db_name}->errstr);
|
||||
$sth->execute() or critical("Unable to execute query `SELECT $get_cols FROM $Links::DBSQL::Users::db_table': ".$sth->errstr);
|
||||
my $ins_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Users $ins_cols VALUES $ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Users $ins_cols VALUES $ins_vals': ".$e_dbh->errstr);
|
||||
my $user_count_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
my $username_sth = $e_dbh->prepare("SELECT Username FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT Username FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
|
||||
# What other than the Name and ReceiveMail can be updated here?
|
||||
my $user_mod_sth = $e_dbh->prepare("UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$e_dbh->errstr;
|
||||
|
||||
while (my $row = $sth->fetchrow_arrayref) {
|
||||
$user_count_sth->execute($$row[2]) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_array) { # This e-mail address already exists, so skip it
|
||||
next;
|
||||
}
|
||||
$ins_sth->execute(@$row[0,0],($$row[1] or random_pass()),@$row[2..$#$row]) or warning("Unable to execute query `INSERT INTO ${e_prefix}Users $ins_cols VALUES $ins_vals' ($$row[0]): ".$ins_sth->errstr),next;
|
||||
}
|
||||
}
|
||||
# Subscribe users - these users receive the newsletter.
|
||||
{
|
||||
my $get_subscribers = $i_dbh{$Links::DBSQL::Subscribe::db_name}->prepare("SELECT Name, Email FROM $Links::DBSQL::Subscribe::db_table") or warning("Unable to prepare query `SELECT Name, Email FROM $Links::DBSQL::Subscribe::db_table': ".$i_dbh{$Links::DBSQL::Subscribe::db_name}->errstr);
|
||||
$get_subscribers->execute();
|
||||
my $count_users = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?");
|
||||
my $add_user = $e_dbh->prepare("INSERT INTO ${e_prefix}Users (Name, Username, Password, Email, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Yes', 'Registered')");
|
||||
my $give_newsletter = $e_dbh->prepare("UPDATE ReceiveMail = 'Yes' WHERE Email = ?");
|
||||
|
||||
my $sub_imported = 0;
|
||||
import_print "\nImporting Subscribed users (users who receive the newsletter) ...\n";
|
||||
while (my $row = $get_subscribers->fetchrow_arrayref) {
|
||||
# If we are under ODBC we need to reset the sth handle to avoid a "Invalid Cursor State" error.
|
||||
$odbc and ($count_users->finish);
|
||||
$count_users->execute($$row[1]) or warning("Unable to count users with email $$row[1]: ".$count_users->errstr), next;
|
||||
if ($count_users->fetchrow_array) {
|
||||
$give_newsletter->execute($$row[1]) or warning("Unable to set Newsletter = 'Yes' for user with e-mail $$row[1]: ".$give_newsletter->errstr),--$sub_imported;
|
||||
}
|
||||
else { # User doesn't already exist
|
||||
$add_user->execute($$row[0], $$row[1], random_pass(), $$row[1]) or warning("Unable to insert user $$row[1]: ".$add_user->errstr),--$sub_imported;
|
||||
}
|
||||
import_print "$sub_imported\n" unless ++$sub_imported % 500;
|
||||
}
|
||||
import_print "$sub_imported Subscribed users imported.\n";
|
||||
}
|
||||
|
||||
# Everything else (in most cases including even more users)
|
||||
{
|
||||
# Category select statements
|
||||
my $cat_get_cols = "ID, Name, Description, Meta_Description, Meta_Keywords, " .
|
||||
"Header, Footer, Number_of_Links, Has_New_Links, Has_Changed_Links, Newest_Link";
|
||||
my $cat_ins_cols = "(ID, Name, FatherID, Full_Name, Description, Meta_Description, Meta_Keywords, " .
|
||||
"Header, Footer, Number_of_Links, Has_New_Links, Has_Changed_Links, Newest_Link";
|
||||
my $cat_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
# Links select statements
|
||||
my $links_get_cols = "ID, Contact_Name, Contact_Email, ReceiveMail, CategoryID, " .
|
||||
"Title, URL, Add_Date, Mod_Date, Description, Hits, isNew, " .
|
||||
"isChanged, isPopular, Rating, Votes, Status, Date_Checked";
|
||||
my $links_ins_cols = "(ID, LinkOwner, isValidated, Contact_Name, Contact_Email, " .
|
||||
"Title, URL, Add_Date, Mod_Date, Description, Hits, isNew, " .
|
||||
"isChanged, isPopular, Rating, Votes, Status, Date_Checked";
|
||||
my $links_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
# Validate select statements
|
||||
my $validate_get_cols = "ID, Contact_Name, Contact_Email, ReceiveMail, CategoryID, " .
|
||||
"Title, URL, Add_Date, Mod_Date, Description, Hits, isNew, " .
|
||||
"isChanged, isPopular, Rating, Votes, Status, Date_Checked";
|
||||
my $validate_ins_cols = "(ID, LinkOwner, isValidated, Contact_Name, Contact_Email, " .
|
||||
"Title, URL, Add_Date, Mod_Date, Description, Hits, isNew, " .
|
||||
"isChanged, isPopular, Rating, Votes, Status, Date_Checked";
|
||||
my $validate_ins_vals = "(?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?, ?";
|
||||
|
||||
# Build up extra fields that exist in both old and new Category tables
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Category"}}) {
|
||||
if ($i_non_standard_cols{Category}{$_}) {
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
$cat_get_cols .= ", $_";
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Category.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Category"}{$_}, keys %{$i_non_standard_cols{Category}}) {
|
||||
next if $e_non_standard_cols{"${e_prefix}Category"}{$_};
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Category.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Category");
|
||||
my @def = @{$Links::DBSQL::Category::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'CHAR' and $def[3] > 255) ? 'TEXT' : $def[1]),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ()),
|
||||
($def[7] ? (weight => $def[7]) : ())
|
||||
}
|
||||
);
|
||||
$cat_ins_cols .= ", $_";
|
||||
$cat_ins_vals .= ", ?";
|
||||
$cat_get_cols .= ", $_";
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Category"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Category.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$cat_ins_cols .= ")";
|
||||
$cat_ins_vals .= ")";
|
||||
|
||||
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Links"}}) {
|
||||
if ($i_non_standard_cols{Links}{$_}) {
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
$links_get_cols .= ", $_";
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Links.$_' has no equivelant import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Links"}{$_}, keys %{$i_non_standard_cols{Links}}) {
|
||||
next if $e_non_standard_cols{"${e_prefix}Links"}{$_};
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Links.$_' had no destination equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Links");
|
||||
my @def = @{$Links::DBSQL::Links::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'CHAR' and $def[3] > 255) ? 'TEXT' : $def[1]),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ()),
|
||||
($def[7] ? (weight => $def[7]) : ())
|
||||
}
|
||||
);
|
||||
$links_ins_cols .= ", $_";
|
||||
$links_ins_vals .= ", ?";
|
||||
$links_get_cols .= ", $_";
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Links"}{$_} = 1;
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Links.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$links_ins_cols .= ")";
|
||||
$links_ins_vals .= ")";
|
||||
|
||||
|
||||
for (keys %{$e_non_standard_cols{"${e_prefix}Links"}}) {
|
||||
if ($i_non_standard_cols{Validate}{$_}) {
|
||||
$validate_ins_cols .= ", $_";
|
||||
$validate_ins_vals .= ", ?";
|
||||
$validate_get_cols .= ", $_";
|
||||
}
|
||||
else {
|
||||
mild_warning("Custom destination column `${e_prefix}Links.$_' has no equivelant Validate import column. It will contain the default values for the column");
|
||||
}
|
||||
}
|
||||
|
||||
for (grep !$e_non_standard_cols{"${e_prefix}Links"}{$_}, keys %{$i_non_standard_cols{Validate}}) {
|
||||
next if $e_non_standard_cols{"${e_prefix}Links"}{$_};
|
||||
if ($opt->{create_columns}) {
|
||||
mild_warning("Custom import column `Validate.$_' had no destination Links equivelant. A destination column will be created");
|
||||
my $editor = $DB->editor("Links");
|
||||
my @def = @{$Links::DBSQL::Validate::db_def{$_}};
|
||||
$editor->add_col(
|
||||
$_,
|
||||
{
|
||||
type => ((uc $def[1] eq 'CHAR' and $def[3] > 255) ? 'TEXT' : $def[1]),
|
||||
($def[2] ? (form_size => ((index($def[2],"x") > -1) ? [split(/x/,$def[2],2)] : $def[2])) : ()),
|
||||
size => $def[3],
|
||||
($def[4] ? (not_null => 1) : ()),
|
||||
($def[5] ? (default => $def[5]) : ()),
|
||||
($def[6] ? (regex => $def[6]) : ()),
|
||||
($def[7] ? (weight => $def[7]) : ())
|
||||
}
|
||||
);
|
||||
$validate_ins_cols .= ", $_";
|
||||
$validate_ins_vals .= ", ?";
|
||||
$validate_get_cols .= ", $_";
|
||||
|
||||
$e_non_standard_cols{"${e_prefix}Links"}{$_} = 1;
|
||||
|
||||
}
|
||||
else {
|
||||
warning("Custom import column `Validate.$_' has no destination equivelant. It will be ignored");
|
||||
}
|
||||
}
|
||||
$validate_ins_cols .= ")";
|
||||
$validate_ins_vals .= ")";
|
||||
|
||||
my $cat_sth = $i_dbh{$Links::DBSQL::Category::db_name}->prepare("SELECT $cat_get_cols FROM $Links::DBSQL::Category::db_table ORDER BY Name") or critical("Unable to prepare query `SELECT $cat_get_cols FROM $Links::DBSQL::Category::db_table ORDER BY Name': ".$i_dbh{$Links::DBSQL::Category::db_name}->errstr);
|
||||
$cat_sth->execute() or critical("Unable to execute query `SELECT $cat_get_cols FROM $Links::DBSQL::Category::db_table ORDER BY Name': ".$cat_sth->errstr);
|
||||
|
||||
my $get_cat_relations = $i_dbh{$Links::DBSQL::CategoryRelations::db_name}->prepare("SELECT CategoryID, RelatedID from $Links::DBSQL::CategoryRelations::db_table") or critical "Unable to prepare query `SELECT CategoryID, RelatedID from $Links::DBSQL::CategoryRelations::db_table': ".$i_dbh{$Links::DBSQL::CategoryRelations::db_name}->errstr;
|
||||
my $add_cat_relation = $e_dbh->prepare("INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)") or critical "Unable to prepare query `INSERT INTO ${e_prefix}CatRelations (CategoryID, RelatedID) VALUES (?, ?)': ".$e_dbh->errstr;
|
||||
my @cat_map; # $cat_map[old_id] = new_id; Don't need this with --straight-import enabled
|
||||
|
||||
my $count_cats_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
|
||||
my $get_cat_alts = $i_dbh{$Links::DBSQL::CategoryAlternates::db_name}->prepare("SELECT CategoryID FROM $Links::DBSQL::CategoryAlternates::db_table WHERE LinkID = ?") or critical "Unable to prepare query `SELECT * FROM $Links::DBSQL::CategoryAlternates::db_table WHERE LinkID = ?': ".$i_dbh{$Links::DBSQL::CategoryAlternates::db_name}->errstr;
|
||||
|
||||
my $cat_ins_sth = $odbc ?
|
||||
($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals': ".$e_dbh->errstr)) :
|
||||
($e_dbh->prepare("INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals': ".$e_dbh->errstr));
|
||||
|
||||
my $cat_ins_simple_sth = $odbc ?
|
||||
($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Category ON; INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr)) :
|
||||
($e_dbh->prepare("INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Category (ID, Name, Full_Name, FatherID) VALUES (?, ?, ?, ?)': ".$e_dbh->errstr));
|
||||
|
||||
my $user_ins_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}Users (Username, Email, Password, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, ?, 'Registered')': ".$e_dbh->errstr);
|
||||
my $cat_links_sth = $e_dbh->prepare("INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)") or critical("Unable to prepare query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$e_dbh->errstr);
|
||||
my $insert_link_sth = $odbc ?
|
||||
($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Links ON; INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals': ".$e_dbh->errstr)) :
|
||||
($e_dbh->prepare("INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals': ".$e_dbh->errstr));
|
||||
|
||||
my $insert_vlink_sth = $odbc ?
|
||||
($e_dbh->prepare("SET IDENTITY_INSERT ${e_prefix}Links ON; INSERT INTO ${e_prefix}Links $validate_ins_cols VALUES $validate_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $validate_ins_cols VALUES $validate_ins_vals': ".$e_dbh->errstr)) :
|
||||
($e_dbh->prepare("INSERT INTO ${e_prefix}Links $validate_ins_cols VALUES $validate_ins_vals") or critical("Unable to prepare query `INSERT INTO ${e_prefix}Links $validate_ins_cols VALUES $validate_ins_vals': ".$e_dbh->errstr));
|
||||
|
||||
my $father_sth = $e_dbh->prepare("SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?") or critical("Unable to prepare query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$e_dbh->errstr);
|
||||
|
||||
my $get_links_sth = $i_dbh{$Links::DBSQL::Links::db_name}->prepare("SELECT $links_get_cols FROM $Links::DBSQL::Links::db_table WHERE CategoryID = ?") or critical("Unable to prepare query `SELECT $links_get_cols FROM $Links::DBSQL::Links::db_table WHERE CategoryID = ?': ".$i_dbh{$Links::DBSQL::Links::db_name}->errstr);
|
||||
my $get_vlinks_sth = $i_dbh{$Links::DBSQL::Validate::db_name}->prepare("SELECT $validate_get_cols FROM $Links::DBSQL::Validate::db_table WHERE CategoryID = ?") or critical("Unable to prepare query `SELECT $validate_get_cols FROM $Links::DBSQL::Validate::db_table WHERE CategoryID = ?': ".$i_dbh{$Links::DBSQL::Validate::db_name}->errstr);
|
||||
|
||||
my $user_count_sth = $e_dbh->prepare("SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
my $username_sth = $e_dbh->prepare("SELECT Username FROM ${e_prefix}Users WHERE Email = ?") or critical("Unable to prepare query `SELECT Username FROM ${e_prefix}Users WHERE Email = ?': ".$e_dbh->errstr);
|
||||
|
||||
# What other than the Name and ReceiveMail can be updated here?
|
||||
my $user_mod_sth = $e_dbh->prepare("UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$e_dbh->errstr;
|
||||
my $num_links_sth = $e_dbh->prepare("UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$e_dbh->errstr;
|
||||
|
||||
import_print "\nImporting Categories and Links ...\n";
|
||||
my $links_imported = 0;
|
||||
my $cats_imported = 0;
|
||||
my @missing_cats; # contains the Full_Name's of missing categories.
|
||||
my %missing_cats; # contains Full_name => true for missing categories.
|
||||
|
||||
# Have to go through hoops here as ODBC can only run one sth at a time.
|
||||
my $sub;
|
||||
if ($odbc) {
|
||||
my $results = $cat_sth->fetchall_arrayref;
|
||||
$cat_sth->finish;
|
||||
import_print "\n\tImporting ", scalar @$results, " categories ..\n";
|
||||
$sub = sub { return shift @$results; }
|
||||
}
|
||||
else {
|
||||
$sub = sub { $cat_sth->fetchrow_arrayref; }
|
||||
}
|
||||
while(my $row = $sub->()) {
|
||||
$row = [@$row];
|
||||
my $old_id = shift @$row;
|
||||
my $new_id = $$opt{straight_import} ? $old_id : ++$Category_counter;
|
||||
my ($name) = (my $full_name = shift @$row) =~ m[([^/]*)\Z];
|
||||
unless (defined $name and length $name) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Cannot insert Category $full_name because it is an invalid name";
|
||||
next;
|
||||
}
|
||||
my ($father_full_name) = $full_name =~ m[\A(.*)/];
|
||||
my $father_id;
|
||||
if (not defined $father_full_name) {
|
||||
$father_id = 0;
|
||||
}
|
||||
else {
|
||||
$odbc and $father_sth->finish;
|
||||
$father_sth->execute($father_full_name) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$father_sth->errstr;
|
||||
if (my $ar = $father_sth->fetchrow_arrayref()) {
|
||||
$father_id = $ar->[0] || 0;
|
||||
}
|
||||
else {
|
||||
if ($$opt{create_missing_categories}) {
|
||||
if ($missing_cats{$father_full_name}++) {
|
||||
mild_warning "$father_full_name is needed for category $full_name and is already in the list of categories to be created";
|
||||
}
|
||||
else {
|
||||
my $ins_pos = @missing_cats;
|
||||
splice @missing_cats, $ins_pos, 0, $father_full_name;
|
||||
mild_warning "$father_full_name is needed for category $full_name and does not exist. It will be created";
|
||||
my $fn = $father_full_name;
|
||||
while ($fn =~ s[/[^/]*\Z][]) {
|
||||
$count_cats_sth->execute($fn) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
if ($count_cats_sth->fetchrow_array) { # It exists
|
||||
last;
|
||||
}
|
||||
else {
|
||||
splice @missing_cats, $ins_pos, 0, $fn;
|
||||
mild_warning "$fn is needed for category $full_name and does not exist. It will be created";
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
else {
|
||||
warning "No father row found for $full_name! This may be a serious error as $full_name should probably have a father category";
|
||||
}
|
||||
$father_id = 0;
|
||||
}
|
||||
}
|
||||
if ($$opt{data_integrity}) {
|
||||
$odbc and $count_cats_sth->finish;
|
||||
$count_cats_sth->execute($full_name) or critical "Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Category WHERE Full_Name = ?': ".$count_cats_sth->errstr;
|
||||
unless ($count_cats_sth->fetchrow_array) {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
$Category_counter-- unless $$opt{straight_import};
|
||||
warning "Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr;
|
||||
next;
|
||||
}
|
||||
elsif (not $$opt{straight_import}) {
|
||||
$cat_map[$old_id] = $new_id;
|
||||
}
|
||||
}
|
||||
else {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
mild_warning("Duplicate category found ($full_name) and skipped");
|
||||
next;
|
||||
}
|
||||
}
|
||||
else {
|
||||
unless ($cat_ins_sth->execute($new_id,$name,$father_id,$full_name,@$row)) {
|
||||
--$Category_counter unless $$opt{straight_import};
|
||||
warning("Unable to insert category `$full_name' (SQL query: `INSERT INTO ${e_prefix}Category $cat_ins_cols VALUES $cat_ins_vals'): ".$cat_ins_sth->errstr);
|
||||
next;
|
||||
}
|
||||
elsif (not $$opt{straight_import}) {
|
||||
$cat_map[$old_id] = $new_id;
|
||||
}
|
||||
}
|
||||
|
||||
import_print "$cats_imported Categories imported\n" unless ++$cats_imported % 500;
|
||||
|
||||
my $num_of_links = 0;
|
||||
my $link_sub;
|
||||
$get_links_sth->execute($old_id) or critical "Unable to execute query: ".$get_links_sth->errstr;
|
||||
if ($odbc) {
|
||||
my $links_results = $get_links_sth->fetchall_arrayref;
|
||||
$get_links_sth->finish;
|
||||
$link_sub = sub { return shift @$links_results; }
|
||||
}
|
||||
else {
|
||||
$link_sub = sub { $get_links_sth->fetchrow_arrayref; }
|
||||
}
|
||||
while(my $row = $link_sub->()) {
|
||||
$row = [@$row];
|
||||
my ($id, $contact_name, $contact_email, $receive_mail, $cat_id) = splice @$row,0,5;
|
||||
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
|
||||
$get_cat_alts->execute($id) or critical "Unable to execute query `SELECT CategoryID FROM $Links::DBSQL::CategoryAlternates::db_table WHERE LinkID = ?': ".$get_cat_alts->errstr;
|
||||
my @alt_ids;
|
||||
while (my $row = $get_cat_alts->fetchrow_arrayref) {
|
||||
push @alt_ids, ($$opt{straight_import} ? $$row[0] : $cat_map[$$row[0]]);
|
||||
}
|
||||
|
||||
$id = ++$Links_counter unless $$opt{straight_import};
|
||||
my $username;
|
||||
$odbc and $user_count_sth->finish;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query `SELECT COUNT(*) FROM ${e_prefix}Users WHERE Email = ?': ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_array) { # This e-mail address already exists
|
||||
$user_mod_sth->execute($contact_name, ($receive_mail eq 'Yes' ? 'Yes' : 'No'), $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$odbc and $username_sth->finish;
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
}
|
||||
elsif ($contact_email) {
|
||||
$user_ins_sth->execute(($contact_email) x 2, '', (defined $contact_name ? $contact_name : ""), ($receive_mail eq 'Yes' ? 'Yes' : 'No')) or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Password, Email, Name, ReceiveMail, Status) VALUES (?, ?, ?, ?, 'Registered')': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else {
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
if ($insert_link_sth->execute($id,$username,'Yes',@$row)) {
|
||||
for ($new_id,@alt_ids) {
|
||||
if (! defined $_) { next; }
|
||||
$cat_links_sth->execute($id,$_) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
}
|
||||
$num_of_links++;
|
||||
import_print "$links_imported Links imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter-- unless $$opt{straight_import};
|
||||
warning("Unable to insert validated link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $links_ins_cols VALUES $links_ins_vals'): ".$insert_link_sth->errstr);
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
# Even with a straight import, Validate ID's cannot stay the same because they would conflict with link ID's.
|
||||
my $sth = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Links") or critical "Unable to prepare query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$e_dbh->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM ${e_prefix}Links': ".$sth->errstr;
|
||||
$Links_counter = $sth->fetchrow_array;
|
||||
$sth->finish;
|
||||
if ($$opt{straight_import}) {
|
||||
# For a straight import, we need to make sure that the link ID's used
|
||||
# for non-validated links start after the highest old Link ID.
|
||||
$sth = $i_dbh{$Links::DBSQL::Links::db_name}->prepare("SELECT MAX(ID) FROM $Links::DBSQL::Users::db_table") or critical "Unable to prepare query `SELECT MAX(ID) FROM $Links::DBSQL::Users::db_table: ".$i_dbh{$Links::DBSQL::Links::db_name}->errstr;
|
||||
$sth->execute or critical "Unable to execute query `SELECT MAX(ID) FROM $Links::DBSQL::Users::db_table: ".$sth->errstr;
|
||||
my $old_max = $sth->fetchrow_array;
|
||||
$sth->finish;
|
||||
$Links_counter = $old_max if $old_max > $Links_counter;
|
||||
}
|
||||
}
|
||||
$get_vlinks_sth->execute($old_id) or critical "Unable to execute query: ".$get_vlinks_sth->errstr;
|
||||
if ($odbc) {
|
||||
my $links_results = $get_vlinks_sth->fetchall_arrayref;
|
||||
$get_vlinks_sth->finish;
|
||||
$link_sub = sub { return shift @$links_results }
|
||||
}
|
||||
else {
|
||||
$link_sub = sub { $get_vlinks_sth->fetchrow_arrayref }
|
||||
}
|
||||
while(my $row = $link_sub->()) {
|
||||
$row = [@$row]; # Get rid of a peculiar read-only aliasing in DBI
|
||||
my ($id, $contact_name, $contact_email, $receive_mail, $cat_id) = splice @$row,0,5;
|
||||
|
||||
unshift @$row, $contact_name, $contact_email;
|
||||
|
||||
$get_cat_alts->execute($id) or critical "Unable to execute query `SELECT CategoryID FROM $Links::DBSQL::CategoryAlternates::db_table WHERE LinkID = ?': ".$get_cat_alts->errstr;
|
||||
my @alt_ids;
|
||||
while (my $row = $get_cat_alts->fetchrow_arrayref) {
|
||||
push @alt_ids, ($$opt{straight_import} ? $$row[0] : $cat_map[$$row[0]]);
|
||||
}
|
||||
|
||||
$id = ++$Links_counter;
|
||||
my $username;
|
||||
$user_count_sth->execute($contact_email) or warning("Unable to execute query: ".$user_count_sth->errstr);
|
||||
if ($user_count_sth->fetchrow_array) { # Exists
|
||||
$user_mod_sth->execute($contact_name, ($receive_mail eq 'Yes' ? 'Yes' : 'No'), $contact_email) or warning("Unable to execute query `UPDATE ${e_prefix}Users SET Name = ?, ReceiveMail = ? WHERE Email = ?': ".$user_mod_sth->errstr);
|
||||
$username_sth->execute($contact_email) or warning("Unable to execute query: ".$username_sth->errstr);
|
||||
$username = $username_sth->fetchrow_arrayref()->[0];
|
||||
}
|
||||
elsif ($contact_email) { # Doesn't exist, but we can make the e-mail address into a username
|
||||
$user_ins_sth->execute(($contact_email) x 2, '', (defined $contact_name ? $contact_name : ""), ($receive_mail eq 'Yes' ? 'Yes' : 'No')) or warning("Unable to execute query `INSERT INTO ${e_prefix}Users (Username, Email, Name, ReceiveMail) VALUES (?, ?, ?, ?, ?)': ".$user_ins_sth->errstr);
|
||||
$username = $contact_email;
|
||||
}
|
||||
else { # Can't make a user; use the `admin' user.
|
||||
mild_warning("Not enough information to add a user for link `".($$row[0] or '<unknown>')." (URL: ".($$row[1] or "<none>")."). Setting link owner to `admin'");
|
||||
$username = 'admin';
|
||||
}
|
||||
if ($insert_vlink_sth->execute($id,$username,'No',@$row)) {
|
||||
for ($id,@alt_ids) {
|
||||
$cat_links_sth->execute($_,$new_id) or warning "Unable to execute query `INSERT INTO ${e_prefix}CatLinks (LinkID, CategoryID) VALUES (?, ?)': ".$cat_links_sth->errstr;
|
||||
}
|
||||
$num_of_links++;
|
||||
import_print "$links_imported Links imported\n" unless ++$links_imported % 500;
|
||||
}
|
||||
else {
|
||||
$Links_counter--;
|
||||
warning("Unable to insert non-validated link `$$row[0]' (SQL query: `INSERT INTO ${e_prefix}Links $validate_ins_cols VALUES $validate_ins_vals'): ".$insert_vlink_sth->errstr);
|
||||
}
|
||||
}
|
||||
$num_links_sth->execute($num_of_links,$new_id) or warning "Unable to execute query `UPDATE ${e_prefix}Category SET Number_of_Links = ? WHERE ID = ?': ".$num_links_sth->errstr;
|
||||
}
|
||||
my $missing_cats;
|
||||
if ($$opt{create_missing_categories} and @missing_cats) {
|
||||
my $counter = $e_dbh->prepare("SELECT MAX(ID) FROM ${e_prefix}Category");
|
||||
$counter->execute();
|
||||
my $count = $counter->fetchrow_array();
|
||||
my $update_sub_cats = $e_dbh->prepare("UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?") or critical "Unable to prepare query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? AND Full_Name NOT LIKE ?': ".$e_dbh->errstr;
|
||||
for (@missing_cats) {
|
||||
my ($name) = m[([^/]+)\Z];
|
||||
my ($father_full) = m[\A(.*)/];
|
||||
my $father_id;
|
||||
if ($father_full) {
|
||||
$father_sth->execute($father_full) or critical "Unable to execute query `SELECT ID FROM ${e_prefix}Category WHERE Full_Name = ?': ".$father_sth->errstr;
|
||||
$father_id = $father_sth->fetchrow_array;
|
||||
}
|
||||
else { # Must be a root category
|
||||
$father_id = 0;
|
||||
}
|
||||
$cat_ins_simple_sth->execute(++$count,$name,$_,$father_id) or critical "Unable to create missing category $_: ".$cat_ins_simple_sth->errstr;
|
||||
$update_sub_cats->execute($count,"$_/%","$_/%/%") or critical "Unable to execute query `UPDATE ${e_prefix}Category SET FatherID = ? WHERE Full_Name LIKE ? and Full_Name NOT LIKE ?': ".$update_sub_cats->errstr;
|
||||
$missing_cats++;
|
||||
}
|
||||
}
|
||||
|
||||
import_print "$cats_imported Categories imported";
|
||||
import_print ", $missing_cats missing categories created" if $missing_cats;
|
||||
import_print ".\n";
|
||||
import_print "$links_imported Links imported.\n";
|
||||
|
||||
# Category Relations:
|
||||
if ($$opt{straight_import}) {
|
||||
$get_cat_relations->execute or critical "Unable to execute query `SELECT CategoryID, RelatedID from $Links::DBSQL::CategoryRelations::db_table': ".$get_cat_relations->errstr;
|
||||
while (my $row = $get_cat_relations->fetchrow_arrayref) {
|
||||
$add_cat_relation->execute(@$row) or warning "Unable to add category relation for categories with ID's $$row[0] and $$row[1]. Reason: ".$add_cat_relation->errstr;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$get_cat_relations->execute or critical "Unable to execute query `SELECT CategoryID, RelatedID from $Links::DBSQL::CategoryRelations::db_table': ".$get_cat_relations->errstr;
|
||||
while (my $row = $get_cat_relations->fetchrow_arrayref) {
|
||||
$add_cat_relation->execute(@cat_map[@$row]) or warning "Unable to add category relation for categories with ID's: (new: $cat_map[$$row[0]], old: $$row[0]) and (new: $cat_map[$$row[1]], old: $$row[1]). Reason: ".$add_cat_relation->errstr;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
for (keys %i_dbh) {
|
||||
$i_dbh{$_}->disconnect;
|
||||
}
|
||||
$e_dbh->disconnect;
|
||||
import_print "\nNOTE: You must run Rebuild Cat. tree, Repair Tables, and Rebuild Search after performing an import!\n";
|
||||
|
||||
1;
|
||||
}
|
||||
|
||||
# Returns a random password of random length (20-25 characters).
|
||||
sub random_pass () {
|
||||
my @chars = ('a'..'z','A'..'Z',0..9,qw a _ [ ] { } ` ' " ! @ ^ * ( ) - _ = + : ; . / \ a,'#',',');
|
||||
my $pass = join '', map { $chars[rand @chars] } 0..(20+rand(5));
|
||||
}
|
||||
|
||||
1;
|
||||
152
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S2BK.pm
Normal file
152
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S2BK.pm
Normal file
@@ -0,0 +1,152 @@
|
||||
# ==================================================================
|
||||
# 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: S2BK.pm,v 1.13 2009/05/09 06:35:25 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::Import::S2BK;
|
||||
|
||||
use 5.004_04;
|
||||
use strict;
|
||||
use vars qw/$Warning_Code $Critical_Code $Mild_Code $Print_Out/;
|
||||
|
||||
use GT::SQL;
|
||||
use Links qw/$CFG/;
|
||||
|
||||
sub critical {
|
||||
$Critical_Code->(@_);
|
||||
}
|
||||
|
||||
sub warning {
|
||||
$Warning_Code->(@_);
|
||||
}
|
||||
|
||||
sub mild_warning {
|
||||
ref $Mild_Code eq 'CODE' and $Mild_Code->(@_);
|
||||
}
|
||||
|
||||
sub import_print {
|
||||
if (ref $Print_Out eq 'CODE') {
|
||||
$Print_Out->(@_);
|
||||
}
|
||||
else {
|
||||
print @_;
|
||||
}
|
||||
}
|
||||
|
||||
# Takes 3-4 arguments: hash reference, 2 or 3 code refs
|
||||
# The hash reference is the options hash for an import.
|
||||
# The first code reference will be called when a warning occurs.
|
||||
# The second code reference will be called when a critical error occurs.
|
||||
# If provided, the third code reference will be called when a mild warning occurs
|
||||
sub import {
|
||||
my $opt = shift;
|
||||
return if ref $opt ne 'HASH';
|
||||
{
|
||||
my $warning = shift;
|
||||
return if ref $warning ne 'CODE';
|
||||
$Warning_Code = $warning;
|
||||
|
||||
my $critical = shift;
|
||||
return if ref $critical ne 'CODE';
|
||||
$Critical_Code = $critical;
|
||||
|
||||
my $mild = shift;
|
||||
$Mild_Code = $mild if ref $mild eq 'CODE';
|
||||
|
||||
my $output = shift;
|
||||
$Print_Out = $output if ref $output eq 'CODE';
|
||||
}
|
||||
|
||||
my $DB = new GT::SQL(def_path => $$opt{source}, subclass => 0);
|
||||
my $prefix = $DB->prefix || "";
|
||||
|
||||
my $delimiter = $$opt{delimiter};
|
||||
critical "Invalid delimiter `".(defined$delimiter?$delimiter:'')."' for a delimited file!"
|
||||
unless defined $delimiter and length $delimiter == 1 and $delimiter ne '\\';
|
||||
|
||||
my @tables;
|
||||
opendir (D, "$CFG->{admin_root_path}/defs") or critical "unable to opendir $CFG->{admin_root_path}/defs ($!)";
|
||||
while (defined (my $def = readdir(D))) {
|
||||
next unless $def =~ /^\Q$prefix\E(.*)\.def$/;
|
||||
push @tables, $1 if $1 !~ /_(?:Word|Score)_List$/;
|
||||
}
|
||||
|
||||
local ($,,$\,*EXPORT_FH);
|
||||
open EXPORT_FH, "> $$opt{destination}" or critical "Unable to open $$opt{destination} for writing: $!";
|
||||
binmode EXPORT_FH; # this is NOT a text file.
|
||||
print EXPORT_FH "Links SQL 2 backup. This backup was generated at " . gmtime() . " UTC. THIS FILE IS NOT A TEXT FILE. You should NOT attempt to edit this file as you will end up corrupting the data contained in it.\0";
|
||||
|
||||
=pod
|
||||
Schematic for the file:
|
||||
|
||||
- Newline delimiter is changed to \0 (hex and ascii 0).
|
||||
- Each line starting with '\\\\' starts off a new table.
|
||||
- The first line following the '\\\\' is the table name by itself (NOT prefixed).
|
||||
- The first character of the line after that is the delimiter for that table, and
|
||||
the rest of that line is the columns of the table delimited by the delimiter.
|
||||
- All subsequent lines (until another '\\\\') are individual records.
|
||||
- All fields (headers and records) are escaped where needed in '\\XX' format
|
||||
(where 'XX' is the hexadecimal representation of the character).
|
||||
- All lines until the first '\\\\' are treated as comments and are ignored.
|
||||
- Everything following '\\\\' is treated as a comment and is ignored.
|
||||
|
||||
=cut
|
||||
|
||||
for my $t (@tables) {
|
||||
$GT::SQL::error = '';
|
||||
my $table = $DB->table($t);
|
||||
my $count = $table->count;
|
||||
next if $GT::SQL::error;
|
||||
|
||||
import_print "Exporting $prefix$t ...\n";
|
||||
print EXPORT_FH "\\\\ The following is table $t".($prefix ? " (from prefixed table $prefix$t)" : "")."\0";
|
||||
print EXPORT_FH "$t\0";
|
||||
print EXPORT_FH $delimiter; # The first character on this line is the delimiter
|
||||
local ($a,$b);
|
||||
print EXPORT_FH join($delimiter, sort { $table->{schema}{cols}{$a}{pos} <=> $table->{schema}{cols}{$b}{pos} } map BK_escape($_,$delimiter), keys %{$table->cols}),"\0";
|
||||
my $sth;
|
||||
my $printed = 0;
|
||||
for my $i (0 .. $count/1000) {
|
||||
$sth = $table->prepare("SELECT * FROM $prefix$t LIMIT ".($i * 1000).", 1000") or critical "Unable to prepare query `SELECT * FROM $prefix$t LIMIT ".($i * 1000).", 1000': ".$sth->errstr;
|
||||
$sth->execute();
|
||||
while (my $row = $sth->fetchrow_arrayref) {
|
||||
print EXPORT_FH join($delimiter, map BK_escape($_,$delimiter), @$row),"\0";
|
||||
unless (++$printed % 500) {
|
||||
import_print "$printed records from $prefix$t exported ...\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
import_print "$printed records from $prefix$t exported.\n",
|
||||
"All records from $prefix$t have been exported.\n\n";
|
||||
}
|
||||
close EXPORT_FH;
|
||||
}
|
||||
|
||||
# Takes two parameters: The field to escape, and the delimiter. It will return
|
||||
# the escaped form of the field.
|
||||
sub BK_escape ($$) {
|
||||
return unless defined wantarray;
|
||||
my $field = shift;
|
||||
my $delimiter = shift;
|
||||
$delimiter = "" unless defined $delimiter;
|
||||
critical "Bad delimiter `$delimiter'" unless length $delimiter == 1 and $delimiter ne '\\';
|
||||
my $escape_chr = '\\';
|
||||
if (not defined $field) {
|
||||
return 'NULL';
|
||||
}
|
||||
elsif ($field eq 'NULL') {
|
||||
return 'NUL\4C'; # If it is the actual string 'NULL' this will keep it
|
||||
} # from being recognized as a NULL field when it is read in again.
|
||||
$field =~ s/([\Q$delimiter$escape_chr\E\x00-\x1f])/sprintf '\%02X', ord $1/ge;
|
||||
$field;
|
||||
}
|
||||
|
||||
"Once upon a time, in a galaxy far, far away . . . There was a true value";
|
||||
1214
site/slowtwitch.com/cgi-bin/articles/admin/Links/MassMailer.pm
Normal file
1214
site/slowtwitch.com/cgi-bin/articles/admin/Links/MassMailer.pm
Normal file
File diff suppressed because it is too large
Load Diff
622
site/slowtwitch.com/cgi-bin/articles/admin/Links/Newsletter.pm
Normal file
622
site/slowtwitch.com/cgi-bin/articles/admin/Links/Newsletter.pm
Normal file
@@ -0,0 +1,622 @@
|
||||
# ==================================================================
|
||||
# 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: Newsletter.pm,v 1.15 2007/09/06 01:43: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.
|
||||
# ==================================================================
|
||||
|
||||
# Notes about the Newsletter code:
|
||||
# ================================
|
||||
# Example category structure:
|
||||
# a
|
||||
# b
|
||||
# c
|
||||
# d
|
||||
# If a user is subscribed to a category (eg. category a), then they will
|
||||
# be automatically subscribed to all the subcategories of that category
|
||||
# (ie. b, c, d). If the user is already subscribed to a subcategory
|
||||
# (eg. b), then that subscription will be removed when they subscribe to
|
||||
# a parent category (ie. a). This keeps listing subscribed categories
|
||||
# simple.
|
||||
#
|
||||
# Remember that the root category (0) is a special category and needs to be
|
||||
# handled appropriately. It is not a real category as it does not exist in
|
||||
# the Category table.
|
||||
|
||||
package Links::Newsletter;
|
||||
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::SiteHTML;
|
||||
use GT::Dumper;
|
||||
|
||||
sub handle {
|
||||
# ---------------------------------------------------
|
||||
# Determine what to do.
|
||||
#
|
||||
my $res;
|
||||
my $action = lc $IN->param('action');
|
||||
|
||||
require Links::Build;
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_NEWSLETTER'), "$CFG->{db_cgi_url}/subscribe.cgi");
|
||||
|
||||
# Custom lists
|
||||
if ($IN->param('list')) {
|
||||
my $email = $IN->param('email');
|
||||
if ($email and $action eq 'subscribe') {
|
||||
$res = $PLG->dispatch('custom_list_subscribe', \&custom_list_subscribe);
|
||||
}
|
||||
elsif ($email and $action eq 'unsubscribe') {
|
||||
$res = $PLG->dispatch('custom_list_unsubscribe', \&custom_list_unsubscribe);
|
||||
}
|
||||
else {
|
||||
$res = { error => Links::language('SUBSCRIBE_ERROR') };
|
||||
}
|
||||
$res->{main_title_loop} ||= $mtl;
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('newsletter', $res);
|
||||
}
|
||||
|
||||
# With the old Newsletter code, anyone could sign up to it. This is bad since
|
||||
# no e-mail validation is performed. The new code will only allow signed up
|
||||
# users to sign up.
|
||||
unless ($USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('subscribe'));
|
||||
return;
|
||||
}
|
||||
|
||||
my $page;
|
||||
if ($CFG->{newsletter_global_subscribe}) {
|
||||
$page = 'newsletter_global';
|
||||
if ($action eq 'subscribe') {
|
||||
$res = $PLG->dispatch('newsletter_global_sub', \&global_subscribe);
|
||||
}
|
||||
elsif ($action eq 'unsubscribe') {
|
||||
$res = $PLG->dispatch('newsletter_global_unsub', \&global_unsubscribe);
|
||||
}
|
||||
}
|
||||
elsif ($action eq 'list') {
|
||||
$page = 'newsletter_list';
|
||||
}
|
||||
elsif ($action eq 'unsubscribe') {
|
||||
$res = $PLG->dispatch('newsletter_unsubscribe', \&unsubscribe);
|
||||
$page = $IN->param('page') || 'newsletter';
|
||||
}
|
||||
elsif ($action eq 'subscribe') {
|
||||
$res = $PLG->dispatch('newsletter_subscribe', \&subscribe);
|
||||
$page = 'newsletter';
|
||||
}
|
||||
elsif ($action eq 'update') {
|
||||
$res = $PLG->dispatch('newsletter_update', \&update_subscription);
|
||||
$page = 'newsletter_browse';
|
||||
}
|
||||
else {
|
||||
$page = 'newsletter_browse';
|
||||
}
|
||||
$res->{main_title_loop} ||= $mtl;
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display($page, $res);
|
||||
}
|
||||
|
||||
sub custom_list_subscribe {
|
||||
# ---------------------------------------------------
|
||||
# Subscribe to a custom list
|
||||
#
|
||||
my $list = $IN->param('list');
|
||||
my $email = $IN->param('email');
|
||||
my $mli = $DB->table('MailingListIndex');
|
||||
my $ml = $DB->table('MailingList');
|
||||
unless ($mli->count({ Name => $list })) {
|
||||
return { error => Links::language('SUBSCRIBE_INVALIDLIST', $list) };
|
||||
}
|
||||
|
||||
my $id = $mli->select('ID', { Name => $list })->fetchrow;
|
||||
|
||||
if ($ml->count({ Email => $email, ID => $id })) {
|
||||
return { error => Links::language('SUBSCRIBE_ALREADYSUB') };
|
||||
}
|
||||
$ml->insert({ Email => $email, ID => $id });
|
||||
return { message => Links::language('SUBSCRIBE_SUCCESS') };
|
||||
}
|
||||
|
||||
sub custom_list_unsubscribe {
|
||||
# ---------------------------------------------------
|
||||
# Unsubscribe from a custom list
|
||||
#
|
||||
my $list = $IN->param('list');
|
||||
my $email = $IN->param('email');
|
||||
my $mli = $DB->table('MailingListIndex');
|
||||
my $ml = $DB->table('MailingList');
|
||||
unless ($mli->count({ Name => $list })) {
|
||||
return { error => Links::language('SUBSCRIBE_INVALIDLIST', $list) };
|
||||
}
|
||||
|
||||
my $id = $mli->select('ID', { Name => $list })->fetchrow;
|
||||
|
||||
unless ($ml->count({ Email => $email, ID => $id })) {
|
||||
return { error => Links::language('SUBSCRIBE_NOTSUB') };
|
||||
}
|
||||
$ml->delete({ Email => $email, ID => $id });
|
||||
return { message => Links::language('SUBSCRIBE_UNSUBSUCCESS') };
|
||||
}
|
||||
|
||||
sub global_subscribe {
|
||||
# ---------------------------------------------------
|
||||
# Global subscribe to the newsletter. If the admin option is enabled, then this
|
||||
# will behave like the newsletter did in 2.x, where there is only one global
|
||||
# newsletter. The only difference is that only registered users can subscribe.
|
||||
#
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
|
||||
if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) {
|
||||
return { error => Links::language('NEWSLETTERERR_ALREADYSUB') };
|
||||
}
|
||||
_subscribe(0);
|
||||
return { message => Links::language('NEWSLETTER_SUBSCRIBED') };
|
||||
}
|
||||
|
||||
sub global_unsubscribe {
|
||||
# ---------------------------------------------------
|
||||
# Unsubscribe from the newsletter.
|
||||
#
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
|
||||
if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) {
|
||||
_unsubscribe(0);
|
||||
return { message => Links::language('NEWSLETTER_UNSUBSCRIBED') };
|
||||
}
|
||||
return { error => Links::language('NEWSLETTERERR_NOTSUB') };
|
||||
}
|
||||
|
||||
sub global_subscribe_info {
|
||||
# ---------------------------------------------------
|
||||
# Returns information about the user's newsletter subscription.
|
||||
#
|
||||
return { subscribed => $DB->table('NewsletterSubscription')->count({ UserID => $USER->{Username}, CategoryID => 0 }) };
|
||||
}
|
||||
|
||||
sub list_subscribed {
|
||||
# ---------------------------------------------------
|
||||
# Returns a list of categories they are subscribed to.
|
||||
#
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
my $nsc = $DB->table('NewsletterSubscription', 'Category');
|
||||
|
||||
if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) {
|
||||
return { subscribed => [_root()] };
|
||||
}
|
||||
|
||||
$nsc->select_options("ORDER BY Full_Name");
|
||||
my $list = $nsc->select({ UserID => $USER->{Username} })->fetchall_hashref;
|
||||
return { subscribed => $list };
|
||||
}
|
||||
|
||||
sub unsubscribe {
|
||||
# ---------------------------------------------------
|
||||
# Unsubscribe from one or more categories.
|
||||
#
|
||||
my @unsub = $IN->param('ID');
|
||||
@unsub = @_ unless @unsub;
|
||||
|
||||
return { error => Links::language('NEWSLETTERERR_NOCATSUB') } unless @unsub;
|
||||
|
||||
_unsubscribe(@unsub);
|
||||
|
||||
return { message => Links::language('NEWSLETTER_CATUNSUB') };
|
||||
}
|
||||
|
||||
sub subscribe {
|
||||
# ---------------------------------------------------
|
||||
# Subscribe to one or more categories.
|
||||
#
|
||||
my @sub = $IN->param('ID');
|
||||
@sub = @_ unless @sub;
|
||||
|
||||
return { error => Links::language('NEWSLETTER_NOCATUNSUB') } unless @sub;
|
||||
|
||||
_subscribe(@sub);
|
||||
|
||||
return { message => Links::language('NEWSLETTER_CATSUB') };
|
||||
}
|
||||
|
||||
sub update_subscription {
|
||||
# ---------------------------------------------------
|
||||
# Update a User's category subscriptions from their browse selection.
|
||||
#
|
||||
|
||||
# These should be the original subscribe states of the categories. S<ID> are the
|
||||
# categories which they wish to be subscribed to.
|
||||
my @presub = $IN->param('subscribed');
|
||||
my @preunsub = $IN->param('unsubscribed');
|
||||
my (@sub, @unsub);
|
||||
|
||||
for (@presub) {
|
||||
next if $_ =~ /\D/;
|
||||
push @unsub, $_ unless defined $IN->param("S$_");
|
||||
}
|
||||
_unsubscribe(@unsub);
|
||||
|
||||
for (@preunsub) {
|
||||
next if $_ =~ /\D/;
|
||||
push @sub, $_ if defined $IN->param("S$_");
|
||||
}
|
||||
_subscribe(@sub);
|
||||
|
||||
return { message => Links::language('NEWSLETTER_CATUPDATED') };
|
||||
}
|
||||
|
||||
sub browse {
|
||||
# ---------------------------------------------------
|
||||
# Browse the categories.
|
||||
#
|
||||
my $root = $IN->param('root') || 0;
|
||||
my $cat = $DB->table('Category');
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
if ($root != 0 and not $cat->count({ ID => $root })) {
|
||||
$root = 0;
|
||||
}
|
||||
|
||||
my $root_cat;
|
||||
if ($root == 0) {
|
||||
$root_cat = _root();
|
||||
$root_cat->{CatDepth} = -1;
|
||||
}
|
||||
else {
|
||||
$root_cat = $cat->select({ ID => $root })->fetchrow_hashref or return { error => $GT::SQL::error };
|
||||
}
|
||||
|
||||
my $tree = $cat->tree;
|
||||
my $cats;
|
||||
# When root = 0, max_depth is kind of weird because there isn't actually a Category with ID = 0.
|
||||
# Because of this GT::SQL::Tree doesn't handle the case where max_depth = 1 and root = 0, so
|
||||
# we'll handle it ourselves.
|
||||
if ($root == 0 and $CFG->{newsletter_max_depth} == 1) {
|
||||
$cat->select_options("ORDER BY Full_Name");
|
||||
$cats = $cat->select({ FatherID => 0 })->fetchall_hashref;
|
||||
}
|
||||
else {
|
||||
$cats = $tree->children(id => $root, max_depth => ($root == 0 ? $CFG->{newsletter_max_depth} - 1 : $CFG->{newsletter_max_depth}), sort_col => 'Full_Name');
|
||||
}
|
||||
# Insert the root category as the first element
|
||||
splice @$cats, 0, 0, $root_cat;
|
||||
my @parents;
|
||||
my %catids;
|
||||
for (0 .. $#$cats) {
|
||||
my $c = $cats->[$_];
|
||||
# ID to $cats index mapping
|
||||
$catids{$c->{ID}}->{index} = $_;
|
||||
# List of children (only ones which are shown in the trimmed tree)
|
||||
$catids{$c->{ID}}->{children} = [];
|
||||
# Fix CatDepth to be relative to $root
|
||||
if ($_) {
|
||||
$c->{CatDepth} -= $root_cat->{CatDepth};
|
||||
}
|
||||
|
||||
# Keep track of categories which could have sub categories (that are past max_depth)
|
||||
if ($CFG->{newsletter_max_depth} > 0 and $c->{CatDepth} == $CFG->{newsletter_max_depth}) {
|
||||
$catids{$c->{ID}}->{check_child}++;
|
||||
}
|
||||
else {
|
||||
$c->{HasMoreChildren} = 0;
|
||||
}
|
||||
$c->{Subscribed} = 0;
|
||||
|
||||
# Find all the children
|
||||
while (@parents and @parents > $c->{CatDepth}) {
|
||||
my $p = pop @parents;
|
||||
for (@parents) {
|
||||
push @{$catids{$_}->{children}}, $p;
|
||||
}
|
||||
}
|
||||
push @parents, $c->{ID};
|
||||
}
|
||||
while (@parents) {
|
||||
my $p = pop @parents;
|
||||
for (@parents) {
|
||||
push @{$catids{$_}->{children}}, $p;
|
||||
}
|
||||
}
|
||||
$cats->[0]->{CatDepth} = 0;
|
||||
|
||||
if (%catids) {
|
||||
for (keys %catids) {
|
||||
$cats->[$catids{$_}->{index}]->{Children} = $catids{$_}->{children};
|
||||
}
|
||||
|
||||
# Figure out which categories the user has subscribed to
|
||||
my @subscribed = $ns->select('CategoryID', { UserID => $USER->{Username}, CategoryID => [keys %catids] })->fetchall_list;
|
||||
for (@subscribed) {
|
||||
$cats->[$catids{$_}->{index}]->{Subscribed}++;
|
||||
}
|
||||
|
||||
# Check to see which categories have sub categories
|
||||
my @check = grep $catids{$_}->{check_child}, keys %catids;
|
||||
if (@check) {
|
||||
my $subcats = $tree->child_ids(id => \@check);
|
||||
for (keys %$subcats) {
|
||||
$cats->[$catids{$_}->{index}]->{HasMoreChildren} = @{$subcats->{$_}};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my %previous = (PPID => '');
|
||||
my $parent_subscribed;
|
||||
if ($root != 0) {
|
||||
my @parents = @{$tree->parent_ids(id => $root)};
|
||||
splice(@parents, 0, 0, 0);
|
||||
|
||||
$parent_subscribed = $ns->count({ UserID => $USER->{Username}, CategoryID => \@parents });
|
||||
|
||||
my $parent;
|
||||
if (@parents < $CFG->{newsletter_max_depth}) {
|
||||
$parent = $parents[0];
|
||||
}
|
||||
else {
|
||||
$parent = $parents[-$CFG->{newsletter_max_depth}];
|
||||
}
|
||||
|
||||
# Get the previous parent's info
|
||||
if ($parent == 0) {
|
||||
$parent = _root();
|
||||
}
|
||||
else {
|
||||
$parent = $cat->select({ ID => $parent })->fetchrow_hashref;
|
||||
}
|
||||
%previous = map { "PP" . $_ => $parent->{$_} } keys %$parent;
|
||||
}
|
||||
|
||||
return { %previous, category => $cats, parent_subscribed => $parent_subscribed };
|
||||
}
|
||||
|
||||
sub admin_browse {
|
||||
# ---------------------------------------------------
|
||||
# Browse the categories (admin side).
|
||||
#
|
||||
my $root = $IN->param('root') || 0;
|
||||
my $cat = $DB->table('Category');
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
if ($root != 0 and not $cat->count({ ID => $root })) {
|
||||
$root = 0;
|
||||
}
|
||||
|
||||
my $root_cat;
|
||||
if ($root == 0) {
|
||||
$root_cat = _root();
|
||||
$root_cat->{CatDepth} = -1;
|
||||
}
|
||||
else {
|
||||
$root_cat = $cat->select({ ID => $root })->fetchrow_hashref or return { error => $GT::SQL::error };
|
||||
}
|
||||
|
||||
my $tree = $cat->tree;
|
||||
my $cats;
|
||||
# root (0) isn't a 'real' category in the tree, so we have to select it ourselves
|
||||
if ($root == 0 and $CFG->{newsletter_max_depth} == 1) {
|
||||
$cat->select_options("ORDER BY Full_Name");
|
||||
$cats = $cat->select({ FatherID => 0 })->fetchall_hashref;
|
||||
}
|
||||
else {
|
||||
$cats = $tree->children(id => $root, max_depth => ($root == 0 ? $CFG->{newsletter_max_depth} - 1 : $CFG->{newsletter_max_depth}), sort_col => 'Full_Name');
|
||||
}
|
||||
# Insert the root category as the first element of the list of categories
|
||||
splice @$cats, 0, 0, $root_cat;
|
||||
|
||||
my %catids;
|
||||
for (0 .. $#$cats) {
|
||||
my $c = $cats->[$_];
|
||||
# ID to $cats index mapping
|
||||
$catids{$c->{ID}}->{index} = $_;
|
||||
# List of children (only ones which are shown in the trimmed tree)
|
||||
$catids{$c->{ID}}->{children} = [];
|
||||
# Fix CatDepth to be relative to $root
|
||||
if ($_) {
|
||||
$c->{CatDepth} -= $root_cat->{CatDepth};
|
||||
}
|
||||
|
||||
# Keep track of categories which could have sub categories (that are past max_depth)
|
||||
if ($CFG->{newsletter_max_depth} > 0 and $c->{CatDepth} == $CFG->{newsletter_max_depth}) {
|
||||
$catids{$c->{ID}}->{check_child}++;
|
||||
}
|
||||
else {
|
||||
$c->{HasMoreChildren} = 0;
|
||||
}
|
||||
$c->{DirectSubscribers} = 0;
|
||||
}
|
||||
$cats->[0]->{CatDepth} = 0;
|
||||
|
||||
# Get a list of the root's parents (this is used twice below)
|
||||
my @root_parents = $root == 0 ? () : (0, @{$tree->parent_ids(id => $root)});
|
||||
|
||||
if (%catids) {
|
||||
# Calculate the number of direct subscribers for each category
|
||||
my %subscribers;
|
||||
$ns->select_options("GROUP BY CategoryID");
|
||||
my $sth = $ns->select('CategoryID', 'COUNT(*)', { CategoryID => [@root_parents, keys %catids] });
|
||||
while (my ($catid, $count) = $sth->fetchrow_array) {
|
||||
if (exists $catids{$catid}) {
|
||||
$cats->[$catids{$catid}->{index}]->{DirectSubscribers} = $count;
|
||||
}
|
||||
# Save the counts to calculate the total subscribers
|
||||
$subscribers{$catid} = $count;
|
||||
}
|
||||
|
||||
# Calculate the number of subscribers for each category (if a newsletter was
|
||||
# sent to this category, it would go to this many people)
|
||||
my $parents = $tree->parent_ids(id => [keys %catids]);
|
||||
for my $catid (keys %$parents) {
|
||||
for (@{$parents->{$catid}}, $catid) {
|
||||
$cats->[$catids{$catid}->{index}]->{Subscribers} += $subscribers{$_};
|
||||
}
|
||||
$cats->[$catids{$catid}->{index}]->{Subscribers} += $subscribers{0} if $catid;
|
||||
}
|
||||
|
||||
# Check to see which categories have sub categories
|
||||
my @check = grep $catids{$_}->{check_child}, keys %catids;
|
||||
if (@check) {
|
||||
my $subcats = $tree->child_ids(id => \@check);
|
||||
for (keys %$subcats) {
|
||||
$cats->[$catids{$_}->{index}]->{HasMoreChildren} = @{$subcats->{$_}};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
my %previous = (PPID => '');
|
||||
if ($root != 0) {
|
||||
my $parent;
|
||||
if (@root_parents < $CFG->{newsletter_max_depth}) {
|
||||
$parent = $root_parents[0];
|
||||
}
|
||||
else {
|
||||
$parent = $root_parents[-$CFG->{newsletter_max_depth}];
|
||||
}
|
||||
|
||||
# Get the previous parent's info
|
||||
if ($parent == 0) {
|
||||
$parent = _root();
|
||||
}
|
||||
else {
|
||||
$parent = $cat->select({ ID => $parent })->fetchrow_hashref;
|
||||
}
|
||||
%previous = map { "PP" . $_ => $parent->{$_} } keys %$parent;
|
||||
}
|
||||
|
||||
return { %previous, category => $cats };
|
||||
}
|
||||
|
||||
sub subscriber_info {
|
||||
# ---------------------------------------------------
|
||||
# Returns information about the subscribers of a category.
|
||||
#
|
||||
my $catid = $IN->param('ID');
|
||||
my $direct = $IN->param('direct');
|
||||
my $cat = $DB->table('Category');
|
||||
my $nsu = $DB->table('NewsletterSubscription', 'Users');
|
||||
|
||||
if (not defined $catid or not ($catid == 0 or $cat->count({ ID => $catid }))) {
|
||||
return { error => 'Invalid ID' };
|
||||
}
|
||||
|
||||
my $tree = $cat->tree;
|
||||
my @parents = $direct || $catid == 0 ? ($catid) : (0, @{$tree->parent_ids(id => $catid)}, $catid);
|
||||
|
||||
$nsu->select_options("ORDER BY Username");
|
||||
my $subscribers = $nsu->select({ CategoryID => \@parents })->fetchall_hashref;
|
||||
|
||||
return { subscribers => $subscribers };
|
||||
}
|
||||
|
||||
sub subscription_info {
|
||||
# ---------------------------------------------------
|
||||
# Returns subscription information about a category.
|
||||
# 0 = not subscribed
|
||||
# 1 = indirectly subscribed (parent is subscribed)
|
||||
# 2 = directly subscribed
|
||||
#
|
||||
my $catid = $IN->param('ID') || shift;
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
my $tree = $DB->table('Category')->tree;
|
||||
|
||||
if ($ns->count({ UserID => $USER->{Username}, CategoryID => $catid })) {
|
||||
return { SubscriptionStatus => 2 };
|
||||
}
|
||||
|
||||
if ($catid == 0) {
|
||||
return { SubscriptionStatus => 0 };
|
||||
}
|
||||
|
||||
my @parents = (0, @{$tree->parent_ids(id => $catid)});
|
||||
my @pids = $ns->select('CategoryID', { UserID => $USER->{Username}, CategoryID => \@parents })->fetchall_list;
|
||||
if (@pids) {
|
||||
return { SubscriptionStatus => 1 };
|
||||
}
|
||||
|
||||
return { SubscriptionStatus => 0 };
|
||||
}
|
||||
|
||||
sub _root {
|
||||
# ---------------------------------------------------
|
||||
# Since there is no real root category, return what a select from the Category
|
||||
# table would return.
|
||||
#
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
return {
|
||||
ID => 0,
|
||||
Name => Links::language('NEWSLETTER_ROOTCAT'),
|
||||
CatDepth => 0,
|
||||
Full_Name => Links::language('NEWSLETTER_ROOTCAT'),
|
||||
Description => '',
|
||||
Subscribed => $USER->{Username} ? $ns->count({ UserID => $USER->{Username}, CategoryID => 0 }) : 0,
|
||||
};
|
||||
}
|
||||
|
||||
sub _subscribe {
|
||||
# ---------------------------------------------------
|
||||
# Subscribe to the categories passed in.
|
||||
#
|
||||
my @sub = @_;
|
||||
return 0 unless @sub;
|
||||
|
||||
my $cat = $DB->table('Category');
|
||||
my $ns = $DB->table('NewsletterSubscription');
|
||||
my $tree = $cat->tree;
|
||||
|
||||
# Already subscribed to root category
|
||||
if ($ns->count({ UserID => $USER->{Username}, CategoryID => 0 })) {
|
||||
return 0;
|
||||
}
|
||||
|
||||
@sub = sort { $a <=> $b } @sub;
|
||||
if ($sub[0] == 0) {
|
||||
@sub = (0);
|
||||
}
|
||||
else {
|
||||
# Filter out the invalid category ID's
|
||||
my @s = $cat->select('ID', { ID => \@sub })->fetchall_list;
|
||||
# Filter out categories which are already subscribed to by being a subcat
|
||||
@sub = ();
|
||||
my $parents = $tree->parent_ids(id => \@s);
|
||||
for (@s) {
|
||||
unless (@{$parents->{$_}} and $ns->count({ UserID => $USER->{Username}, CategoryID => $parents->{$_} })) {
|
||||
push @sub, $_;
|
||||
}
|
||||
}
|
||||
}
|
||||
return 0 unless @sub;
|
||||
|
||||
# Subscribing to the root, subscribes you to all, so remove any existing subscriptions.
|
||||
$ns->delete({ UserID => $USER->{Username} }) if $sub[0] == 0;
|
||||
|
||||
$ns->insert_multiple([qw/UserID CategoryID/], map { [$USER->{Username}, $_] } @sub);
|
||||
|
||||
# Remove any subscribed subcats of the ones we just added
|
||||
if ($sub[0] != 0) {
|
||||
my $c = $tree->child_ids(id => \@sub);
|
||||
my @subcats = map { @{$c->{$_}} } keys %$c;
|
||||
if (@subcats) {
|
||||
$ns->delete({ UserID => $USER->{Username}, CategoryID => \@subcats });
|
||||
}
|
||||
}
|
||||
|
||||
# FIXME need to take into account how many were deleted
|
||||
return scalar @sub;
|
||||
}
|
||||
|
||||
sub _unsubscribe {
|
||||
# ---------------------------------------------------
|
||||
# Unsubscribe from categories passed in. Returns the number of categories
|
||||
# unsubscribed from.
|
||||
#
|
||||
my @unsub = @_;
|
||||
return 0 unless @unsub;
|
||||
|
||||
return $DB->table('NewsletterSubscription')->delete({ UserID => $USER->{Username}, CategoryID => \@unsub });
|
||||
}
|
||||
|
||||
1;
|
||||
284
site/slowtwitch.com/cgi-bin/articles/admin/Links/Parallel.pm
Normal file
284
site/slowtwitch.com/cgi-bin/articles/admin/Links/Parallel.pm
Normal file
@@ -0,0 +1,284 @@
|
||||
# ==================================================================
|
||||
# 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: Parallel.pm,v 1.8 2005/03/05 01:29:09 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::Parallel;
|
||||
# ==================================================================
|
||||
# A way to get parallel work for ceartain tasks (not thread based).
|
||||
#
|
||||
use strict;
|
||||
|
||||
sub new {
|
||||
#------------------------------------------------------------
|
||||
# creats a new class, be sure to take a look at how it can
|
||||
# be configured
|
||||
#
|
||||
my $class = shift;
|
||||
my %p;
|
||||
|
||||
ref $_[0] ? (%p = %{$_[0]} ) : (%p = @_);
|
||||
|
||||
my $self = {};
|
||||
bless $self, $class;
|
||||
|
||||
$self->{max_workunit} = defined ( $p{max_workunit} ) ? $p{max_workunit} : 10;
|
||||
$self->{min_workunit} = defined ( $p{min_workunit} ) ? $p{min_workunit} : 3;
|
||||
$self->{max_children} = defined ( $p{max_children} ) ? $p{max_children} : 3;
|
||||
$self->{child_path} = defined ( $p{child_path} ) ? $p{child_path} : "./child.pl";
|
||||
$self->{path_to_perl} = defined ( $p{path_to_perl} ) ? $p{path_to_perl} : "/usr/local/bin/perl";
|
||||
$self->{max_children} = defined ( $p{max_children} ) ? $p{max_children} : 3;
|
||||
|
||||
$self->{spawn_delay} = defined ( $p{spawn_delay} ) ? $p{spawn_delay} : 2;
|
||||
|
||||
$self->{to_check} = defined ( $p{to_check} ) ? $p{to_check} : [];
|
||||
$self->{on_response} = defined ( $p{on_response} ) ? $p{on_response} : sub { };
|
||||
|
||||
# for statistics
|
||||
$self->{start_time} = 0;
|
||||
$self->{end_time} = 0;
|
||||
$self->{threads_spawned}= 0;
|
||||
|
||||
$self->{threads_stats} = {};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub wait {
|
||||
#------------------------------------------------------------
|
||||
# the main loop that waits until the subset is checked.
|
||||
#
|
||||
my $self = shift;
|
||||
my $max_children = $self->{max_children};
|
||||
my @active_units = ();
|
||||
$self->{start_time} = time;
|
||||
my $temp = 0;
|
||||
|
||||
# while there's stuff to check
|
||||
while ( ( @{$self->{to_check}} ) or ( @active_units) ) {
|
||||
# create work units
|
||||
my $spawned = 0;
|
||||
while ( ( ($#active_units+1) < $max_children ) and ( @{$self->{to_check}} ) ) {
|
||||
# if we've already spawned a child, wait one so we don't
|
||||
# spike the load
|
||||
sleep $self->{spawn_delay} if $spawned;
|
||||
$spawned++;
|
||||
push @active_units, $self->new_work_unit ();
|
||||
};
|
||||
|
||||
# wait for any connections, blocking call.
|
||||
my $rin = fhbits ( \@active_units );
|
||||
select ( $rin, undef, undef, undef );
|
||||
|
||||
# find out who is has input
|
||||
my ( $i, $wild_protect );
|
||||
$i = 0; $wild_protect = 0;
|
||||
while ( $i <= $#active_units ) {
|
||||
|
||||
# if a unit requires attention, get input or kill it
|
||||
if ( $active_units[$i]->has_input () ) {
|
||||
$wild_protect++;
|
||||
my ( $id, $code, $message ) = $active_units[$i]->get_input ();
|
||||
if ( defined $id ) {
|
||||
&{$self->{on_response}}( $id, $code, $message );
|
||||
} else {
|
||||
my ( $unit_id, $start_time, $number_checked, $time_taken ) = $active_units[$i]->get_stats();
|
||||
${$self->{thread_stats}}{$unit_id} = [$start_time, $number_checked, $time_taken];
|
||||
$active_units[$i]->end_unit();
|
||||
# in case the child aborted abnormally, push the remaining
|
||||
# urls to be checked onto the stack
|
||||
push @{$self->{to_check}}, @{$active_units[$i]->{to_check}};
|
||||
splice ( @active_units, $i, 1 );
|
||||
next;
|
||||
};
|
||||
};
|
||||
$i++;
|
||||
};
|
||||
|
||||
# protect against wild looping
|
||||
$wild_protect || die "Error in verifier, looping wildly";
|
||||
};
|
||||
$self->{end_time} = time;
|
||||
}
|
||||
|
||||
sub get_stats {
|
||||
#------------------------------------------------------------
|
||||
# Return stats for the thread information.
|
||||
#
|
||||
my $self = shift;
|
||||
return [ $self->{threads_spawned}, $self->{end_time} - $self->{start_time}, $self->{thread_stats} ];
|
||||
}
|
||||
|
||||
sub new_work_unit {
|
||||
#------------------------------------------------------------
|
||||
# allocates a new work unit for the chilren
|
||||
# there are some optimization routines that should at some
|
||||
# point be implemented (for better allocation of
|
||||
# work units
|
||||
#
|
||||
my $self = shift;
|
||||
my $num_units = $#{$self->{to_check}}+1;
|
||||
my $max_children= $self->{max_children};
|
||||
my $unit_size = int ( $num_units / ( $max_children + 1 ) );
|
||||
|
||||
($unit_size > $self->{max_workunit}) and $unit_size = $self->{max_workunit};
|
||||
($unit_size < $self->{min_workunit}) and $unit_size = $self->{min_workunit};
|
||||
($unit_size > $num_units) and $unit_size = $num_units;
|
||||
|
||||
my @to_check = @{$self->{to_check}}[0..$unit_size-1];
|
||||
splice ( @{$self->{to_check}}, 0, $unit_size );
|
||||
|
||||
$self->{threads_spawned}++;
|
||||
|
||||
return Links::Parallel::WorkUnit->new ( $self->{path_to_perl}, $self->{child_path}, $self->{child_args}, \@to_check );
|
||||
}
|
||||
|
||||
sub fhbits {
|
||||
#------------------------------------------------------------
|
||||
# to set the fhandle bits for the impending select call
|
||||
#
|
||||
my ($work_units, $bits) = @_;
|
||||
defined $bits or ($bits = '');
|
||||
foreach (@$work_units) {
|
||||
vec($bits,$_->fno(),1) = 1;
|
||||
};
|
||||
return $bits;
|
||||
}
|
||||
|
||||
#####################################################
|
||||
package Links::Parallel::WorkUnit;
|
||||
|
||||
use FileHandle;
|
||||
use strict;
|
||||
my $clwork_units = 0;
|
||||
|
||||
sub new {
|
||||
#------------------------------------------------------------
|
||||
# creates a new work unit, starts up the child process
|
||||
# and encapsulats all the required data...,
|
||||
#
|
||||
my ($class, $perlpath, $child, $cmdline, $to_check, $verbosity) = @_;
|
||||
my $self = {};
|
||||
$self->{verbosity} = $verbosity || 1;
|
||||
($self->{istream}, $self->{pid}) = new_handle ( $perlpath, $child, $cmdline, $to_check );
|
||||
@{$self->{to_check}} = @$to_check;
|
||||
@{$self->{checked}} = ();
|
||||
$self->{unitid} = $clwork_units++;
|
||||
$self->{start_time} = time;
|
||||
$self->{number_checked} = 0;
|
||||
bless $self, $class;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub new_handle {
|
||||
#------------------------------------------------------------
|
||||
# the function that actually creates a new child process
|
||||
#
|
||||
my ($perlpath, $child, $cmdline, $to_check, $verbosity) = @_;
|
||||
$verbosity ||= 1;
|
||||
|
||||
my $newfh = new FileHandle;
|
||||
my $pid = 0;
|
||||
$cmdline ||= '';
|
||||
$, = "|";
|
||||
|
||||
if ($verbosity) {
|
||||
print "Launching new child ... ";
|
||||
}
|
||||
if (-e $child) {
|
||||
$pid = $newfh->open ( "$perlpath $child $cmdline @$to_check |" );
|
||||
if ((!$pid)or($?)) { die "Error launching child '$perlpath $child $cmdline'. Status: $?"; }
|
||||
} else {
|
||||
die "Child ($child) must exist";
|
||||
}
|
||||
print "ok ($pid)\n";
|
||||
return ( $newfh, $pid );
|
||||
}
|
||||
|
||||
sub fno {
|
||||
#------------------------------------------------------------
|
||||
# returns the file handle, useful when using the
|
||||
# "select" call
|
||||
#
|
||||
my $self = shift;
|
||||
return fileno ( $self->{istream} );
|
||||
}
|
||||
|
||||
sub has_input {
|
||||
#------------------------------------------------------------
|
||||
# returns whether or not this workunit has anything to
|
||||
# report to the parent
|
||||
#
|
||||
my $self = shift;
|
||||
my $rin = '';
|
||||
vec ( $rin, $self->fno(), 1 ) = 1;
|
||||
my $s = select ( $rin, undef, undef, 0 );
|
||||
return $s;
|
||||
}
|
||||
|
||||
sub get_input {
|
||||
#------------------------------------------------------------
|
||||
# process the local input.
|
||||
# this is only here because we want to make sure that
|
||||
# the work unit keeps track of it's own work pool
|
||||
# this frees the task administrator to do it's real
|
||||
# work and helps with crash recovery
|
||||
#
|
||||
my $self = shift;
|
||||
my $fh = $self->{istream};
|
||||
$fh || die "not defined!";
|
||||
my $str = <$fh>;
|
||||
if ( defined ( $str ) ) {
|
||||
chop $str;
|
||||
$str =~ /\s*([0-9]+)\t([-0-9]*)\t(.*)/;
|
||||
push @{$self->{checked}}, $1;
|
||||
splice @{$self->{to_check}}, 0, 1;
|
||||
$self->{number_checked}++;
|
||||
return ( $1, $2, $3 );
|
||||
} else {
|
||||
$self->end_unit ();
|
||||
return;
|
||||
};
|
||||
}
|
||||
|
||||
sub get_stats {
|
||||
#------------------------------------------------------------
|
||||
# Display statistic information.
|
||||
#
|
||||
my $self = shift;
|
||||
return ( $self->{unitid}, $self->{start_time}, $self->{number_checked}, time-$self->{start_time} );
|
||||
}
|
||||
|
||||
sub end_unit {
|
||||
#------------------------------------------------------------
|
||||
# prepares the WorkUnit for deallocation. Note how
|
||||
# there is a force -9 kill, without that, perl will wait
|
||||
# until the child finishes on it's own, which might be
|
||||
# soon, later or in a 100 years
|
||||
#
|
||||
my $self = shift;
|
||||
my $fh = $self->{istream};
|
||||
|
||||
kill 9, ( $self->{pid} );
|
||||
$self->{istream}->close ();
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
#------------------------------------------------------------
|
||||
# deallocs the object
|
||||
# we want perl to force kill the child so we can ensure we exit
|
||||
# quickly
|
||||
my $self = shift;
|
||||
$self->end_unit;
|
||||
}
|
||||
|
||||
1;
|
||||
1663
site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm
Normal file
1663
site/slowtwitch.com/cgi-bin/articles/admin/Links/Payment.pm
Normal file
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,165 @@
|
||||
# ==================================================================
|
||||
# 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: AuthorizeDotNet.pm,v 1.3 2005/03/05 01:29:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Gossamer Links and Authorize.Net payment interface
|
||||
|
||||
package Links::Payment::Direct::AuthorizeDotNet;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use GT::Payment::Direct::AuthorizeDotNet;
|
||||
use Links qw/$IN $CFG $DB/;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of required field names. Each field name will be looked for
|
||||
# in the language file, prefixed with 'PAYMENT_DIRECT_AuthorizeDotNet_', for
|
||||
# the title of the field, and 'PAYMENT_DIRECT_DESC_AuthorizeDotNet_' for a
|
||||
# description of the field's contents.
|
||||
# Note that these are just required SETUP fields, so things like credit card
|
||||
# number, billing name, etc. are NOT included.
|
||||
return
|
||||
account_username => { type => 'TEXT', valid => '^\w+$' }, # FIXME - I have no idea what this can be
|
||||
account_key => { type => 'TEXT', valid => '^\w+$' };
|
||||
|
||||
}
|
||||
|
||||
sub optional {
|
||||
# -----------------------------------------------------------------------------
|
||||
my @currencies;
|
||||
for (sort {
|
||||
$a eq 'USD' ? -1 : $b eq 'USD' ? 1 : $a eq 'CAD' ? -1 : $b eq 'CAD' ? 1 :
|
||||
$GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$a} cmp
|
||||
$GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$b}
|
||||
} keys %GT::Payment::Direct::AuthorizeDotNet::CURRENCY) {
|
||||
push @currencies, $_ => $GT::Payment::Direct::AuthorizeDotNet::CURRENCY{$_};
|
||||
}
|
||||
return
|
||||
currency => {
|
||||
type => 'SELECT',
|
||||
options => \@currencies
|
||||
},
|
||||
account_password => { type => 'TEXT', size => 40, valid => '.' }, # An optionally-required account password
|
||||
confirmation_merchant => { type => 'TEXT', size => 40, valid => '.@.' }, # A merchant confirmation e-mail address
|
||||
confirmation_confirm => { type => 'YESNO' }, # Whether or not to send a customer confirmation e-mail.
|
||||
test_mode => { type => 'YESNO' }
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hash of various parameters used to figure out how to display the
|
||||
# payment form for this payment method.
|
||||
return {
|
||||
no_cc_brand => 1,
|
||||
fields => [
|
||||
grep ! /^(?:account|capture|currency|test)/, keys %GT::Payment::Direct::AuthorizeDotNet::VALID
|
||||
],
|
||||
billing_phone_required => 1
|
||||
}
|
||||
}
|
||||
|
||||
sub verify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns 1 on success, or an array ref of invalid keys
|
||||
# on failure.
|
||||
_collect_data();
|
||||
if (keys %INVALID or keys %EMPTY) {
|
||||
my ($i, %order);
|
||||
for (@{$GT::Payment::Direct::AuthorizeDotNet::REQUIRED{AUTHORIZE}}) { $order{$_} = $i++ }
|
||||
return [ # Error
|
||||
[sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %INVALID],
|
||||
[sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %EMPTY]
|
||||
];
|
||||
}
|
||||
else {
|
||||
return 1; # Success
|
||||
}
|
||||
}
|
||||
|
||||
sub complete {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns (1, $message) on success, (0, $reason) on
|
||||
# declined, or (-1, $errormsg) on error.
|
||||
|
||||
my $pay = _collect_data() or return;
|
||||
|
||||
# Set the admin-specified fields
|
||||
while (my ($k, $v) = each %{$CFG->{payment}->{direct}->{used}->{AuthorizeDotNet}}) {
|
||||
$pay->$k($v) or return (-1, "Payment configuration error (Invalid $k)");
|
||||
}
|
||||
|
||||
$pay->check('sale') or return (-1, $pay->error);
|
||||
my $ret = $pay->sale;
|
||||
if (not defined $ret) { # An error occured in the module
|
||||
return (-1, $pay->error);
|
||||
}
|
||||
else { # The request at least got through to Authorize.Net
|
||||
my $response = $pay->response;
|
||||
if ($ret == 1) { # Approved!
|
||||
my @receipt = @{$response->{receipt}};
|
||||
|
||||
my $receipt = "Transaction approved\n\n";
|
||||
while (@receipt) {
|
||||
my ($k, $v) = splice @receipt, 0, 2;
|
||||
$receipt .= "$k: $v\n";
|
||||
}
|
||||
|
||||
return (1, $response->{reason_text}, $receipt);
|
||||
}
|
||||
elsif ($ret == 0) { # Declined
|
||||
return (0, $response->{reason_text});
|
||||
}
|
||||
else { # An error was generated by Authorize.Net
|
||||
return (-1, $response->{reason_text});
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _collect_data {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Collect data from the payment data saved in the admin, and any valid columns
|
||||
# in $IN. Anything from $IN is checked for validity, and $INVALID{column} is
|
||||
# set if invalid.
|
||||
%INVALID = %EMPTY = ();
|
||||
return unless $CFG->{payment}->{direct}->{used}->{AuthorizeDotNet};
|
||||
my %data = %{$CFG->{payment}->{direct}->{used}->{AuthorizeDotNet}};
|
||||
my $pay = GT::Payment::Direct::AuthorizeDotNet->new();
|
||||
my %required = map { $_ => 1 } @{$GT::Payment::Direct::AuthorizeDotNet::REQUIRED{AUTHORIZE}};
|
||||
for my $field (keys %GT::Payment::Direct::AuthorizeDotNet::VALID) {
|
||||
# The account_*, capture_*, currency_*, etc. fields should not be user-settable.
|
||||
next if exists $data{$field} or $field =~ /^(?:account|capture|currency|test)/;
|
||||
if (my $value = $IN->param($field)) {
|
||||
if ($pay->$field($value)) {
|
||||
$data{$field} = $value;
|
||||
}
|
||||
else {
|
||||
$INVALID{$field}++;
|
||||
$data{$field} = undef;
|
||||
}
|
||||
}
|
||||
elsif ($required{$field}) {
|
||||
$EMPTY{$field}++;
|
||||
$data{$field} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
$pay->billing_ip($ENV{REMOTE_ADDR}) if $ENV{REMOTE_ADDR} and $ENV{REMOTE_ADDR} ne '127.0.0.1';
|
||||
|
||||
return if keys %INVALID or keys %EMPTY;
|
||||
return $pay;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,152 @@
|
||||
# ==================================================================
|
||||
# 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: Moneris.pm,v 1.2 2005/03/05 01:29:09 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Gossamer Links and Moneris payment interface
|
||||
|
||||
package Links::Payment::Direct::Moneris;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use GT::Payment::Direct::Moneris 1.007; # CVS Versions < 1.7 were for the old, defunct Moneris payment system
|
||||
use Links qw/$IN $CFG $DB/;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
my @FIELDS = (
|
||||
keys %GT::Payment::Direct::Moneris::NAME_MAP,
|
||||
qw/ credit_card_number credit_card_expiry_month credit_card_expiry_year
|
||||
billing_country billing_email charge_total/
|
||||
);
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of required field names. Each field name will be looked for
|
||||
# in the language file, prefixed with 'PAYMENT_DIRECT_Moneris_', for the title
|
||||
# of the field, and 'PAYMENT_DIRECT_DESC_Moneris_' for a description of the
|
||||
# field's contents.
|
||||
# Note that these are just required SETUP fields, so things like credit card
|
||||
# number, billing name, etc. are NOT included.
|
||||
return
|
||||
account_token => { type => 'TEXT', valid => '^\w+$' },
|
||||
account_token2 => { type => 'TEXT', valid => '^\w+$' };
|
||||
}
|
||||
|
||||
sub optional {
|
||||
return
|
||||
test_mode => { type => 'YESNO' }
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hash of various parameters used to figure out how to display the
|
||||
# payment form for this payment method.
|
||||
return {
|
||||
fields => [
|
||||
grep ! /^(?:account|capture|currency|test)/, @FIELDS
|
||||
],
|
||||
no_cc_brand => 1
|
||||
};
|
||||
}
|
||||
|
||||
sub verify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns 1 on success, or an array ref of invalid and
|
||||
# empty keys array references (i.e. [\@invalid, \@empty]) on failure.
|
||||
_collect_data();
|
||||
if (keys %INVALID or keys %EMPTY) {
|
||||
my ($i, %order);
|
||||
for (@{$GT::Payment::Direct::Moneris::REQUIRED{AUTHORIZE}}) { $order{$_} = $i++ }
|
||||
return [ # Error
|
||||
[sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %INVALID],
|
||||
[sort { ($order{$a} || 0x7fff_ffff) <=> ($order{$b} || 0x7fff_ffff) } keys %EMPTY]
|
||||
];
|
||||
}
|
||||
else {
|
||||
return 1; # Success
|
||||
}
|
||||
}
|
||||
|
||||
sub complete {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns (1, $message) on success, (0, $reason) on
|
||||
# declined, or (-1, $errormsg) on error.
|
||||
|
||||
my $pay = _collect_data() or return;
|
||||
|
||||
# Set the admin-specified fields
|
||||
while (my ($k, $v) = each %{$CFG->{payment}->{direct}->{used}->{Moneris}}) {
|
||||
$pay->$k($v) or return (-1, "Payment configuration error (Invalid $k)");
|
||||
}
|
||||
|
||||
$pay->check('sale') or return (-1, $pay->error);
|
||||
my $ret = $pay->sale;
|
||||
if (not defined $ret) { # An error occured in the module
|
||||
return (-1, $pay->error);
|
||||
}
|
||||
else { # The request at least got through to Moneris
|
||||
if ($ret == 1) { # Approved!
|
||||
my $resp_text;
|
||||
my @receipt = $pay->receipt();
|
||||
my $receipt = "Transaction approved\n\n";
|
||||
while (@receipt) {
|
||||
my ($k, $v) = splice @receipt, 0, 2;
|
||||
$receipt .= "$k: $v\n";
|
||||
$resp_text = $v if $k eq 'Status';
|
||||
}
|
||||
|
||||
return (1, $resp_text, $receipt);
|
||||
}
|
||||
elsif ($ret == 0) { # Declined
|
||||
return (0, $pay->error);
|
||||
}
|
||||
else { # An error was generated by Moneris
|
||||
return (-1, $pay->error);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _collect_data {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Collect data from the payment data saved in the admin, and any valid columns
|
||||
# in $IN. Anything from $IN is checked for validity, and $INVALID{column} is
|
||||
# set if invalid.
|
||||
%INVALID = %EMPTY = ();
|
||||
return unless $CFG->{payment}->{direct}->{used}->{Moneris};
|
||||
my %data = %{$CFG->{payment}->{direct}->{used}->{Moneris}};
|
||||
return unless keys %data;
|
||||
my $pay = GT::Payment::Direct::Moneris->new(debug_level => $CFG->{debug});
|
||||
my %required = map { $_ => 1 } @{$GT::Payment::Direct::Moneris::REQUIRED{AUTHORIZE}};
|
||||
for my $field (@FIELDS) {
|
||||
# The account_*, capture_*, currency_*, etc. fields should not be user-settable.
|
||||
next if exists $data{$field} or $field =~ /^(?:account|capture|currency|test)/;
|
||||
if (my $value = $IN->param($field)) {
|
||||
if ($pay->$field($value)) {
|
||||
$data{$field} = $value;
|
||||
}
|
||||
else {
|
||||
$INVALID{$field}++;
|
||||
$data{$field} = undef;
|
||||
}
|
||||
}
|
||||
elsif ($required{$field}) {
|
||||
$EMPTY{$field}++;
|
||||
$data{$field} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
return if keys %INVALID or keys %EMPTY;
|
||||
return $pay;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,122 @@
|
||||
# ==================================================================
|
||||
# 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: 2CheckOut.pm,v 1.13 2006/08/22 23:07:53 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Gossamer Links and 2CheckOut payment interface
|
||||
|
||||
package Links::Payment::Remote::2CheckOut;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use GT::Payment::Remote::2CheckOut;
|
||||
use Links qw/:objects/;
|
||||
use Links::Payment qw/:status :log/;
|
||||
use Links::SiteHTML;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of required field names. Each field name will be looked for
|
||||
# in the language file, prefixed with 'PAYMENT_REMOTE_2CheckOut_', for the
|
||||
# title of the field, and 'PAYMENT_REMOTE_DESC_2CheckOut_' for a description of
|
||||
# the field's contents.
|
||||
# Note that these are just required SETUP fields, so things like credit card
|
||||
# number, billing name, etc. are NOT included.
|
||||
|
||||
return
|
||||
seller_id => { type => 'TEXT', valid => '^\d{1,10}$' },
|
||||
secret_word => { type => 'TEXT', valid => '^(?!tango$).+$' };
|
||||
}
|
||||
|
||||
sub optional {
|
||||
# -----------------------------------------------------------------------------
|
||||
return
|
||||
demo => { type => 'YESNO' };
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hashref of payment hints
|
||||
#
|
||||
my @fields = qw/seller_id secret_word demo/;
|
||||
my $ret = {
|
||||
fields => \@fields
|
||||
};
|
||||
if (my $info = $CFG->{payment}->{remote}->{used}->{'2CheckOut'}) {
|
||||
for (@fields) {
|
||||
$ret->{$_} = $info->{$_};
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub verify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns 1 on success, or an array ref of invalid keys
|
||||
# on failure. For Remote payment methods, this has no real effect.
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub postback {
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
my $pay = $DB->table('Payments');
|
||||
my $log = $DB->table('PaymentLogs');
|
||||
|
||||
my $unique = $IN->param('cart_order_id');
|
||||
my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref
|
||||
or return; # Whatever it is, we didn't create it.
|
||||
|
||||
GT::Payment::Remote::2CheckOut::process(
|
||||
param => $IN,
|
||||
sellerid => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{seller_id},
|
||||
password => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{secret_word},
|
||||
demo => $CFG->{payment}->{remote}->{used}->{'2CheckOut'}->{demo},
|
||||
on_valid => sub {
|
||||
return unless $IN->param('total') >= $payment->{payments_amount};
|
||||
|
||||
return if $payment->{payments_status} == COMPLETED;
|
||||
|
||||
my $cond = GT::SQL::Condition->new();
|
||||
$cond->add(paylogs_payments_id => '=' => $unique);
|
||||
$cond->add(paylogs_type => '=' => LOG_ACCEPTED);
|
||||
$cond->add(paylogs_text => LIKE => "%\n2CheckOut order number: " . $IN->param('order_number') . "%\n");
|
||||
my $found = $log->count($cond);
|
||||
return if $found;
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => '2CheckOut') . "\n" .
|
||||
"2CheckOut order number: " . $IN->param('order_number') . "\n" .
|
||||
"Amount: $payment->{payments_amount}\n"
|
||||
)
|
||||
});
|
||||
|
||||
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term});
|
||||
}
|
||||
);
|
||||
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('payment_success');
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,70 @@
|
||||
# ==================================================================
|
||||
# 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: Manual.pm,v 1.3 2005/03/05 01:46:06 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Gossamer Links and Manual payment interface
|
||||
|
||||
package Links::Payment::Remote::Manual;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use Links qw/:objects/;
|
||||
use Links::Payment qw/:status :log/;
|
||||
use Links::SiteHTML;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# No required parameters available
|
||||
return;
|
||||
}
|
||||
|
||||
sub optional {
|
||||
# -----------------------------------------------------------------------------
|
||||
# No optional parameters available.
|
||||
return;
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hashref of payment hints
|
||||
#
|
||||
return;
|
||||
}
|
||||
|
||||
sub insert_log {
|
||||
# -----------------------------------------------------------------------------
|
||||
#
|
||||
my $unique = shift;
|
||||
my $pay = $DB->table('Payments');
|
||||
my $log = $DB->table('PaymentLogs');
|
||||
my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref or return; # return if the payment doesn't exist.
|
||||
return if $payment->{payments_status} == COMPLETED;
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
paylogs_payments_id => '=' => $unique,
|
||||
paylogs_type => '=' => LOG_ACCEPTED
|
||||
);
|
||||
my $found = $log->count($cond);
|
||||
return if $found;
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_MANUAL,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
"This payment will be manually approved by admin.\n" .
|
||||
"Amount: $payment->{payments_amount}\n"
|
||||
)
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,296 @@
|
||||
# ==================================================================
|
||||
# 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: PayPal.pm,v 1.16 2006/12/01 00:31:56 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Gossamer Links and PayPal IPN payment interface
|
||||
|
||||
package Links::Payment::Remote::PayPal;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use GT::Payment::Remote::PayPal;
|
||||
use Links qw/:objects/;
|
||||
use Links::Payment qw/:status :log/;
|
||||
use Links::SiteHTML;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of required field names. Each field name will be looked for
|
||||
# in the language hash, prefixed with 'PAYMENT_REMOTE_PayPal_', for the title
|
||||
# of the field, and 'PAYMENT_REMOTE_DESC_PayPal_' for a description of the
|
||||
# field's contents.
|
||||
# Note that these are just required SETUP fields, so things like credit card
|
||||
# number, billing name, etc. are NOT included.
|
||||
my @currencies;
|
||||
for (qw/USD CAD AUD EUR GBP JPY NZD CHF HKD SGD SEK DKK PLN NOK HUF CZK/) {
|
||||
push @currencies, $_ => Links::language('PAYMENT_CURRENCY_' . $_);
|
||||
}
|
||||
|
||||
my @buttons;
|
||||
for (qw/23 cc 02 03 01 9 5 6/) {
|
||||
push @buttons, "x-click-but$_.gif" => qq|<img src="https://www.paypal.com/images/x-click-but$_.gif">|;
|
||||
}
|
||||
|
||||
my $custom = qq|Custom image:<br><input type="text" name="button_custom" size="60"|;
|
||||
if ($CFG->{payment}->{remote}->{used}->{PayPal} and $CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}) {
|
||||
$custom .= qq| value="$CFG->{payment}->{remote}->{used}->{PayPal}->{button_custom}"|;
|
||||
}
|
||||
$custom .= '>';
|
||||
|
||||
push @buttons, "custom" => $custom;
|
||||
|
||||
return
|
||||
business_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' },
|
||||
currency => {
|
||||
type => 'SELECT',
|
||||
options => \@currencies
|
||||
},
|
||||
button => {
|
||||
type => 'RADIO',
|
||||
options => \@buttons,
|
||||
custom => 1,
|
||||
valid => '^https?://[a-zA-Z0-9-]' # Only applies to the custom value
|
||||
}
|
||||
}
|
||||
|
||||
sub optional {
|
||||
# -----------------------------------------------------------------------------
|
||||
return
|
||||
image_url => { type => 'TEXT', size => 60, value => '^https?://[a-zA-Z0-9-]' },
|
||||
notify_url => { type => 'TEXT', size => '60', value => '^https?://[a-zA-Z0-9-]' },
|
||||
note => { type => 'TEXT', size => 30, value => '^.{1,30}$' },
|
||||
color => {
|
||||
type => 'SELECT',
|
||||
options => [
|
||||
white => Links::language('PAYMENT_REMOTE_PayPal_color_white'),
|
||||
black => Links::language('PAYMENT_REMOTE_PayPal_color_black')
|
||||
]
|
||||
},
|
||||
to_email => { type => 'TEXT', valid => '.@[a-zA-Z0-9-]' },
|
||||
sandbox => { type => 'YESNO' };
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hash of payment hints
|
||||
#
|
||||
my @fields = qw/business_email to_email currency button button_custom image_url notify_url note color sandbox/;
|
||||
my $ret = {
|
||||
fields => \@fields
|
||||
};
|
||||
if (my $pp = $CFG->{payment}->{remote}->{used}->{PayPal}) {
|
||||
for (@fields) {
|
||||
$ret->{$_ eq 'image_url' ? 'pp_image_url' : $_} = $pp->{$_};
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub verify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns 1 on success, or an array ref of invalid keys
|
||||
# on failure.
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub postback {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Handle PayPal postback
|
||||
my $unique = $IN->param('invoice');
|
||||
my $pay = $DB->table('Payments');
|
||||
my $log = $DB->table('PaymentLogs');
|
||||
my $payment = $pay->get($unique) or return;
|
||||
|
||||
GT::Payment::Remote::PayPal::process(
|
||||
param => $IN,
|
||||
sandbox => $CFG->{payment}->{remote}->{used}->{PayPal}->{sandbox},
|
||||
on_valid => sub {
|
||||
# If taxes or shipping was added, then mc_gross may be greater than payments_amount.
|
||||
if ($IN->param('mc_gross') < $payment->{payments_amount}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
||||
$IN->param('mc_gross') . " < " . $payment->{payments_amount}
|
||||
});
|
||||
return;
|
||||
}
|
||||
elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (different currency): " .
|
||||
$IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
return if $payment->{payments_status} == COMPLETED;
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" .
|
||||
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
||||
"Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: "
|
||||
. $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" .
|
||||
"Payer Email: " . $IN->param('payer_email') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term});
|
||||
},
|
||||
on_pending => sub {
|
||||
$pay->update({ payments_last => time }, { payments_id => $unique });
|
||||
|
||||
my $match = Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason'));
|
||||
my $str = $match ? Links::language('PAYLOG_PayPal_' . $IN->param('pending_reason')) : '';
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_INFO,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
||||
"Pending: " . ($match ? $str : scalar $IN->param('pending_reason'))
|
||||
)
|
||||
});
|
||||
},
|
||||
on_refund => sub {
|
||||
$pay->update({ payments_last => time }, { payments_id => $unique });
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_INFO,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_REFUND') => 'PayPal') . "\n" .
|
||||
"Transaction ID: " . $IN->param('txn_id') . "\n"
|
||||
)
|
||||
});
|
||||
},
|
||||
on_failed => sub {
|
||||
$pay->update(
|
||||
{ payments_status => DECLINED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_DECLINED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Transaction ID: " . $IN->param('txn_id')
|
||||
});
|
||||
},
|
||||
on_denied => sub {
|
||||
$pay->update(
|
||||
{ payments_status => DECLINED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_DECLINED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Transaction ID: " . $IN->param('txn_id')
|
||||
});
|
||||
},
|
||||
duplicate => sub {
|
||||
my $id = $IN->param('txn_id');
|
||||
my $cond = GT::SQL::Condition->new();
|
||||
$cond->add(paylogs_payments_id => '=' => $unique);
|
||||
$cond->add(paylogs_type => '=' => LOG_ACCEPTED);
|
||||
$cond->add(paylogs_text => LIKE => "%\nTransaction ID: $id\n%");
|
||||
my $found = $log->count($cond);
|
||||
return $found ? undef : 1; # True if everything checks out; undef if a duplicate was found
|
||||
},
|
||||
email => sub {
|
||||
my $email = shift;
|
||||
return lc $email eq lc $CFG->{payment}->{remote}->{used}->{PayPal}->{business_email}
|
||||
},
|
||||
on_error => sub {
|
||||
my $errmsg = shift;
|
||||
$pay->update(
|
||||
{ payments_status => ERROR, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => $errmsg
|
||||
});
|
||||
},
|
||||
on_recurring => sub {
|
||||
if ($IN->param('mc_gross') < $payment->{payments_amount}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (payment amount is less than original charge): " .
|
||||
$IN->param('mc_gross') . " < " . $payment->{payments_amount}
|
||||
});
|
||||
return;
|
||||
}
|
||||
elsif ($IN->param('mc_currency') ne $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}) {
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => "Invalid payment (different currency): " .
|
||||
$IN->param('mc_currency') . " != " . $CFG->{payment}->{remote}->{used}->{PayPal}->{currency}
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'PayPal') . "\n" .
|
||||
"Transaction ID: " . $IN->param('txn_id') . "\n" .
|
||||
"Amount: " . $IN->param('mc_currency') . " " . $IN->param('mc_gross') . " (Fee: "
|
||||
. $IN->param('mc_currency') . " " . $IN->param('mc_fee') . ")\n" .
|
||||
"Payer Email: " . $IN->param('payer_email') . "\n" .
|
||||
"Subscription ID: " . $IN->param('subscr_id') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}, 1);
|
||||
}
|
||||
);
|
||||
|
||||
# There is no way to distinguish between PayPal sending the user back, and
|
||||
# PayPal posting the IPN, so we print a payment confirmation page.
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('payment_success');
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,207 @@
|
||||
# ==================================================================
|
||||
# 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: WorldPay.pm,v 1.13 2006/08/22 23:05:13 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2003 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
#
|
||||
# Glue between Links and WorldPay payment interface
|
||||
|
||||
package Links::Payment::Remote::WorldPay;
|
||||
use strict;
|
||||
|
||||
# Make sure the payment module is available
|
||||
use GT::Payment::Remote::WorldPay;
|
||||
use Links qw/:objects/;
|
||||
use Links::Payment qw/:status :log/;
|
||||
use Links::SiteHTML;
|
||||
use vars qw/%INVALID %EMPTY/;
|
||||
|
||||
sub required {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a list of required field names. Each field name will be looked for
|
||||
# in the language file, prefixed with 'PAYMENT_REMOTE_WorldPay_', for the title
|
||||
# of the field, and 'PAYMENT_REMOTE_DESC_WorldPay_' for a description of the
|
||||
# field's contents.
|
||||
# Note that these are just required SETUP fields, so things like credit card
|
||||
# number, billing name, etc. are NOT included.
|
||||
my @currencies;
|
||||
for (qw/USD CAD EUR GBP AFA ALL DZD AON ARS AWG AUD BSD BHD BDT BBD BZD BMD BOB BAD BWP BRL BND BGL XOF BIF KHR
|
||||
XAF CVE KYD CLP CNY COP KMF CRC HRK CUP CYP CZK DKK DJF XCD DOP TPE ECS EGP SVC EEK ETB FKP FJD XPF GMD GHC
|
||||
GIP GTQ GNF GWP GYD HTG HNL HKD HUF ISK INR IDR IRR IQD ILS JMD JPY JOD KZT KES KRW KPW KWD KGS LAK LVL LBP
|
||||
LSL LRD LYD LTL MOP MKD MGF MWK MYR MVR MTL MRO MUR MXN MNT MAD MZM MMK NAD NPR ANG NZD NIO NGN NOK OMR PKR
|
||||
PAB PGK PYG PEN PHP PLN QAR ROL RUR RWF WST STD SAR SCR SLL SGD SKK SIT SBD SOS ZAR LKR SHP SDP SRG SZL SEK
|
||||
CHF SYP TWD TJR TZS THB TOP TTD TND TRL UGX UAH AED UYU VUV VEB VND YER YUM ZRN ZMK ZWD/) {
|
||||
push @currencies, $_ => Links::language('PAYMENT_CURRENCY_' . $_);
|
||||
}
|
||||
|
||||
return
|
||||
installation_id => { type => 'TEXT', valid => '^\d{1,16}$' },
|
||||
callback_password => { type => 'TEXT' },
|
||||
md5_password => { type => 'TEXT' },
|
||||
currency => {
|
||||
type => 'SELECT',
|
||||
options => \@currencies
|
||||
}
|
||||
}
|
||||
|
||||
sub optional {
|
||||
# -----------------------------------------------------------------------------
|
||||
return
|
||||
test_mode => { type => 'SELECT', options => [100 => 'Test mode: Always approved', 101 => 'Test mode: Always declined'] }
|
||||
}
|
||||
|
||||
sub payment_info {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Returns a hashref of payment hints
|
||||
#
|
||||
my @fields = qw/currency installation_id md5_password test_mode/;
|
||||
my $ret = {
|
||||
fields => \@fields
|
||||
};
|
||||
if (my $pp = $CFG->{payment}->{remote}->{used}->{WorldPay}) {
|
||||
for (@fields) {
|
||||
$ret->{$_ eq 'image_url' ? 'pp_image_url' : $_} = $pp->{$_};
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub verify {
|
||||
# -----------------------------------------------------------------------------
|
||||
# Checks that $IN, combined with the saved admin settings, makes up all of the
|
||||
# required information. Returns 1 on success, or an array ref of invalid keys
|
||||
# on failure. For Remote payment methods, this has no real effect.
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub postback {
|
||||
# -----------------------------------------------------------------------------
|
||||
|
||||
my $pay = $DB->table('Payments');
|
||||
my $log = $DB->table('PaymentLogs');
|
||||
|
||||
my $unique = $IN->param('cartId');
|
||||
my $payment = $pay->select({ payments_id => $unique })->fetchrow_hashref
|
||||
or return; # Whatever it is, we didn't create it.
|
||||
|
||||
my $end = 1; # Returned after processing - if true, a blank page will be displayed,
|
||||
# if false, a worldpay receipt page.
|
||||
|
||||
GT::Payment::Remote::WorldPay::process(
|
||||
param => $IN,
|
||||
password => $CFG->{payment}->{remote}->{used}->{WorldPay}->{callback_password},
|
||||
test_mode => $CFG->{payment}->{remote}->{used}->{WorldPay}->{test_mode},
|
||||
on_valid => sub {
|
||||
# A one-time payment (or the initial payment, in the case of recurring payments)
|
||||
return unless $IN->param('amount') >= $payment->{payments_amount};
|
||||
|
||||
return if $payment->{payments_status} == COMPLETED;
|
||||
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_APPROVED') => 'WorldPay') . "\n" .
|
||||
"Transaction ID: " . $IN->param('transId') . "\n" .
|
||||
"Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" .
|
||||
($IN->param('futurePayId') ? "FuturePay ID: " . $IN->param('futurePayId') . "\n" : '') .
|
||||
"Authorization Message: " . $IN->param('rawAuthMessage') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term});
|
||||
|
||||
$end = 0;
|
||||
},
|
||||
on_cancel => sub {
|
||||
# The user clicked "cancel payment"
|
||||
$pay->update(
|
||||
{ payments_status => DECLINED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_DECLINED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_CANCELLED') => 'WorldPay') . "\n" .
|
||||
"Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n"
|
||||
)
|
||||
});
|
||||
},
|
||||
on_invalid_password => sub {
|
||||
$pay->update(
|
||||
{ payments_status => ERROR, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ERROR,
|
||||
paylogs_time => time,
|
||||
paylogs_text => sprintf(Links::language('PAYMENT_REMOTE_INVALIDPW') => 'WorldPay') . "\n"
|
||||
});
|
||||
},
|
||||
on_recurring => sub {
|
||||
# A recurring payment, NOT counting the original payment
|
||||
$pay->update(
|
||||
{ payments_status => COMPLETED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_ACCEPTED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_RECURRING_ACCEPTED') => 'WorldPay') . "\n" .
|
||||
"Transaction ID: " . $IN->param('transId') . "\n" .
|
||||
"Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n" .
|
||||
"FuturePay ID: " . $IN->param('futurePayId') . "\n" .
|
||||
"Authorization Message: " . $IN->param('rawAuthMessage') . "\n"
|
||||
)
|
||||
});
|
||||
|
||||
# The "1" gives them an extra day for recurring payments.
|
||||
Links::Payment::process_payment($payment->{payments_linkid}, $payment->{payments_term}, 1);
|
||||
},
|
||||
on_recurring_failed => sub {
|
||||
$pay->update(
|
||||
{ payments_status => DECLINED, payments_last => time },
|
||||
{ payments_id => $payment->{payments_id} }
|
||||
);
|
||||
|
||||
$log->insert({
|
||||
paylogs_payments_id => $payment->{payments_id},
|
||||
paylogs_type => LOG_DECLINED,
|
||||
paylogs_time => time,
|
||||
paylogs_text => (
|
||||
sprintf(Links::language('PAYMENT_REMOTE_RECURRING_DECLINED') => 'WorldPay') . "\n" .
|
||||
"Amount: " . $IN->param('amountString') . " (" . $IN->param('authAmountString') . ")\n"
|
||||
)
|
||||
});
|
||||
}
|
||||
);
|
||||
|
||||
print $IN->header;
|
||||
unless ($end) {
|
||||
print Links::SiteHTML::display('payment_success');
|
||||
}
|
||||
1;
|
||||
}
|
||||
|
||||
1;
|
||||
166
site/slowtwitch.com/cgi-bin/articles/admin/Links/Plugins.pm
Normal file
166
site/slowtwitch.com/cgi-bin/articles/admin/Links/Plugins.pm
Normal file
@@ -0,0 +1,166 @@
|
||||
# ==================================================================
|
||||
# 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: Plugins.pm,v 1.48 2005/04/14 01:08:49 jagerman 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::Plugins;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/$IN $CFG/;
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Plugin config #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub get_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'Links::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
my $opts = {};
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opts->{$opt->[0]} = $opt->[1];
|
||||
}
|
||||
return $opts;
|
||||
}
|
||||
|
||||
sub set_plugin_user_cfg {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'Links::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
(ref $cfg->{$plugin_name}->{user} eq 'ARRAY') or return {};
|
||||
|
||||
foreach my $opt (@{$cfg->{$plugin_name}->{user}}) {
|
||||
$opt->[1] = $hash->{$opt->[0]};
|
||||
}
|
||||
return GT::Plugins->save_cfg ( $CFG->{admin_root_path} . '/Plugins', $cfg );
|
||||
}
|
||||
|
||||
sub get_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Returns the user config hash for a given plugin.
|
||||
#
|
||||
my $class = ($_[0] eq 'Links::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/Plugins' );
|
||||
exists $cfg->{$plugin_name} or return {};
|
||||
|
||||
return ( $cfg->{$plugin_name}->{registry} || {} );
|
||||
}
|
||||
|
||||
sub set_plugin_registry {
|
||||
# --------------------------------------------------------------
|
||||
# Takes a plugin name and config hash and saves it.
|
||||
#
|
||||
my $class = ($_[0] eq 'Links::Plugins') ? shift : '';
|
||||
my $plugin_name = shift || return;
|
||||
my $hash = shift || return;
|
||||
|
||||
my $cfg = GT::Plugins->load_cfg ( $CFG->{admin_root_path} . '/Plugins' );
|
||||
|
||||
exists $cfg->{$plugin_name} or return;
|
||||
|
||||
my $registry = ( $cfg->{$plugin_name}->{registry} ||= {} );
|
||||
foreach my $opt ( keys %{$hash} ) {
|
||||
$registry->{$opt} = $hash->{$opt};
|
||||
}
|
||||
|
||||
return GT::Plugins->save_cfg ( $CFG->{admin_root_path} . '/Plugins', $cfg );
|
||||
}
|
||||
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Displaying #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub admin_menu {
|
||||
# -----------------------------------------------------------------
|
||||
# Displays the admin menu with the plugin options shown.
|
||||
#
|
||||
require GT::Plugins::Manager;
|
||||
my $man = new GT::Plugins::Manager (
|
||||
cgi => $IN,
|
||||
tpl_root => $CFG->{admin_root_path} . "/templates/admin",
|
||||
plugin_dir => $CFG->{admin_root_path} . "/Plugins",
|
||||
prog_name => 'lsql',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
base_url => 'admin.cgi?do=page&page=plugin_manager.html',
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{admin_root_path}"
|
||||
);
|
||||
return $man->admin_menu;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Wizard #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub wizard {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin wizard, basically just creates a wizard object,
|
||||
# and returns the output. Real work is done in GT::Plugins::Wizard.
|
||||
#
|
||||
require GT::Plugins::Wizard;
|
||||
my $wiz = GT::Plugins::Wizard->new(
|
||||
cgi => $IN,
|
||||
tpl_root => $CFG->{admin_root_path} . "/templates/admin",
|
||||
plugin_dir => $CFG->{admin_root_path} . "/Plugins",
|
||||
prog_ver => $CFG->{version},
|
||||
install_header => 'use Links qw/:objects/;',
|
||||
initial_indent => '',
|
||||
dirs => {
|
||||
user_cgi => '$CFG->{admin_root_path}/..',
|
||||
admin_cgi => '$CFG->{admin_root_path}'
|
||||
},
|
||||
oo => '$PLG'
|
||||
);
|
||||
return $wiz->process;
|
||||
}
|
||||
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
# Manager #
|
||||
# ------------------------------------------------------------------------------------------------- #
|
||||
|
||||
sub manager {
|
||||
# -------------------------------------------------------------------
|
||||
# Manages the plugin installer, basically just creates an installerobject,
|
||||
# and returns the output. Real work is done in GT::Plugins::Installer
|
||||
#
|
||||
|
||||
require GT::Plugins::Manager;
|
||||
my $man = GT::Plugins::Manager->new(
|
||||
cgi => $IN,
|
||||
tpl_root => $CFG->{admin_root_path} . "/templates/admin",
|
||||
plugin_dir => $CFG->{admin_root_path} . "/Plugins",
|
||||
prog_name => 'lsql',
|
||||
prog_ver => $CFG->{version},
|
||||
prog_init => $CFG->{admin_root_path},
|
||||
prog_reg => $CFG->{reg_number},
|
||||
base_url => 'admin.cgi?do=page&page=plugin_manager.html',
|
||||
path_to_perl => $CFG->{path_to_perl},
|
||||
perl_args => "-cw -I$CFG->{admin_root_path}"
|
||||
) or return "Error loading plugin manager: $GT::Plugins::error";
|
||||
return $man->process;
|
||||
}
|
||||
|
||||
1;
|
||||
586
site/slowtwitch.com/cgi-bin/articles/admin/Links/SQL.pm
Normal file
586
site/slowtwitch.com/cgi-bin/articles/admin/Links/SQL.pm
Normal file
@@ -0,0 +1,586 @@
|
||||
# ==================================================================
|
||||
# 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: SQL.pm,v 1.141 2007/11/16 07:15:00 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.
|
||||
# ==================================================================
|
||||
|
||||
# Contains the default table structure for Gossamer Links tables.
|
||||
package Links::SQL;
|
||||
|
||||
use strict;
|
||||
use vars qw/@TABLES/;
|
||||
use Links qw/:payment $DB/;
|
||||
|
||||
@TABLES = qw(
|
||||
Users Links Changes Category CatPrice Reviews CatLinks CatRelations
|
||||
Editors Verify Sessions EmailTemplates EmailMailings MailingIndex
|
||||
MailingList MailingListIndex ClickTrack Payments PaymentLogs
|
||||
Bookmark_Folders Bookmark_Links SearchLogs NewsletterSubscription
|
||||
);
|
||||
|
||||
sub tables {
|
||||
# ------------------------------------------------------------------
|
||||
# Defines the SQL tables.
|
||||
#
|
||||
my $action = shift || 'warn';
|
||||
my $output = '';
|
||||
|
||||
my $ok = Links::language('dialog_ok');
|
||||
|
||||
# --------- Users Table ----------------
|
||||
create_table(\$output, 'Users', $action,
|
||||
cols => [
|
||||
Username => { type => 'CHAR', size => 50, not_null => 1, form_display => Links::language('prompt_Username') },
|
||||
Password => { type => 'CHAR', binary => 1, size => 25, not_null => 1, form_display => Links::language('prompt_Password') },
|
||||
Email => { type => 'CHAR', size => 75, not_null => 1, regex => '^(?:.+\@.+\..+|\s*)$', form_display => Links::language('prompt_Email') },
|
||||
Name => { type => 'CHAR', size => 75, form_display => Links::language('prompt_Name') },
|
||||
Validation => { type => 'CHAR', size => 20, , form_display => Links::language('prompt_Validation') },
|
||||
Status => { type => 'ENUM', values => ['Not Validated', 'Registered', 'Administrator'], not_null => 1, default => 'Registered', form_display => Links::language('prompt_Status') },
|
||||
ReceiveMail => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'Yes', form_display => Links::language('prompt_ReceiveMail') },
|
||||
SortField => { type => 'VARCHAR', size => 255, not_null => 1, regex => '^[\s\w]+$', default => 'Title', form_display => Links::language('prompt_SortField') },
|
||||
SortOrd => { type => 'ENUM', values => ['ASC', 'DESC'], not_null => 1, default => 'ASC', form_display => Links::language('prompt_SortOrd') },
|
||||
PerPage => { type => 'INT', not_null => 1, unsigned => 1, default => 15, form_display => Links::language('prompt_PerPage') },
|
||||
Grouping => { type => 'TINYINT', not_null => 1, unsigned => 1, default => 0, form_display => Links::language('prompt_Grouping') },
|
||||
],
|
||||
index => {
|
||||
emailndx => ['Email']
|
||||
},
|
||||
pk => 'Username',
|
||||
subclass => {
|
||||
table => { Users => 'Links::Table::Users' },
|
||||
html => { Users => 'Links::HTML::Users' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Links Table ----------------
|
||||
create_table(\$output, 'Links', $action,
|
||||
cols => [
|
||||
ID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_ID') },
|
||||
Title => { type => 'CHAR', size => 100, not_null => 1, weight => 3, form_display => Links::language('prompt_Title') },
|
||||
URL => { type => 'CHAR', size => 255, not_null => 1, weight => 1, default => 'http://', regex => '^\w+:', form_display => Links::language('prompt_URL') },
|
||||
LinkOwner => { type => 'CHAR', size => 50, not_null => 1, default => 'admin', form_display => Links::language('prompt_LinkOwner') },
|
||||
Add_Date => { type => 'DATE', not_null => 1, form_display => Links::language('prompt_Add_Date') },
|
||||
Mod_Date => { type => 'DATE', not_null => 1, form_display => Links::language('prompt_Mod_Date') },
|
||||
Description => { type => 'TEXT', weight => 1, form_display => Links::language('prompt_Description') },
|
||||
Contact_Name => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Contact_Name') },
|
||||
Contact_Email => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Contact_Email') },
|
||||
Hits => { type => 'INT', not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Hits') },
|
||||
isNew => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isNew') },
|
||||
isChanged => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isChanged') },
|
||||
isPopular => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_isPopular') },
|
||||
isValidated => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'Yes', form_display => Links::language('prompt_isValidated') },
|
||||
Rating => { type => 'DECIMAL', precision => 4, scale => 2, not_null => 1, default => 0, regex => '^(?:10(?:\.0*)?|\d(?:\.\d*)?)$', form_display => Links::language('prompt_Rating') },
|
||||
Votes => { type => 'SMALLINT', unsigned => 1, not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Votes') },
|
||||
Status => { type => 'SMALLINT', not_null => 1, default => 0, regex => '^-?\d+$', form_display => Links::language('prompt_Status') },
|
||||
Date_Checked => { type => 'DATETIME', form_display => Links::language('prompt_Date_Checked') },
|
||||
Timestmp => { type => 'TIMESTAMP', time_check => 1, form_display => Links::language('prompt_Timestmp') },
|
||||
ExpiryDate => { type => 'INT', not_null => 1, default => FREE, form_display => Links::language('prompt_ExpiryDate'), form_size => 35 }, # See FREE, UNPAID & UNLIMITED constants in Links.pm
|
||||
ExpiryCounted => { type => 'TINYINT', not_null => 1, default => 0, form_display => Links::language('prompt_ExpiryCounted'), form_type => 'hidden' },
|
||||
ExpiryNotify => { type => 'TINYINT', not_null => 1, default => 0, form_display => Links::language('prompt_ExpiryNotify'), form_type => 'hidden' },
|
||||
LinkExpired => { type => 'INT', form_display => Links::language('prompt_LinkExpired'), form_type => 'hidden' },
|
||||
],
|
||||
pk => 'ID',
|
||||
ai => 'ID',
|
||||
fk => {
|
||||
Users => { LinkOwner => 'Username' }
|
||||
},
|
||||
index => {
|
||||
urlndx => ['URL'],
|
||||
stndx => ['Status'],
|
||||
valexpndx => [qw/isValidated ExpiryDate/],
|
||||
newndx => ['isNew'],
|
||||
popndx => ['isPopular'],
|
||||
userndx => ['LinkOwner'],
|
||||
expiryndx => [qw/ExpiryDate ExpiryNotify/],
|
||||
expcntndx => [qw/ExpiryCounted ExpiryDate/]
|
||||
},
|
||||
subclass => {
|
||||
table => { Links => 'Links::Table::Links' },
|
||||
html => { Links => 'Links::HTML::Links' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Changes Table ----------------
|
||||
create_table(\$output, 'Changes', $action,
|
||||
cols => [
|
||||
LinkID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$' },
|
||||
Username => { type => 'CHAR', size => 50, not_null => 1, default => 'admin' },
|
||||
ChgRequest => { type => 'TEXT' },
|
||||
Timestmp => { type => 'TIMESTAMP' }
|
||||
],
|
||||
fk => {
|
||||
Links => { LinkID => 'ID' },
|
||||
Users => { Username => 'Username' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Category Table ----------------
|
||||
my $new_category = create_table(\$output, 'Category', $action,
|
||||
cols => [
|
||||
ID => { type => 'INT', not_null => 1, unsigned => 1, form_display => Links::language('prompt_ID') },
|
||||
Name => { type => 'CHAR', size => 255, not_null => 1, weight => 3, regex => '^[^/]+$', form_display => Links::language('prompt_Name') },
|
||||
FatherID => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_size => 1, form_display => Links::language('prompt_FatherID') },
|
||||
CatRoot => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' },
|
||||
CatDepth => { type => 'INT', not_null => 1, unsigned => 1, default => 0, form_type => 'hidden' },
|
||||
Full_Name => { type => 'CHAR', size => 255, form_display => Links::language('prompt_Full_Name') },
|
||||
Description => { type => 'TEXT', weight => 1, form_display => Links::language('prompt_Description') },
|
||||
Meta_Description => { type => 'TEXT', form_display => Links::language('prompt_Meta_Description') },
|
||||
Meta_Keywords => { type => 'TEXT', form_display => Links::language('prompt_Meta_Keywords') },
|
||||
Header => { type => 'TEXT', form_display => Links::language('prompt_Header') },
|
||||
Footer => { type => 'TEXT', form_display => Links::language('prompt_Footer') },
|
||||
Category_Template => { type => 'CHAR', size => 20, form_display => Links::language('prompt_Category_Template') },
|
||||
Number_of_Links => { type => 'INT', not_null => 1, default => 0, form_display => Links::language('prompt_Number_of_Links') },
|
||||
Direct_Links => { type => 'INT', not_null => 1, default => 0, form_display => Links::language('prompt_Direct_Links') },
|
||||
Has_New_Links => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Has_New_Links') },
|
||||
Has_Changed_Links => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Has_Changed_Links') },
|
||||
Newest_Link => { type => 'DATE', form_display => Links::language('prompt_Newest_Link') },
|
||||
Timestmp => { type => 'TIMESTAMP', time_check => 1, form_display => Links::language('prompt_Timestmp') },
|
||||
Payment_Mode => { type => 'TINYINT', not_null => 1, default => 0, form_size => 1, form_names => [GLOBAL,NOT_ACCEPTED,OPTIONAL,REQUIRED], form_values => ['Use global settings','Not accepted','Optional','Required'], form_type => 'SELECT', form_display => Links::language('prompt_Payment_Mode') },
|
||||
Payment_Description => { type => 'TEXT', form_display => Links::language('prompt_Payment_Description') },
|
||||
],
|
||||
subclass => {
|
||||
table => { Category => 'Links::Table::Category' },
|
||||
html => { Category => 'Links::HTML::Category' }
|
||||
},
|
||||
pk => 'ID',
|
||||
ai => 'ID',
|
||||
index => {
|
||||
catndx => ['Name'],
|
||||
namndx => ['Full_Name'],
|
||||
fthrindex => ['FatherID'],
|
||||
rootndx => ['CatRoot'],
|
||||
c_p => ['Payment_Mode'],
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Category Tree -------------------------
|
||||
$output .= "Creating Category tree... ";
|
||||
my $e = $DB->editor('Category');
|
||||
if ($e->add_tree(father => "FatherID", root => "CatRoot", depth => "CatDepth", force => ($new_category ? 'force' : 'check'))) {
|
||||
$output .= "okay\n";
|
||||
}
|
||||
else {
|
||||
$output .= "failed ($GT::SQL::error)\n";
|
||||
}
|
||||
|
||||
# --------- CatPrice Table ----------------
|
||||
create_table(\$output, 'CatPrice', $action,
|
||||
cols => [
|
||||
cp_id => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
cp_cat_id_fk => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
cp_term => { type => 'CHAR', not_null => 1, size => 10 }, # e.g. 8d, 1m, 2y, 3w, unlimited, etc.
|
||||
cp_cost => { type => 'DOUBLE', not_null => 1 },
|
||||
cp_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = signup, 1 = renewal, 2 = recurring
|
||||
cp_description => { type => 'TEXT' }
|
||||
],
|
||||
pk => 'cp_id',
|
||||
ai => 'cp_id',
|
||||
fk => {
|
||||
Category => { cp_cat_id_fk => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Reviews Table ----------------
|
||||
create_table(\$output, 'Reviews', $action,
|
||||
cols => [
|
||||
ReviewID => { type => 'INT', not_null => 1, unsigned => 1, form_display => Links::language('prompt_ReviewID') },
|
||||
Review_LinkID => { type => 'INT', not_null => 1, unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_LinkID') },
|
||||
Review_Owner => { type => 'CHAR', size => 50, not_null => 1, form_display => Links::language('prompt_Review_Owner') },
|
||||
Review_Rating => { type => 'SMALLINT', unsigned => 1, not_null => 1, default => 0, regex => '^\d+$', form_display => Links::language('prompt_Review_Rating') },
|
||||
Review_Date => { type => 'DATETIME', not_null => 1, form_display => Links::language('prompt_Review_Date') },
|
||||
Review_ModifyDate => { type => 'DATETIME', not_null => 1, form_display => Links::language('prompt_Review_ModifyDate') },
|
||||
Review_Subject => { type => 'CHAR', size => 100, not_null => 1, form_display => Links::language('prompt_Review_Subject') },
|
||||
Review_Contents => { type => 'TEXT', not_null => 1, form_display => Links::language('prompt_Review_Contents') },
|
||||
Review_ByLine => { type => 'CHAR', size => 50, form_display => Links::language('prompt_Review_ByLine') },
|
||||
Review_WasHelpful => { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_WasHelpful') },
|
||||
Review_WasNotHelpful => { type => 'INT', unsigned => 1, regex => '^\d+$', form_display => Links::language('prompt_Review_WasNotHelpful') },
|
||||
Review_Validated => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No', form_display => Links::language('prompt_Review_Validated') },
|
||||
Review_GuestName => { type => 'CHAR', size => 75, form_display => Links::language('prompt_Review_GuestName') },
|
||||
Review_GuestEmail => { type => 'CHAR', size => 75, regex => '^(?:(?:.+\@.+\..+)|\s*)$', form_display => Links::language('prompt_Review_GuestEmail') },
|
||||
],
|
||||
pk => 'ReviewID',
|
||||
ai => 'ReviewID',
|
||||
subclass => {
|
||||
table => { Reviews => 'Links::Table::Reviews' }
|
||||
},
|
||||
index => {
|
||||
rownerndx => ['Review_Owner'],
|
||||
rdatendx => ['Review_Date'],
|
||||
rlinkndx => ['Review_LinkID']
|
||||
},
|
||||
fk => {
|
||||
Links => { Review_LinkID => 'ID' },
|
||||
Users => { Review_Owner => 'Username' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- CatLinks Table ----------------
|
||||
create_table(\$output, 'CatLinks', $action,
|
||||
cols => [
|
||||
LinkID => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
CategoryID => { type => 'INT', not_null => 1, unsigned => 1 }
|
||||
],
|
||||
subclass => {
|
||||
table => { CatLinks => 'Links::Table::CatLinks' }
|
||||
},
|
||||
index => {
|
||||
lndx => ['LinkID']
|
||||
},
|
||||
unique => {
|
||||
cl_cl_q => [qw/CategoryID LinkID/]
|
||||
},
|
||||
fk => {
|
||||
Links => { LinkID => 'ID' },
|
||||
Category => { CategoryID => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- CatRelations Table ----------------
|
||||
create_table(\$output, 'CatRelations', $action,
|
||||
cols => [
|
||||
CategoryID => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
RelatedID => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
RelationName => { type => 'VARCHAR', size => 255 }
|
||||
],
|
||||
index => {
|
||||
catid => ['CategoryID']
|
||||
},
|
||||
fk => {
|
||||
Category => { CategoryID => 'ID', RelatedID => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- User Editors Table ----------------
|
||||
create_table(\$output, 'Editors', $action,
|
||||
cols => [
|
||||
Username => { type => 'CHAR', size => 50, not_null => 1 },
|
||||
CategoryID => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
CanAddCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanModCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanDelCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanMoveCat => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanAddLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanDelLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanModLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanCopyLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanMoveLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanValLink => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanModReview => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanAddRel => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
CanAddEdit => { type => 'ENUM', values => ['No', 'Yes'], not_null => 1, default => 'No' },
|
||||
],
|
||||
unique => {
|
||||
edituserndx => ['Username', 'CategoryID']
|
||||
},
|
||||
fk => {
|
||||
Users => { Username => 'Username' },
|
||||
Category => { CategoryID => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Verify History Table ----------------
|
||||
create_table(\$output, 'Verify', $action,
|
||||
cols => [
|
||||
LinkID => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
Status => { type => 'SMALLINT', not_null => 1, default => 0 },
|
||||
Date_Checked => { type => 'DATE' }
|
||||
],
|
||||
index => {
|
||||
veriflndx => ['LinkID']
|
||||
},
|
||||
fk => {
|
||||
Links => { LinkID => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Session Table ----------------
|
||||
create_table(\$output, 'Sessions', $action,
|
||||
cols => [
|
||||
session_id => { type => 'CHAR', size => 32, not_null => 1, binary => 1 },
|
||||
session_user_id => { type => 'CHAR', size => 50, not_null => 1 },
|
||||
session_date => { type => 'INT', not_null => 1 },
|
||||
session_expires => { type => 'TINYINT', default => 1 },
|
||||
session_data => { type => 'TEXT' }
|
||||
],
|
||||
pk => 'session_id',
|
||||
fk => {
|
||||
Users => { session_user_id => 'Username' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Email Template Table ----------------
|
||||
create_table(\$output, 'EmailTemplates', $action,
|
||||
cols => [
|
||||
Name => { type => 'CHAR', size => 50, not_null => 1, regex => '\S' },
|
||||
MsgFrom => { type => 'TEXT', not_null => 1, regex => '\A(?:\S+\@[a-zA-Z0-9][a-zA-Z0-9-]*(?:\.[a-zA-Z0-9][a-zA-Z0-9-]*)+)\Z' },
|
||||
MsgFromName => { type => 'TEXT', not_null => 1 },
|
||||
Subject => { type => 'TEXT', not_null => 1 },
|
||||
Message => { type => 'MEDIUMTEXT', not_null => 1 },
|
||||
MessageFormat => { type => 'ENUM', values => [qw[text html]], not_null => 1, default => 'text' },
|
||||
LinkTemplate => { type => 'MEDIUMTEXT' }
|
||||
],
|
||||
pk => 'Name'
|
||||
);
|
||||
|
||||
# --------- Email Mailings Table -------------
|
||||
create_table(\$output, 'EmailMailings', $action,
|
||||
cols => [
|
||||
ID => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
Mailing => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
Email => { type => 'TEXT', size => 75, not_null => 1 },
|
||||
Sent => { type => 'TINYINT', default => 0, not_null => 1 },
|
||||
LinkID => { type => 'INT', unsigned => 1 } # If this is a sending to link owners, this will hold the Link ID
|
||||
],
|
||||
pk => 'ID',
|
||||
ai => 'ID'
|
||||
);
|
||||
|
||||
# --------- Email Mailing Index Table --------
|
||||
create_table(\$output, 'MailingIndex', $action,
|
||||
cols => [
|
||||
Mailing => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
extra => { type => 'TINYTEXT', not_null => 1 },
|
||||
done => { type => 'INT' },
|
||||
mailfrom => { type => 'TEXT', not_null => 1 },
|
||||
name => { type => 'TEXT', not_null => 1 },
|
||||
subject => { type => 'TEXT', not_null => 1 },
|
||||
message => { type => 'MEDIUMTEXT', not_null => 1 },
|
||||
messageformat => { type => 'ENUM', values => [qw[text html]], not_null => 1, default => 'text' },
|
||||
],
|
||||
pk => 'Mailing',
|
||||
ai => 'Mailing'
|
||||
);
|
||||
|
||||
# --------- MailingList Table ----------------
|
||||
create_table(\$output, 'MailingList', $action,
|
||||
cols => [
|
||||
ID => { type => 'INT', not_null => 1 },
|
||||
Email => { type => 'CHAR', size => 255, not_null => 1 }
|
||||
],
|
||||
index => {
|
||||
maillistndx => ['Email']
|
||||
}
|
||||
);
|
||||
|
||||
# --------- MailingListIndex Table ----------------
|
||||
create_table(\$output, 'MailingListIndex', $action,
|
||||
cols => [
|
||||
ID => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
Name => { type => 'CHAR', size => 255, not_null => 1 },
|
||||
DateModified => { type => 'INT', not_null => 1 },
|
||||
DateCreated => { type => 'INT', not_null => 1 }
|
||||
],
|
||||
pk => 'ID',
|
||||
ai => 'ID'
|
||||
);
|
||||
|
||||
# --------- ClickTrack Table ----------------
|
||||
create_table(\$output, 'ClickTrack', $action,
|
||||
cols => [
|
||||
LinkID => { type => 'INT', not_null => 1 },
|
||||
IP => { type => 'CHAR', size => 16, not_null => 1 },
|
||||
ClickType => { type => 'ENUM', values => ['Rate', 'Hits','Review'], not_null => 1 },
|
||||
ReviewID => { type => 'INT', not_null => 1, default => 0},
|
||||
Created => { type => 'TIMESTAMP' }
|
||||
],
|
||||
subclass => {
|
||||
table => { ClickTrack => 'Links::Table::ClickTrack' }
|
||||
},
|
||||
unique => {
|
||||
ct_licr => ['LinkID', 'IP', 'ClickType','ReviewID']
|
||||
},
|
||||
index => {
|
||||
cndx => ['Created']
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Payments Table ----------------
|
||||
create_table(\$output, 'Payments', $action,
|
||||
cols => [
|
||||
payments_id => { type => 'CHAR', not_null => 1, size => 16 },
|
||||
payments_linkid => { type => 'INT', unsigned => 1, not_null => 1 },
|
||||
payments_status => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = pending, 1 = completed, 2 = declined, 3 = error
|
||||
payments_method => { type => 'CHAR', not_null => 1, size => 25 },
|
||||
payments_type => { type => 'TINYINT', not_null => 1, unsigned => 1 }, # 0 = initial payment, 1 = renewal payment, 2 = recurring payment
|
||||
payments_amount => { type => 'DOUBLE', not_null => 1 },
|
||||
payments_term => { type => 'CHAR', not_null => 1, size => 10 }, # e.g. 8d, 1m, 2y, 3w, unlimited, etc.
|
||||
payments_start => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
payments_last => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
],
|
||||
pk => 'payments_id',
|
||||
fk => {
|
||||
Links => { payments_linkid => 'ID' }
|
||||
},
|
||||
index => {
|
||||
p_sl => ['payments_status', 'payments_last'],
|
||||
p_ll => ['payments_linkid', 'payments_last'],
|
||||
p_al => ['payments_amount', 'payments_last'],
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Payment Logs Table ----------------
|
||||
create_table(\$output, 'PaymentLogs', $action,
|
||||
cols => [
|
||||
paylogs_id => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
paylogs_payments_id => { type => 'CHAR', not_null => 1, size => 16 },
|
||||
paylogs_type => { type => 'INT', not_null => 1, default => 0, unsigned => 1 }, # 0 = info, 1 = accepted, 2 = declined, 3 = error
|
||||
paylogs_time => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
paylogs_viewed => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 },
|
||||
paylogs_text => { type => 'TEXT' },
|
||||
],
|
||||
pk => 'paylogs_id',
|
||||
ai => 'paylogs_id',
|
||||
fk => {
|
||||
Payments => { paylogs_payments_id => 'payments_id' }
|
||||
},
|
||||
index => {
|
||||
pl_yt => ['paylogs_type', 'paylogs_time'],
|
||||
pl_t => ['paylogs_time']
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Bookmark Folders Table ----------------
|
||||
create_table(\$output, 'Bookmark_Folders', $action,
|
||||
cols => [
|
||||
my_folder_id => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
my_folder_name => { type => 'VARCHAR', not_null => 1, size => 255 },
|
||||
my_folder_description => { type => 'VARCHAR', size => 255 },
|
||||
my_folder_user_username_fk => { type => 'VARCHAR', size => 50 },
|
||||
my_folder_default => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 },
|
||||
my_folder_public => { type => 'TINYINT', not_null => 1, default => 0, unsigned => 1 }
|
||||
],
|
||||
pk => 'my_folder_id',
|
||||
ai => 'my_folder_id',
|
||||
fk => {
|
||||
Users => { my_folder_user_username_fk => 'Username' }
|
||||
}
|
||||
);
|
||||
|
||||
# --------- Bookmark Links Table ----------------
|
||||
create_table(\$output, 'Bookmark_Links', $action,
|
||||
cols => [
|
||||
my_id => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
my_link_id_fk => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
my_user_username_fk => { type => 'VARCHAR', size => 50 },
|
||||
my_folder_id_fk => { type => 'INT', not_null => 1, unsigned => 1 },
|
||||
my_comment => { type => 'VARCHAR', size => '255' }
|
||||
],
|
||||
pk => 'my_id',
|
||||
ai => 'my_id',
|
||||
fk => {
|
||||
Users => { my_user_username_fk => 'Username' },
|
||||
Bookmark_Folders => { my_folder_id_fk => 'my_folder_id' },
|
||||
Links => { my_link_id_fk => 'ID' },
|
||||
}
|
||||
);
|
||||
|
||||
# --------- SearchLogs Table ----------------
|
||||
create_table(\$output, 'SearchLogs', $action,
|
||||
cols => [
|
||||
slog_query => { type => 'VARCHAR', not_null => 1, size => 255 },
|
||||
slog_count => { type => 'INT', not_null => 1, default => 0 },
|
||||
slog_hits => { type => 'INT', not_null => 1, default => 0 },
|
||||
slog_time => { type => 'FLOAT' },
|
||||
slog_last => { type => 'INT', not_null => 1, default => 0 },
|
||||
],
|
||||
pk => 'slog_query'
|
||||
);
|
||||
|
||||
# --------- Newsletter Subscription Table ----------------
|
||||
create_table(\$output, 'NewsletterSubscription', $action,
|
||||
cols => [
|
||||
UserID => { type => 'CHAR', size => 50 },
|
||||
CategoryID => { type => 'INT', not_null => 1 },
|
||||
],
|
||||
unique => {
|
||||
ns_uc => ['UserID', 'CategoryID']
|
||||
},
|
||||
fk => {
|
||||
Users => { UserID => 'Username' },
|
||||
Category => { CategoryID => 'ID' }
|
||||
}
|
||||
);
|
||||
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub create_table {
|
||||
my ($output, $table, $action, @def) = @_;
|
||||
|
||||
$$output .= Links::language('dialog_create', $table);
|
||||
my $c = $DB->creator($table);
|
||||
$c->clear_schema() if $action eq 'force';
|
||||
|
||||
@def % 2 and die "Odd number of table defs passed to create_table()";
|
||||
while (@def) {
|
||||
my ($meth, $arg) = splice @def, 0, 2;
|
||||
$c->$meth($arg);
|
||||
}
|
||||
|
||||
if ($c->create($action)) {
|
||||
$$output .= Links::language('dialog_ok');
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
$$output .= Links::language($GT::SQL::errcode eq 'TBLEXISTS' ? ('error_failed_exists') : ('error_failed_other', $GT::SQL::error));
|
||||
$GT::SQL::errcode if 0; # silence "used only once" warning
|
||||
$c->set_defaults;
|
||||
$c->save_schema;
|
||||
return 0;
|
||||
}
|
||||
}
|
||||
|
||||
sub load_from_sql {
|
||||
# ---------------------------------------------------------------
|
||||
# Creates def files based on existing tables.
|
||||
#
|
||||
my ($output, $return);
|
||||
foreach my $table (@TABLES) {
|
||||
$output .= "$table .. ";
|
||||
my $c = $DB->creator($table);
|
||||
$return = $c->load_table($table);
|
||||
if ($return) {
|
||||
if ($table eq 'Links' or $table eq 'Users' or $table eq 'Category') {
|
||||
$c->subclass(
|
||||
table => { $table => "Links::Table::$table" },
|
||||
html => { $table => "Links::HTML::$table" }
|
||||
);
|
||||
}
|
||||
elsif ($table eq 'CatLinks' or $table eq 'ClickTrack') {
|
||||
$c->subclass(
|
||||
table => { $table => "Links::Table::$table" }
|
||||
);
|
||||
}
|
||||
$output .= "ok!\n";
|
||||
$c->save_schema();
|
||||
}
|
||||
else {
|
||||
$output .= "failed: $GT::SQL::error\n";
|
||||
}
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub load {
|
||||
# ---------------------------------------------------------------
|
||||
# Return a hash of current connection settings.
|
||||
#
|
||||
my %h = ();
|
||||
$h{prefix} = $DB->prefix();
|
||||
$h{database} = $DB->{connect}->{database};
|
||||
$h{login} = $DB->{connect}->{login};
|
||||
$h{password} = $DB->{connect}->{password};
|
||||
$h{host} = $DB->{connect}->{host};
|
||||
$h{host} .= ":" . $DB->{connect}->{port} if $DB->{connect}->{port};
|
||||
$h{driver} = $DB->{connect}->{driver};
|
||||
return \%h;
|
||||
}
|
||||
|
||||
1;
|
||||
313
site/slowtwitch.com/cgi-bin/articles/admin/Links/SiteHTML.pm
Normal file
313
site/slowtwitch.com/cgi-bin/articles/admin/Links/SiteHTML.pm
Normal file
@@ -0,0 +1,313 @@
|
||||
# ==================================================================
|
||||
# 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: SiteHTML.pm,v 1.89 2008/04/29 04:02:34 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::SiteHTML;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects :payment/;
|
||||
|
||||
sub display {
|
||||
# -----------------------------------------------------------------
|
||||
# Returns a specified template parsed.
|
||||
#
|
||||
my ($template, $vars, $opts) = @_;
|
||||
my $code = exists $Links::SiteHTML::{"site_html_$template"} ? $Links::SiteHTML::{"site_html_$template"} : _compile("site_html_$template");
|
||||
defined $code or die "Invalid method: site_html_$template called.";
|
||||
|
||||
$PLG->dispatch("site_html_$template", $code, $vars, $opts);
|
||||
}
|
||||
|
||||
sub tags {
|
||||
# -----------------------------------------------------------------
|
||||
# Returns the tags needed to properly include a template in another template,
|
||||
# instead of returning parsed HTML like display(). Currently only supports
|
||||
# 'link' for formatted link information.
|
||||
#
|
||||
my ($sub, $vars, $opts) = @_;
|
||||
my $code = exists $Links::SiteHTML::{"site_tags_$sub"} && $Links::SiteHTML::{"site_tags_$sub"};
|
||||
defined $code or die "Invalid method: site_tags_$sub called.";
|
||||
|
||||
$PLG->dispatch("site_tags_$sub", $code, $vars, $opts);
|
||||
}
|
||||
|
||||
# All the templates are auto-loaded, except for the ones below which need
|
||||
# to do some special stuff.
|
||||
|
||||
sub site_tags_link {
|
||||
# --------------------------------------------------------
|
||||
# Format the tags for a single link.
|
||||
#
|
||||
my ($vars, $cat_id) = @_;
|
||||
|
||||
my %block = $Links::GLOBALS ? map { $_ => 1 } keys %$Links::GLOBALS : ();
|
||||
my %rec = map { exists $block{$_} ? () : ($_ => $vars->{$_}) } keys %$vars;
|
||||
|
||||
$rec{Add_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec{Add_Date}, GT::Date::FORMAT_DATE));
|
||||
$rec{Mod_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec{Mod_Date}, GT::Date::FORMAT_DATE));
|
||||
|
||||
# Convert the date formats.
|
||||
if (GT::Date::FORMAT_DATE ne $CFG->{date_user_format}) {
|
||||
Links::init_date();
|
||||
$rec{Add_Date} = GT::Date::date_transform($rec{Add_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec{Add_Date};
|
||||
$rec{Mod_Date} = GT::Date::date_transform($rec{Mod_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec{Mod_Date};
|
||||
}
|
||||
|
||||
# Set new and pop to either 1 or undef for templates.
|
||||
$rec{isNew} = ($rec{isNew} and ($rec{isNew} eq 'Yes' or $rec{isNew} eq '1')) ? 1 : 0;
|
||||
$rec{isChanged} = ($rec{isChanged} and ($rec{isChanged} eq 'Yes' or $rec{isChanged} eq '1')) ? 1 : 0;
|
||||
$rec{isPopular} = ($rec{isPopular} and ($rec{isPopular} eq 'Yes' or $rec{isPopular} eq '1')) ? 1 : 0;
|
||||
$rec{isLinkOwner} = ($USER and defined $USER->{Username} and $rec{LinkOwner} eq $USER->{Username}) ? 1 : 0;
|
||||
|
||||
$rec{paymentsEnabled} = 0; # The payment url is disabled by default
|
||||
|
||||
if ($CFG->{payment}->{enabled}) {
|
||||
my $catp;
|
||||
# Fetch payment information for the category the link is in (used below to determine if the payment data should be shown)
|
||||
my @cid = $DB->table('CatLinks')->select('CategoryID', { LinkID => $rec{ID} })->fetchall_list;
|
||||
require Links::Payment;
|
||||
$catp = Links::Payment::load_cat_price(\@cid);
|
||||
|
||||
# Add various extra tags regarding payment if the current user is the link owner:
|
||||
if ($rec{isLinkOwner} and $rec{ExpiryDate} != UNLIMITED and $catp->{payment_mode} != NOT_ACCEPTED) {
|
||||
my $expiry_date = $rec{ExpiryDate};
|
||||
my $notify_date = time + $CFG->{payment}->{expiry_notify} * (24*60*60);
|
||||
$rec{paymentsEnabled} = 1;
|
||||
$rec{isUnpaid} = $expiry_date == UNPAID;
|
||||
$rec{isFree} = $expiry_date == FREE;
|
||||
$rec{isExpired} = ($expiry_date > UNPAID and $expiry_date < time or $rec{isFree} and $rec{LinkExpired});
|
||||
$rec{wasPaid} = ($expiry_date > UNPAID and $expiry_date < FREE or $rec{isFree} and $rec{LinkExpired});
|
||||
$rec{ExpiryDateFormatted} = ($expiry_date > UNPAID and $expiry_date < FREE)
|
||||
? GT::Date::date_get($expiry_date, $CFG->{date_expiry_format})
|
||||
: ($rec{isFree} and $rec{LinkExpired})
|
||||
? GT::Date::date_get($rec{LinkExpired}, $CFG->{date_expiry_format})
|
||||
: '';
|
||||
$rec{isNotify} = ($expiry_date >= time and $expiry_date <= $notify_date) ? 1 : 0;
|
||||
}
|
||||
|
||||
$rec{isPaidLink} = 0;
|
||||
$rec{isFreeLink} = 0;
|
||||
if ($rec{ExpiryDate} >= time and $rec{ExpiryDate} < FREE) {
|
||||
$rec{isPaidLink} = 1;
|
||||
}
|
||||
elsif ($rec{ExpiryDate} == FREE) {
|
||||
$rec{isFreeLink} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
my $links = $DB->table('Links');
|
||||
if ($CFG->{build_detailed}) {
|
||||
my $detailed;
|
||||
# Generate the detailed url for a specific the category that we're in (a link may be in multiple categories)
|
||||
if ($cat_id) {
|
||||
$detailed = $links->category_detailed_url($cat_id, $rec{ID});
|
||||
}
|
||||
else {
|
||||
$detailed = $links->detailed_url($rec{ID});
|
||||
}
|
||||
$rec{detailed_url} = "$CFG->{build_detail_url}/$detailed";
|
||||
}
|
||||
|
||||
# Load any reviews, if not already done
|
||||
$links->add_reviews(\%rec) unless exists $rec{Review_Loop};
|
||||
|
||||
\%rec;
|
||||
}
|
||||
|
||||
sub site_html_link {
|
||||
# --------------------------------------------------------
|
||||
# Format and return the HTML for a single link.
|
||||
#
|
||||
# Note that this method is deprecated in favour of generating all the html in
|
||||
# the templates. Instead, you should be doing:
|
||||
# <%Links::Utils::load_link_info%><%include link.html%>
|
||||
#
|
||||
my $rec = tags(link => @_);
|
||||
|
||||
# Set the template set to use.
|
||||
my $opts = { dynamic => 0 };
|
||||
if ($rec->{Category_Template} and $rec->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) {
|
||||
$opts->{template} = delete $rec->{Category_Template};
|
||||
}
|
||||
|
||||
# Parse the template.
|
||||
return Links::user_page('link.html', $rec, $opts);
|
||||
}
|
||||
|
||||
sub site_html_detailed {
|
||||
# --------------------------------------------------------
|
||||
# Return parsed detailed page (one link per html page).
|
||||
#
|
||||
my $rec = shift;
|
||||
|
||||
$rec->{Add_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec->{Add_Date}, GT::Date::FORMAT_DATE));
|
||||
$rec->{Mod_Date_time} = GT::Date::timelocal(GT::Date::parse_format($rec->{Mod_Date}, GT::Date::FORMAT_DATE));
|
||||
|
||||
# Convert the date formats.
|
||||
if (GT::Date::FORMAT_DATE ne $CFG->{date_user_format}) {
|
||||
Links::init_date();
|
||||
$rec->{Add_Date_orig} = $rec->{Add_Date};
|
||||
$rec->{Add_Date} = GT::Date::date_transform($rec->{Add_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec->{Add_Date};
|
||||
$rec->{Mod_Date_orig} = $rec->{Mod_Date};
|
||||
$rec->{Mod_Date} = GT::Date::date_transform($rec->{Mod_Date}, GT::Date::FORMAT_DATE, $CFG->{date_user_format}) || $rec->{Mod_Date};
|
||||
}
|
||||
|
||||
# Set new and pop to either 1 or undef for templates.
|
||||
$rec->{isNew} = ($rec->{isNew} and ($rec->{isNew} eq 'Yes' or $rec->{isNew} eq '1')) ? 1 : 0;
|
||||
$rec->{isChanged} = ($rec->{isChanged} and ($rec->{isChanged} eq 'Yes' or $rec->{isChanged} eq '1')) ? 1 : 0;
|
||||
$rec->{isPopular} = ($rec->{isPopular} and ($rec->{isPopular} eq 'Yes' or $rec->{isPopular} eq '1')) ? 1 : 0;
|
||||
$rec->{isLinkOwner} = ($USER and defined $USER->{Username} and $rec->{LinkOwner} eq $USER->{Username}) ? 1 : 0;
|
||||
|
||||
if ($CFG->{payment}->{enabled}) {
|
||||
$rec->{isPaidLink} = 0;
|
||||
$rec->{isFreeLink} = 0;
|
||||
if ($rec->{ExpiryDate} >= time and $rec->{ExpiryDate} < FREE) {
|
||||
$rec->{isPaidLink} = 1;
|
||||
}
|
||||
elsif ($rec->{ExpiryDate} == FREE) {
|
||||
$rec->{isFreeLink} = 1;
|
||||
}
|
||||
}
|
||||
|
||||
# Set the template set to use.
|
||||
my $opts = { dynamic => 1 };
|
||||
if ($rec->{Category_Template} and $rec->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) {
|
||||
$opts->{template} = delete $rec->{Category_Template};
|
||||
}
|
||||
|
||||
my $output = Links::user_page('detailed.html', $rec, $opts);
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub site_html_category {
|
||||
# --------------------------------------------------------
|
||||
# Return parsed category page.
|
||||
#
|
||||
my $tags = shift;
|
||||
|
||||
$tags->{build_links_per_page} = $CFG->{build_links_per_page};
|
||||
($tags->{category_first}) = $tags->{'category_name'} =~ m,/?([^/]+)$,;
|
||||
|
||||
my $opts = { dynamic => 1 };
|
||||
|
||||
# Find the proper template.
|
||||
my $template = 'category.html';
|
||||
|
||||
# If the Category_Template ends with .htm or .html, then use that file as a template, otherwise, use it as a template set.
|
||||
if ($tags->{Category_Template} and $tags->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) {
|
||||
$opts->{template} = delete $tags->{Category_Template};
|
||||
}
|
||||
elsif ($tags->{Category_Template}) {
|
||||
$template = $tags->{Category_Template};
|
||||
}
|
||||
my $output = Links::user_page($template, $tags, $opts);
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub site_html_print_cat {
|
||||
# --------------------------------------------------------
|
||||
# This routine prints out a list of categories.
|
||||
#
|
||||
# Note that this method has been deprecated in favour of using loops and
|
||||
# performing html generation in the templates. If you need to modify
|
||||
# the category data, use the build_category_loop plugin hook.
|
||||
#
|
||||
my @subcat = @{$_[0]};
|
||||
my $parent_cat = shift @subcat;
|
||||
my $breakpoint = int(@subcat / $CFG->{build_category_columns});
|
||||
$breakpoint++ if @subcat % $CFG->{build_category_columns};
|
||||
my $table_head = $CFG->{build_category_table} || '';
|
||||
my $width = int(100 / $CFG->{build_category_columns});
|
||||
my $output = '';
|
||||
my $i = 0;
|
||||
my $cat_db = $DB->table('Category');
|
||||
my $opts = { dynamic => 0 };
|
||||
|
||||
# Print Header.
|
||||
if ($CFG->{build_category_columns}) {
|
||||
$output = qq|<div class="margin"><table $table_head><tr><td class="catlist" width="$width%" valign="top">\n|;
|
||||
}
|
||||
|
||||
# Figure out if we should use a different template.
|
||||
if ($parent_cat->{Category_Template} and $parent_cat->{Category_Template} =~ /^[\w-]+(\.[\w-]+)?$/ and (not $1 or ($1 ne '.html' and $1 ne '.htm'))) {
|
||||
$opts->{template} = delete $parent_cat->{Category_Template};
|
||||
}
|
||||
|
||||
# Go through each subcategory and print its template.
|
||||
for my $cat_r (@subcat) {
|
||||
$cat_r->{Short_Name} = $cat_r->{Name} =~ m,.*/([^/]+)$, ? $1 : $cat_r->{Name};
|
||||
$cat_r->{URL} ||= $CFG->{build_root_url} . "/" . $cat_db->as_url($cat_r->{Full_Name}) . "/" . ($CFG->{build_index_include} ? $CFG->{build_index} : '');
|
||||
|
||||
# Set the short name.
|
||||
if ($cat_r->{Related}) {
|
||||
if ($cat_r->{RelationName}) {
|
||||
$cat_r->{Short_Name} = $cat_r->{RelationName};
|
||||
}
|
||||
else {
|
||||
if (exists $parent_cat->{Name} and ($cat_r->{Short_Name} eq $parent_cat->{Name})) {
|
||||
my ($short) = $cat_r->{Full_Name} =~ m,([^/]+)/[^/]*$,;
|
||||
$short and ($cat_r->{Short_Name} = $short);
|
||||
}
|
||||
else {
|
||||
$cat_r->{Short_Name} = $cat_r->{Short_Name};
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# We check to see if we are half way through, if so we stop this table cell
|
||||
# and begin a new one (this lets us have category names in two columns).
|
||||
if ($CFG->{build_category_columns}) {
|
||||
$output .= qq|</td>\n<td valign="top" width="$width%" class="catlist">\n| if $i > 0 and not $i % $breakpoint;
|
||||
$i++;
|
||||
}
|
||||
$output .= Links::user_page('subcategory.html', $cat_r, $opts);
|
||||
}
|
||||
|
||||
# Don't forget to end the table properly ..
|
||||
if ($CFG->{build_category_columns}) {
|
||||
$output .= "</td></tr></table></div>\n";
|
||||
}
|
||||
return $output;
|
||||
}
|
||||
|
||||
sub site_html_error {
|
||||
# --------------------------------------------------------
|
||||
# Print out the error page
|
||||
#
|
||||
my ($vars, $opts) = @_;
|
||||
$opts ||= { dynamic => 1 };
|
||||
unless (exists $vars->{main_title_loop}) {
|
||||
require Links::Build;
|
||||
$vars->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ERROR'), $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : '')));
|
||||
}
|
||||
return Links::user_page('error.html', $vars, $opts);
|
||||
}
|
||||
|
||||
sub _compile {
|
||||
# -------------------------------------------------------------------
|
||||
# Compile dynamically creates site_html routines if a template file
|
||||
# exists.
|
||||
#
|
||||
my $sub = shift;
|
||||
my ($file) = $sub =~ /^site_html_([\w-]+)$/;
|
||||
$file or return sub { display('error', { error => "Invalid SiteHTML method: '" . $IN->html_escape($sub) . "'." }) };
|
||||
$file .= '.html';
|
||||
my $template_set = Links::template_set();
|
||||
unless (Links::template_exists($template_set, $file)) {
|
||||
return sub { display('error', { error => "Invalid SiteHTML method: $sub ($file). The template does not exist in '$template_set'." }) };
|
||||
}
|
||||
my $code = sub { my ($vars, $opts) = @_; $opts ||= { dynamic => 1 }; return Links::user_page($file, $vars, $opts) };
|
||||
$Links::SiteHTML::{$sub} = $code;
|
||||
$code;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -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;
|
||||
@@ -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;
|
||||
@@ -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
630
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Links.pm
Normal 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;
|
||||
@@ -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
162
site/slowtwitch.com/cgi-bin/articles/admin/Links/Table/Users.pm
Normal 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;
|
||||
1736
site/slowtwitch.com/cgi-bin/articles/admin/Links/Tools.pm
Normal file
1736
site/slowtwitch.com/cgi-bin/articles/admin/Links/Tools.pm
Normal file
File diff suppressed because it is too large
Load Diff
287
site/slowtwitch.com/cgi-bin/articles/admin/Links/Update.pm
Normal file
287
site/slowtwitch.com/cgi-bin/articles/admin/Links/Update.pm
Normal file
@@ -0,0 +1,287 @@
|
||||
# ==================================================================
|
||||
# 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: Update.pm,v 1.11 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.
|
||||
# ==================================================================
|
||||
#
|
||||
|
||||
package Links::Update;
|
||||
use strict;
|
||||
use Links qw/$CFG $IN %STASH/;
|
||||
use GT::Update qw/:severity/;
|
||||
use GT::File::Tools qw/basename/;
|
||||
use GT::Config;
|
||||
use constant CACHE_TIMEOUT => 5*60; # Only check the server at most once every 5 minutes
|
||||
|
||||
sub _updater {
|
||||
$STASH{updates} ||= GT::Config->load("$CFG->{admin_root_path}/Links/Config/Updates.pm", { debug => $CFG->{debug_level} });
|
||||
return $STASH{updater} if $STASH{updater};
|
||||
(my $cgi_path = $CFG->{admin_root_path}) =~ s{[\\/]+admin[\\/]*$}//;
|
||||
$STASH{updater} = GT::Update->new(
|
||||
product => 'Links',
|
||||
version => $CFG->{version},
|
||||
reg_number => $CFG->{reg_number},
|
||||
init_path => $CFG->{admin_root_path},
|
||||
perl_path => $CFG->{path_to_perl},
|
||||
backup_path => "$CFG->{admin_root_path}/updates",
|
||||
paths => {
|
||||
script => {
|
||||
cgi => $cgi_path,
|
||||
admin => $CFG->{admin_root_path}
|
||||
},
|
||||
library => $CFG->{admin_root_path},
|
||||
template => $CFG->{admin_root_path} . '/templates',
|
||||
static => {
|
||||
static => $CFG->{build_static_path},
|
||||
},
|
||||
fixed => {
|
||||
static => $CFG->{build_static_path},
|
||||
cool => $CFG->{build_cool_path},
|
||||
detail => $CFG->{build_detail_path},
|
||||
new => $CFG->{build_new_path},
|
||||
ratings => $CFG->{build_ratings_path},
|
||||
build => $CFG->{build_root_path},
|
||||
},
|
||||
version => $CFG->{admin_root_path}
|
||||
},
|
||||
replacements => {
|
||||
library => {
|
||||
'' => {
|
||||
'Links.pm' => {
|
||||
'<%VERSION%>' => $CFG->{version}
|
||||
}
|
||||
}
|
||||
}
|
||||
},
|
||||
installed => ($STASH{updates}->{installed} ||= {}),
|
||||
testing => $STASH{updates}->{testing}
|
||||
);
|
||||
}
|
||||
|
||||
sub check {
|
||||
my $updater = _updater;
|
||||
my ($cached, @updates);
|
||||
if (my $cache = $STASH{updates}->{cache} and !$STASH{updates}->{testing}) {
|
||||
if ($cache->{version} == $GT::Update::VERSION and $cache->{time} > time - CACHE_TIMEOUT) { # Only check at most once every 5 minutes
|
||||
@updates = @{$cache->{updates}};
|
||||
$cached = 1;
|
||||
}
|
||||
}
|
||||
unless ($cached) {
|
||||
@updates = $updater->check;
|
||||
|
||||
if (@updates == 1 and not defined $updates[0]) {
|
||||
my $error = $updater->error;
|
||||
my ($error_code, $error_message) = $error =~ /error code: (\d{3})\s*(.*)/;
|
||||
return { error => $error, update_error_code => $error_code, update_error_message => $error_message };
|
||||
}
|
||||
|
||||
$STASH{updates}->{cache} = { time => time, version => $GT::Update::VERSION, updates => \@updates };
|
||||
$STASH{updates}->save;
|
||||
}
|
||||
|
||||
my %ret;
|
||||
my %available = map { $_->id => $_ } @updates;
|
||||
for my $update (@updates) {
|
||||
my $id = $update->id;
|
||||
my $severity = $update->severity;
|
||||
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
||||
my $info = {
|
||||
id => $id,
|
||||
title => $update->title,
|
||||
description => \($update->description),
|
||||
severity => $severity,
|
||||
files => [$update->files],
|
||||
reversible => $update->reversible,
|
||||
unique => $update->unique,
|
||||
deps => [$update->deps],
|
||||
revdeps => [$update->revdeps],
|
||||
requires => [$update->requires],
|
||||
deps_first => $update->deps_first,
|
||||
update_type => $update_type,
|
||||
installed => $update->installed
|
||||
};
|
||||
push @{$ret{$update_type}}, $info;
|
||||
$ret{update}->{$id} = $info;
|
||||
}
|
||||
for (sort { $a <=> $b } keys %{$STASH{updates}->{installed}->{$CFG->{version}}}) {
|
||||
next if $available{$_};
|
||||
my %info = %{$STASH{updates}->{installed}->{$CFG->{version}}->{$_}};
|
||||
$info{id} = $_;
|
||||
my $severity = $info{severity};
|
||||
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
||||
push @{$ret{$update_type}}, \%info;
|
||||
}
|
||||
|
||||
for (qw/critical recommended optional version/) {
|
||||
$ret{"${_}_total"} = @{$ret{$_} ||= []};
|
||||
$ret{"${_}_installed"} = $ret{"${_}_installable"} = 0;
|
||||
for my $update (@{$ret{$_}}) {
|
||||
next unless $available{$update->{id}};
|
||||
if ($available{$update->{id}}->{installed}) {
|
||||
$ret{"${_}_installed"}++;
|
||||
}
|
||||
elsif (!$available{$update->{id}}->{impossible}) {
|
||||
$ret{"${_}_installable"}++;
|
||||
}
|
||||
}
|
||||
push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} };
|
||||
}
|
||||
|
||||
my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } keys %{$STASH{updates}->{installed}};
|
||||
$ret{historic} = \@historic;
|
||||
|
||||
\%ret;
|
||||
}
|
||||
|
||||
sub check_historic {
|
||||
my $updater = _updater;
|
||||
my $version = shift || $CFG->{version};
|
||||
|
||||
my @updates = $updater->check($version);
|
||||
my %ret = (historic_version => $version, current_version => $CFG->{version});
|
||||
|
||||
for (@updates) {
|
||||
my @files = $_->files;
|
||||
my $severity = $_->severity;
|
||||
my $update_type = $severity == CRITICAL ? 'critical' : $severity == RECOMMENDED ? 'recommended' : $severity == VERSION ? 'version' : 'optional';
|
||||
my $id = $_->id;
|
||||
my %info = (
|
||||
id => $id,
|
||||
title => $_->title,
|
||||
description => \($_->description),
|
||||
severity => $severity,
|
||||
files => \@files,
|
||||
reversible => ($version eq $CFG->{version} ? $_->reversible : 0),
|
||||
unique => $_->unique,
|
||||
deps => [$_->deps],
|
||||
revdeps => [$_->revdeps],
|
||||
requires => [$_->requires],
|
||||
revdeps_first => $_->revdeps_first,
|
||||
update_type => $update_type,
|
||||
installed => $_->installed
|
||||
);
|
||||
push @{$ret{$update_type}}, \%info;
|
||||
$ret{update}->{$id} = \%info;
|
||||
}
|
||||
|
||||
for (qw/critical recommended optional version/) {
|
||||
push @{$ret{update_types}}, { update_type => $_, updates => $ret{$_} };
|
||||
}
|
||||
|
||||
my @historic = sort { _numeric_version($a) <=> _numeric_version($b) } grep keys %{$STASH{updates}->{installed}->{$_}}, keys %{$STASH{updates}->{installed}};
|
||||
$ret{historic} = \@historic;
|
||||
|
||||
\%ret;
|
||||
}
|
||||
|
||||
# Takes a version such as 1.3.7 and converts it to 1.0307.
|
||||
sub _numeric_version {
|
||||
my @v = split /\./, (shift =~ /^(\d+(?:\.\d+)*)/)[0];
|
||||
my $numeric = 0;
|
||||
for (0 .. $#v) { $numeric += $v[$_] * 100**-$_ }
|
||||
$numeric;
|
||||
}
|
||||
|
||||
sub browser_install {
|
||||
my @updates = $IN->param('install');
|
||||
my ($status, $errors) = install(@updates);
|
||||
if (!$status) {
|
||||
$errors->{updates_selected} = \@updates;
|
||||
return $errors;
|
||||
}
|
||||
my %ret = (update_success => 1, update_status => $status, updates_selected => []);
|
||||
|
||||
if ($status == 2) {
|
||||
my $id = $errors;
|
||||
my $path;
|
||||
for (@{$STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{files}}) {
|
||||
if (basename($_->{file}) eq 'install.cgi') {
|
||||
$path = $_->{file} . "?upgrade_choice=Yes;install_dir=" . $IN->escape($CFG->{admin_root_path});
|
||||
last;
|
||||
}
|
||||
}
|
||||
$ret{continue_url} = $path;
|
||||
}
|
||||
|
||||
return \%ret;
|
||||
}
|
||||
|
||||
# Installs updates passed in. Returns (0, \%error_hash) on failure, 1 on
|
||||
# success of normal updates, (2, $id) on the success of version upgrade files.
|
||||
sub install {
|
||||
my @updates = @_;
|
||||
my $updater = _updater;
|
||||
my $v = $updater->verify(@updates);
|
||||
return 0, { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH';
|
||||
@updates = @$v;
|
||||
|
||||
my $success = $updater->install_verified(@updates);
|
||||
if (!$success) {
|
||||
my $error = $updater->error;
|
||||
return 0, { update_failed => 1, error => "Update failed: $error" };
|
||||
}
|
||||
$STASH{updates}->{installed} = { $updater->installed };
|
||||
delete $STASH{updates}->{cache};
|
||||
$STASH{updates}->save;
|
||||
|
||||
if (@updates == 1 and $STASH{updates}->{installed}->{$CFG->{version}}->{$updates[0]}->{severity} == VERSION) {
|
||||
# We just installed a version upgrade
|
||||
return (2, $updates[0]);
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub browser_uninstall {
|
||||
my @updates = $IN->param('uninstall');
|
||||
my ($status, $errors) = uninstall(@updates);
|
||||
if (!$status) {
|
||||
$errors->{updates_selected} = \@updates;
|
||||
return $errors;
|
||||
}
|
||||
return { uninstall_success => 1, updates_selected => [] };
|
||||
}
|
||||
|
||||
sub uninstall {
|
||||
my @updates = @_;
|
||||
my $updater = _updater;
|
||||
my $v = $updater->verify_uninstall(@updates);
|
||||
return { %$v, update_failed => 1, verify_failed => 1 } if ref $v eq 'HASH';
|
||||
@updates = @$v;
|
||||
|
||||
my $success = $updater->uninstall_verified(@updates);
|
||||
if (!$success) {
|
||||
my $error = $updater->error;
|
||||
return 0, { uninstall_failed => 1, error => "Update uninstall failed: $error" };
|
||||
}
|
||||
$STASH{updates}->{installed} = { $updater->installed };
|
||||
delete $STASH{updates}->{cache};
|
||||
$STASH{updates}->save;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Takes a string, such as '/foo/bar/blah/sdffffffddddddddddddddddddddddddddddd'
|
||||
# and replaces a part of it with ...
|
||||
# The arguments are:
|
||||
# - string
|
||||
# - number of characters before the ...
|
||||
# - number of characters after the ...
|
||||
sub shorten {
|
||||
my ($string, $leading, $trailing) = @_;
|
||||
if (length($string) <= ($leading + $trailing + 3)) {
|
||||
return $string;
|
||||
}
|
||||
else {
|
||||
return substr($string, 0, $leading) . ' ... ' . substr($string, -$trailing);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
1034
site/slowtwitch.com/cgi-bin/articles/admin/Links/Upgrade.pm
Normal file
1034
site/slowtwitch.com/cgi-bin/articles/admin/Links/Upgrade.pm
Normal file
File diff suppressed because it is too large
Load Diff
303
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Add.pm
Normal file
303
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Add.pm
Normal file
@@ -0,0 +1,303 @@
|
||||
# ==================================================================
|
||||
# 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: Add.pm,v 1.59 2007/12/20 20:31:35 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::User::Add;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects :payment/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# -------------------------------------------------------------------
|
||||
# Display either an add form or process an add request.
|
||||
#
|
||||
if ($CFG->{user_required} and !$USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('add'));
|
||||
return;
|
||||
}
|
||||
|
||||
my $custom;
|
||||
if (exists $CFG->{payment}->{remote}->{used}->{PayPal} and $custom = $IN->param('custom') and substr($custom, 0, 3) eq 'do;') {
|
||||
substr($custom, 0, 3) = '';
|
||||
my @pairs = split /;/, $custom;
|
||||
for (@pairs) {
|
||||
my ($key, $val) = split /=/, $_;
|
||||
next unless $key and $val;
|
||||
$IN->param($key => $val) unless $IN->param($key);
|
||||
}
|
||||
}
|
||||
|
||||
print $IN->header;
|
||||
|
||||
# We are processing an add request.
|
||||
if ($IN->param('add')) {
|
||||
my $results = $PLG->dispatch('user_add_link', \&add_link);
|
||||
if (defined $results->{error}) {
|
||||
print Links::SiteHTML::display('add', $results);
|
||||
}
|
||||
else {
|
||||
$results = Links::SiteHTML::tags('link', $results);
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD_SUCCESS'), "$CFG->{db_cgi_url}/add.cgi");
|
||||
if ($CFG->{payment}->{enabled}) {
|
||||
require Links::Payment;
|
||||
my @cats = $IN->param('CatLinks.CategoryID');
|
||||
my $opt = Links::Payment::load_cat_price(\@cats);
|
||||
if (exists $opt->{error}) {
|
||||
print Links::SiteHTML::display('error', $opt);
|
||||
}
|
||||
elsif ($opt->{payment_mode} == NOT_ACCEPTED) {
|
||||
if ($CFG->{admin_email_add}) {
|
||||
Links::send_email('link_added.eml', $results, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error";
|
||||
}
|
||||
print Links::SiteHTML::display('add_success', $results);
|
||||
}
|
||||
else {# payment option for this category is required or optional
|
||||
$results->{link_id} = $results->{ID}; # we need a different tag since both Category and Link have ID
|
||||
$opt->{CategoryID} = delete $opt->{ID}; # remove category id
|
||||
$opt->{CategoryDescription} = delete $opt->{Description};
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$results->{link_id}");
|
||||
print Links::SiteHTML::display('payment', { %$results, %$opt });
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($CFG->{admin_email_add}) {
|
||||
Links::send_email('link_added.eml', $results, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error";
|
||||
}
|
||||
print Links::SiteHTML::display('add_success', $results);
|
||||
}
|
||||
}
|
||||
}
|
||||
# We are processing a payment request.
|
||||
elsif ($IN->param('process_payment') and $CFG->{payment}->{enabled}) {
|
||||
my $payment_term = $IN->param('payment_term') || '';
|
||||
my $do = $IN->param('do');
|
||||
if ($payment_term eq 'free') {
|
||||
my $link = $DB->table('Links')->get($IN->param('link_id'));
|
||||
if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) {
|
||||
print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') });
|
||||
return;
|
||||
};
|
||||
$link = Links::SiteHTML::tags('link', $link);
|
||||
|
||||
# Set ExpiryDate to free
|
||||
$link->{'CatLinks.CategoryID'} = $IN->param('cat_id');
|
||||
$link->{ExpiryDate} = FREE;
|
||||
$link->{ExpiryNotify}= 0;
|
||||
# Update the link
|
||||
$DB->table('Links')->update({ ExpiryDate => FREE, ExpiryNotify => 0 }, { ID => $link->{ID} });
|
||||
# Update the Timestmp for link's categories so they get rebuilt with build changed
|
||||
my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list;
|
||||
$DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats });
|
||||
|
||||
# Add some special tags for formatting.
|
||||
@cats = $DB->table('Category', 'CatLinks')->select('Category.Full_Name', { 'CatLinks.LinkID' => $link->{ID} })->fetchall_list;
|
||||
$link->{Category} = join "\n", sort @cats;
|
||||
$link->{Category_loop} = [sort @cats];
|
||||
$link->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none';
|
||||
$link->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none';
|
||||
$link->{AutoValidate} = $CFG->{build_auto_validate};
|
||||
if ($CFG->{admin_email_add}) {
|
||||
Links::send_email('link_added.eml', $link, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error";
|
||||
}
|
||||
$link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD_SUCCESS'), "$CFG->{db_cgi_url}/add.cgi");
|
||||
print Links::SiteHTML::display('add_success', $link);
|
||||
}
|
||||
elsif ($IN->param('payment_success')) {
|
||||
print Links::SiteHTML::display('payment_success', { main_title_loop => Links::Build::build('title', Links::language('LINKS_PAYMENT_SUCCESS'), $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : ''))) });
|
||||
}
|
||||
elsif ($do =~ /^payment_(method|form|direct)$/) {
|
||||
require Links::Payment;
|
||||
my $vars = Links::Payment->$1();
|
||||
my $page = $IN->param('page') || $IN->param('do');
|
||||
my $opt = Links::Payment::load_cat_price($IN->param('cat_id'));
|
||||
if ($opt->{payment_mode} == NOT_ACCEPTED) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') });
|
||||
return;
|
||||
}
|
||||
my $link = $DB->table('Links')->get($IN->param('link_id'));
|
||||
if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) {
|
||||
print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') });
|
||||
return;
|
||||
}
|
||||
$link = Links::SiteHTML::tags('link', $link);
|
||||
|
||||
$link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{ID}");
|
||||
print Links::SiteHTML::display($page, { %$vars, %$opt, %$link });
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('error', { error => "Invalid action" });
|
||||
}
|
||||
}
|
||||
# We are displaying an add form.
|
||||
else {
|
||||
my @id = grep { /^\d+$/ } $IN->param('ID');
|
||||
|
||||
# If we don't have an id, and can't generate a list, let's send the user a message.
|
||||
if (!@id and !$CFG->{db_gen_category_list}) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('ADD_SELCAT') });
|
||||
}
|
||||
else {
|
||||
# Otherwise display the add form.
|
||||
if ($USER) {
|
||||
$IN->param('Contact_Name') or ($IN->param('Contact_Name', $USER->{Name} || $USER->{Username}));
|
||||
$IN->param('Contact_Email') or ($IN->param('Contact_Email', $USER->{Email}));
|
||||
}
|
||||
|
||||
if ($DB->table('Category')->count == 0) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('ADD_NOCATEGORIES') });
|
||||
}
|
||||
# If we're not generating a category list, the add form can't be shown without a valid category ID.
|
||||
elsif (!$CFG->{db_gen_category_list} and $DB->table('Category')->count({ ID => \@id }) == 0) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('ADD_INVALIDCAT', join(', ', @id)) });
|
||||
}
|
||||
else {
|
||||
my $category = {};
|
||||
if ($CFG->{db_gen_category_list} < 2) {
|
||||
require Links::Tools;
|
||||
$category = Links::Tools::category_list();
|
||||
$category->{Category} = sub { Links::Tools::category_list_html() };
|
||||
}
|
||||
print Links::SiteHTML::display('add', {
|
||||
main_title_loop => Links::Build::build('title', Links::language('LINKS_ADD'), "$CFG->{db_cgi_url}/add.cgi" . (@id ? "?ID=" . join(';ID=', @id) : '')),
|
||||
%$category
|
||||
});
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub add_link {
|
||||
# --------------------------------------------------------
|
||||
# Add the link to the database.
|
||||
#
|
||||
my $class = shift;
|
||||
my @id = $IN->param('CatLinks.CategoryID');
|
||||
my %ret;
|
||||
if ($CFG->{db_gen_category_list} < 2) {
|
||||
require Links::Tools;
|
||||
%ret = %{Links::Tools::category_list()};
|
||||
$ret{Category} = sub { Links::Tools::category_list_html() };
|
||||
}
|
||||
$ret{main_title_loop} = Links::Build::build('title', Links::language('LINKS_ADD'), "$CFG->{db_cgi_url}/add.cgi" . (@id ? "?ID=" . join(';ID=', @id) : ''));
|
||||
|
||||
# Check the referer.
|
||||
if (@{$CFG->{db_referers}}) {
|
||||
my $found = 0;
|
||||
if ($ENV{'HTTP_REFERER'}) {
|
||||
foreach (@{$CFG->{db_referers}}) { $ENV{'HTTP_REFERER'} =~ /\Q$_\E/i and $found++ and last; }
|
||||
}
|
||||
unless ($found) {
|
||||
return { error => Links::language('ADD_BADREFER', $ENV{'HTTP_REFERER'}), %ret };
|
||||
}
|
||||
}
|
||||
|
||||
# Get our form data.
|
||||
my $input = $IN->get_hash;
|
||||
|
||||
# Check if the link is valid
|
||||
if ($CFG->{user_link_validation}) {
|
||||
require Links::Tools;
|
||||
my $status = Links::Tools::link_status($input->{URL});
|
||||
if ($status and $Links::Tools::STATUS_BAD{$status}) {
|
||||
return { error => Links::language('ADD_BADSTATUS', $Links::Tools::STATUS_BAD{$status}), %ret };
|
||||
}
|
||||
}
|
||||
|
||||
my $db = $DB->table('Links');
|
||||
my $cdb = $DB->table('Category');
|
||||
|
||||
# Columns the user should not be passing in
|
||||
for my $key (qw/ID LinkOwner Add_Date Mod_Date Timestmp Date_Checked ExpiryDate ExpiryCounted ExpiryNotify LinkExpired/) {
|
||||
delete $input->{$key};
|
||||
}
|
||||
|
||||
for my $key (keys %{$CFG->{add_system_fields}}) {
|
||||
$input->{$key} = $CFG->{add_system_fields}->{$key};
|
||||
}
|
||||
|
||||
# Set the LinkOwner
|
||||
$input->{LinkOwner} = $USER ? $USER->{Username} : 'admin';
|
||||
|
||||
# Set date variable to today's date.
|
||||
Links::init_date();
|
||||
my $today = GT::Date::date_get();
|
||||
$input->{Add_Date} = $today;
|
||||
$input->{Mod_Date} = $today;
|
||||
|
||||
# Backward compatibility
|
||||
$input->{Contact_Name} = $input->{'Contact_Name'} || $input->{'Contact Name'} || ($USER ? $USER->{Name} : '');
|
||||
$input->{Contact_Email} = $input->{'Contact_Email'} || $input->{'Contact Email'} || ($USER ? $USER->{Email} : '');
|
||||
|
||||
$input->{isValidated} = ($CFG->{build_auto_validate} == 1 and $USER or $CFG->{build_auto_validate} == 2) ? 'Yes' : 'No';
|
||||
|
||||
# Check the category
|
||||
my @cids = $IN->param('CatLinks.CategoryID');
|
||||
my @name;
|
||||
if (@cids) {
|
||||
foreach my $cid (@cids) {
|
||||
next if (! $cid);
|
||||
my $sth = $cdb->select('Full_Name', { ID => $cid });
|
||||
$sth->rows or return { error => Links::language('ADD_INVALIDCAT', $cid), %ret };
|
||||
push @name, $sth->fetchrow;
|
||||
}
|
||||
if (@name) {
|
||||
$input->{'CatLinks.CategoryID'} = \@cids;
|
||||
}
|
||||
}
|
||||
|
||||
my $take_payments = (
|
||||
$CFG->{payment}->{enabled}
|
||||
and
|
||||
(
|
||||
$cdb->count(GT::SQL::Condition->new(Payment_Mode => '>=' => OPTIONAL, ID => '=' => \@cids))
|
||||
or
|
||||
(
|
||||
$CFG->{payment}->{mode} >= OPTIONAL and
|
||||
$cdb->count(GT::SQL::Condition->new(Payment_Mode => '=' => GLOBAL, ID => '=' => \@cids))
|
||||
)
|
||||
)
|
||||
);
|
||||
|
||||
# Set the payment expiry
|
||||
# Set this to unlimited when payment is turned off so that if payment is turned on
|
||||
# at a later date, those users aren't forced to pay.
|
||||
$input->{ExpiryDate} = $CFG->{payment}->{enabled} && $take_payments ? UNPAID : FREE;
|
||||
|
||||
# Setup the language for GT::SQL.
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL');
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL');
|
||||
local $Links::Table::Links::ERRORS->{NOCATEGORY} = Links::language('ADD_NOCATEGORY');
|
||||
$Links::Table::Links::ERRORS if 0; # silence -w
|
||||
|
||||
# Add the record.
|
||||
my $id = $db->add($input);
|
||||
$input->{ID} = $id;
|
||||
if (! $id) {
|
||||
my $error = "<ul>" . join('', map "<li>$_</li>", $db->error) . "</ul>";
|
||||
return { error => $error, %ret };
|
||||
}
|
||||
|
||||
# Add some special tags for formatting.
|
||||
$input->{Category} = join "\n", sort @name;
|
||||
$input->{Category_loop} = [sort @name];
|
||||
$input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none';
|
||||
$input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none';
|
||||
$input->{AutoValidate} = $CFG->{build_auto_validate};
|
||||
|
||||
# Send the visitor to the success page.
|
||||
return $input;
|
||||
}
|
||||
|
||||
1;
|
||||
126
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Editor.pm
Normal file
126
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Editor.pm
Normal file
@@ -0,0 +1,126 @@
|
||||
# ==================================================================
|
||||
# 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: Editor.pm,v 1.15 2009/05/09 06:40:54 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::User::Editor;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Browser::Controller;
|
||||
use Links::Browser;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# ------------------------------------------------------------------
|
||||
# This script is only available to users who have logged on.
|
||||
#
|
||||
unless ($USER) {
|
||||
my $url = $IN->url(absolute => 1, query_string => 1);
|
||||
$url = $IN->escape($url);
|
||||
$url = $CFG->{db_cgi_url} . "/user.cgi?url=$url;from=browser";
|
||||
print $IN->redirect($url);
|
||||
return;
|
||||
}
|
||||
my $editors = $DB->table('Editors');
|
||||
my @nodes;
|
||||
my $perms = {};
|
||||
|
||||
# Get a controller to manage access.
|
||||
my $ctrl = Links::Browser::Controller->new(user => $USER);
|
||||
|
||||
if ($USER->{Status} eq 'Administrator') {
|
||||
$ctrl->{admin} = 1;
|
||||
}
|
||||
else {
|
||||
my $sth = $editors->select({ Username => $USER->{Username} });
|
||||
if ($sth->rows) {
|
||||
while (my $ed = $sth->fetchrow_hashref) {
|
||||
push @nodes, $ed->{CategoryID};
|
||||
$perms->{$ed->{CategoryID}} = $ed;
|
||||
}
|
||||
}
|
||||
unless (@nodes) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BROWSER_NOTEDITOR') });
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Handle the special condition which related to viewing
|
||||
# and downloading files. Must remap the passed column
|
||||
# values so Jump functions properly.
|
||||
my $method = $IN->param('do');
|
||||
if ($method and $method =~ m/^(?:(v)iew|(download))_file$/) {
|
||||
$IN->param($+, $IN->param('cn'));
|
||||
$IN->param('ID', $IN->param('link_id') || $IN->param('id'));
|
||||
$IN->param('DB', $IN->param('db'));
|
||||
require Links::User::Jump;
|
||||
return Links::User::Jump::handle();
|
||||
}
|
||||
elsif ($method and $method =~ m/^(?:(v)iew|(download))_tmp_file$/) {
|
||||
my $download = $2;
|
||||
# view_tmp_file doesn't go through Jump because only editors are
|
||||
# allowed to see them - the tmp files are used for pending Changes.
|
||||
my $col = $IN->param('cn');
|
||||
my $id = $IN->param('link_id');
|
||||
my $changes = $DB->table('Changes')->select({ LinkID => $id })->fetchrow_hashref;
|
||||
|
||||
my ($linkinfo, $fh);
|
||||
if ($changes) {
|
||||
$linkinfo = eval $changes->{ChgRequest};
|
||||
if ($linkinfo and -f $linkinfo->{$col}) {
|
||||
my $colfh = \do { local *FH; *FH };
|
||||
if (open $colfh, "<$linkinfo->{$col}") {
|
||||
$fh = $colfh;
|
||||
binmode $fh;
|
||||
}
|
||||
}
|
||||
}
|
||||
if (!$fh) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('FILE_UNKNOWN', $id) });
|
||||
return;
|
||||
}
|
||||
|
||||
(my $filename = $linkinfo->{"${col}_filename"} || $linkinfo->{$col}) =~ s{.*[/\\]}{};
|
||||
print $IN->header($IN->file_headers(
|
||||
filename => $filename,
|
||||
inline => $download ? 0 : 1,
|
||||
size => -s $linkinfo->{$col}
|
||||
));
|
||||
|
||||
while (read $fh, my $buffer, 64*1024) {
|
||||
print $buffer;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Load the tree if it is under 200 categories.
|
||||
$ctrl->{load_tree} = 1;
|
||||
$ctrl->{user_base_node} = \@nodes;
|
||||
$ctrl->{perms} = $perms;
|
||||
$ctrl->{admin_templates} = 0;
|
||||
|
||||
# Begin the script.
|
||||
print $IN->header(-charset => $CFG->{header_charset});
|
||||
$method = $ctrl->can_run;
|
||||
if ($method) {
|
||||
my $browser = Links::Browser->new(ctrl => $ctrl);
|
||||
$PLG->dispatch("browser_$method", sub { $browser->$method(); }, $browser);
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('BROWSER_UNAUTHORIZED') });
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
186
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Jump.pm
Normal file
186
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Jump.pm
Normal file
@@ -0,0 +1,186 @@
|
||||
# ==================================================================
|
||||
# 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: Jump.pm,v 1.26 2006/02/20 22:38:31 jagerman 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::User::Jump;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects :payment/;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# --------------------------------------------------------------
|
||||
# Jump to a given ID.
|
||||
#
|
||||
$PLG->dispatch('jump_link', \&_plg_jump, {});
|
||||
}
|
||||
|
||||
sub _plg_jump {
|
||||
# --------------------------------------------------------------
|
||||
# Jump to a given link.
|
||||
#
|
||||
my $links = $DB->table('Links');
|
||||
my $id = $IN->param('ID') || $IN->param('Detailed');
|
||||
my $action = $IN->param('action') || '';
|
||||
my $goto = '';
|
||||
my $rec = {};
|
||||
|
||||
if ($CFG->{framed_jump} and $id and $action eq 'jump_frame') {
|
||||
my $error;
|
||||
if ($id !~ /^\d+$/) {
|
||||
$error = Links::language('JUMP_INVALIDID', $id);
|
||||
}
|
||||
else {
|
||||
$rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref;
|
||||
unless ($rec) {
|
||||
$error = Links::language('JUMP_INVALIDID', $id);
|
||||
$rec = {};
|
||||
}
|
||||
elsif ($CFG->{build_detailed}) {
|
||||
$rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id);
|
||||
}
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('jump_frame', { error => $error, %$rec });
|
||||
return;
|
||||
}
|
||||
|
||||
# If we are chosing a random link, then get the total and go to one at random.
|
||||
if (lc $id eq "random") {
|
||||
my $offset = int rand $links->count(VIEWABLE);
|
||||
$links->select_options("LIMIT 1 OFFSET $offset");
|
||||
my $sth = $links->select(qw/ID URL/ => VIEWABLE);
|
||||
($id, $goto) = $sth->fetchrow_array;
|
||||
}
|
||||
elsif (defined $id) {
|
||||
if ($id !~ /^\d+$/) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) });
|
||||
return;
|
||||
}
|
||||
|
||||
# Find out if we're going to be displaying a file
|
||||
my $col = $IN->param('v') || $IN->param('dl') || $IN->param('view') || $IN->param('download');
|
||||
|
||||
if ($col) {
|
||||
# in this case, we need to know from what table we want to load our data from.
|
||||
# It will by default pull information from the Links table, however if the
|
||||
# DB=tablename option is used, it will apply the request to that table instead
|
||||
my $table_name = $IN->param('DB') || 'Links';
|
||||
|
||||
unless ($table_name =~ m/^\w+$/) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLEFORMAT' ) });
|
||||
return;
|
||||
};
|
||||
|
||||
if ($table_name ne 'Links') {
|
||||
eval { $links = $DB->table($table_name) };
|
||||
if ($@) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('FILE_TABLE', $table_name, $GT::SQL::error) });
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my $fh;
|
||||
eval { $fh = $links->file_info($col, $id); };
|
||||
if ($fh) {
|
||||
if ($IN->param('v') or $IN->param('view')) { # Viewing
|
||||
print $IN->header($IN->file_headers(
|
||||
filename => $fh->File_Name,
|
||||
mimetype => $fh->File_MimeType,
|
||||
inline => 1,
|
||||
size => $fh->File_Size
|
||||
));
|
||||
}
|
||||
else { # Downloading
|
||||
print $IN->header($IN->file_headers(
|
||||
filename => $fh->File_Name,
|
||||
mimetype => $fh->File_MimeType,
|
||||
inline => 0,
|
||||
size => $fh->File_Size
|
||||
));
|
||||
}
|
||||
binmode $fh;
|
||||
while (read($fh, my $buffer, 65536)) {
|
||||
print $buffer;
|
||||
}
|
||||
return 1;
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('FILE_UNKNOWN', $id) });
|
||||
return;
|
||||
}
|
||||
}
|
||||
# Jump to a URL, bump the hit counter.
|
||||
else {
|
||||
$rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref;
|
||||
unless ($rec) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) });
|
||||
return;
|
||||
}
|
||||
$goto = $rec->{URL};
|
||||
|
||||
my $clicktrack = $DB->table('ClickTrack');
|
||||
my $rows = $clicktrack->count({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits' });
|
||||
unless ($rows) {
|
||||
eval {
|
||||
$clicktrack->insert({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Hits', Created => \"NOW()" });
|
||||
$links->update({ Hits => \"Hits + 1" }, { ID => $id }, { GT_SQL_SKIP_INDEX => 1 });
|
||||
};
|
||||
}
|
||||
}
|
||||
}
|
||||
# Oops, no link.
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) });
|
||||
return;
|
||||
}
|
||||
|
||||
unless (defined $goto) {
|
||||
my $error = ($IN->param('ID') eq 'random') ? Links::language('RANDOM_NOLINKS') : Links::language('JUMP_INVALIDID', $id);
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => $error });
|
||||
return;
|
||||
}
|
||||
|
||||
# Redirect to a detailed page if requested.
|
||||
if ($CFG->{build_detailed} and $IN->param('Detailed')) {
|
||||
$goto = Links::transform_url("$CFG->{build_detail_url}/" . $links->detailed_url($id));
|
||||
}
|
||||
($goto =~ m,^\w+://,) or ($goto = "http://$goto");
|
||||
if ($goto) {
|
||||
if ($CFG->{framed_jump} and not ($CFG->{build_detailed} and $IN->param('Detailed'))) {
|
||||
unless (keys %$rec) {
|
||||
$rec = $links->select({ ID => $id }, VIEWABLE)->fetchrow_hashref;
|
||||
}
|
||||
$rec->{detailed_url} = "$CFG->{build_detail_url}/" . $links->detailed_url($id) if $CFG->{build_detailed};
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('jump', { destination => $goto, %$rec });
|
||||
return;
|
||||
}
|
||||
else {
|
||||
print $IN->redirect($goto);
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('JUMP_INVALIDID', $id) });
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
263
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Login.pm
Normal file
263
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Login.pm
Normal file
@@ -0,0 +1,263 @@
|
||||
# ==================================================================
|
||||
# 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: Login.pm,v 1.19 2005/05/08 09:56:44 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::User::Login;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# -------------------------------------------------------------------
|
||||
# Determine what to do.
|
||||
#
|
||||
my $input = $IN->get_hash;
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi");
|
||||
if ($input->{login}) {
|
||||
$PLG->dispatch('user_login', \&login_user);
|
||||
}
|
||||
elsif ($input->{signup_user}) {
|
||||
$PLG->dispatch('user_signup', \&signup_user);
|
||||
}
|
||||
elsif ($input->{validate_user}) {
|
||||
$PLG->dispatch('user_validate', \&validate_user);
|
||||
}
|
||||
elsif ($input->{send_validate}) {
|
||||
$PLG->dispatch('user_validate_email', \&send_validate);
|
||||
}
|
||||
elsif ($input->{send_pass} and $CFG->{user_allow_pass}) {
|
||||
$PLG->dispatch('user_pass_email', \&send_pass);
|
||||
}
|
||||
elsif ($input->{signup_form}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { Username => $IN->param('Username') || '', Password => '', Email => $IN->param('Email') || '', main_title_loop => Links::Build::build('title', Links::language('LINKS_SIGNUP'), "$CFG->{db_cgi_url}/user.cgi?signup_form=1") });
|
||||
}
|
||||
elsif ($input->{validate}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('validate_form', { main_title_loop => Links::Build::build('title', Links::language('LINKS_VALIDATE'), "$CFG->{db_cgi_url}/user.cgi?validate=1") });
|
||||
}
|
||||
elsif ($input->{logout}) {
|
||||
Links::Authenticate::auth('delete_session');
|
||||
$USER = undef;
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('login', { Username => '', Password => '', Email => '', error => Links::language('USER_LOGOUT'), main_title_loop => $mtl });
|
||||
}
|
||||
elsif ($input->{email_pass} and $CFG->{user_allow_pass}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('login_email', { main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") });
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('login', { Username => $IN->param('Username') || '', main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
# ==============================================================
|
||||
|
||||
sub login_user {
|
||||
# --------------------------------------------------------
|
||||
# Logs a user in, and creates a session ID.
|
||||
#
|
||||
my $username = $IN->param('Username') || shift;
|
||||
my $password = $IN->param('Password') || shift;
|
||||
my $goto = shift || 'login_success';
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi");
|
||||
|
||||
# Make sure we have both a username and password.
|
||||
if (!$username or !$password) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('login', { error => Links::language('USER_BADLOGIN'), Username => $username, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Check that the user exists, and that the password is valid.
|
||||
my $user = Links::init_user($username, $password);
|
||||
if (!$user) {
|
||||
print $IN->header();
|
||||
require Links::Authenticate;
|
||||
if (Links::Authenticate::auth_valid_user({ Username => $username, Password => $password })) {
|
||||
print Links::SiteHTML::display('login', { error => Links::language('USER_NOTVAL', $user->{Email}), Username => $user->{Username}, main_title_loop => $mtl });
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('login', { error => Links::language('USER_BADLOGIN'), main_title_loop => $mtl });
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
# Store the session in either a cookie or url based.
|
||||
my $results = Links::Authenticate::auth('create_session', { Username => $user->{Username} });
|
||||
return if $results->{redirect};
|
||||
|
||||
# Get the $USER information.
|
||||
$USER = Links::Authenticate::auth('get_user', { Username => $username, Password => $password, auto_create => 1 });
|
||||
|
||||
print $IN->header(); # In case the session didn't print it.
|
||||
print Links::SiteHTML::display($goto, { %$user, main_title_loop => $mtl });
|
||||
}
|
||||
|
||||
sub signup_user {
|
||||
# --------------------------------------------------------
|
||||
# Signs a new user up.
|
||||
#
|
||||
my $username = $IN->param('Username');
|
||||
my $password = $IN->param('Password');
|
||||
my $email = $IN->param('Email');
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_SIGNUP'), "$CFG->{db_cgi_url}/user.cgi?signup_form=1");
|
||||
|
||||
if (!$username or !$password or !$email) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { error => Links::language('USER_INVALIDSIGNUP'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
unless ($email =~ /.\@.+\../) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { error => Links::language('USER_INVALIDEMAIL', $email), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Check that the username doesn't already exist.
|
||||
my $db = $DB->table('Users');
|
||||
my $user = $db->get($username);
|
||||
if ($user) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display( 'signup_form', { error => Links::language('USER_NAMETAKEN', $username), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Check that the email address doesn't already exist.
|
||||
my $hits = $db->count({ Email => $email });
|
||||
if ($hits) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { error => Links::language('USER_EMAILTAKEN', $email), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my ($code, $msg);
|
||||
|
||||
# Add the user in, set defaults for fields not specified.
|
||||
$user = $IN->get_hash();
|
||||
my $def = $db->default || {};
|
||||
foreach (keys %$def) {
|
||||
$user->{$_} = $def->{$_} unless (exists $user->{$_});
|
||||
}
|
||||
|
||||
# Send validation email if needed.
|
||||
if ($CFG->{user_validation}) {
|
||||
my $code = time . $$ . int rand 1000;
|
||||
$user->{Status} = "Not Validated";
|
||||
$user->{Validation} = $code;
|
||||
my $ret = $db->add($user);
|
||||
if (!$ret) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { error => $db->error, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
$user->{Status} = "Registered";
|
||||
$user->{Validation} = 0;
|
||||
my $ret = $db->add($user);
|
||||
if (!$ret) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_form', { error => $db->error, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
# Print the welcome screen.
|
||||
if ($CFG->{user_validation}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_success', { %$user, main_title_loop => $mtl });
|
||||
Links::send_email('validate.eml', $user) or die "Unable to send message: $GT::Mail::error";
|
||||
}
|
||||
else {
|
||||
my $results = Links::Authenticate::auth('create_session', { Username => $user->{Username} });
|
||||
$USER = Links::Authenticate::auth('get_user', { Username => $user->{Username}, Password => $user->{Password}, auto_create => 1 });
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('signup_success', { %$user, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub validate_user {
|
||||
# --------------------------------------------------------
|
||||
# Validates a user.
|
||||
#
|
||||
my $code = $IN->param('code');
|
||||
$code =~ s/^\s*|\s*$//g;
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_VALIDATE'), "$CFG->{db_cgi_url}/user.cgi?validate=1");
|
||||
|
||||
if (!$code) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('validate_form', { error => Links::language('USER_INVALIDVAL'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my $db = $DB->table('Users');
|
||||
my $sth = $db->select({ Validation => $code });
|
||||
my $user = $sth->fetchrow_hashref;
|
||||
|
||||
if (! $user) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('validate_form', { error => Links::language('USER_INVALIDVAL'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$db->update({ Status => 'Registered' }, { Username => $user->{Username} });
|
||||
login_user($user->{Username}, $user->{Password}, 'validate_success');
|
||||
}
|
||||
|
||||
sub send_pass {
|
||||
# -------------------------------------------------------------------
|
||||
# Sends the user a password reminder email.
|
||||
#
|
||||
my $email = $IN->param('Email');
|
||||
my $user_db = $DB->table('Users');
|
||||
my $sth = $user_db->select( { Email => $email } );
|
||||
print $IN->header();
|
||||
my $user = $sth->fetchrow_hashref;
|
||||
if ($user and $email =~ /.+\@.+\..+/) {
|
||||
Links::send_email('password.eml', { %$user, %ENV }) or die "Unable to send message: $GT::Mail::error";
|
||||
print Links::SiteHTML::display('login', { error => Links::language('USER_PASSSENT'), Username => '', Password => '', main_title_loop => Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi") });
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('login_email', { error => Links::language('USER_NOEMAIL'), main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") });
|
||||
}
|
||||
}
|
||||
|
||||
sub send_validate {
|
||||
# -------------------------------------------------------------------
|
||||
# Sends the validation email if the user needs another one.
|
||||
#
|
||||
my $email = $IN->param('Email');
|
||||
my $user_db = $DB->table('Users');
|
||||
my $sth = $user_db->select( { Email => $email } );
|
||||
print $IN->header();
|
||||
if ($sth->rows) {
|
||||
# Prepare the message.
|
||||
my $user = $sth->fetchrow_hashref;
|
||||
|
||||
# Make sure there is a validation code.
|
||||
if (! $user->{Validation}) {
|
||||
$user->{Validation} = (time) . ($$) . (int rand(1000));
|
||||
$user_db->modify($user);
|
||||
}
|
||||
Links::send_email('validate.eml', $user) or die "Unable to send message: $GT::Mail::error";
|
||||
|
||||
print Links::SiteHTML::display('login', { error => Links::language('USER_VALSENT'), Username => '', Password => '', main_title_loop => Links::Build::build('title', Links::language('LINKS_LOGIN'), "$CFG->{db_cgi_url}/user.cgi") });
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('login_email', { error => Links::language('USER_NOEMAIL'), main_title_loop => Links::Build::build('title', Links::language('LINKS_EMAILPASS'), "$CFG->{db_cgi_url}/user.cgi?email_pass=1") });
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
571
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm
Normal file
571
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Modify.pm
Normal file
@@ -0,0 +1,571 @@
|
||||
# ==================================================================
|
||||
# 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: Modify.pm,v 1.82 2013/02/01 04:43:56 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::User::Modify;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects :payment/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# ---------------------------------------------------
|
||||
# Determine what to do.
|
||||
#
|
||||
my $link_id = $IN->param('LinkID');
|
||||
if ($CFG->{user_required} and !$USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('modify'));
|
||||
return;
|
||||
}
|
||||
|
||||
# Perform the link modification
|
||||
if ($IN->param('modify')) {
|
||||
_modify();
|
||||
}
|
||||
elsif ($USER) {
|
||||
# Display the link modify form (for a specific link)
|
||||
if ($IN->param('LinkID')) {
|
||||
_modify_passed_in();
|
||||
}
|
||||
else {
|
||||
_list_owned_links();
|
||||
}
|
||||
}
|
||||
# Display the link modify form (used when user_required is off)
|
||||
else {
|
||||
_modify_form();
|
||||
}
|
||||
}
|
||||
|
||||
# ==============================================================
|
||||
|
||||
sub _modify {
|
||||
# --------------------------------------------------------
|
||||
# Modifies a link.
|
||||
#
|
||||
# If payment is enabled and we are processing a payment
|
||||
if ($CFG->{payment}->{enabled} and $IN->param('process_payment')) {
|
||||
my $payment_term = $IN->param('payment_term') || '';
|
||||
my $do = $IN->param('do') || '';
|
||||
if ($payment_term eq 'free') {
|
||||
print $IN->header();
|
||||
my $link = $DB->table('Links')->get(scalar $IN->param('link_id'));
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY_SUCCESS'), "$CFG->{db_cgi_url}/modify.cgi");
|
||||
if (not $link or ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username})) {
|
||||
print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$link = Links::SiteHTML::tags('link', $link);
|
||||
|
||||
# Add some special tags for formatting.
|
||||
$link->{Category} = $DB->table('Category', 'CatLinks')->select('Category.Full_Name', { 'CatLinks.LinkID' => $link->{ID} })->fetchrow;
|
||||
|
||||
# Set ExpiryDate to free
|
||||
$link->{'CatLinks.CategoryID'} = $IN->param('cat_id');
|
||||
$link->{ExpiryDate} = FREE;
|
||||
$link->{ExpiryNotify}= 0;
|
||||
# Update the link
|
||||
$DB->table('Links')->update({ ExpiryDate => FREE, ExpiryNotify => 0 }, { ID => $link->{ID} });
|
||||
# Update the Timestmp for link's categories so they get rebuilt with build changed
|
||||
my @cats = $DB->table('Links', 'CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list;
|
||||
$DB->table('Category')->update({ Timestmp => \'NOW()' }, { ID => \@cats });
|
||||
|
||||
print Links::SiteHTML::display('modify_success', { %$link, main_title_loop => $mtl });
|
||||
}
|
||||
elsif ($do eq 'payment_linked') {
|
||||
print $IN->header;
|
||||
my $link = $DB->table('Links', 'CatLinks')->select({ ID => scalar $IN->param('ID') })->fetchrow_hashref;
|
||||
if (!$link) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOLINKS') });
|
||||
return;
|
||||
}
|
||||
elsif ($CFG->{user_required} and $link->{LinkOwner} ne $USER->{Username}) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTOWNER') });
|
||||
return;
|
||||
}
|
||||
$link = Links::SiteHTML::tags('link', $link);
|
||||
|
||||
require Links::Payment;
|
||||
my @cid = $DB->table('CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list;
|
||||
my $opt = Links::Payment::load_cat_price(\@cid);
|
||||
if ($opt->{payment_mode} == NOT_ACCEPTED) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') });
|
||||
return;
|
||||
}
|
||||
$link->{link_id} = $link->{ID}; # we need a different tag since both Category and Link have ID
|
||||
$opt->{CategoryID} = delete $opt->{ID}; # remove category id
|
||||
$opt->{CategoryDescription} = delete $opt->{Description};
|
||||
$link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{link_id}");
|
||||
print Links::SiteHTML::display('payment', { %$link, %$opt });
|
||||
}
|
||||
elsif ($do =~ /^payment_(method|form|direct)$/) {
|
||||
require Links::Payment;
|
||||
my $vars = Links::Payment->$1();
|
||||
my $page = $IN->param('page') || $IN->param('do');
|
||||
my $opt = Links::Payment::load_cat_price($IN->param('cat_id'));
|
||||
if ($opt->{payment_mode} == NOT_ACCEPTED) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAYMENTERR_NOTACCEPTED') });
|
||||
return;
|
||||
}
|
||||
my $link = $DB->table('Links')->get($IN->param('link_id'));
|
||||
print $IN->header();
|
||||
if (not $link or $link->{LinkOwner} ne $USER->{Username}) {
|
||||
print Links::SiteHTML::display('error', { error => !$link ? $GT::SQL::ERRORS : Links::language('PAYMENTERR_NOTOWNER') });
|
||||
return;
|
||||
}
|
||||
$link = Links::SiteHTML::tags('link', $link);
|
||||
|
||||
$link->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$link->{ID}");
|
||||
print Links::SiteHTML::display($page, { %$vars, %$opt, %$link });
|
||||
}
|
||||
else {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => "Invalid action" });
|
||||
}
|
||||
}
|
||||
# Otherwise, modify the link
|
||||
else {
|
||||
my $results = $PLG->dispatch('user_modify_link', \&modify_link, {});
|
||||
if (defined $results->{error}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('modify', $results);
|
||||
}
|
||||
else {
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_MODIFY_SUCCESS'), "$CFG->{db_cgi_url}/modify.cgi");
|
||||
if ($CFG->{payment}->{enabled}) {
|
||||
require Links::Payment;
|
||||
my @cid = $IN->param('CatLinks.CategoryID');
|
||||
my $opt = Links::Payment::load_cat_price(\@cid);
|
||||
print $IN->header();
|
||||
if (exists $opt->{error}) {
|
||||
print Links::SiteHTML::display('error', $opt);
|
||||
}
|
||||
elsif ($opt->{payment_mode} == NOT_ACCEPTED or ($results->{ExpiryDate} >= time)) {
|
||||
print Links::SiteHTML::display('modify_success', $results);
|
||||
}
|
||||
else {# display payment form if the link is expired or payment mode for this category is required or optional
|
||||
$results->{link_id} = $results->{ID}; # we need a different tag since both Category and Link have ID
|
||||
$opt->{CategoryID} = delete $opt->{ID}; # remove category id
|
||||
$opt->{CategoryDescription} = delete $opt->{Description};
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_PAYMENT'), "$CFG->{db_cgi_url}/modify.cgi?do=payment_linked;process_payment=1;modify=1;ID=$results->{link_id}");
|
||||
print Links::SiteHTML::display('payment', {%$results,%$opt});
|
||||
}
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('modify_success', $results);
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub _modify_passed_in {
|
||||
# --------------------------------------------------------
|
||||
# Display link that was passed in.
|
||||
#
|
||||
my $lid = $IN->param('LinkID');
|
||||
my $link_db = $DB->table('Links');
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi?LinkID=$lid");
|
||||
my $sth = $link_db->select({ ID => $lid, LinkOwner => $USER->{Username} }, VIEWABLE);
|
||||
if ($sth->rows) {
|
||||
my $link = $sth->fetchrow_hashref;
|
||||
my @ids = $DB->table('CatLinks')->select('CategoryID', { LinkID => $link->{ID} })->fetchall_list;
|
||||
$IN->param('CatLinks.CategoryID', \@ids);
|
||||
|
||||
$link->{Contact_Name} ||= $USER->{Name} || $USER->{Username};
|
||||
$link->{Contact_Email} ||= $USER->{Email};
|
||||
|
||||
my $category = {};
|
||||
if ($CFG->{db_gen_category_list} < 2) {
|
||||
require Links::Tools;
|
||||
$category = Links::Tools::category_list();
|
||||
$category->{Category} = sub { Links::Tools::category_list_html() };
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('modify', {
|
||||
main_title_loop => $mtl,
|
||||
%$link,
|
||||
%$category
|
||||
});
|
||||
}
|
||||
elsif (!$CFG->{user_required}) {
|
||||
_modify_form();
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOTOWNER'), LinkID => $lid, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub _list_owned_links {
|
||||
# --------------------------------------------------------
|
||||
# Display a list of links the user owns.
|
||||
#
|
||||
my $link_db = $DB->table('Links');
|
||||
my ($limit, $offset, $nh) = Links::limit_offset();
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi");
|
||||
$link_db->select_options("ORDER BY Title ASC", "LIMIT $limit OFFSET $offset");
|
||||
my $sth = $link_db->select({
|
||||
LinkOwner => $USER->{Username},
|
||||
# If payment is enabled, we want to show non-validated links to allow
|
||||
# payment to occur, otherwise only show validated ones
|
||||
($CFG->{payment}->{enabled} ? () : (isValidated => 'Yes'))
|
||||
});
|
||||
my $total = $link_db->hits;
|
||||
if (! $sth->rows) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('MODIFY_NOLINKS'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
my ($toolbar, %paging);
|
||||
my @links;
|
||||
while (my $hash = $sth->fetchrow_hashref) {
|
||||
push @links, Links::SiteHTML::tags('link', $hash);
|
||||
}
|
||||
if ($total > $limit) {
|
||||
my $url = $CFG->{db_cgi_url} . "/" . $IN->url;
|
||||
$toolbar = $DB->html(['Links'], $IN)->toolbar($nh, $limit, $total, $url);
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $total,
|
||||
max_hits => $limit,
|
||||
current_page => $nh
|
||||
);
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('modify_select', {
|
||||
link_results_loop => \@links,
|
||||
main_title_loop => $mtl,
|
||||
total => $total,
|
||||
next => $toolbar,
|
||||
paging => \%paging
|
||||
});
|
||||
}
|
||||
|
||||
sub _modify_form {
|
||||
# --------------------------------------------------------
|
||||
# Just display the regular form.
|
||||
#
|
||||
my @id = $IN->param('ID'); # Category ID.
|
||||
my $link = {};
|
||||
print $IN->header();
|
||||
if ($IN->param('LinkID')) {
|
||||
my $lid = $IN->param('LinkID');
|
||||
$link = $DB->table('Links')->select({ ID => $lid }, VIEWABLE)->fetchrow_hashref;
|
||||
if (!$link) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('MODIFY_INVALIDLINKID', $lid) });
|
||||
return;
|
||||
}
|
||||
if (!@id) {
|
||||
@id = $DB->table('CatLinks')->select('CategoryID', { LinkID => $lid })->fetchall_list;
|
||||
# Set ID to the categories that the link is in so Links::Tools::category_list
|
||||
# pre-selects them
|
||||
$IN->param(ID => \@id);
|
||||
}
|
||||
}
|
||||
|
||||
if (!@id and !$CFG->{db_gen_category_list}) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('MODIFY_SELCAT') });
|
||||
}
|
||||
else {
|
||||
my $category = {};
|
||||
if ($CFG->{db_gen_category_list} < 2) {
|
||||
require Links::Tools;
|
||||
$category = Links::Tools::category_list();
|
||||
$category->{Category} = sub { Links::Tools::category_list_html() };
|
||||
}
|
||||
print Links::SiteHTML::display('modify', {
|
||||
main_title_loop => Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi" . (@id ? "?ID=" . join(';ID=', @id) : '')),
|
||||
%$category,
|
||||
%$link
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
sub modify_link {
|
||||
# --------------------------------------------------------
|
||||
# Change the requested link.
|
||||
#
|
||||
my $args = $IN->get_hash();
|
||||
my $db = $DB->table('Links');
|
||||
my %cols = $db->cols;
|
||||
|
||||
# Make it possible to use any column to find the link we're modifying.
|
||||
# Normally, we use the LinkID to find the link, but in some conditions the URL
|
||||
# is used. Using this isn't recommended as you're not guaranteed to get the
|
||||
# same or unique results.
|
||||
my ($column, $value);
|
||||
foreach my $col (keys %cols) {
|
||||
if (exists $args->{'Current_' . $col} and $args->{'Current_' . $col}) {
|
||||
$column = $col;
|
||||
$value = $args->{'Current_' . $col};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
my $lid = $args->{LinkID};
|
||||
my %ret;
|
||||
if ($CFG->{db_gen_category_list} < 2) {
|
||||
require Links::Tools;
|
||||
%ret = %{Links::Tools::category_list()};
|
||||
$ret{Category} = sub { Links::Tools::category_list_html() };
|
||||
}
|
||||
$ret{main_title_loop} = Links::Build::build('title', Links::language('LINKS_MODIFY'), "$CFG->{db_cgi_url}/modify.cgi" . ($lid ? "?LinkID=$lid" : ''));
|
||||
$ret{LinkID} = $lid;
|
||||
unless ($value or ($lid and $USER)) {
|
||||
return { error => Links::language('MODIFY_NOURL'), %ret };
|
||||
}
|
||||
|
||||
# Find the requested link
|
||||
my ($link, $sth);
|
||||
if ($USER and $lid) {
|
||||
#if ($CFG->{user_required}) {
|
||||
# Mod added back on April 10 by Virginia
|
||||
if ($CFG->{user_required} and $USER->{Status} ne 'Administrator') { # mod by Virginia Lo on Oct 29, 2007
|
||||
$sth = $db->select({ ID => $lid, LinkOwner => $USER->{Username} });
|
||||
}
|
||||
else {
|
||||
$sth = $db->select({ ID => $lid });
|
||||
}
|
||||
$sth->rows or return { error => Links::language('MODIFY_INVALIDLINKID', $lid), %ret };
|
||||
}
|
||||
else {
|
||||
$sth = $db->select({ $column => $value });
|
||||
$sth->rows or return { error => Links::language('MODIFY_BADURL', $value), %ret };
|
||||
}
|
||||
$link = $sth->fetchrow_hashref;
|
||||
|
||||
# Make sure to only allow modifications to validated links. We currently allow
|
||||
# the user to modify expired links.
|
||||
unless ($link->{isValidated} eq 'Yes') {
|
||||
return { error => Links::language('MODIFY_NOLINKS'), %ret };
|
||||
}
|
||||
|
||||
my $new = {%$args};
|
||||
|
||||
# Forced system fields (these aren't in the add_system_fields option)
|
||||
my @system = qw/ID LinkOwner Add_Date Mod_Date Timestmp Date_Checked ExpiryDate ExpiryCounted ExpiryNotify LinkExpired/;
|
||||
my %system = map { $_ => 1 } @system;
|
||||
|
||||
for my $key (keys %cols) {
|
||||
# Users can't modify system fields, so remove them so the columns don't get
|
||||
# modified
|
||||
if (exists $system{$key} or exists $CFG->{add_system_fields}->{$key}) {
|
||||
delete $new->{$key};
|
||||
next;
|
||||
}
|
||||
|
||||
# Use the original link value if it hasn't been passed in from cgi. This is
|
||||
# done to make sure all Links columns pass the column checks (not null, regex,
|
||||
# etc checks). It has to be done for all columns, since column definitions may
|
||||
# have changed since the record was originally inserted.
|
||||
$new->{$key} = $link->{$key} unless defined $args->{$key};
|
||||
}
|
||||
|
||||
# Check that the ExpiryDate is valid for the categories the link is in
|
||||
if ($CFG->{payment}->{enabled}) {
|
||||
require Links::Payment;
|
||||
my $expiry = Links::Payment::check_expiry_date($link);
|
||||
$new->{ExpiryDate} = $expiry if $expiry;
|
||||
}
|
||||
|
||||
# modify() needs the primary key to perform the update
|
||||
$new->{ID} = $link->{ID};
|
||||
|
||||
Links::init_date();
|
||||
$new->{Mod_Date} = GT::Date::date_get();
|
||||
|
||||
# Backwards compatibility
|
||||
$new->{Contact_Name} = $args->{Contact_Name} || $args->{'Contact Name'} || ($USER ? $USER->{Name} : '');
|
||||
$new->{Contact_Email} = $args->{Contact_Email} || $args->{'Contact Email'} || ($USER ? $USER->{Email} : '');
|
||||
|
||||
# Setup the language for GT::SQL
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL');
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL');
|
||||
local $Links::Table::Links::ERRORS->{NOCATEGORY} = Links::language('MODIFY_NOCATEGORY');
|
||||
$Links::Table::Links::ERRORS if 0; # silence -w
|
||||
|
||||
# On error, file column values need to be restored (since they need to get
|
||||
# re-uploaded). This is done so that the templates show the correct fields on
|
||||
# an error.
|
||||
my %fcols = $db->_file_cols();
|
||||
for (keys %fcols) {
|
||||
$ret{$_} = $link->{$_};
|
||||
}
|
||||
|
||||
# Because we store the change request in the Changes table and do not perform
|
||||
# the modify directly, all the column checks that modify() would normally do
|
||||
# need to be done now.
|
||||
my $fset;
|
||||
unless ($USER and $CFG->{user_direct_mod}) {
|
||||
if (keys %fcols) {
|
||||
require GT::SQL::File;
|
||||
my $file = GT::SQL::File->new({ parent_table => $DB->table('Links'), connect => $DB->{connect} });
|
||||
$fset = $file->pre_file_actions(\%fcols, $new, $args, $new->{ID}) or return { error => $GT::SQL::error, %ret };
|
||||
}
|
||||
|
||||
# The following block of code modifies $new (so that _check_update() works
|
||||
# properly), but we don't want that later on, so make a shallow copy of it.
|
||||
my $new_copy = { %$new };
|
||||
|
||||
# This block of code is pulled from GT::SQL::Table::modify (minus the comments)
|
||||
my $cols = $db->{schema}->{cols};
|
||||
for my $col (keys %$cols) {
|
||||
next unless exists $new_copy->{$col};
|
||||
|
||||
if ($cols->{$col}->{type} eq 'TIMESTAMP') {
|
||||
delete $new_copy->{$col};
|
||||
}
|
||||
elsif ($cols->{$col}->{type} =~ /^(?:.*INT|INTEGER|FLOAT|REAL|DOUBLE|DECIMAL|DATE|TIME|DATETIME)$/ and defined $new_copy->{$col} and $new_copy->{$col} eq '') {
|
||||
$new_copy->{$col} = undef;
|
||||
}
|
||||
elsif ($cols->{$col}->{not_null} and not (defined $new_copy->{$col} and length $new_copy->{$col})) {
|
||||
$new_copy->{$col} = undef;
|
||||
}
|
||||
}
|
||||
|
||||
$db->_check_update($new_copy, { ID => $new_copy->{ID} }) or return { error => $GT::SQL::error, %ret };
|
||||
}
|
||||
|
||||
# Make sure the category id's are valid
|
||||
$IN->param('CatLinks.CategoryID')
|
||||
or return { error => Links::language('MODIFY_NOCATEGORY'), %ret };
|
||||
|
||||
# Set the Category ID's
|
||||
my @c_ids = $IN->param('CatLinks.CategoryID');
|
||||
$new->{'CatLinks.CategoryID'} = $db->clean_category_ids(\@c_ids)
|
||||
or return { error => $GT::SQL::error, %ret };
|
||||
|
||||
# Check if the link is valid
|
||||
if ($CFG->{user_link_validation}) {
|
||||
require Links::Tools;
|
||||
my $status = Links::Tools::link_status($new->{URL});
|
||||
if ($status and $Links::Tools::STATUS_BAD{$status}) {
|
||||
return { error => Links::language('MODIFY_BADSTATUS', $Links::Tools::STATUS_BAD{$status}), %ret };
|
||||
}
|
||||
}
|
||||
|
||||
my $orig_cats = $db->get_categories($new->{ID});
|
||||
my $new_cats;
|
||||
|
||||
# Add the link either directly in, or into the change request table.
|
||||
if ($USER and $CFG->{user_direct_mod}) {
|
||||
if ($USER->{Status} ne 'Administrator' and $link->{LinkOwner} ne $USER->{Username}) {
|
||||
return { error => Links::language('MODIFY_NOTOWNER'), %ret };
|
||||
}
|
||||
|
||||
my $res = $db->modify($new) or return { error => $GT::SQL::error, %ret };
|
||||
$new_cats = $db->get_categories($new->{ID});
|
||||
}
|
||||
else {
|
||||
require GT::Dumper;
|
||||
my $chg_db = $DB->table('Changes');
|
||||
|
||||
# Remove any columns which haven't changed
|
||||
for my $key (keys %cols) {
|
||||
next if not exists $new->{$key} or $key eq 'ID';
|
||||
|
||||
delete $new->{$key} if $new->{$key} eq (defined $link->{$key} ? $link->{$key} : '');
|
||||
}
|
||||
|
||||
# Handle updating the expiry date later on (when the admin does the change
|
||||
# validation). It can't be done here because payments can be made to the link
|
||||
# before the change validation occurs, losing the user's updated expiry date.
|
||||
delete $new->{ExpiryDate};
|
||||
|
||||
# pre_file_actions() pulls the file columns out of the $new hash; put them back
|
||||
# in and save the uploaded file(s) in a temporary location for processing upon
|
||||
# change validation.
|
||||
foreach my $col (keys %fcols) {
|
||||
if (exists $fset->{$col}) {
|
||||
my $fh = $fset->{$col};
|
||||
my $fname = GT::CGI->escape(get_filename($fh));
|
||||
my $fpath = "$CFG->{admin_root_path}/tmp/$new->{ID}-$fname";
|
||||
|
||||
open F, ">$fpath";
|
||||
binmode F; binmode $fh;
|
||||
my $buf;
|
||||
while (read $fh, $buf, 4096) { print F $buf; };
|
||||
close F;
|
||||
|
||||
$new->{$col} = $fpath;
|
||||
$new->{"${col}_filename"} = $fset->{"${col}_filename"} || get_filename($fh);
|
||||
}
|
||||
elsif (exists $fset->{"${col}_del"}) {
|
||||
$new->{"${col}_del"} = $fset->{"${col}_del"};
|
||||
}
|
||||
}
|
||||
|
||||
my $count = $chg_db->count({ LinkID => $new->{ID} });
|
||||
if ($count) {
|
||||
my $href = $chg_db->select('ChgRequest', { LinkID => $new->{ID} })->fetchrow;
|
||||
$href = eval $href;
|
||||
foreach (keys %fcols) {
|
||||
my $fpath = $href->{$_} or next;
|
||||
$fpath ne $new->{$_} or next;
|
||||
$fpath !~ /\.\./ or next;
|
||||
$fpath =~ /^[\w\\\/\-\.%]+$/ or next;
|
||||
-e $fpath or next;
|
||||
$fpath =~ m,^\Q$CFG->{admin_root_path}\E/tmp/, or next;
|
||||
unlink $fpath;
|
||||
}
|
||||
$chg_db->update({ LinkID => $new->{ID}, Username => $link->{LinkOwner}, ChgRequest => GT::Dumper->dump({ data => $new, var => '' }) }, { LinkID => $new->{ID} })
|
||||
or return { error => $GT::SQL::error, %ret };
|
||||
}
|
||||
else {
|
||||
$chg_db->insert({ LinkID => $new->{ID}, Username => $link->{LinkOwner}, ChgRequest => GT::Dumper->dump({ data => $new, var => '' }) })
|
||||
or return { error => $GT::SQL::error, %ret };
|
||||
}
|
||||
my $cdb = $DB->table('Category');
|
||||
foreach my $id (@c_ids) {
|
||||
my $cat = $cdb->get($id, 'HASH', ['Full_Name']);
|
||||
$new_cats->{$id} = $cat->{Full_Name};
|
||||
}
|
||||
}
|
||||
|
||||
# Now email the site admin.
|
||||
if ($CFG->{admin_email_mod}) {
|
||||
my %tags;
|
||||
for my $key (keys %$link) {
|
||||
$tags{"Original_" . $key} = $link->{$key};
|
||||
$tags{"New_" . $key} = exists $new->{$key} ? $new->{$key} : $link->{$key};
|
||||
}
|
||||
# Pull in the extra fields that might be in $new (eg. extra file data)
|
||||
for my $key (keys %$new) {
|
||||
next if exists $tags{"New_" . $key};
|
||||
$tags{"New_" . $key} = $new->{$key};
|
||||
}
|
||||
$tags{Original_Category} = join "\n", sort values %$orig_cats;
|
||||
$tags{Original_Category_loop} = [sort values %$orig_cats];
|
||||
$tags{New_Category} = join "\n", sort values %$new_cats;
|
||||
$tags{New_Category_loop} = [sort values %$new_cats];
|
||||
|
||||
$GT::Mail::error ||= '';
|
||||
Links::send_email('link_modified.eml', \%tags, { admin_email => 1 }) or die "Unable to send message: $GT::Mail::error";
|
||||
}
|
||||
$new->{Category} = join("\n", sort values %$new_cats);
|
||||
$new->{Category_loop} = [sort values %$new_cats];
|
||||
|
||||
# All done!
|
||||
return { %$args, %$link, %$new };
|
||||
}
|
||||
|
||||
sub get_filename {
|
||||
# -------------------------------------------------------------------
|
||||
my $fpath = shift;
|
||||
my @path = split /[\\\/]/, $fpath;
|
||||
return pop @path;
|
||||
}
|
||||
|
||||
1;
|
||||
250
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Page.pm
Normal file
250
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Page.pm
Normal file
@@ -0,0 +1,250 @@
|
||||
# ==================================================================
|
||||
# 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: Page.pm,v 1.33 2007/12/19 06:59:12 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::User::Page;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# --------------------------------------------------------------
|
||||
# Wrap in a subroutine to prevent possible mod_perl probs.
|
||||
#
|
||||
$ENV{PATH_INFO} and ($ENV{PATH_INFO} =~ s/.*page\.cgi//);
|
||||
my $page = $IN->param('g') || $ENV{PATH_INFO} || '';
|
||||
|
||||
# We can display a custom template by passing in p=template (the p is for
|
||||
# page).
|
||||
my $custom = $IN->param('p') || '';
|
||||
return generate_custom_page($custom) if $custom;
|
||||
|
||||
# Clean up page a little.
|
||||
$page =~ s|^/+||;
|
||||
$page =~ s|/+$||;
|
||||
|
||||
# Reset the grand total.
|
||||
$Links::Build::GRAND_TOTAL = 0;
|
||||
|
||||
# Figure out what to look for.
|
||||
my ($new_match) = $CFG->{build_new_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
|
||||
my ($cool_match) = $CFG->{build_cool_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
|
||||
my ($rate_match) = $CFG->{build_ratings_url} =~ m{^\Q$CFG->{build_root_url}\E/(.+)};
|
||||
|
||||
# Strip out the index.html/more*.html if it is there.
|
||||
$page =~ s{/*(?:\Q$CFG->{build_home}\E|\Q$CFG->{build_index}\E|\Q$CFG->{build_more}\E\d+\Q$CFG->{build_extension}\E)$}{};
|
||||
|
||||
if ($new_match and $page =~ m{^\Q$new_match\E(?:/|$)}) {
|
||||
$PLG->dispatch('generate_new', \&generate_new_page);
|
||||
}
|
||||
elsif ($cool_match and $page =~ m{^\Q$cool_match\E(?:/|$)}) {
|
||||
$PLG->dispatch('generate_cool', \&generate_cool_page);
|
||||
}
|
||||
elsif ($rate_match and $page =~ m{^\Q$rate_match\E/?$}) {
|
||||
$PLG->dispatch('generate_rate', \&generate_rate_page);
|
||||
}
|
||||
# By default the detailed page format in dynamic mode will be
|
||||
# "<%config.build_detailed_url%>/<%ID%>.<%build_extension%>", but other certain
|
||||
# formats can be used without breaking other URLs.
|
||||
elsif ($page =~ /\d+\Q$CFG->{build_extension}\E$/) {
|
||||
$PLG->dispatch('generate_detailed', \&generate_detailed_page);
|
||||
}
|
||||
elsif ($page !~ /\S/) {
|
||||
$PLG->dispatch('generate_home', \&generate_home_page);
|
||||
}
|
||||
elsif ($page =~ /(\w+\.cgi)/) {
|
||||
print $IN->redirect("$CFG->{db_cgi_url}/$1");
|
||||
}
|
||||
else {
|
||||
$PLG->dispatch('generate_category', \&generate_category_page);
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_custom_page {
|
||||
# --------------------------------------------------------
|
||||
# Displays a custom template.
|
||||
#
|
||||
my $page = shift;
|
||||
if ($CFG->{dynamic_404_status}) {
|
||||
my $template_set = Links::template_set();
|
||||
if (! Links::template_exists($template_set, "$page.html")) {
|
||||
print "Status: 404" . $GT::CGI::EOL;
|
||||
}
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display($page, {});
|
||||
}
|
||||
|
||||
sub generate_home_page {
|
||||
# --------------------------------------------------------
|
||||
# Display the home page.
|
||||
#
|
||||
print $IN->header();
|
||||
print Links::Build::build(home => {});
|
||||
}
|
||||
|
||||
sub generate_category_page {
|
||||
# --------------------------------------------------------
|
||||
# This routine will display a category, first thing we need
|
||||
# to do is figure out what category we've been asked for.
|
||||
#
|
||||
my $page_num = 1;
|
||||
my $page = $IN->param('g') || $ENV{PATH_INFO} || '';
|
||||
$page_num = $1 if $page =~ s{/\Q$CFG->{build_more}\E(\d+)\Q$CFG->{build_extension}\E$}{};
|
||||
$page =~ s/\Q$CFG->{build_index}\E$//;
|
||||
$page =~ s|^/+||;
|
||||
$page =~ s|/+$||;
|
||||
my $like = $page;
|
||||
$page =~ y/_/ /;
|
||||
|
||||
# Now we get the ID number of the category based on the URL.
|
||||
my $cat_db = $DB->table('Category');
|
||||
my $id;
|
||||
if ($CFG->{build_category_dynamic} eq 'ID' or $page =~ /^\d+$/) {
|
||||
($id) = $page =~ /(\d+)$/;
|
||||
# Make sure the ID is valid
|
||||
$id = $cat_db->select(ID => { ID => $id })->fetchrow;
|
||||
}
|
||||
else {
|
||||
$id = $cat_db->select(ID => { ($CFG->{build_category_dynamic} || 'Full_Name') => $page })->fetchrow;
|
||||
}
|
||||
|
||||
if (!$id) {
|
||||
# Oops, we may have had a escaped character '_' that wasn't a space. We need
|
||||
# to look it up manually.
|
||||
$like =~ y/'"//d;
|
||||
$id = $cat_db->select(ID => GT::SQL::Condition->new(($CFG->{build_category_dynamic} || 'Full_Name') => LIKE => $like))->fetchrow;
|
||||
}
|
||||
|
||||
# Check for valid sort order.
|
||||
my %opts;
|
||||
$opts{id} = $id;
|
||||
$opts{nh} = $page_num;
|
||||
$opts{sb} = $IN->param('sb');
|
||||
$opts{so} = $IN->param('so');
|
||||
$opts{cat_sb} = $IN->param('cat_sb');
|
||||
$opts{cat_so} = $IN->param('cat_so');
|
||||
unless ($opts{sb} and exists $DB->table('Links')->cols->{$opts{sb}} and (not $opts{so} or $opts{so} =~ /^(?:desc|asc)$/i)) {
|
||||
delete $opts{sb};
|
||||
delete $opts{so};
|
||||
}
|
||||
unless ($opts{cat_sb} and exists $DB->table('Category')->cols->{$opts{cat_sb}} and (not $opts{cat_so} or $opts{cat_so} =~ /^(?:desc|asc)$/i)) {
|
||||
delete $opts{cat_sb};
|
||||
delete $opts{cat_so};
|
||||
}
|
||||
|
||||
if ($id) {
|
||||
print $IN->header();
|
||||
print Links::Build::build('category', \%opts);
|
||||
}
|
||||
else {
|
||||
print "Status: 404" . $GT::CGI::EOL if $CFG->{dynamic_404_status};
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAGE_INVALIDCAT', $page) });
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_new_page {
|
||||
# --------------------------------------------------------
|
||||
# Creates a "What's New" page. Set build_span_pages to 1 in setup
|
||||
# and it will create a seperate page for each date.
|
||||
#
|
||||
my ($page, $date);
|
||||
|
||||
$page = $IN->param('g') || $ENV{PATH_INFO} || '';
|
||||
if ($page =~ /\Q$CFG->{build_index}\E$/) {
|
||||
$date = '';
|
||||
}
|
||||
else {
|
||||
($date) = $page =~ m{/([^/]+)\Q$CFG->{build_extension}\E$};
|
||||
}
|
||||
|
||||
if ($date) {
|
||||
my $nh = 1;
|
||||
my $lpp = $CFG->{build_links_per_page} || 25;
|
||||
if ($date =~ s/_(\d+)//) {
|
||||
$nh = $1;
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::Build::build('new_subpage', { date => $date, mh => $lpp, nh => $nh });
|
||||
}
|
||||
elsif ($CFG->{build_new_date_span_pages}) {
|
||||
print $IN->header();
|
||||
print Links::Build::build('new_index', {});
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::Build::build('new', {});
|
||||
}
|
||||
}
|
||||
|
||||
sub generate_cool_page {
|
||||
# --------------------------------------------------------
|
||||
# Creates a "What's Cool" page.
|
||||
#
|
||||
my $page = $IN->param('g') || $ENV{PATH_INFO} || '';
|
||||
my $nh = 1;
|
||||
my $mh = $CFG->{build_span_pages} ? $CFG->{build_links_per_page} : 1000;
|
||||
if ($page =~ /\Q$CFG->{build_more}\E(\d+)\Q$CFG->{build_extension}\E$/) {
|
||||
$nh = $1;
|
||||
}
|
||||
print $IN->header();
|
||||
print Links::Build::build('cool', { mh => $mh, nh => $nh });
|
||||
}
|
||||
|
||||
sub generate_rate_page {
|
||||
# --------------------------------------------------------
|
||||
# Creates a Top 10 ratings page.
|
||||
#
|
||||
print $IN->header();
|
||||
print Links::Build::build('rating', {});
|
||||
}
|
||||
|
||||
sub generate_detailed_page {
|
||||
# --------------------------------------------------------
|
||||
# This routine build a single page for every link.
|
||||
#
|
||||
my ($page, $id, $link, $detail_match);
|
||||
|
||||
$page = $IN->param('g') || $ENV{PATH_INFO} || '';
|
||||
($id) = $page =~ /(\d+)\Q$CFG->{build_extension}\E$/;
|
||||
|
||||
# Fetch the category info if the link is in multiple categories and the category
|
||||
# the detailed page was accessed from was passed in. This is done so the next
|
||||
# and previous links are correct.
|
||||
# Note that due to the URL transformation (Links::clean_output), it isn't
|
||||
# possible to pass in the CategoryID unless the detailed url is self generated
|
||||
# (ie. <%detailed_url%> isn't used).
|
||||
if ($id) {
|
||||
my $cat_id = $IN->param('CategoryID');
|
||||
if ($cat_id and $DB->table('CatLinks')->count({ LinkID => $id, CategoryID => $cat_id })) {
|
||||
$link = $DB->table(qw/Links CatLinks Category/)->select({ LinkID => $id, CategoryID => $cat_id })->fetchrow_hashref;
|
||||
}
|
||||
else {
|
||||
$link = $DB->table('Links')->get($id, 'HASH');
|
||||
}
|
||||
}
|
||||
|
||||
if (!$link) {
|
||||
print "Status: 404" . $GT::CGI::EOL if $CFG->{dynamic_404_status};
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('PAGE_INVALIDDETAIL', $page) });
|
||||
return;
|
||||
}
|
||||
|
||||
print $IN->header();
|
||||
print Links::Build::build('detailed', $link);
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,96 @@
|
||||
# ==================================================================
|
||||
# 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: Rate.pm,v 1.20 2007/12/19 06:59:12 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::User::Rate;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# ---------------------------------------------------
|
||||
# Determine what to do.
|
||||
#
|
||||
my $id = $IN->param('ID');
|
||||
|
||||
# Make sure we are allowed to rate it.
|
||||
if ($CFG->{user_rate_required} and not $USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('rate'));
|
||||
return;
|
||||
}
|
||||
|
||||
# Now figure out what to do.
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_RATE'), "$CFG->{db_cgi_url}/rate.cgi");
|
||||
if ($IN->param('rate')) {
|
||||
my $results = $PLG->dispatch('rate_link', \&rate_it, {});
|
||||
$results->{main_title_loop} = $mtl;
|
||||
if (defined $results->{error}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('rate', $results);
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('rate_success', $results);
|
||||
}
|
||||
}
|
||||
elsif (defined $id and ($id =~ /^\d+$/)) {
|
||||
print $IN->header();
|
||||
my $rec = $DB->table('Links')->get($id);
|
||||
unless ($rec) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('RATE_INVALIDID', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$rec->{detailed_url} = $CFG->{build_detail_url} . '/' . $DB->table('Links')->detailed_url($rec->{ID}) if $CFG->{build_detailed};
|
||||
print Links::SiteHTML::display('rate', { %$rec, main_title_loop => $mtl });
|
||||
}
|
||||
else {
|
||||
print $IN->redirect($IN->param('d') ? "$CFG->{db_cgi_url}/page.cgi?d=1" : $CFG->{build_root_url} . "/" . ($CFG->{build_home} || ($CFG->{build_index_include} ? $CFG->{build_index} : '')));
|
||||
}
|
||||
}
|
||||
|
||||
sub rate_it {
|
||||
# --------------------------------------------------------
|
||||
# Give this link a rating.
|
||||
#
|
||||
my $id = $IN->param('ID');
|
||||
my $rating = $IN->param('rate');
|
||||
|
||||
# Let's get the link information.
|
||||
my $links = $DB->table('Links');
|
||||
my $rec = $links->get($id);
|
||||
$rec or return { error => Links::language('RATE_INVALIDID', $id) };
|
||||
|
||||
# Make sure we have a valid rating.
|
||||
unless ($rating =~ /^\d\d?$/ and $rating >= 1 and $rating <= 10) {
|
||||
return { error => Links::language('RATE_INVALIDRATE', $rating), %$rec };
|
||||
}
|
||||
|
||||
# Update the rating unless they have already voted.
|
||||
my $clicktrack = $DB->table('ClickTrack');
|
||||
my $rows = $clicktrack->count({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Rate' });
|
||||
if ($rows) {
|
||||
return { error => Links::language('RATE_VOTED', $id), %$rec };
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
$clicktrack->insert({ LinkID => $id, IP => $ENV{REMOTE_ADDR}, ClickType => 'Rate', Created => \'NOW()' });
|
||||
|
||||
$rec->{Rating} = ($rec->{Rating} * $rec->{Votes} + $rating) / ++$rec->{Votes};
|
||||
$links->update({ Rating => $rec->{Rating}, Votes => $rec->{Votes} }, { ID => $rec->{ID} });
|
||||
};
|
||||
return $rec;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
605
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Review.pm
Normal file
605
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Review.pm
Normal file
@@ -0,0 +1,605 @@
|
||||
# ==================================================================
|
||||
# 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: Review.pm,v 1.78 2007/11/16 07:12:57 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::User::Review;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::Build;
|
||||
use Links::SiteHTML;
|
||||
|
||||
sub handle {
|
||||
# ------------------------------------------------------------------
|
||||
# Determine what to do.
|
||||
#
|
||||
my $input = $IN->get_hash;
|
||||
if ($input->{add_review}) { $PLG->dispatch('review_add', \&add_review) }
|
||||
elsif ($input->{edit_review}) { $PLG->dispatch('review_edit', \&edit_review) }
|
||||
elsif ($input->{helpful}) { $PLG->dispatch('review_helpful', \&helpful_review) }
|
||||
else { $PLG->dispatch('review_search', \&review_search_results) }
|
||||
return;
|
||||
}
|
||||
# ==================================================================
|
||||
|
||||
sub review_search_results {
|
||||
# ------------------------------------------------------------------
|
||||
# Display a list of validated reviews for a link
|
||||
#
|
||||
my $id = shift;
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW'), "$CFG->{db_cgi_url}/review.cgi");
|
||||
|
||||
# Get our form data and prepare some default data.
|
||||
my $args = $IN->get_hash;
|
||||
$id ||= $args->{ID};
|
||||
$args->{username} = '\*' if $args->{username} eq '*';
|
||||
|
||||
# Return error if no action
|
||||
unless ($args->{keyword} or $args->{ReviewID} or $id) {
|
||||
if ($USER) {
|
||||
$args->{username} ||= $USER->{Username};
|
||||
$IN->param(username => $args->{username});
|
||||
}
|
||||
elsif (!$args->{username} and !$args->{helpful}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALID_ACTION'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
# Reset ReviewID to null
|
||||
my $from_helpful = ($args->{helpful}) ? $args->{ReviewID} : '';
|
||||
$args->{ReviewID} = '';
|
||||
|
||||
# Review must be validated to list
|
||||
$args->{Review_Validated} = 'Yes';
|
||||
$args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^(\d+)$/) ? $1 : $CFG->{reviews_per_page};
|
||||
$args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)$/i) ? $1 : $CFG->{review_sort_order};
|
||||
($args->{sb} and ($args->{sb} =~ /^[\w\s,]+$/) or ($args->{sb} = $CFG->{review_sort_by}));
|
||||
delete $args->{ma};
|
||||
|
||||
my $rec = { noLink => 1 };
|
||||
# If we are listing reviews of a link
|
||||
if ($id) {
|
||||
$id and $args->{ID} = $id;
|
||||
|
||||
# Check if ID is valid
|
||||
$rec = $DB->table('Links')->get($args->{ID});
|
||||
$rec or do {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $args->{ID}), main_title_loop => $mtl });
|
||||
return;
|
||||
};
|
||||
$rec = Links::SiteHTML::tags('link', $rec);
|
||||
$args->{Review_LinkID} = $args->{ID};
|
||||
$args->{ww} = 1;
|
||||
}
|
||||
# If we have a user to list
|
||||
elsif ($args->{username}) {
|
||||
$args->{Review_LinkID} = '';
|
||||
$args->{Review_Owner} = $args->{username};
|
||||
$args->{'Review_Owner-opt'} = '=';
|
||||
}
|
||||
elsif ($IN->param('ReviewID')) {
|
||||
$args->{ReviewID} = $IN->param('ReviewID');
|
||||
$args->{'ReviewID-opt'} = '=';
|
||||
}
|
||||
|
||||
my $reviews = $DB->table('Reviews');
|
||||
my $review_sth = $reviews->query_sth($args);
|
||||
my $review_hits = $reviews->hits;
|
||||
|
||||
# Return if no results.
|
||||
unless ($review_hits) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_NORESULTS', $args->{ID} || $args->{username}), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
my @review_results_loop;
|
||||
Links::init_date();
|
||||
my $today = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME);
|
||||
my %review_cache;
|
||||
my $last_review = 0;
|
||||
while (my $review = $review_sth->fetchrow_hashref) {
|
||||
$review->{Review_Count} = $reviews->count({ Review_LinkID => $review->{Review_LinkID}, Review_Validated => 'Yes' });
|
||||
$review->{Review_IsNew} = (GT::Date::date_diff($today, $review->{Review_Date}) < $CFG->{review_days_old});
|
||||
if ($CFG->{review_allow_modify} and $USER->{Username} eq $review->{Review_Owner}) {
|
||||
if ($CFG->{review_modify_timeout}) {
|
||||
my $oldfmt = GT::Date::date_get_format();
|
||||
GT::Date::date_set_format(GT::Date::FORMAT_DATETIME);
|
||||
my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60);
|
||||
my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate};
|
||||
if (GT::Date::date_is_greater($date, $timeout)) {
|
||||
$review->{Review_CanModify} = 1;
|
||||
}
|
||||
GT::Date::date_set_format($oldfmt);
|
||||
}
|
||||
else {
|
||||
$review->{Review_CanModify} = 1;
|
||||
}
|
||||
}
|
||||
if ($review->{Review_ModifyDate} ne $review->{Review_Date} and $review->{Review_ModifyDate} !~ /^0000-00-00 00:00:00/) {
|
||||
$review->{Review_ModifyDate} = GT::Date::date_transform($review->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
}
|
||||
else {
|
||||
delete $review->{Review_ModifyDate};
|
||||
}
|
||||
$review->{Review_Date} = GT::Date::date_transform($review->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
$review->{Num} = $review->{Review_WasHelpful} + $review->{Review_WasNotHelpful};
|
||||
($from_helpful eq $review->{ReviewID}) and $review->{last_helpful} = 1;
|
||||
$CFG->{review_convert_br_tags} and $review->{Review_Contents} = _translate_html($review->{Review_Contents});
|
||||
|
||||
# Add the link info to the review
|
||||
if ($args->{username} or $args->{ReviewID} or $args->{keyword}) {
|
||||
my $catlink = $DB->table('CatLinks', 'Category', 'Links');
|
||||
unless (exists $review_cache{$review->{Review_LinkID}}) {
|
||||
$review_cache{$review->{Review_LinkID}} = $catlink->get({ LinkID => $review->{Review_LinkID} });
|
||||
}
|
||||
if ($last_review != $review->{Review_LinkID}) {
|
||||
my $names = $review_cache{$review->{Review_LinkID}};
|
||||
$review->{LinkID} = $names->{ID};
|
||||
$review->{cat_linked} = sub { Links::Build::build('title_linked', { name => $names->{Full_Name}, complete => 1 }) };
|
||||
$review->{cat_loop} = Links::Build::build('title', $names->{Full_Name});
|
||||
foreach my $key (keys %$names) {
|
||||
next if ($key eq 'ID');
|
||||
exists $review->{$key} or ($review->{$key} = $names->{$key});
|
||||
}
|
||||
}
|
||||
$last_review = $review->{Review_LinkID};
|
||||
}
|
||||
push @review_results_loop, $review;
|
||||
}
|
||||
|
||||
my ($toolbar, %paging);
|
||||
if ($review_hits > $args->{mh}) {
|
||||
my $url = $CFG->{db_cgi_url} . "/" . $IN->url;
|
||||
$url =~ s/([;&?]?)nh=(\d+)/($1 and $1 eq '?') ? '?' : ''/eg;
|
||||
$url =~ s/[;&]helpful=1//eg;
|
||||
$toolbar = $DB->html($reviews, $args)->toolbar($args->{nh} || 1, $args->{mh} || 25, $review_hits, $url);
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $review_hits,
|
||||
max_hits => $args->{mh} || 25,
|
||||
current_page => $args->{nh} || 1
|
||||
);
|
||||
}
|
||||
else {
|
||||
$toolbar = '';
|
||||
}
|
||||
|
||||
# Some statistics for review list
|
||||
my ($review_stats,$review_count);
|
||||
if (!defined $args->{keyword}) {
|
||||
if ($args->{username}) {
|
||||
%$review_stats = map { $_ => $reviews->count({ Review_Owner => $args->{username}, Review_Rating => $_, Review_Validated => 'Yes' }) } (1 .. 5);
|
||||
$review_count = $reviews->count({ Review_Owner => $args->{username}, Review_Validated => 'Yes'} );
|
||||
}
|
||||
else {
|
||||
%$review_stats = map { $_ => $reviews->count({ Review_LinkID => $args->{ID}, Review_Rating => $_, Review_Validated => 'Yes' }) } (1 .. 5);
|
||||
$review_count = $reviews->count({ Review_LinkID => $args->{ID}, Review_Validated => 'Yes'});
|
||||
}
|
||||
if ($review_count) {
|
||||
for (1 .. 5) {
|
||||
$review_stats->{'p' . $_} = $review_stats->{$_} * 150 / $review_count;
|
||||
}
|
||||
}
|
||||
}
|
||||
$review_stats ||= { noStats => 1 };
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('review_search_results', {
|
||||
%$review_stats,
|
||||
%$rec,
|
||||
show_link_info => ($args->{username} or $args->{ReviewID} or $args->{keyword}),
|
||||
main_title_loop => $mtl,
|
||||
Review_Count => $review_hits,
|
||||
Review_Loop => \@review_results_loop,
|
||||
Review_SpeedBar => $toolbar,
|
||||
paging => \%paging
|
||||
});
|
||||
return;
|
||||
}
|
||||
|
||||
sub add_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Add a review (only logged in users can add reviews if required)
|
||||
#
|
||||
my $id = $IN->param('ID') || '';
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW_ADD'), "$CFG->{db_cgi_url}/review.cgi");
|
||||
|
||||
# Check if we have a valid ID
|
||||
my $db = $DB->table('Links');
|
||||
my $rec = $db->get($id);
|
||||
unless ($id =~ /^\d+$/ and $rec) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$rec = Links::SiteHTML::tags('link', $rec);
|
||||
$rec->{anonymous} = !$CFG->{user_review_required};
|
||||
|
||||
# Only logged in users can add reviews (if required) or must redirect to the login page
|
||||
if ($CFG->{user_review_required} and !$USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('review'));
|
||||
return;
|
||||
}
|
||||
|
||||
my ($cat_id, $cat_name) = each %{$db->get_categories($id)};
|
||||
my %title = (
|
||||
title_loop => Links::Build::build('title', "$cat_name/$rec->{Title}"),
|
||||
title => sub { Links::Build::build('title_unlinked', "$cat_name/$rec->{Title}") },
|
||||
title_linked => sub { Links::Build::build('title_linked', "$cat_name/$rec->{Title}") }
|
||||
);
|
||||
|
||||
print $IN->header();
|
||||
# If we have a review to add from a form
|
||||
if ($IN->param('add_this_review')) {
|
||||
my $results = $PLG->dispatch('add_this_review', \&_add_this_review, $rec);
|
||||
|
||||
# If we have error
|
||||
if (defined $results->{error}) {
|
||||
print Links::SiteHTML::display('review_add', { %$results, %$rec, %title, main_title_loop => $mtl });
|
||||
}
|
||||
# Return to add success page
|
||||
else {
|
||||
print Links::SiteHTML::display('review_add_success', { %$results, %$rec, %title, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
else {
|
||||
if ($USER) {
|
||||
my $reviews = $DB->table('Reviews');
|
||||
my $rc = $reviews->count({ Review_LinkID => $id, Review_Owner => $USER->{Username} });
|
||||
# Keep pre 3.2.0 behaviour of allowing the user to edit their existing review
|
||||
if ($rc == 1 and $CFG->{review_max_reviews} == 1) {
|
||||
my $review = $reviews->select({ Review_LinkID => $id, Review_Owner => $USER->{Username} })->fetchrow_hashref;
|
||||
my $oldfmt = GT::Date::date_get_format();
|
||||
GT::Date::date_set_format(GT::Date::FORMAT_DATETIME);
|
||||
my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60);
|
||||
my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate};
|
||||
if (not $CFG->{review_allow_modify} or $review->{Review_Validated} eq 'No' or ($CFG->{review_modify_timeout} and GT::Date::date_is_smaller($date, $timeout))) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}), main_title_loop => $mtl });
|
||||
}
|
||||
else {
|
||||
print Links::SiteHTML::display('review_edit', {
|
||||
%$rec, %title, confirm => 1,
|
||||
main_title_loop => Links::Build::build('title', Links::language('LINKS_REVIEW_EDIT'), "$CFG->{db_cgi_url}/review.cgi")
|
||||
});
|
||||
}
|
||||
GT::Date::date_set_format($oldfmt);
|
||||
return;
|
||||
}
|
||||
elsif ($CFG->{review_max_reviews} and $rc + 1 > $CFG->{review_max_reviews}) {
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
# We are displaying an add review form
|
||||
print Links::SiteHTML::display('review_add', { %$rec, %title, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
|
||||
sub _add_this_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Add this review
|
||||
#
|
||||
|
||||
# Get our form data and some default data.
|
||||
my $rec = shift;
|
||||
my $reviews = $DB->table('Reviews');
|
||||
my $id = $IN->param('ID');
|
||||
my $input = $IN->get_hash;
|
||||
$input->{Review_LinkID} = $id;
|
||||
$input->{Review_Validated} = ($CFG->{review_auto_validate} == 1 and $USER or $CFG->{review_auto_validate} == 2) ? 'Yes' : 'No';
|
||||
$input->{Review_WasHelpful} = 0 ;
|
||||
$input->{Review_WasNotHelpful} = 0 ;
|
||||
$input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none';
|
||||
$input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none';
|
||||
|
||||
# Get the review owner
|
||||
$input->{Review_Owner} = $USER ? $USER->{Username} : 'admin';
|
||||
|
||||
if (not $CFG->{user_review_required} and not $USER) {
|
||||
$input->{Review_GuestName} or return { error => Links::language('REVIEW_GUEST_NAME_REQUIRED') };
|
||||
$input->{Review_GuestEmail} or return { error => Links::language('REVIEW_GUEST_EMAIL_REQUIRED') };
|
||||
}
|
||||
|
||||
# Make sure we have a valid rating.
|
||||
my $cols = $reviews->cols;
|
||||
if (exists $cols->{Review_Rating} and $cols->{Review_Rating}->{not_null} and ($input->{Review_Rating} !~ /^\d$/ or $input->{Review_Rating} < 1 or $input->{Review_Rating} > 5)) {
|
||||
return { error => Links::language('REVIEW_RATING', $input->{Review_Rating}) };
|
||||
}
|
||||
|
||||
# Set date review to today's date.
|
||||
Links::init_date();
|
||||
$input->{Review_Date} = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME);
|
||||
$input->{Review_ModifyDate} = $input->{Review_Date};
|
||||
|
||||
# Check that the number of reviews the user owns is under the limit.
|
||||
if ($USER and $CFG->{review_max_reviews} and
|
||||
$CFG->{review_max_reviews} < $reviews->count({ Review_LinkID => $id, Review_Owner => $USER->{Username} }) + 1) {
|
||||
return { error => Links::language('REVIEW_MAX_REVIEWS', $CFG->{review_max_reviews}) };
|
||||
}
|
||||
|
||||
# Change the language.
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL');
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL');
|
||||
|
||||
# Add the review.
|
||||
# The review will be added only if Review_email_2 is blank
|
||||
my $added_id = $input->{Review_email_2} ? 1 : $reviews->add($input);
|
||||
$input->{ReviewID} = $added_id;
|
||||
unless ($added_id) {
|
||||
my $error = "<ul><li>" . join("</li><li>", $reviews->error) . "</li></ul>";
|
||||
return { error => $error };
|
||||
}
|
||||
|
||||
# Format the date for sending email
|
||||
$input->{Review_Date} = GT::Date::date_transform($input->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
|
||||
# Mail the email.
|
||||
if ($CFG->{admin_email_review_add}) {
|
||||
Links::send_email('review_added.eml', { %{$USER || {}}, %$input, %$rec }, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error";
|
||||
}
|
||||
|
||||
# Review added successfully, return to review_add_success page
|
||||
$CFG->{review_convert_br_tags} and $input->{Review_Contents} = _translate_html($input->{Review_Contents});
|
||||
return $input;
|
||||
}
|
||||
|
||||
sub edit_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Edit a review (only logged in users can edit their reviews)
|
||||
#
|
||||
my $id = $IN->param('ID') || '';
|
||||
my $rid = $IN->param('ReviewID');
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW_EDIT'), "$CFG->{db_cgi_url}/review.cgi");
|
||||
|
||||
if (!$CFG->{review_allow_modify}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MODIFY_DENIED'), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Only logged in users can update their reviews or must redirect to the login page
|
||||
if (!$USER) {
|
||||
print $IN->redirect(Links::redirect_login_url('review'));
|
||||
return;
|
||||
}
|
||||
|
||||
# Check if we have a valid ID
|
||||
my $db = $DB->table('Links');
|
||||
my $rec = $db->get($id);
|
||||
unless (($id =~ /^\d+$/) and $rec) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
$rec = Links::SiteHTML::tags('link', $rec);
|
||||
|
||||
# If a ReviewID isn't passed in and they have more than one review, then just edit the first review
|
||||
my $review = $DB->table('Reviews')->select({ Review_LinkID => $id, Review_Owner => $USER->{Username}, $rid ? (ReviewID => $rid) : () })->fetchrow_hashref;
|
||||
if (!$review) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_NOT_EXISTS', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
elsif ($review->{Review_Validated} eq 'No') {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_ADD_WAIT', $id), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Has the review modify period passed?
|
||||
if ($CFG->{review_modify_timeout}) {
|
||||
my $oldfmt = GT::Date::date_get_format();
|
||||
GT::Date::date_set_format(GT::Date::FORMAT_DATETIME);
|
||||
my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60);
|
||||
my $date = $review->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $review->{Review_Date} : $review->{Review_ModifyDate};
|
||||
my $smaller = GT::Date::date_is_smaller($date, $timeout);
|
||||
GT::Date::date_set_format($oldfmt);
|
||||
if ($smaller) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_MODIFY_TIMEOUT', $CFG->{review_modify_timeout}), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
my ($cat_id, $cat_name) = each %{$db->get_categories($id)};
|
||||
my %title = (
|
||||
title_loop => Links::Build::build('title', "$cat_name/$rec->{Title}"),
|
||||
title => sub { Links::Build::build('title_unlinked', "$cat_name/$rec->{Title}") },
|
||||
title_linked => sub { Links::Build::build('title_linked', "$cat_name/$rec->{Title}") }
|
||||
);
|
||||
|
||||
# If we have a review to update from a form
|
||||
if ($IN->param('update_this_review')) {
|
||||
my $results = $PLG->dispatch('update_this_review', \&_update_this_review, $rec);
|
||||
|
||||
# If we have error
|
||||
if (defined $results->{error}) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('review_edit', { %$results, %$rec, %title, main_title_loop => $mtl });
|
||||
}
|
||||
# Return to edit success page
|
||||
else {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('review_edit_success', { %$results, %$rec, %title, main_title_loop => $mtl });
|
||||
}
|
||||
}
|
||||
# We are displaying an edit review form
|
||||
elsif ($IN->param('confirmed')) {
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('review_edit', { %$rec, %$review, %title, main_title_loop => $mtl });
|
||||
}
|
||||
|
||||
# Else invalid action
|
||||
else {
|
||||
return review_search_results();
|
||||
}
|
||||
}
|
||||
|
||||
sub _update_this_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Edit this review
|
||||
#
|
||||
# Get our link record.
|
||||
my $rec = shift;
|
||||
|
||||
# Get our form data and some default data.
|
||||
my $input = $IN->get_hash;
|
||||
my $reviews = $DB->table('Reviews');
|
||||
my $id = $IN->param('ID');
|
||||
$input->{Review_LinkID} = $id;
|
||||
$input->{Review_Validated} = ($CFG->{review_auto_validate} == 1 and $USER or $CFG->{review_auto_validate} == 2) ? 'Yes' : 'No';
|
||||
$input->{Review_WasHelpful} = 0 ;
|
||||
$input->{Review_WasNotHelpful} = 0 ;
|
||||
$input->{Host} = $ENV{REMOTE_HOST} ? "$ENV{REMOTE_HOST} ($ENV{REMOTE_ADDR})" : $ENV{REMOTE_ADDR} ? $ENV{REMOTE_ADDR} : 'none';
|
||||
$input->{Referer} = $ENV{HTTP_REFERER} ? $ENV{HTTP_REFERER} : 'none';
|
||||
|
||||
# Get the review owner
|
||||
$input->{Review_Owner} = $USER->{Username};
|
||||
|
||||
# Check if this review is valid for this user
|
||||
my $rows = $reviews->get({ Review_LinkID => $id, Review_Owner => $USER->{Username}, Review_Validated => 'Yes' });
|
||||
return { error => Links::language('REVIEW_INVALID_UPDATE') } unless $rows;
|
||||
|
||||
# Make sure we have a valid rating.
|
||||
my $cols = $reviews->cols;
|
||||
if (exists $cols->{Review_Rating} and $cols->{Review_Rating}->{not_null} and ($input->{Review_Rating} !~ /^\d$/ or $input->{Review_Rating} < 1 or $input->{Review_Rating} > 5)) {
|
||||
return { error => Links::language('REVIEW_RATING', $input->{Review_Rating}) };
|
||||
}
|
||||
|
||||
# Has the review modify period passed?
|
||||
if ($CFG->{review_modify_timeout}) {
|
||||
my $oldfmt = GT::Date::date_get_format();
|
||||
GT::Date::date_set_format(GT::Date::FORMAT_DATETIME);
|
||||
my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60);
|
||||
my $date = $rows->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $rows->{Review_Date} : $rows->{Review_ModifyDate};
|
||||
my $smaller = GT::Date::date_is_smaller($date, $timeout);
|
||||
GT::Date::date_set_format($oldfmt);
|
||||
if ($smaller) {
|
||||
return { error => Links::language('REVIEW_MODIFY_TIMEOUT', $CFG->{review_modify_timeout}) };
|
||||
}
|
||||
}
|
||||
|
||||
# Set date review to today's date.
|
||||
Links::init_date();
|
||||
delete $input->{Review_Date};
|
||||
$input->{Review_ModifyDate} = GT::Date::date_get(time, GT::Date::FORMAT_DATETIME);
|
||||
|
||||
# Change the language.
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL');
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL');
|
||||
|
||||
# Update the record.
|
||||
$reviews->modify($input, { ReviewID => $input->{ReviewID} }) or return { error => $GT::SQL::error };
|
||||
|
||||
# Delete the review track from this ReviewID
|
||||
$DB->table('ClickTrack')->delete({ ReviewID => $input->{ReviewID}, ClickType => 'Review' }) or return { error => $GT::SQL::error };
|
||||
|
||||
# Format the date for sending email
|
||||
$input->{Review_Date} = GT::Date::date_transform($input->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
|
||||
# Mail the email.
|
||||
if ($CFG->{admin_email_review_mod}) {
|
||||
my %tags;
|
||||
foreach my $key (keys %$rows) {
|
||||
$tags{"Original_$key"} = $rows->{$key};
|
||||
}
|
||||
foreach my $key (keys %$input) {
|
||||
$tags{"New_$key"} = $input->{$key};
|
||||
}
|
||||
|
||||
Links::send_email('review_modified.eml', { %$USER, %tags, %$rec }, { admin_email => 1 }) or die "Unable to send mail: $GT::Mail::error";
|
||||
}
|
||||
|
||||
# Review added successfully, return to review_add_success page
|
||||
$CFG->{review_convert_br_tags} and $input->{Review_Contents} = _translate_html($input->{Review_Contents});
|
||||
return $input;
|
||||
|
||||
}
|
||||
|
||||
sub helpful_review {
|
||||
# ------------------------------------------------------------------
|
||||
# Review was helpful or not
|
||||
#
|
||||
my $reviewID = $IN->param('ReviewID');
|
||||
|
||||
my $mtl = Links::Build::build('title', Links::language('LINKS_REVIEW'), "$CFG->{db_cgi_url}/review.cgi");
|
||||
|
||||
# Get our Reviews db object
|
||||
my $db = $DB->table('Reviews');
|
||||
my $rec = $db->get($reviewID);
|
||||
|
||||
if (!$rec) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_INVALIDID', $rec->{Review_Subject}), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
|
||||
# Update the rating unless they have already voted.
|
||||
my $click_db = $DB->table('ClickTrack');
|
||||
my $rows = $click_db->count({ ReviewID => $rec->{ReviewID}, IP => $ENV{REMOTE_ADDR}, ClickType => 'Review' });
|
||||
if ($rows) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => Links::language('REVIEW_VOTED', $rec->{Review_Subject}), main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
else {
|
||||
eval {
|
||||
$click_db->insert({ LinkID => $rec->{Review_LinkID}, ReviewID => $rec->{ReviewID}, IP => $ENV{REMOTE_ADDR}, ClickType => 'Review', Created => \"NOW()" });
|
||||
# Update the Timestmp for the link so that the detailed page gets rebuilt with build changed
|
||||
$DB->table('Links')->update({ Timestmp => \'NOW()' }, { ID => $rec->{Review_LinkID} });
|
||||
};
|
||||
}
|
||||
|
||||
# Change the language.
|
||||
local $GT::SQL::ERRORS->{ILLEGALVAL} = Links::language('ADD_ILLEGALVAL');
|
||||
local $GT::SQL::ERRORS->{UNIQUE} = Links::language('ADD_UNIQUE');
|
||||
local $GT::SQL::ERRORS->{NOTNULL} = Links::language('ADD_NOTNULL');
|
||||
|
||||
# If this review was helpful
|
||||
if ($IN->param('yes')) {
|
||||
if (!$db->update({ Review_WasHelpful => $rec->{Review_WasHelpful} + 1 }, { ReviewID => $reviewID })) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => $db->error, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
else {
|
||||
if (!$db->update({ Review_WasNotHelpful => $rec->{Review_WasNotHelpful} + 1 }, { ReviewID => $reviewID })) {
|
||||
print $IN->header;
|
||||
print Links::SiteHTML::display('error', { error => $db->error, main_title_loop => $mtl });
|
||||
return;
|
||||
}
|
||||
}
|
||||
return review_search_results();
|
||||
}
|
||||
|
||||
sub _translate_html {
|
||||
# -------------------------------------------------------------------
|
||||
# Translate contents to html format
|
||||
#
|
||||
my $html = shift;
|
||||
$html = GT::CGI::html_escape($html);
|
||||
$html =~ s,\r?\n,<br />,g;
|
||||
return $html;
|
||||
}
|
||||
|
||||
1;
|
||||
359
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Search.pm
Normal file
359
site/slowtwitch.com/cgi-bin/articles/admin/Links/User/Search.pm
Normal file
@@ -0,0 +1,359 @@
|
||||
# ==================================================================
|
||||
# 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: Search.pm,v 1.48 2006/08/08 23:30:09 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::User::Search;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
use Links::SiteHTML;
|
||||
use Links::Build;
|
||||
|
||||
my $time_hires;
|
||||
|
||||
sub handle {
|
||||
#--------------------------------------------------------------------------------
|
||||
# Determine whether we are displaying the search form, or doing a
|
||||
# search.
|
||||
#
|
||||
my $db = $DB->table('Links');
|
||||
my $results = {};
|
||||
my $args = $IN->get_hash;
|
||||
|
||||
# Remove search fields we aren't allowed to search on.
|
||||
my @bad = (@{$CFG->{search_blocked}}, qw/isValidated ExpiryDate/);
|
||||
for my $col (@bad) {
|
||||
$col =~ s/^\s*|\s*$//g;
|
||||
if ($args->{$col}) {
|
||||
delete $args->{$col};
|
||||
$IN->delete($col);
|
||||
}
|
||||
for (qw(lt gt opt le ge ne)) {
|
||||
delete $args->{"$col-$_"};
|
||||
$IN->delete("$col-$_");
|
||||
}
|
||||
}
|
||||
|
||||
# If query is set we know we are searching.
|
||||
return search() if defined $args->{query} and $args->{query} =~ /\S/;
|
||||
|
||||
# Otherwise, if we pass in a field name, we can search on that too.
|
||||
foreach (keys %{$db->cols}) {
|
||||
for my $opt ('', qw/-lt -gt -le -ge -ne/) {
|
||||
return search() if defined $args->{"$_$opt"} and length $args->{"$_$opt"};
|
||||
}
|
||||
}
|
||||
|
||||
print $IN->header();
|
||||
print Links::SiteHTML::display('search', { main_title_loop => Links::Build::build('title', Links::language('LINKS_SEARCH'), "$CFG->{db_cgi_url}/search.cgi") });
|
||||
}
|
||||
|
||||
sub search {
|
||||
# ------------------------------------------------------------------
|
||||
# Do the search and print out the results.
|
||||
#
|
||||
my $results = $PLG->dispatch('search_results', \&query, {});
|
||||
if (defined $results->{error}) {
|
||||
print $IN->header();
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_SEARCH'), "$CFG->{db_cgi_url}/search.cgi");
|
||||
print Links::SiteHTML::display('search', $results);
|
||||
}
|
||||
else {
|
||||
print $IN->header();
|
||||
$results->{main_title_loop} = Links::Build::build('title', Links::language('LINKS_SEARCH_RESULTS'), "$CFG->{db_cgi_url}/search.cgi");
|
||||
print Links::SiteHTML::display('search_results', $results);
|
||||
}
|
||||
if ($CFG->{debug_level} > 1) {
|
||||
print "<blockquote><pre>", GT::SQL->query_stack_disp , "</pre></blockquote>";
|
||||
}
|
||||
}
|
||||
|
||||
sub query {
|
||||
# ------------------------------------------------------------------
|
||||
# Query the database.
|
||||
#
|
||||
# First get our search options.
|
||||
my $args = $IN->get_hash;
|
||||
if ($args->{query}) {
|
||||
$args->{query} =~ s/^\s+//;
|
||||
$args->{query} =~ s/\s+$//;
|
||||
}
|
||||
$args->{bool} = (defined $args->{bool} and $args->{bool} =~ /^(and|or)$/i) ? uc $1 : $CFG->{search_bool};
|
||||
$args->{nh} = (defined $args->{nh} and $args->{nh} =~ /^(\d+)$/) ? $1 : 1;
|
||||
$args->{mh} = (defined $args->{mh} and $args->{mh} =~ /^\d+$/) ? $args->{mh} : $CFG->{search_maxhits};
|
||||
$args->{mh} = 200 if $args->{mh} > 200; # Safety limit
|
||||
$args->{substring} = defined $args->{substring} ? $args->{substring} : $CFG->{search_substring};
|
||||
$args->{so} = (defined $args->{so} and $args->{so} =~ /^(asc|desc)$/i) ? $1 : '';
|
||||
$args->{sb} and ($args->{sb} =~ /^[\w\s,]+$/ or ($args->{sb} = ''));
|
||||
delete $args->{ma};
|
||||
|
||||
# Make sure we only search on validated links.
|
||||
$args->{isValidated} = 'Yes';
|
||||
$args->{ExpiryDate} = '>=' . time if $CFG->{payment}->{enabled};
|
||||
|
||||
my $query = $args->{query} || '';
|
||||
my $term = $IN->escape($query);
|
||||
|
||||
my $links = $DB->table('Links');
|
||||
my $categories = $DB->table('Category');
|
||||
|
||||
# We don't do a category search if we only have a filters.
|
||||
my $filter = 0;
|
||||
if (!defined $query or $query eq '') {
|
||||
$filter = 1;
|
||||
}
|
||||
$args->{filter} = $filter;
|
||||
|
||||
# Note: if you use this or the search_set_link_callback, remember to $PLG->action(STOP) or your callback won't be used
|
||||
$args->{callback} = $PLG->dispatch('search_set_cat_callback', sub { return \&_cat_search_subcat if shift }, $args->{catid});
|
||||
my $orig_sb = $args->{sb};
|
||||
my $orig_so = $args->{so};
|
||||
$args->{sb} = $CFG->{build_sort_order_search_cat};
|
||||
$args->{so} = '';
|
||||
$filter and $args->{sb} =~ s/\s*,?\s*score//;
|
||||
|
||||
my $started;
|
||||
if (length $query and $CFG->{search_logging} and $args->{nh} == 1) {
|
||||
if (!defined $time_hires) {
|
||||
$time_hires = eval { require Time::HiRes } || 0;
|
||||
}
|
||||
$started = $time_hires ? Time::HiRes::time() : time;
|
||||
}
|
||||
|
||||
my $cat_sth;
|
||||
$cat_sth = $categories->query_sth($args) unless $filter;
|
||||
my $cat_count = $filter ? 0 : $categories->hits();
|
||||
|
||||
$args->{callback} = $PLG->dispatch('search_set_link_callback', sub { return \&_search_subcat if shift }, $args->{catid});
|
||||
$args->{sb} = $orig_sb ? $orig_sb : $CFG->{build_sort_order_search} || '';
|
||||
$args->{so} = (defined $orig_so and $orig_so =~ /^(asc|desc)$/i) ? $1 : 'ASC';
|
||||
$filter and $args->{sb} =~ s/\s*,?\s*score//;
|
||||
|
||||
# Don't force sorting by whether or not a link is paid, as that would make
|
||||
# searching almost useless w.r.t. unpaid links since a 1% paid match would be
|
||||
# higher than a 99% unpaid match.
|
||||
|
||||
my $link_sth = $links->query_sth($args);
|
||||
my $link_count = $links->hits;
|
||||
|
||||
# Log the search if it's a new query
|
||||
if (length $query and $CFG->{search_logging} and $args->{nh} == 1) {
|
||||
my $elapsed = ($time_hires ? Time::HiRes::time() : time) - $started;
|
||||
my $results = $link_count || 0;
|
||||
my $sl = $DB->table('SearchLogs');
|
||||
my $q = lc $query;
|
||||
substr($q, 255) = '' if length $q > 255;
|
||||
if (my $row = $sl->select({ slog_query => $q })->fetchrow_hashref) {
|
||||
my $slog_time = defined $row->{slog_time}
|
||||
? ($row->{slog_time} * $row->{slog_count} + $elapsed) / ($row->{slog_count} + 1)
|
||||
: $elapsed;
|
||||
$sl->update({
|
||||
slog_count => $row->{slog_count} + 1,
|
||||
slog_time => sprintf('%.6f', $slog_time),
|
||||
slog_last => time,
|
||||
slog_hits => $results
|
||||
}, {
|
||||
slog_query => $q
|
||||
});
|
||||
}
|
||||
else {
|
||||
$sl->insert({
|
||||
slog_query => $q,
|
||||
slog_count => 1,
|
||||
slog_time => sprintf('%.6f', $elapsed),
|
||||
slog_last => time,
|
||||
slog_hits => $results
|
||||
}) or die "$GT::SQL::error";
|
||||
}
|
||||
}
|
||||
|
||||
# Return if no results.
|
||||
unless ($link_count or $cat_count) {
|
||||
return { error => Links::language('SEARCH_NOLINKS', $term), term => $term };
|
||||
}
|
||||
|
||||
# Now format the category results.
|
||||
my $count = 0;
|
||||
my ($category_results, @category_results_loop);
|
||||
if (!$filter and $cat_count) {
|
||||
while (my $cat = $cat_sth->fetchrow_hashref) {
|
||||
last if ($count++ > $args->{mh});
|
||||
my $title = Links::Build::build('title_linked', { name => $cat->{Full_Name}, complete => 1, home => 0 });
|
||||
$category_results .= "<li>$title\n";
|
||||
$cat->{title_linked} = $title;
|
||||
$cat->{title_loop} = Links::Build::build('title', $cat->{Full_Name});
|
||||
push @category_results_loop, $cat;
|
||||
}
|
||||
}
|
||||
|
||||
# And format the link results.
|
||||
my (@link_results_loop, $link_results, %link_output);
|
||||
if ($link_count) {
|
||||
my $results = $link_sth->fetchall_hashref;
|
||||
$links->add_reviews($results);
|
||||
@link_results_loop = map Links::SiteHTML::tags('link', $_) => @$results unless $CFG->{build_search_gb};
|
||||
if ($CFG->{build_search_gb}) {
|
||||
my @ids = map { $_->{ID} } @$results;
|
||||
my $catlink = $DB->table('CatLinks','Category');
|
||||
my %names = $catlink->select('LinkID', 'Full_Name', { LinkID => \@ids })->fetchall_list;
|
||||
foreach my $link (@$results) {
|
||||
push @{$link_output{$names{$link->{ID}}}}, Links::SiteHTML::tags('link', $link);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
# Join the link results by category if we are grouping.
|
||||
if ($CFG->{build_search_gb}) {
|
||||
foreach my $cat (sort keys %link_output) {
|
||||
$link_output{$cat}->[0]->{title_linked} = sub { Links::Build::build('title_linked', { name => $cat, complete => 1, home => 0 }) };
|
||||
$link_output{$cat}->[0]->{title_loop} = Links::Build::build('title', $cat);
|
||||
push @link_results_loop, @{$link_output{$cat}};
|
||||
}
|
||||
}
|
||||
$link_results = sub {
|
||||
my $links;
|
||||
$CFG->{build_search_gb} or return join("", map { Links::SiteHTML::display('link', $_) } @link_results_loop);
|
||||
foreach my $cat (sort keys %link_output) {
|
||||
my $title = Links::Build::build('title_linked', { name => $cat, complete => 1, home => 0 });
|
||||
$links .= "<p>$title" . join("", map { Links::SiteHTML::display('link', $_) } @{$link_output{$cat}});
|
||||
}
|
||||
return $links;
|
||||
};
|
||||
|
||||
# Generate a toolbar if requested.
|
||||
my ($toolbar, %paging);
|
||||
if ($link_count > $args->{mh} or $cat_count > $args->{mh}) {
|
||||
my $url = $CFG->{db_cgi_url} . "/" . $IN->url;
|
||||
$url =~ s/([;&?]?)nh=(\d+)/($1 and $1 eq '?') ? '?' : ''/eg;
|
||||
$toolbar = Links::Build::build(search_toolbar => {
|
||||
url => $url,
|
||||
numlinks => $link_count > $cat_count ? $link_count : $cat_count,
|
||||
nh => $args->{nh},
|
||||
mh => $args->{mh}
|
||||
});
|
||||
%paging = (
|
||||
url => $url,
|
||||
num_hits => $link_count > $cat_count ? $link_count : $cat_count,
|
||||
max_hits => $args->{mh},
|
||||
current_page => $args->{nh}
|
||||
);
|
||||
}
|
||||
else {
|
||||
$toolbar = '';
|
||||
}
|
||||
|
||||
# Print the output.
|
||||
my $results = {
|
||||
link_results => $link_results,
|
||||
link_results_loop => \@link_results_loop,
|
||||
category_results => $category_results,
|
||||
category_results_loop => \@category_results_loop,
|
||||
link_hits => $link_count,
|
||||
cat_hits => $cat_count,
|
||||
next => $toolbar,
|
||||
paging => \%paging,
|
||||
term => $term,
|
||||
highlight => $CFG->{search_highlighting}
|
||||
};
|
||||
return $results;
|
||||
}
|
||||
|
||||
sub _search_subcat {
|
||||
# -------------------------------------------------------------------
|
||||
# First argument is the query/table object, second argument is the current
|
||||
# result set (note: can be quite large). Must return a new result set.
|
||||
#
|
||||
my ($query, $results) = @_;
|
||||
return $results unless (keys %$results); # No matches.
|
||||
|
||||
my $cat_db = $DB->table('Category');
|
||||
my $catlink_db = $DB->table('CatLinks', 'Category');
|
||||
|
||||
# We need the full name of the category.
|
||||
my @cat_ids = $IN->param('catid') or return $results;
|
||||
my (@children, %seen);
|
||||
foreach my $id (@cat_ids) {
|
||||
next if ($id !~ /^\d+$/);
|
||||
my $child = $cat_db->children($id) or next;
|
||||
push @children, @$child, $id;
|
||||
}
|
||||
@children or return $results;
|
||||
@children = grep !$seen{$_}++, @children;
|
||||
|
||||
# Now do the joined query.
|
||||
my %filtered = map { $_ => $results->{$_} }
|
||||
$catlink_db->select(LinkID => { CategoryID => \@children, LinkID => [keys %$results] })->fetchall_list;
|
||||
|
||||
return \%filtered;
|
||||
}
|
||||
|
||||
sub _search_subcat_and {
|
||||
# -------------------------------------------------------------------
|
||||
# Search subcategories using AND.
|
||||
#
|
||||
my ($query, $results) = @_;
|
||||
return $results unless (keys %$results); # No matches
|
||||
|
||||
my $cat_db = $DB->table('Category');
|
||||
my $catlink_db = $DB->table('CatLinks', 'Category');
|
||||
|
||||
# We need the full name of the category.
|
||||
my @cat_ids = $IN->param('catid') or return $results;
|
||||
my %final = %$results;
|
||||
foreach my $id (@cat_ids) {
|
||||
next unless ($id =~ /^\d+$/);
|
||||
my @children;
|
||||
my $childs = $cat_db->children($id);
|
||||
push @children, @$childs, $id;
|
||||
my $cond = GT::SQL::Condition->new(
|
||||
CategoryID => 'IN' => \@children,
|
||||
LinkID => 'IN' => [ keys %final ]
|
||||
);
|
||||
%final = ();
|
||||
my $sth = $catlink_db->select($cond, ['LinkID']);
|
||||
while (my $link_id = $sth->fetchrow_array) {
|
||||
$final{$link_id} = $results->{$link_id};
|
||||
}
|
||||
last unless keys %final;
|
||||
}
|
||||
return \%final;
|
||||
}
|
||||
|
||||
sub _cat_search_subcat {
|
||||
# -------------------------------------------------------------------
|
||||
# First argument is the query/table object, second argument is the current
|
||||
# result set (note: can be quite large). Must return a new result set.
|
||||
#
|
||||
my ($query, $results) = @_;
|
||||
return $results unless (keys %$results); # No matches.
|
||||
|
||||
my $cat_db = $DB->table('Category');
|
||||
my @cat_ids = $IN->param('catid') or return $results;
|
||||
my (@children, %seen);
|
||||
foreach my $id (@cat_ids) {
|
||||
next if ($id !~ /^\d+$/);
|
||||
my $child = $cat_db->children($id) or next;
|
||||
push @children, @$child, $id;
|
||||
}
|
||||
@children or return $results;
|
||||
@children = grep { ! $seen{$_}++ } @children;
|
||||
|
||||
my %subcats = map { $_ => 1 } @children;
|
||||
my $filtered = {};
|
||||
while (my ($k, $s) = each %$results) {
|
||||
$filtered->{$k} = $s if (exists $subcats{$k});
|
||||
}
|
||||
return $filtered;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
@@ -0,0 +1,119 @@
|
||||
# ==================================================================
|
||||
# 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: Treecats.pm,v 1.3 2006/09/12 06:07:12 brewt Exp $
|
||||
#
|
||||
# Copyright (c) 2006 Gossamer Threads Inc. All Rights Reserved.
|
||||
# Redistribution in part or in whole strictly prohibited. Please
|
||||
# see LICENSE file for full details.
|
||||
# ==================================================================
|
||||
|
||||
package Links::User::Treecats;
|
||||
# ==================================================================
|
||||
use strict;
|
||||
use Links qw/:objects/;
|
||||
|
||||
sub handle {
|
||||
# Fetch these categories (and select them)
|
||||
my @cid = $IN->param('cid');
|
||||
# Fetch these links (and select them)
|
||||
my @lid = $IN->param('lid');
|
||||
# Fetch these categories
|
||||
my @id = $IN->param('id');
|
||||
# Fetch links as well as Categories
|
||||
my $fetchlinks = $IN->param('links');
|
||||
|
||||
my $category = $DB->table('Category');
|
||||
my $catlinks = $DB->table('CatLinks', 'Links');
|
||||
|
||||
# Fetching selected categories
|
||||
if (@cid) {
|
||||
@lid = ();
|
||||
@id = @cid;
|
||||
$fetchlinks = 0;
|
||||
}
|
||||
# Fetching selected links
|
||||
elsif (@lid) {
|
||||
# Get all the categories that the links are in
|
||||
@id = $catlinks->select('CategoryID', { LinkID => \@lid }, VIEWABLE)->fetchall_list;
|
||||
$fetchlinks = 1;
|
||||
}
|
||||
# Fetching categories/links
|
||||
else {
|
||||
@cid = ();
|
||||
@lid = ();
|
||||
@id = (0) unless @id;
|
||||
}
|
||||
|
||||
my %vars;
|
||||
# Only allow the use of treecats.cgi if db_gen_category_list == 2 or if
|
||||
# treecats_enabled (hidden config option) is true
|
||||
if ($CFG->{db_gen_category_list} != 2 and not $CFG->{treecats_enabled}) {
|
||||
$vars{error} = 'Permission denied - treecats is currently disabled.';
|
||||
}
|
||||
else {
|
||||
my @fetchlinks;
|
||||
my $cond;
|
||||
if (@cid or @lid) {
|
||||
my $parents = $category->parents(\@id);
|
||||
my @ids;
|
||||
my @fids = (0);
|
||||
for (keys %$parents) {
|
||||
# Fetch all the parents and their children
|
||||
push @ids, @{$parents->{$_}};
|
||||
push @fids, @{$parents->{$_}};
|
||||
# Fetch the category itself
|
||||
push @ids, $_;
|
||||
# When pre-selecting links, @id contains the category the link(s) are in. To
|
||||
# completely draw the tree, the children of those categories need to be
|
||||
# retreived as well.
|
||||
if (@lid) {
|
||||
push @fids, $_;
|
||||
push @fetchlinks, $_;
|
||||
}
|
||||
push @fetchlinks, @{$parents->{$_}};
|
||||
}
|
||||
$cond = GT::SQL::Condition->new(ID => IN => \@ids, FatherID => IN => \@fids);
|
||||
$cond->bool('OR');
|
||||
}
|
||||
else {
|
||||
push @fetchlinks, @id;
|
||||
$cond = GT::SQL::Condition->new(FatherID => IN => \@id);
|
||||
}
|
||||
$category->select_options("ORDER BY Full_Name");
|
||||
$vars{categories} = $category->select($cond)->fetchall_hashref;
|
||||
|
||||
# Find the children counts of all the categories and check if they should be selected or not
|
||||
my @cats;
|
||||
for (@{$vars{categories}}) {
|
||||
push @cats, $_->{ID};
|
||||
}
|
||||
$category->select_options("GROUP BY FatherID");
|
||||
my %children = $category->select('FatherID', 'COUNT(*)', { FatherID => \@cats })->fetchall_list;
|
||||
my %selected = map { $_ => 1 } @cid;
|
||||
for (@{$vars{categories}}) {
|
||||
$_->{children} = $children{$_->{ID}} || 0;
|
||||
$_->{selected} = $selected{$_->{ID}} || 0;
|
||||
}
|
||||
|
||||
if ($fetchlinks and @fetchlinks) {
|
||||
# Remove CategoryID = 0 (shouldn't normally happen)
|
||||
@fetchlinks = grep $_, @fetchlinks;
|
||||
$catlinks->select_options("ORDER BY CategoryID, Title");
|
||||
$vars{links} = $catlinks->select({ CategoryID => \@fetchlinks }, VIEWABLE)->fetchall_hashref;
|
||||
|
||||
%selected = map { $_ => 1 } @lid;
|
||||
for (@{$vars{links}}) {
|
||||
$_->{selected} = $selected{$_->{ID}} || 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
print $IN->header('text/xml');
|
||||
print Links::user_page('treecats.xml', \%vars);
|
||||
}
|
||||
|
||||
1;
|
||||
585
site/slowtwitch.com/cgi-bin/articles/admin/Links/Utils.pm
Normal file
585
site/slowtwitch.com/cgi-bin/articles/admin/Links/Utils.pm
Normal file
@@ -0,0 +1,585 @@
|
||||
# ==================================================================
|
||||
# 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: Utils.pm,v 1.61 2008/07/15 19:50:11 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::Utils;
|
||||
# ==================================================================
|
||||
# This package contains some builtin functions useful in your templates.
|
||||
#
|
||||
use strict;
|
||||
use Links qw/$IN $DB $CFG $USER/;
|
||||
|
||||
sub is_editor {
|
||||
# -------------------------------------------------------------------
|
||||
# Returns true if the current user is an editor.
|
||||
#
|
||||
return unless $USER and $USER->{Status} ne 'Not Validated';
|
||||
return $DB->table('Editors')->count({ Username => $USER->{Username} });
|
||||
}
|
||||
|
||||
sub load_editors {
|
||||
# -------------------------------------------------------------------
|
||||
# You call this tag by placing <%Links::Utils::load_editors%> in your
|
||||
# category.html template. It will then make available an <%editors%>
|
||||
# tag that you can use in your template. For example:
|
||||
# <%Links::Utils::load_editors%>
|
||||
# <%if editors%>
|
||||
# The following users are editors in this category: <%editors%>
|
||||
# <%endif%>
|
||||
#
|
||||
my $vars = GT::Template->vars;
|
||||
my $cat_id = $vars->{category_id} or return "No category_id tag found! This tag can only be used on category.html template";
|
||||
my $cat_db = $DB->table('Category');
|
||||
my @parents = @{$cat_db->parents($cat_id)};
|
||||
push @parents, $cat_id;
|
||||
|
||||
my $ed_db = $DB->table('Editors', 'Users');
|
||||
my $sth = $ed_db->select(GT::SQL::Condition->new('CategoryID', 'IN', \@parents));
|
||||
return {} unless ($sth->rows);
|
||||
|
||||
# Make any formatting changes you need here.
|
||||
my $output = '<ul>';
|
||||
my @editors;
|
||||
my %seen;
|
||||
while (my $user = $sth->fetchrow_hashref) {
|
||||
next if ($seen{$user->{Username}}++);
|
||||
$output .= qq|<li>$user->{Username}</li>|;
|
||||
push @editors, $user;
|
||||
}
|
||||
$output .= "</ul>";
|
||||
return { editors => $output, editors_loop => \@editors };
|
||||
}
|
||||
|
||||
sub load_user {
|
||||
# -------------------------------------------------------------------
|
||||
# You call this tag in your link.html or detailed.html template. It will
|
||||
# provide all the information about the user who owns the link, and also
|
||||
# create a Contact_Name and Contact_Email tag for backwards compatibility.
|
||||
# So you would put:
|
||||
# <%Links::Utils::load_user%>
|
||||
# This link is owned by <%Username%>, whose email is <%Email%>
|
||||
# and password is <%Password%>. They are a <%Status%> user.
|
||||
#
|
||||
my $vars = GT::Template->vars;
|
||||
my $username = $vars->{LinkOwner} or return "No LinkOwner tag found! This tag can only be used on link.html or detailed.html templates.";
|
||||
require Links::Authenticate;
|
||||
my $user_r = Links::Authenticate->auth('get_user', { Username => $username } );
|
||||
return $user_r;
|
||||
}
|
||||
|
||||
sub load_reviews {
|
||||
# -------------------------------------------------------------------
|
||||
# You call this tag in link.html or detailed.html template. It will
|
||||
# load all the reviews associated with this link.
|
||||
# So you would put:
|
||||
# <%Links::Utils::load_reviews($ID, $max_reviews)%>
|
||||
# This link has <%Review_Total%> reviews.
|
||||
# <%loop Reviews_Loop%><%Review_Subject%> - <%Review_ByLine%><%endloop%>
|
||||
# Review_Count is a deprecated backwards compatible variable
|
||||
#
|
||||
my ($id, $max) = @_;
|
||||
unless ($id) {
|
||||
my $vars = GT::Template->vars;
|
||||
$id = $vars->{ID};
|
||||
}
|
||||
my $reviews = $DB->table('Reviews');
|
||||
if ($CFG->{review_sort_by}) {
|
||||
my $order = $CFG->{review_sort_order} || 'DESC';
|
||||
$reviews->select_options("ORDER BY $CFG->{review_sort_by} $order");
|
||||
}
|
||||
if ($max and $max =~ /^\d+$/) {
|
||||
$reviews->select_options("LIMIT $max");
|
||||
}
|
||||
my $review_total = $reviews->count({ Review_LinkID => $id, Review_Validated => 'Yes' });
|
||||
my $sth = $reviews->select({ Review_LinkID => $id, Review_Validated => 'Yes' });
|
||||
my @reviews;
|
||||
Links::init_date();
|
||||
require Links::User::Review;
|
||||
my $today = GT::Date::date_get();
|
||||
while (my $rev = $sth->fetchrow_hashref) {
|
||||
$rev->{Review_IsNew} = (GT::Date::date_diff($today, $rev->{Review_Date}) < $CFG->{review_days_old});
|
||||
$rev->{Review_CanModify} = 0;
|
||||
if ($CFG->{review_allow_modify} and $USER->{Username} eq $rev->{Review_Owner}) {
|
||||
if ($CFG->{review_modify_timeout}) {
|
||||
my $oldfmt = GT::Date::date_get_format();
|
||||
GT::Date::date_set_format(GT::Date::FORMAT_DATETIME);
|
||||
my $timeout = GT::Date::date_get(time - $CFG->{review_modify_timeout} * 60);
|
||||
my $date = $rev->{Review_ModifyDate} =~ /^0000-00-00 00:00:00/ ? $rev->{Review_Date} : $rev->{Review_ModifyDate};
|
||||
if (GT::Date::date_is_greater($date, $timeout)) {
|
||||
$rev->{Review_CanModify} = 1;
|
||||
}
|
||||
GT::Date::date_set_format($oldfmt);
|
||||
}
|
||||
else {
|
||||
$rev->{Review_CanModify} = 1;
|
||||
}
|
||||
}
|
||||
if ($rev->{Review_ModifyDate} ne $rev->{Review_Date} and $rev->{Review_ModifyDate} !~ /^0000-00-00 00:00:00/) {
|
||||
$rev->{Review_ModifyDate} = GT::Date::date_transform($rev->{Review_ModifyDate}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
}
|
||||
else {
|
||||
delete $rev->{Review_ModifyDate};
|
||||
}
|
||||
$rev->{Review_Date} = GT::Date::date_transform($rev->{Review_Date}, GT::Date::FORMAT_DATETIME, $CFG->{date_review_format});
|
||||
$rev->{Num} = $rev->{Review_WasHelpful} + $rev->{Review_WasNotHelpful};
|
||||
$CFG->{review_convert_br_tags} and $rev->{Review_Contents} = Links::User::Review::_translate_html($rev->{Review_Contents});
|
||||
push @reviews, $rev;
|
||||
}
|
||||
|
||||
return { Review_Total => $review_total, Review_Count => scalar @reviews, Review_Loop => \@reviews };
|
||||
}
|
||||
|
||||
sub load_link {
|
||||
# -------------------------------------------------------------------
|
||||
# This will return a fully formatted link. Deprecated in favour of
|
||||
# using load_link_info() + <%include link.html%>
|
||||
#
|
||||
my %vars = %{GT::Template->vars};
|
||||
if ($Links::GLOBALS) {
|
||||
delete @vars{keys %$Links::GLOBALS};
|
||||
}
|
||||
return Links::SiteHTML::display('link', \%vars);
|
||||
}
|
||||
|
||||
sub load_link_info {
|
||||
# -------------------------------------------------------------------
|
||||
# This will return the vars needed to display a fully formatted link (i.e. by
|
||||
# including link.html)
|
||||
#
|
||||
return Links::SiteHTML::tags(link => GT::Template->vars);
|
||||
}
|
||||
|
||||
sub paging {
|
||||
# -------------------------------------------------------------------
|
||||
# Generate the html needed for a paging toolbar
|
||||
#
|
||||
# The paging hash (retrieved from vars) should contain:
|
||||
# url
|
||||
# page
|
||||
# Only one of url or page should be included.
|
||||
# url is used when the generated url will be <%url%>;nh=<%page_number%>
|
||||
# page is used when the generated url will be <%build_root_url%>/<%page%>...
|
||||
# page_format
|
||||
# 1: <%build_root_url%>/<%page%>{index,more<%current_page%>}.html
|
||||
# Used in category, cool, new pages
|
||||
# 2: <%build_root_url%>/<%page%>{,_<%current_page%>}.html
|
||||
# Used in new page
|
||||
# num_hits
|
||||
# max_hits
|
||||
# current_page
|
||||
#
|
||||
# Options:
|
||||
# max_pages
|
||||
# The maximum number of pages to display (excluding boundary pages)
|
||||
# boundary_pages
|
||||
# When there are more pages than max_pages, this number of boundary
|
||||
# pages are added to the paging toolbar
|
||||
# style
|
||||
# 1: |< < [1 of 20] > >|
|
||||
# 2: [1 of 20] < >
|
||||
# 3: |< < 1 2 3 4 5 6 7 8 9 ... 20 > >|
|
||||
# style_next
|
||||
# style_prev
|
||||
# style_first
|
||||
# style_last
|
||||
# style_nonext
|
||||
# style_noprev
|
||||
# style_nofirst
|
||||
# style_nolast
|
||||
# These options allow you to change what's shown for the next/prev/etc
|
||||
# actions
|
||||
# lang_of
|
||||
# For styles 1 and 2, they use the format of "<page> <lang_of> <page>".
|
||||
# This option allows you to change the english text of "of".
|
||||
# lang_button
|
||||
# For styles 1 and 2, a "Go" button is used for users which do not have
|
||||
# javascript support. This option allows you to change the button's
|
||||
# label.
|
||||
# button_id
|
||||
# If you've got two paging toolbars on a page, then you will need to
|
||||
# change the button_id so that the javascript can remove the button.
|
||||
# paging_pre
|
||||
# paging_post
|
||||
# This text or html is added before and after the paging html.
|
||||
#
|
||||
# There are two ways of setting the above options:
|
||||
# 1) Pass them in as arguments
|
||||
# 2) Create a global code ref named 'paging_options' and return the options
|
||||
# as a hash reference
|
||||
# Options passed as arguments override all options passed in via other methods,
|
||||
# followed by the global options and lastly the defaults contained in this
|
||||
# function.
|
||||
#
|
||||
# Note 1: You can override this function by creating a paging_override global
|
||||
# Note 2: The arguments to paging_override are slightly different. To keep
|
||||
# duplicated code to a minimum, %paging with the paging calculations done
|
||||
# is passed as the first argument (it also contains a few helper code
|
||||
# refs), and the second argument contains the options with defaults set.
|
||||
# The left over arguments are the passed in options (shouldn't be needed
|
||||
# since they have been merged into the options already).
|
||||
#
|
||||
my $vars = GT::Template->vars;
|
||||
|
||||
return unless ref $vars->{paging} eq 'HASH';
|
||||
my %paging = %{$vars->{paging}};
|
||||
return if not $paging{num_hits} or $paging{num_hits} < $paging{max_hits};
|
||||
|
||||
%paging = (
|
||||
page_format => 1,
|
||||
current_page => 1,
|
||||
form_hidden => '',
|
||||
%paging
|
||||
);
|
||||
|
||||
# Setup the default options
|
||||
my %paging_options;
|
||||
%paging_options = %{$vars->{paging_options}->()} if ref $vars->{paging_options} eq 'CODE';
|
||||
my %options = (
|
||||
max_pages => 10,
|
||||
boundary_pages => 1,
|
||||
style => 1,
|
||||
style_next => '<img src="' . image_url('paging-next.gif') . '" alt=">" title="Next Page" />',
|
||||
style_prev => '<img src="' . image_url('paging-prev.gif') . '" alt="<" title="Previous Page" />',
|
||||
style_first => '<img src="' . image_url('paging-first.gif') . '" alt="|<" title="First Page" />',
|
||||
style_last => '<img src="' . image_url('paging-last.gif') . '" alt=">|" title="Last Page" />',
|
||||
style_nonext => '<img src="' . image_url('paging-nonext.gif') . '" alt="" />',
|
||||
style_noprev => '<img src="' . image_url('paging-noprev.gif') . '" alt="" />',
|
||||
style_nofirst => '<img src="' . image_url('paging-nofirst.gif') . '" alt="" />',
|
||||
style_nolast => '<img src="' . image_url('paging-nolast.gif') . '" alt="" />',
|
||||
lang_of => 'of',
|
||||
lang_button => 'Go',
|
||||
button_id => 'paging_button',
|
||||
paging_pre => '',
|
||||
paging_post => '',
|
||||
%paging_options,
|
||||
@_
|
||||
);
|
||||
|
||||
# Make all the page calculations
|
||||
$paging{num_pages} = int($paging{num_hits} / $paging{max_hits});
|
||||
$paging{num_pages}++ if $paging{num_hits} % $paging{max_hits};
|
||||
my ($start, $end);
|
||||
if ($paging{num_pages} <= $options{max_pages}) {
|
||||
$start = 1;
|
||||
$end = $paging{num_pages};
|
||||
}
|
||||
elsif ($paging{current_page} >= $paging{num_pages} - $options{max_pages} / 2) {
|
||||
$end = $paging{num_pages};
|
||||
$start = $end - $options{max_pages} + 1;
|
||||
}
|
||||
elsif ($paging{current_page} <= $options{max_pages} / 2) {
|
||||
$start = 1;
|
||||
$end = $options{max_pages};
|
||||
}
|
||||
else {
|
||||
$start = $paging{current_page} - int($options{max_pages} / 2) + 1;
|
||||
$start-- if $options{max_pages} % 2;
|
||||
$end = $paging{current_page} + int($options{max_pages} / 2);
|
||||
}
|
||||
|
||||
my ($left_boundary, $right_boundary);
|
||||
if ($end >= $paging{num_pages} - $options{boundary_pages} - 1) {
|
||||
$end = $paging{num_pages};
|
||||
}
|
||||
else {
|
||||
$right_boundary = 1;
|
||||
}
|
||||
|
||||
if ($start <= $options{boundary_pages} + 2) {
|
||||
$start = 1;
|
||||
}
|
||||
else {
|
||||
$left_boundary = 1;
|
||||
}
|
||||
|
||||
my @pages;
|
||||
push @pages, 1 .. $options{boundary_pages}, '...' if $left_boundary;
|
||||
push @pages, $start .. $end;
|
||||
push @pages, '...', $paging{num_pages} - $options{boundary_pages} + 1 .. $paging{num_pages} if $right_boundary;
|
||||
$paging{pages} = \@pages;
|
||||
|
||||
$paging{create_link} = sub {
|
||||
my ($page, $disp) = @_;
|
||||
my $ret = '';
|
||||
$ret .= qq|<a href="|;
|
||||
|
||||
if ($paging{url}) {
|
||||
(my $url = $paging{url}) =~ s/([;&?]?)nh=(\d+)/($1 and $1 eq '?') ? '?' : ''/eg;
|
||||
$ret .= $url;
|
||||
$ret .= index($url, '?') != -1 ? ';' : '?';
|
||||
$ret .= "nh=$page";
|
||||
}
|
||||
else {
|
||||
$ret .= "$CFG->{build_root_url}/$paging{page}";
|
||||
if ($paging{page_format} == 1) {
|
||||
$ret .= $page == 1 ? ($CFG->{build_index_include} ? $CFG->{build_index} : '') : "$CFG->{build_more}$page$CFG->{build_extension}";
|
||||
}
|
||||
elsif ($paging{page_format} == 2) {
|
||||
$ret .= "_$page" if $page > 1;
|
||||
$ret .= $CFG->{build_extension};
|
||||
}
|
||||
}
|
||||
$ret .= qq|">$disp</a>|;
|
||||
return $ret;
|
||||
};
|
||||
|
||||
$paging{select_value} = sub {
|
||||
my $page = shift;
|
||||
if ($paging{url}) {
|
||||
return $page;
|
||||
}
|
||||
else {
|
||||
my $ret = $paging{page};
|
||||
if ($paging{page_format} == 1) {
|
||||
$ret .= $page == 1 ? ($CFG->{build_index_include} ? $CFG->{build_index} : '') : "$CFG->{build_more}$page$CFG->{build_extension}";
|
||||
}
|
||||
elsif ($paging{page_format} == 2) {
|
||||
$ret .= "_$page" if $page > 1;
|
||||
$ret .= $CFG->{build_extension};
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
};
|
||||
|
||||
if ($paging{url}) {
|
||||
# Figure out what needs to be submitted with the form (it *should* have ? in it
|
||||
# since with these queries, it *will* have other arguments)
|
||||
($paging{form_action}, my $args) = $paging{url} =~ /^(.*?)\?(.*)$/;
|
||||
NV: for (split /[;&]/, $args) {
|
||||
my ($name, $val) = /([^=]+)=(.*)/ or next;
|
||||
$name = $IN->unescape($name);
|
||||
$val = $IN->unescape($val);
|
||||
|
||||
# Skip these since Links::clean_output will put them in automatically
|
||||
for (@{$CFG->{dynamic_preserve}}, 'nh') {
|
||||
next NV if $name eq $_;
|
||||
}
|
||||
$paging{form_hidden} .= qq|<input type="hidden" name="| . $IN->html_escape($name) . qq|" value="| . $IN->html_escape($val) . qq|" />|;
|
||||
}
|
||||
$paging{select_name} = 'nh';
|
||||
}
|
||||
else {
|
||||
$paging{form_action} = "$CFG->{db_cgi_url}/page.cgi";
|
||||
$paging{select_name} = 'g';
|
||||
}
|
||||
|
||||
# Override this function. Pass in the updated %paging and %options hashes so
|
||||
# the calculations don't have to be duplicated in the override.
|
||||
if (ref $vars->{paging_override} eq 'CODE') {
|
||||
return $vars->{paging_override}->(\%paging, \%options, @_);
|
||||
}
|
||||
|
||||
my $html;
|
||||
if ($options{style} == 1) {
|
||||
# |< < [1 of 20] > >|
|
||||
$html .= qq|<form action="$paging{form_action}">$paging{form_hidden}$options{paging_pre}|;
|
||||
if ($paging{current_page} != 1) {
|
||||
$html .= $paging{create_link}->(1, $options{style_first}) . ' ' . $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' ';
|
||||
}
|
||||
else {
|
||||
$html .= "$options{style_nofirst} $options{style_noprev} ";
|
||||
}
|
||||
|
||||
$html .= qq|<select name="$paging{select_name}" onchange="if (this.options[this.selectedIndex].innerHTML != '...' && !this.options[this.selectedIndex].defaultSelected) |;
|
||||
$html .= $IN->param('d') || $paging{url} ? qq|this.form.submit()| : qq|window.location = '$CFG->{build_root_url}/' + this.value|;
|
||||
$html .= qq|">|;
|
||||
for (@{$paging{pages}}) {
|
||||
if ($_ eq '...') {
|
||||
$html .= qq|<option value="" disabled="disabled">...</option>|;
|
||||
}
|
||||
else {
|
||||
$html .= qq|<option value="| . $paging{select_value}->($_) . '"';
|
||||
$html .= qq| selected="selected"| if $_ == $paging{current_page};
|
||||
$html .= qq|>$_ $options{lang_of} $paging{num_pages}</option>|;
|
||||
}
|
||||
}
|
||||
$html .= qq|</select><noscript><input type="submit" id="$options{button_id}" value="$options{lang_button}" class="submit" /></noscript> |;
|
||||
|
||||
if ($paging{current_page} != $paging{num_pages}) {
|
||||
$html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next}) . ' ' . $paging{create_link}->($paging{num_pages}, $options{style_last});
|
||||
}
|
||||
else {
|
||||
$html .= "$options{style_nonext} $options{style_nolast}";
|
||||
}
|
||||
$html .= qq|$options{paging_post}</form>|;
|
||||
}
|
||||
elsif ($options{style} == 2) {
|
||||
# [1 of 20] < >
|
||||
$html .= qq|<form action="$paging{form_action}">$paging{form_hidden}$options{paging_pre}<select name="$paging{select_name}" onchange="if (this.options[this.selectedIndex].innerHTML != '...' && !this.options[this.selectedIndex].defaultSelected) |;
|
||||
$html .= $IN->param('d') || $paging{url} ? qq|this.form.submit()| : qq|window.location = '$CFG->{build_root_url}/' + this.value|;
|
||||
$html .= qq|">|;
|
||||
for (@{$paging{pages}}) {
|
||||
if ($_ eq '...') {
|
||||
$html .= qq|<option value="" disabled="disabled">...</option>|;
|
||||
}
|
||||
else {
|
||||
$html .= qq|<option value="| . $paging{select_value}->($_) . '"';
|
||||
$html .= qq| selected="selected"| if $_ == $paging{current_page};
|
||||
$html .= qq|>$_ $options{lang_of} $paging{num_pages}</option>|;
|
||||
}
|
||||
}
|
||||
$html .= qq|</select><noscript><input type="submit" id="$options{button_id}" value="$options{lang_button}" class="submit" /></noscript> |;
|
||||
|
||||
if ($paging{current_page} != 1) {
|
||||
$html .= $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' ';
|
||||
}
|
||||
else {
|
||||
$html .= "$options{style_noprev} ";
|
||||
}
|
||||
|
||||
if ($paging{current_page} != $paging{num_pages}) {
|
||||
$html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next});
|
||||
}
|
||||
else {
|
||||
$html .= $options{style_nonext};
|
||||
}
|
||||
$html .= qq|$options{paging_post}</form>|;
|
||||
}
|
||||
elsif ($options{style} == 3) {
|
||||
# |< < 1 2 3 4 5 6 7 8 9 ... 20 > >|
|
||||
$html .= $options{paging_pre};
|
||||
if ($paging{current_page} != 1) {
|
||||
$html .= $paging{create_link}->(1, $options{style_first}) . ' ' . $paging{create_link}->($paging{current_page} - 1, $options{style_prev}) . ' ';
|
||||
}
|
||||
else {
|
||||
$html .= "$options{style_nofirst} $options{style_noprev} ";
|
||||
}
|
||||
|
||||
for (@{$paging{pages}}) {
|
||||
if ($_ eq '...') {
|
||||
$html .= "$_ ";
|
||||
}
|
||||
elsif ($_ == $paging{current_page}) {
|
||||
$html .= "<span>$_</span> ";
|
||||
}
|
||||
else {
|
||||
$html .= $paging{create_link}->($_, $_) . ' ';
|
||||
}
|
||||
}
|
||||
|
||||
if ($paging{current_page} != $paging{num_pages}) {
|
||||
$html .= $paging{create_link}->($paging{current_page} + 1, $options{style_next}) . ' ' . $paging{create_link}->($paging{num_pages}, $options{style_last});
|
||||
}
|
||||
else {
|
||||
$html .= "$options{style_nonext} $options{style_nolast}";
|
||||
}
|
||||
$html .= $options{paging_post};
|
||||
}
|
||||
|
||||
return \$html;
|
||||
}
|
||||
|
||||
sub format_title {
|
||||
# -------------------------------------------------------------------
|
||||
# Format a title
|
||||
#
|
||||
# Options:
|
||||
# separator (required)
|
||||
# The separator used to join the items.
|
||||
# no_escape_separator
|
||||
# Set this to a true value if you do not wish to HTML escape the separator.
|
||||
# include_home
|
||||
# Whether or not to include Home as the first entry. Default is no.
|
||||
# include_last
|
||||
# Whether or not to include the last entry. Default is yes.
|
||||
# link_type
|
||||
# How the items should be linked:
|
||||
# 0: No items linked
|
||||
# 1: All items linked separately
|
||||
# 2: All except the last item linked separately
|
||||
# 3: All items linked as one single link (using the last item's URL)
|
||||
# no_span
|
||||
# Don't add the span tags around the last portion of the title. Default is to include the span tags.
|
||||
#
|
||||
# Note: You can override this function by creating a format_title_override global
|
||||
#
|
||||
my ($title_loop, %options) = @_;
|
||||
return unless ref $title_loop eq 'ARRAY';
|
||||
|
||||
my $vars = GT::Template->vars;
|
||||
if (exists $vars->{format_title_override}) {
|
||||
return $vars->{format_title_override}->(@_);
|
||||
}
|
||||
|
||||
if (!exists $options{include_last}) {
|
||||
$options{include_last} = 1;
|
||||
}
|
||||
|
||||
if (!$options{include_last}) {
|
||||
pop @$title_loop;
|
||||
}
|
||||
|
||||
my $ret;
|
||||
$options{separator} = GT::CGI::html_escape($options{separator}) unless $options{no_escape_separator};
|
||||
for (0 .. $#$title_loop) {
|
||||
next unless $_ or $options{include_home};
|
||||
$ret .= '<span class="lasttitle">' if $_ == $#$title_loop and not $options{no_span} and $options{include_last};
|
||||
if ($options{link_type} == 1 or
|
||||
($options{link_type} == 2 and $_ != $#$title_loop)) {
|
||||
$ret .= qq|<a href="| . $IN->html_escape($title_loop->[$_]->{URL}) . qq|">$title_loop->[$_]->{Name}</a>|;
|
||||
}
|
||||
else {
|
||||
$ret .= $title_loop->[$_]->{Name};
|
||||
}
|
||||
$ret .= $options{separator} unless $_ == $#$title_loop;
|
||||
$ret .= '</span>' if $_ == $#$title_loop and not $options{no_span} and $options{include_last};
|
||||
}
|
||||
if ($options{link_type} == 3) {
|
||||
$ret = qq|<a href="| . $IN->html_escape($title_loop->[-1]->{URL}) . qq|">$ret</a>|;
|
||||
}
|
||||
return \$ret;
|
||||
}
|
||||
|
||||
sub column_split {
|
||||
# -------------------------------------------------------------------
|
||||
# Calculate where the columns should be
|
||||
#
|
||||
my ($items, $columns) = @_;
|
||||
if ($items % $columns > 0) {
|
||||
$items += ($columns - $items % $columns);
|
||||
}
|
||||
return $items / $columns;
|
||||
}
|
||||
|
||||
sub image_url {
|
||||
# -------------------------------------------------------------------
|
||||
# Takes an filename and using the current template set and theme, returns
|
||||
# the url of the image. It first checks if the file exists in the theme's
|
||||
# image directory, checks the template's image directory, and then tries
|
||||
# to check the template inheritance tree for more image directories.
|
||||
#
|
||||
my $image = shift;
|
||||
my ($template, $theme) = Links::template_set();
|
||||
|
||||
if (-e "$CFG->{build_static_path}/$template/images/$theme/$image") {
|
||||
return "$CFG->{build_static_url}/$template/images/$theme/$image";
|
||||
}
|
||||
|
||||
# Grab the inheritance tree of the template set and grab the basename of
|
||||
# each template set path (making an assumption that they won't do anything
|
||||
# crazy with their inheritance).
|
||||
require GT::File::Tools;
|
||||
require GT::Template::Inheritance;
|
||||
my @paths = GT::Template::Inheritance->tree(path => "$CFG->{admin_root_path}/templates/$template", local => 0);
|
||||
for (@paths) {
|
||||
my $tpl = GT::File::Tools::basename($_);
|
||||
next if $tpl eq 'browser';
|
||||
if (-e "$CFG->{build_static_path}/$tpl/images/$image") {
|
||||
return "$CFG->{build_static_url}/$tpl/images/$image";
|
||||
}
|
||||
}
|
||||
|
||||
# The image doesn't exist here, but return it anyway
|
||||
return "$CFG->{build_static_url}/$template/images/$image";
|
||||
}
|
||||
|
||||
1;
|
||||
113
site/slowtwitch.com/cgi-bin/articles/admin/Links/mod_perl.pm
Normal file
113
site/slowtwitch.com/cgi-bin/articles/admin/Links/mod_perl.pm
Normal file
@@ -0,0 +1,113 @@
|
||||
# ==================================================================
|
||||
# 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: mod_perl.pm,v 1.34 2005/03/28 22:58:07 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::mod_perl;
|
||||
# ==================================================================
|
||||
use strict();
|
||||
|
||||
# If under mod_perl, we use Apache::DBI to cache connections.
|
||||
use GT::Base qw/MOD_PERL/;
|
||||
|
||||
BEGIN {
|
||||
require Apache::DBI if MOD_PERL;
|
||||
print STDERR "\nPreloading Gossamer Links modules into mod_perl:\n\t";
|
||||
}
|
||||
|
||||
use Links();
|
||||
BEGIN { print STDERR " ." }
|
||||
use Links::Config();
|
||||
|
||||
# Preload commonly used GT libs.
|
||||
use constants();
|
||||
use GT::Cache();
|
||||
use GT::CGI();
|
||||
use GT::Date();
|
||||
use GT::Lock;
|
||||
BEGIN { print STDERR " ." }
|
||||
use GT::Dumper();
|
||||
use GT::FileMan();
|
||||
use GT::Mail();
|
||||
use GT::Mail::BulkMail();
|
||||
use GT::MD5();
|
||||
use GT::MD5::Crypt();
|
||||
use GT::MIMETypes();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GT::SQL();
|
||||
use GT::SQL::Admin();
|
||||
use GT::SQL::File();
|
||||
use GT::SQL::Relation();
|
||||
use GT::SQL::Search();
|
||||
use GT::SQL::Display::HTML::Table();
|
||||
use GT::SQL::Display::HTML::Relation();
|
||||
use GT::SQL::Search::Base::Common();
|
||||
use GT::SQL::Search::Base::Indexer();
|
||||
use GT::SQL::Search::Base::STH();
|
||||
use GT::SQL::Search::Base::Search();
|
||||
BEGIN { print STDERR " ." }
|
||||
use GT::Socket::Client();
|
||||
use GT::TempFile();
|
||||
use GT::Plugins();
|
||||
use GT::Plugins::Author();
|
||||
use GT::Plugins::Installer();
|
||||
use GT::Plugins::Manager();
|
||||
use GT::Template();
|
||||
use GT::Template::Editor();
|
||||
use GT::Template::Parser();
|
||||
use GT::WWW();
|
||||
BEGIN { print STDERR " ." }
|
||||
|
||||
# Preload Gossamer Links modules.
|
||||
use Links::Admin();
|
||||
use Links::Authenticate();
|
||||
use Links::Bookmark();
|
||||
use Links::Browser();
|
||||
use Links::Build();
|
||||
use Links::Bookmark();
|
||||
use Links::Config();
|
||||
use Links::Newsletter();
|
||||
use Links::Parallel();
|
||||
use Links::Payment();
|
||||
use Links::Plugins();
|
||||
BEGIN { print STDERR " ." }
|
||||
use Links::SQL();
|
||||
use Links::SiteHTML();
|
||||
use Links::Tools();
|
||||
use Links::Utils();
|
||||
use Links::Browser::Controller();
|
||||
use Links::Browser::JFunction();
|
||||
use Links::Table::Category();
|
||||
use Links::Table::Links();
|
||||
use Links::Table::Users();
|
||||
use Links::HTML::Category();
|
||||
use Links::HTML::Links();
|
||||
use Links::HTML::Users();
|
||||
BEGIN { print STDERR " ." }
|
||||
use Links::User::Add();
|
||||
use Links::User::Editor();
|
||||
use Links::User::Jump();
|
||||
use Links::User::Login();
|
||||
use Links::User::Modify();
|
||||
use Links::User::Page();
|
||||
use Links::User::Rate();
|
||||
use Links::User::Review();
|
||||
use Links::User::Search();
|
||||
|
||||
BEGIN { print STDERR " .\nAll modules loaded ok!\n" }
|
||||
|
||||
print STDERR "Compiling all functions ...";
|
||||
|
||||
GT::AutoLoader::compile_all();
|
||||
|
||||
print STDERR " All modules compiled and loaded okay!\n\n";
|
||||
|
||||
1;
|
||||
23
site/slowtwitch.com/cgi-bin/articles/admin/Links/tmp.pl
Normal file
23
site/slowtwitch.com/cgi-bin/articles/admin/Links/tmp.pl
Normal file
@@ -0,0 +1,23 @@
|
||||
sub {
|
||||
my $related = shift || return;
|
||||
my @ids = split ("\n",$related);
|
||||
my @loop;
|
||||
my $db = $DB->table('Links');
|
||||
|
||||
my $tags = GT::Template->tags;
|
||||
my $id = $tags->{ID};
|
||||
my $cond = GT::SQL::Condition->new('RelatedArticles','like',$id . "\n%");
|
||||
$cond->add('RelatedArticles','like', "%\n" . $id . "\n%");
|
||||
$cond->add('RelatedArticles','like', "\n" . $id);
|
||||
use Data::Dumper;
|
||||
print Dumper($cond);
|
||||
#my $sth = $db->select($cond);
|
||||
|
||||
require Links::SiteHTML;
|
||||
foreach my $id (@ids) {
|
||||
my $link = $db->get($id);
|
||||
$link = Links::SiteHTML::tags('link',$link);
|
||||
push @loop, $link;
|
||||
}
|
||||
return { related_articles_loop => \@loop };
|
||||
}
|
||||
Reference in New Issue
Block a user