misc/fix_globals.pl

   1 #!/usr/bin/env perl
   2
   3 use feature 'say';
   4 use lib 'lib';
   5 use strict;
   6 use warnings;
   7 use Text::Tradition::Collation::Reading::Lexeme;
   8 use Text::Tradition::Directory;
   9 use TryCatch;
  10 use utf8;
  11
  12 binmode STDOUT, ':utf8';
  13 binmode STDERR, ':utf8';
  14 eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 };
  15
  16 my $dir = Text::Tradition::Directory->new(
  17     'dsn' => 'dbi:SQLite:dbname=stemmaweb/db/traditions.db',
  18     );
  19
  20 my $scope = $dir->new_scope();
  21 my @traditions;
  22 my $lookfor = $ARGV[0] || '';
  23 foreach my $tinfo ( $dir->traditionlist ) {
  24     next unless $tinfo->{id} eq $lookfor || $tinfo->{name} =~ /$lookfor/;
  25     my $tradition = $dir->lookup( $tinfo->{id} );
  26     print STDERR "Found " . $tradition->name . "\n";
  27     my $c = $tradition->collation;
  28     $c->_set_tradition( $tradition );
  29     # Make the change(s)
  30     say STDERR "First run:";
  31     do_the_work( $c );
  32     say STDERR "Second run:";
  33     do_the_work( $c );
  34
  35     # Save the lot
  36     $dir->save( $tradition );
  37 }
  38
  39 sub do_the_work {
  40     my $c = shift;
  41     foreach my $rel ( $c->relationships ) {
  42         my $relobj = $c->get_relationship( $rel );
  43         next unless $relobj->scope eq 'global';
  44
  45         # For any global relationship, the relationship store should contain an
  46         # entry in $self->scopedrels for the text of the two related readings.
  47         # The scoped relationship is case insensitive unless the relationship type
  48         # is 'orthographic'. The object of this script is to detect when a global
  49         # relationship object is not the one in $self->scopedrels, and replace it
  50         # with the one that is.
  51
  52         # Case insensitive unless orthographic...
  53         my $rdga = $relobj->type eq 'orthographic'
  54             ? $relobj->reading_a : lc( $relobj->reading_a );
  55         my $rdgb = $relobj->type eq 'orthographic'
  56             ? $relobj->reading_b : lc( $relobj->reading_b );
  57
  58         # Get the applicable scoped relationship object
  59         my $scopeobj = $c->relations->scoped_relationship( $rdga, $rdgb );
  60
  61         # Test to see whether it exists, corresponds with $relobj, and if it is not
  62         # identical to $relobj then replace $relobj with it.
  63         if( $scopeobj ) {
  64             if( $scopeobj->type ne $relobj->type ) {
  65                 say STDERR sprintf( "Different scoped relationship types at %s - %s: %s vs. %s",
  66                              @$rel, $scopeobj->type, $relobj->type );
  67             } elsif( ( $scopeobj->reading_a ne $relobj->reading_a )
  68                      || ( $scopeobj->reading_b ne $relobj->reading_b) ) {
  69                 say STDERR "Different a/b readings for scoped object at @$rel";
  70             } elsif( $scopeobj ne $relobj ) {
  71                 say STDERR "Replacing " . $relobj->type . " relobj with scoped object at @$rel";
  72                 $c->relations->_set_relationship( $scopeobj, @$rel );
  73             }
  74         } else {
  75             say STDERR "No scoped object for relationship at @$rel";
  76         }
  77
  78     }
  79 }