From: Tara L Andrews <tla@mit.edu>
Date: Wed, 11 Jul 2012 23:21:31 +0000 (+0200)
Subject: regularize some script libs and interface
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=446a738965dd6a13ec11ea519067095d618f82d5;p=scpubgit%2Fstemmatology.git

regularize some script libs and interface
---

diff --git a/script/join_readings.pl b/script/join_readings.pl
index 0b803a8..a5ef593 100755
--- a/script/join_readings.pl
+++ b/script/join_readings.pl
@@ -5,9 +5,7 @@ use feature 'say';
 use strict;
 use warnings;
 use Getopt::Long;
-use Lingua::Features::Structure;
 use Text::Tradition::Directory;
-use XML::Easy::Syntax qw/ $xml10_name_rx $xml10_namestartchar_rx /;
 use TryCatch;
 
 binmode STDOUT, ':utf8';
diff --git a/script/orth_case_links.pl b/script/orth_case_links.pl
index efde97c..9487984 100755
--- a/script/orth_case_links.pl
+++ b/script/orth_case_links.pl
@@ -1,27 +1,40 @@
 #!/usr/bin/env perl
 
 use lib 'lib';
+use feature 'say';
 use strict;
 use warnings;
+use Getopt::Long;
 use Text::Tradition::Directory;
+use TryCatch;
 
-binmode STDERR, ':utf8';
 binmode STDOUT, ':utf8';
-eval { no warnings; binmode $DB::OUT, ':utf8' };
+binmode STDERR, ':utf8';
+eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
+
+my( $dbuser, $dbpass );
+my $dsn = 'dbi:SQLite:dbname=stemmaweb/db/traditions.db';
+my $testrun;
+
+GetOptions( 
+	'dsn=s'    => \$dsn,
+	'u|user=s' => \$dbuser,
+	'p|pass=s' => \$dbpass,
+	'n|test'   => \$testrun,
+	);
 
-my( $dsn, $user, $pass ) = @ARGV;
+my $dbopts = { dsn => $dsn };
+$dbopts->{extra_args}->{user} = $dbuser if $dbuser;
+$dbopts->{extra_args}->{password} = $dbpass if $dbpass;
 
-my $connect_args = { dsn => $dsn };
-$connect_args->{'extra_args'} = { user => $user, password => $pass }
-	if $user && $pass;
-my $dir = Text::Tradition::Directory->new( $connect_args );
+my $dir = Text::Tradition::Directory->new( $dbopts );
 
-foreach my $text ( $dir->traditionlist ) {
-	my $id = $text->{'id'};
-	next unless $text->{'name'} =~ /Heinrichi/;
-	my $scope = $dir->new_scope;
-	my $tradition = $dir->lookup( $id );
-	print STDERR "Processing tradition " . $tradition->name . "\n";
+my $scope = $dir->new_scope();
+my $lookfor = $ARGV[0] || '';
+foreach my $tinfo ( $dir->traditionlist() ) {
+	next unless $tinfo->{'name'} =~ /$lookfor/ || $tinfo->{'id'} eq $lookfor;
+	my $tradition = $dir->lookup( $tinfo->{id} );
+	say STDERR "Processing tradition " . $tradition->name;
 	my $c = $tradition->collation;
 	$c->flatten_ranks(); # just in case
 	foreach my $rank ( 1 .. $c->end->rank - 1 ) {
@@ -34,16 +47,19 @@ foreach my $text ( $dir->traditionlist ) {
 			my @orthmatch = grep { lc( $r->text ) eq lc( $_->text ) } @readings;
 			foreach my $om ( @orthmatch ) {
 				if( $r->text eq $om->text ) {
-					print STDERR "Merging identical readings $r and $om (" 
-						. $r->text . ")\n";
+					say STDERR "Merging identical readings $r and $om (" 
+						. $r->text . ")";
 					$merged{$om->id} = 1;
 					$c->merge_readings( $r, $om ); 
 				} else {
-					print STDERR sprintf( "Adding orthographic link for %s and %s (%s / %s)\n", 
+					say STDERR sprintf( "Adding orthographic link for %s and %s (%s / %s)", 
 						$r->id, $om->id, $r->text, $om->text );
-					eval { $c->add_relationship( $r, $om, 
-						{ 'type' => 'orthographic', 'scope' => 'global' } ); };
-					print STDERR $@ if $@;
+					try { 
+						$c->add_relationship( $r, $om, 
+							{ 'type' => 'orthographic', 'scope' => 'global' } ); };
+					} catch ( Text::Tradition::Error $e ) {
+						say STDERR "Relationship skipped: " . $e->message;
+					}
 				}
 			}
 		}		
diff --git a/script/propagate_transitive.pl b/script/propagate_transitive.pl
index afe11d7..2d49467 100755
--- a/script/propagate_transitive.pl
+++ b/script/propagate_transitive.pl
@@ -5,9 +5,7 @@ use feature 'say';
 use strict;
 use warnings;
 use Getopt::Long;
-use Lingua::Features::Structure;
 use Text::Tradition::Directory;
-use XML::Easy::Syntax qw/ $xml10_name_rx $xml10_namestartchar_rx /;
 use TryCatch;
 
 binmode STDOUT, ':utf8';