153 lines
5.7 KiB
Perl
153 lines
5.7 KiB
Perl
# ==================================================================
|
|
# 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";
|