640 lines
21 KiB
Perl
Executable file
640 lines
21 KiB
Perl
Executable file
#!/usr/bin/perl
|
|
# This code was forked from the LiveJournal project owned and operated
|
|
# by Live Journal, Inc. The code has been modified and expanded by
|
|
# Dreamwidth Studios, LLC. These files were originally licensed under
|
|
# the terms of the license supplied by Live Journal, Inc, which can
|
|
# currently be found at:
|
|
#
|
|
# http://code.livejournal.org/trac/livejournal/browser/trunk/LICENSE-LiveJournal.txt
|
|
#
|
|
# In accordance with the original license, this code and all its
|
|
# modifications are provided under the GNU General Public License.
|
|
# A copy of that license can be found in the LICENSE file included as
|
|
# part of this distribution.
|
|
|
|
#
|
|
# This program deals with inserting/extracting text/language data
|
|
# from the database.
|
|
#
|
|
|
|
use strict;
|
|
|
|
BEGIN { $LJ::_T_CONFIG = $ENV{DW_TEST}; require "$ENV{LJHOME}/cgi-bin/ljlib.pl"; }
|
|
use File::Basename ();
|
|
use File::Path ();
|
|
use File::Find ();
|
|
use Getopt::Long;
|
|
use LJ::Config;
|
|
LJ::Config->load;
|
|
use LJ::LangDatFile;
|
|
use LJ::Lang;
|
|
use LJ::Web;
|
|
|
|
my $DATA_DIR = "bin/upgrading";
|
|
|
|
my $opt_help = 0;
|
|
my $opt_local_lang;
|
|
my $opt_only;
|
|
my $opt_verbose;
|
|
exit 1
|
|
unless GetOptions(
|
|
"help" => \$opt_help,
|
|
"local-lang=s" => \$opt_local_lang,
|
|
"verbose" => \$opt_verbose,
|
|
"only=s" => \$opt_only
|
|
);
|
|
|
|
my $mode = shift @ARGV;
|
|
|
|
help() if $opt_help or not defined $mode;
|
|
|
|
sub help {
|
|
die 'Usage: texttool.pl <command>
|
|
|
|
Where <command> is one of:
|
|
load Runs the following five commands in order:
|
|
popstruct Populate lang data from text[-local].dat into db
|
|
poptext Populate text from en.dat, etc into database. This will also
|
|
delete any text items listed in deadphrases[-local].dat. If
|
|
texttool.pl is run on a production server ($LJ::IS_DEV_SERVER is
|
|
false), the text items will be dumped first (as if by dumptext)
|
|
for all languages except en and the local root language
|
|
($LJ::DEFAULT_LANG or $LJ::LANGS[0]), but existing text files
|
|
will be appended, not overwritten.
|
|
copyfaq If site is translating FAQ, copy FAQ data into trans area
|
|
makeusable Setup internal indexes necessary after loading text
|
|
dumptext Dump lang text based on text[-local].dat information
|
|
Optionally:
|
|
[lang...] list of languages to dump (default is all)
|
|
check Check validity of text[-local].dat files
|
|
wipedb Remove all language/text data from database.
|
|
remove takes two extra arguments: domain name and code, and removes
|
|
that code and its text in all languages
|
|
|
|
';
|
|
}
|
|
|
|
my %dom_id; # number -> {}
|
|
my %dom_code; # name -> {}
|
|
my %lang_id; # number -> {}
|
|
my %lang_code; # name -> {}
|
|
my @lang_domains;
|
|
|
|
my $set = sub {
|
|
my ( $hash, $key, $val, $errmsg ) = @_;
|
|
die "$errmsg$key\n" if exists $hash->{$key};
|
|
$hash->{$key} = $val;
|
|
};
|
|
|
|
my %lang_dir_map;
|
|
|
|
foreach my $scope ( "general", "local" ) {
|
|
my $file = $scope eq "general" ? "text.dat" : "text-local.dat";
|
|
my @files = LJ::get_all_files( "$DATA_DIR/$file", home_first => 1 );
|
|
if ( $scope eq 'general' && !@files ) {
|
|
die "$file file not found; odd: did you delete it?\n";
|
|
}
|
|
foreach my $ffile (@files) {
|
|
my $dir = File::Basename::dirname($ffile);
|
|
$dir =~ s!/\Q$DATA_DIR\E$!!;
|
|
|
|
open( F, $ffile ) or die "Can't open file: $file: $!\n";
|
|
while (<F>) {
|
|
s/\s+$//;
|
|
s/^\#.+//;
|
|
next unless /\S/;
|
|
my @vals = split( /:/, $_ );
|
|
my $what = shift @vals;
|
|
|
|
# language declaration
|
|
if ( $what eq "lang" ) {
|
|
$lang_dir_map{ $vals[1] } = $dir;
|
|
|
|
my $lang = {
|
|
scope => $scope,
|
|
lnid => $vals[0],
|
|
lncode => $vals[1],
|
|
lnname => $vals[2],
|
|
parentlnid => 0, # default. changed later.
|
|
parenttype => 'diff',
|
|
};
|
|
$lang->{'parenttype'} = $vals[3] if defined $vals[3];
|
|
if ( defined $vals[4] ) {
|
|
unless ( exists $lang_code{ $vals[4] } ) {
|
|
die
|
|
"Can't declare language $lang->{'lncode'} with missing parent language $vals[4].\n";
|
|
}
|
|
$lang->{'parentlnid'} = $lang_code{ $vals[4] }->{'lnid'};
|
|
}
|
|
$set->( \%lang_id, $lang->{'lnid'}, $lang, "Language already defined with ID: " );
|
|
$set->(
|
|
\%lang_code, $lang->{'lncode'}, $lang, "Language already defined with code: "
|
|
);
|
|
}
|
|
|
|
# domain declaration
|
|
if ( $what eq "domain" ) {
|
|
my $dcode = $vals[1];
|
|
my ( $type, $args ) = split( m!/!, $dcode );
|
|
my $dom = {
|
|
scope => $scope,
|
|
dmid => $vals[0],
|
|
type => $type,
|
|
args => $args || "",
|
|
};
|
|
$set->( \%dom_id, $dom->{'dmid'}, $dom, "Domain already defined with ID: " );
|
|
$set->( \%dom_code, $dcode, $dom, "Domain already defined with parameters: " );
|
|
}
|
|
|
|
# langdomain declaration
|
|
if ( $what eq "langdomain" ) {
|
|
my $ld = {
|
|
lnid => (
|
|
exists $lang_code{ $vals[0] } ? $lang_code{ $vals[0] }->{'lnid'}
|
|
: die "Undefined language: $vals[0]\n"
|
|
),
|
|
dmid => (
|
|
exists $dom_code{ $vals[1] } ? $dom_code{ $vals[1] }->{'dmid'}
|
|
: die "Undefined domain: $vals[1]\n"
|
|
),
|
|
dmmaster => $vals[2] ? "1" : "0",
|
|
};
|
|
push @lang_domains, $ld;
|
|
}
|
|
}
|
|
close F;
|
|
}
|
|
}
|
|
|
|
if ( $mode eq "check" ) {
|
|
print "all good.\n";
|
|
exit 0;
|
|
}
|
|
|
|
## make sure we can connect
|
|
my $dbh = LJ::get_dbh("master");
|
|
my $sth;
|
|
unless ($dbh) {
|
|
die "Can't connect to the database.\n";
|
|
}
|
|
$dbh->{RaiseError} = 1;
|
|
|
|
# indenter
|
|
my $idlev = 0;
|
|
my $out = sub {
|
|
my @args = @_;
|
|
while (@args) {
|
|
my $a = shift @args;
|
|
if ( $a eq "+" ) { $idlev++; }
|
|
elsif ( $a eq "-" ) { $idlev--; }
|
|
elsif ( $a eq "x" ) { $a = shift @args; die " " x $idlev . $a . "\n"; }
|
|
else { print " " x $idlev, $a, "\n"; }
|
|
}
|
|
};
|
|
|
|
my @good = qw(load popstruct poptext dumptext dumptextcvs wipedb
|
|
makeusable copyfaq remove);
|
|
|
|
popstruct() if $mode eq "popstruct" or $mode eq "load";
|
|
poptext(@ARGV) if $mode eq "poptext" or $mode eq "load";
|
|
copyfaq() if $mode eq "copyfaq" or $mode eq "load";
|
|
makeusable() if $mode eq "makeusable" or $mode eq "load";
|
|
dumptext( 0, @ARGV ) if $mode =~ /^dumptext?$/;
|
|
wipedb() if $mode eq "wipedb";
|
|
remove(@ARGV) if $mode eq "remove" and scalar(@ARGV) == 2;
|
|
help() unless grep { $mode eq $_ } @good;
|
|
exit 0;
|
|
|
|
sub makeusable {
|
|
$out->( "Making usable...", '+' );
|
|
my $rec = sub {
|
|
my ( $lang, $rec ) = @_;
|
|
my $l = $lang_code{$lang};
|
|
$out->( "x", "Bogus language: $lang" ) unless $l;
|
|
my @children = grep { $_->{'parentlnid'} == $l->{'lnid'} } values %lang_code;
|
|
foreach my $cl (@children) {
|
|
$out->("$l->{'lncode'} -- $cl->{'lncode'}");
|
|
|
|
my %need;
|
|
|
|
# push downwards everything that has some valid text in some language (< 4)
|
|
$sth = $dbh->prepare(
|
|
"SELECT dmid, itid, txtid FROM ml_latest WHERE lnid=$l->{'lnid'} AND staleness < 4"
|
|
);
|
|
$sth->execute;
|
|
while ( my ( $dmid, $itid, $txtid ) = $sth->fetchrow_array ) {
|
|
$need{"$dmid:$itid"} = $txtid;
|
|
}
|
|
$sth =
|
|
$dbh->prepare("SELECT dmid, itid, txtid FROM ml_latest WHERE lnid=$cl->{'lnid'}");
|
|
$sth->execute;
|
|
while ( my ( $dmid, $itid, $txtid ) = $sth->fetchrow_array ) {
|
|
delete $need{"$dmid:$itid"};
|
|
}
|
|
while ( my $k = each %need ) {
|
|
my ( $dmid, $itid ) = split( /:/, $k );
|
|
my $txtid = $need{$k};
|
|
my $stale = $cl->{'parenttype'} eq "diff" ? 3 : 0;
|
|
$dbh->do(
|
|
"INSERT INTO ml_latest (lnid, dmid, itid, txtid, chgtime, staleness) VALUES "
|
|
. "($cl->{'lnid'}, $dmid, $itid, $txtid, NOW(), $stale)" );
|
|
die $dbh->errstr if $dbh->err;
|
|
}
|
|
$rec->( $cl->{'lncode'}, $rec );
|
|
}
|
|
};
|
|
$rec->( "en", $rec );
|
|
$out->( "-", "done." );
|
|
}
|
|
|
|
sub copyfaq {
|
|
my $faqd = LJ::Lang::get_dom("faq");
|
|
my $ll = LJ::Lang::get_root_lang($faqd);
|
|
unless ($ll) { return; }
|
|
|
|
my $domid = $faqd->{'dmid'};
|
|
|
|
$out->( "Copying FAQ...", '+' );
|
|
|
|
my %existing;
|
|
$sth = $dbh->prepare( "SELECT i.itcode FROM ml_items i, ml_latest l "
|
|
. "WHERE l.lnid=$ll->{'lnid'} AND l.dmid=$domid AND l.itid=i.itid AND i.dmid=$domid" );
|
|
$sth->execute;
|
|
$existing{$_} = 1 while $_ = $sth->fetchrow_array;
|
|
|
|
# faq category
|
|
$sth = $dbh->prepare("SELECT faqcat, faqcatname FROM faqcat");
|
|
$sth->execute;
|
|
while ( my ( $cat, $name ) = $sth->fetchrow_array ) {
|
|
next if exists $existing{"cat.$cat"};
|
|
my $opts = { childrenlatest => 1 };
|
|
LJ::Lang::set_text( $domid, $ll->{'lncode'}, "cat.$cat", $name, $opts );
|
|
}
|
|
|
|
# faq items
|
|
$sth = $dbh->prepare("SELECT faqid, question, answer, summary FROM faq");
|
|
$sth->execute;
|
|
while ( my ( $faqid, $q, $a, $s ) = $sth->fetchrow_array ) {
|
|
next
|
|
if exists $existing{"$faqid.1question"}
|
|
and exists $existing{"$faqid.2answer"}
|
|
and exists $existing{"$faqid.3summary"};
|
|
my $opts = { childrenlatest => 1 };
|
|
LJ::Lang::set_text( $domid, $ll->{'lncode'}, "$faqid.1question", $q, $opts );
|
|
LJ::Lang::set_text( $domid, $ll->{'lncode'}, "$faqid.2answer", $a, $opts );
|
|
LJ::Lang::set_text( $domid, $ll->{'lncode'}, "$faqid.3summary", $s, $opts );
|
|
}
|
|
|
|
$out->( '-', "done." );
|
|
}
|
|
|
|
sub wipedb {
|
|
$out->( "Wiping DB...", '+' );
|
|
foreach (qw(domains items langdomains langs latest text)) {
|
|
$out->("deleting from $_");
|
|
$dbh->do("DELETE FROM ml_$_");
|
|
}
|
|
$out->( "-", "done." );
|
|
}
|
|
|
|
sub popstruct {
|
|
$out->( "Populating structure...", '+' );
|
|
foreach my $l ( values %lang_id ) {
|
|
$out->("Inserting language: $l->{'lnname'}");
|
|
$dbh->do(
|
|
"REPLACE INTO ml_langs (lnid, lncode, lnname, parenttype, parentlnid) "
|
|
. "VALUES ("
|
|
. join( ",",
|
|
map { $dbh->quote( $l->{$_} ) } qw(lnid lncode lnname parenttype parentlnid) )
|
|
. ")"
|
|
);
|
|
}
|
|
|
|
foreach my $d ( values %dom_id ) {
|
|
$out->("Inserting domain: $d->{'type'}\[$d->{'args'}\]");
|
|
$dbh->do( "REPLACE INTO ml_domains (dmid, type, args) "
|
|
. "VALUES ("
|
|
. join( ",", map { $dbh->quote( $d->{$_} ) } qw(dmid type args) )
|
|
. ")" );
|
|
}
|
|
|
|
$out->("Inserting language domains ...");
|
|
foreach my $ld (@lang_domains) {
|
|
$dbh->do( "INSERT IGNORE INTO ml_langdomains (lnid, dmid, dmmaster) VALUES " . "("
|
|
. join( ",", map { $dbh->quote( $ld->{$_} ) } qw(lnid dmid dmmaster) )
|
|
. ")" );
|
|
}
|
|
$out->( "-", "done." );
|
|
}
|
|
|
|
sub poptext {
|
|
my @langs = @_;
|
|
push @langs, ( keys %lang_code ) unless @langs;
|
|
|
|
$out->( "Populating text...", '+' );
|
|
|
|
# learn about base files
|
|
my %source; # langcode -> absfilepath
|
|
foreach my $lang (@langs) {
|
|
my $file = $lang_dir_map{$lang} . "/$DATA_DIR/${lang}.dat";
|
|
next if $opt_only && $lang ne $opt_only;
|
|
next unless -e $file;
|
|
$source{$file} = [ $lang, '' ];
|
|
}
|
|
|
|
my $wanted = sub {
|
|
print join( " ", ( $_, $File::Find::Dir, $File::Find::name ) ) . "\n";
|
|
return $_ =~ m/\.text(\.local)?$/;
|
|
};
|
|
|
|
# learn about local files
|
|
|
|
my $lang;
|
|
my $current_dir;
|
|
|
|
my $process_file = sub {
|
|
my $tf = $File::Find::name;
|
|
return unless $tf =~ m/\.text(\.local)?$/;
|
|
|
|
my $is_local = $tf =~ /\.local$/;
|
|
|
|
if ($is_local) {
|
|
die "uh, what is this .local file?" unless $lang ne "en";
|
|
}
|
|
|
|
my $pfx = $tf;
|
|
$pfx =~ s!^htdocs/!!;
|
|
$pfx =~ s!^views/!!;
|
|
$pfx =~ s!\.text(\.local)?$!!;
|
|
$pfx = "/$pfx";
|
|
$source{ $current_dir . '/' . $tf } = [ $lang, $pfx ];
|
|
};
|
|
|
|
my $original_dir = Cwd::getcwd();
|
|
|
|
# Only going over these directories and not all directories
|
|
# This can be revisited if we have .text(.local) files
|
|
# outside of these
|
|
foreach my $the_lang ( keys %lang_dir_map ) {
|
|
$lang = $the_lang;
|
|
$current_dir = $lang_dir_map{$lang};
|
|
next unless -d $current_dir;
|
|
chdir $current_dir;
|
|
File::Find::find( $process_file, 'htdocs', 'views' );
|
|
}
|
|
|
|
chdir $original_dir;
|
|
|
|
my %existing_item; # langid -> code -> 1
|
|
|
|
foreach my $file ( keys %source ) {
|
|
my ( $lang, $pfx ) = @{ $source{$file} };
|
|
|
|
$out->( "$lang", '+' );
|
|
my $ldf = LJ::LangDatFile->new($file);
|
|
|
|
my $l = $lang_code{$lang} or die "unknown language '$lang'";
|
|
|
|
my $addcount = 0;
|
|
$ldf->foreach_key(
|
|
sub {
|
|
my $code = shift;
|
|
|
|
my %metadata = $ldf->meta($code);
|
|
my $text = $ldf->value($code);
|
|
|
|
$code = "$pfx$code";
|
|
die "Code in file $file can't start with a dot: $code"
|
|
if $code =~ /^\./;
|
|
|
|
# load existing items for target language
|
|
unless ( exists $existing_item{ $l->{'lnid'} } ) {
|
|
$existing_item{ $l->{'lnid'} } = {};
|
|
my $sth = $dbh->prepare(
|
|
qq{
|
|
SELECT i.itcode, t.text
|
|
FROM ml_latest l, ml_items i, ml_text t
|
|
WHERE i.dmid=1 AND l.dmid=1 AND i.itid=l.itid AND l.lnid=?
|
|
AND t.lnid=l.lnid and t.txtid = l.txtid
|
|
AND i.dmid=i.dmid and t.dmid=i.dmid
|
|
}
|
|
);
|
|
$sth->execute( $l->{lnid} );
|
|
die $sth->errstr if $sth->err;
|
|
while ( my ( $code, $oldtext ) = $sth->fetchrow_array ) {
|
|
$existing_item{ $l->{'lnid'} }->{ lc($code) } = $oldtext;
|
|
}
|
|
}
|
|
|
|
# if this is the local/default language (which means people are likely to
|
|
# be translating it live on the site) then don't overwrite...
|
|
return
|
|
if $lang eq $LJ::DEFAULT_LANG
|
|
&& $existing_item{ $l->{lnid} }->{$code};
|
|
|
|
# Remove last '\r' char from loaded from files text before compare.
|
|
# In database text stored without this '\r', LJ::Lang::set_text remove it
|
|
# before update database.
|
|
$text =~ s/\r//;
|
|
unless ( $existing_item{ $l->{'lnid'} }->{$code} eq $text ) {
|
|
$addcount++;
|
|
|
|
# if the text is changing, the staleness is at least 1
|
|
my $staleness = $metadata{'staleness'} + 0 || 1;
|
|
|
|
my $res = LJ::Lang::set_text(
|
|
1,
|
|
$l->{'lncode'},
|
|
$code, $text,
|
|
{
|
|
'staleness' => $staleness,
|
|
'notes' => $metadata{'notes'},
|
|
'changeseverity' => 2,
|
|
}
|
|
);
|
|
$out->("set: $code") if $opt_verbose;
|
|
unless ($res) {
|
|
$out->( 'x', "ERROR: " . LJ::Lang::last_error() );
|
|
}
|
|
}
|
|
}
|
|
);
|
|
$out->( "added: $addcount", '-' );
|
|
}
|
|
$out->( "-", "done." );
|
|
|
|
# dead phrase removal
|
|
unless ($LJ::IS_DEV_SERVER) {
|
|
my @trans = grep { $_ ne "en" && $_ ne $LJ::DEFAULT_LANG } @LJ::LANGS;
|
|
if (@trans) {
|
|
$out->('Dumping text (with append) before removing deadphrases');
|
|
dumptext( 0, 1, @trans );
|
|
}
|
|
else {
|
|
$out->('No translated languages, skipping dumptext');
|
|
}
|
|
}
|
|
$out->( "Removing dead phrases...", '+' );
|
|
my @dp_files;
|
|
foreach my $file ( "deadphrases.dat", "deadphrases-local.dat" ) {
|
|
foreach my $lang (@langs) {
|
|
my $fn = $lang_dir_map{$lang} . "/$DATA_DIR/$file";
|
|
next unless -e $fn;
|
|
push @dp_files, $fn;
|
|
}
|
|
}
|
|
foreach my $ffile (@dp_files) {
|
|
next unless -s $ffile;
|
|
my ($fn) = ( $ffile =~ /^\Q$ENV{LJHOME}\E\/(.*)$/ );
|
|
$out->("File: $fn");
|
|
open( DP, $ffile ) or die;
|
|
while ( my $li = <DP> ) {
|
|
$li =~ s/\#.*//;
|
|
next unless $li =~ /\S/;
|
|
$li =~ s/\s+$//;
|
|
my ( $dom, $it ) = split( /\s+/, $li );
|
|
next unless exists $dom_code{$dom};
|
|
my $dmid = $dom_code{$dom}->{'dmid'};
|
|
|
|
my @items;
|
|
if ( $it =~ s/\*$/\%/ ) {
|
|
my $sth =
|
|
$dbh->prepare("SELECT itcode FROM ml_items WHERE dmid=? AND itcode LIKE ?");
|
|
$sth->execute( $dmid, $it );
|
|
push @items, $_ while $_ = $sth->fetchrow_array;
|
|
}
|
|
else {
|
|
@items = ($it);
|
|
}
|
|
foreach (@items) {
|
|
remove( $dom, $_, 1 );
|
|
}
|
|
}
|
|
close DP;
|
|
}
|
|
$out->( '-', "Done." );
|
|
}
|
|
|
|
# TODO: use LJ::LangDatFile->save
|
|
sub dumptext {
|
|
my $append = shift;
|
|
my @langs = @_;
|
|
unless (@langs) { @langs = keys %lang_code; }
|
|
|
|
$out->( 'Dumping text...', '+' );
|
|
foreach my $lang (@langs) {
|
|
my $lang_dir = $lang_dir_map{$lang};
|
|
my $d_langdir = $lang_dir;
|
|
$d_langdir =~ s!^\Q$LJ::HOME\E/!!;
|
|
|
|
$out->("$lang ( $d_langdir )");
|
|
|
|
my $l = $lang_code{$lang};
|
|
|
|
my %fh_map = (); # filename => filehandle
|
|
|
|
my $sth = $dbh->prepare(
|
|
"SELECT i.itcode, t.text, l.staleness, i.notes FROM "
|
|
. "ml_items i, ml_latest l, ml_text t "
|
|
. "WHERE l.lnid=$l->{'lnid'} AND l.dmid=1 "
|
|
. "AND i.dmid=1 AND l.itid=i.itid AND "
|
|
. "t.dmid=1 AND t.txtid=l.txtid AND "
|
|
.
|
|
|
|
# only export mappings that aren't inherited:
|
|
"t.lnid=$l->{'lnid'} " . "ORDER BY i.itcode"
|
|
);
|
|
$sth->execute;
|
|
die $dbh->errstr if $dbh->err;
|
|
|
|
my $writeline = sub {
|
|
my ( $fh, $k, $v ) = @_;
|
|
|
|
# kill any \r since they shouldn't be there anyway
|
|
$v =~ s/\r//g;
|
|
|
|
# print to .dat file
|
|
if ( $v =~ /\n/ ) {
|
|
$v =~ s/\n\./\n\.\./g;
|
|
print $fh "$k<<\n$v\n.\n";
|
|
}
|
|
else {
|
|
print $fh "$k=$v\n";
|
|
}
|
|
};
|
|
|
|
while ( my ( $itcode, $text, $staleness, $notes ) = $sth->fetchrow_array ) {
|
|
|
|
my $langdat_file = LJ::Lang::relative_langdat_file_of_lang_itcode( $lang, $itcode );
|
|
|
|
$itcode = LJ::Lang::itcode_for_langdat_file( $langdat_file, $itcode );
|
|
|
|
my $fh = $fh_map{$langdat_file};
|
|
unless ($fh) {
|
|
my $langdat_path = $lang_dir . '/' . $langdat_file;
|
|
|
|
# the dir might not exist in some cases
|
|
my $d = File::Basename::dirname($langdat_file);
|
|
File::Path::mkpath($d) unless -e $d;
|
|
|
|
open( $fh, $append ? ">>$langdat_path" : ">$langdat_path" )
|
|
or die "unable to open langdat file: $langdat_path ($!)";
|
|
|
|
$fh_map{$langdat_file} = $fh;
|
|
|
|
# print utf-8 encoding header
|
|
$fh->print(";; -*- coding: utf-8 -*-\n");
|
|
}
|
|
|
|
$writeline->( $fh, "$itcode|staleness", $staleness )
|
|
if $staleness;
|
|
$writeline->( $fh, "$itcode|notes", $notes )
|
|
if $notes =~ /\S/;
|
|
$writeline->( $fh, $itcode, $text );
|
|
|
|
# newline between record sets
|
|
print $fh "\n";
|
|
}
|
|
|
|
# close filehandles now
|
|
foreach my $file ( keys %fh_map ) {
|
|
close $fh_map{$file} or die "unable to close: $file ($!)";
|
|
}
|
|
}
|
|
$out->( '-', 'done.' );
|
|
}
|
|
|
|
sub remove {
|
|
my ( $dmcode, $itcode, $no_error ) = @_;
|
|
my $dmid;
|
|
if ( exists $dom_code{$dmcode} ) {
|
|
$dmid = $dom_code{$dmcode}->{'dmid'};
|
|
}
|
|
else {
|
|
$out->( "x", "Unknown domain code $dmcode." );
|
|
}
|
|
|
|
my $qcode = $dbh->quote($itcode);
|
|
my $itid =
|
|
$dbh->selectrow_array("SELECT itid FROM ml_items WHERE dmid=$dmid AND itcode=$qcode");
|
|
return if $no_error && !$itid;
|
|
$out->( "x", "Unknown item code $itcode." ) unless $itid;
|
|
|
|
$out->( "Removing item $itcode from domain $dmcode ($itid)...", "+" );
|
|
|
|
# need to delete everything from: ml_items ml_latest ml_text
|
|
|
|
$dbh->do("DELETE FROM ml_items WHERE dmid=$dmid AND itid=$itid");
|
|
|
|
my $txtids = "";
|
|
my $sth = $dbh->prepare("SELECT txtid FROM ml_latest WHERE dmid=$dmid AND itid=$itid");
|
|
$sth->execute;
|
|
while ( my $txtid = $sth->fetchrow_array ) {
|
|
$txtids .= "," if $txtids;
|
|
$txtids .= $txtid;
|
|
}
|
|
$dbh->do("DELETE FROM ml_latest WHERE dmid=$dmid AND itid=$itid");
|
|
$dbh->do("DELETE FROM ml_text WHERE dmid=$dmid AND txtid IN ($txtids)") if $txtids;
|
|
|
|
$out->( "-", "done." );
|
|
}
|