discourse-legacysite-perl/site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/BKS2.pm

# ==================================================================
# 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;