First pass at adding key files

site/slowtwitch.com/cgi-bin/articles/admin/Links/Import/S2BK.pm

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