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

First pass at adding key files

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

183
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/BKS2.pm Normal file
View 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;

189
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/BKS2.pm.mod Normal file
View File

@@ -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;

581
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/Interface/CGI.pm Normal file
View File

@@ -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/&/&amp;/g;
$to_escape =~ s/ /&nbsp;/g;
$to_escape =~ s/</&lt;/g;
$to_escape =~ s/>/&gt;/g;
$to_escape =~ s/"/&quot;/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>$_&nbsp;</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:&nbsp;&nbsp;
</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/&/&amp;/g;
s/</&lt;/g;
s/>/&gt;/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?"

294
site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/Interface/Text.pm Normal file
View File

@@ -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
View 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
View 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
View 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
View 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
View 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";