438 lines
17 KiB
Perl
438 lines
17 KiB
Perl
# ==================================================================
|
|
# 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;
|