discourse-legacysite-perl/site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S2BK.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: 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";