190 lines
6.6 KiB
Modula-2
190 lines
6.6 KiB
Modula-2
# ==================================================================
|
|
# 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;
|