Commit | Line | Data |
c23749b5 |
1 | use lib 'lib'; |
2 | use feature 'say'; |
3 | use strict; |
4 | use warnings; |
5 | use Getopt::Long; |
6 | use Text::Tradition::Directory; |
7 | use TryCatch; |
8 | |
9 | binmode STDOUT, ':utf8'; |
10 | binmode STDERR, ':utf8'; |
11 | eval { no warnings; binmode $DB::OUT, ':utf8'; $DB::deep = 1000 }; |
12 | |
13 | my( $dbuser, $dbpass ); |
14 | my $dsn = 'dbi:SQLite:dbname=stemmaweb/db/traditions.db'; |
15 | |
16 | GetOptions( |
17 | 'dsn=s' => \$dsn, |
18 | 'u|user=s' => \$dbuser, |
19 | 'p|pass=s' => \$dbpass, |
20 | ); |
21 | |
22 | my $dbopts = { dsn => $dsn }; |
23 | $dbopts->{extra_args}->{user} = $dbuser if $dbuser; |
24 | $dbopts->{extra_args}->{password} = $dbpass if $dbpass; |
25 | |
26 | my $dir = Text::Tradition::Directory->new( $dbopts ); |
27 | |
28 | my $scope = $dir->new_scope(); |
29 | my $lookfor = $ARGV[0] || ''; |
30 | foreach my $tinfo ( $dir->traditionlist() ) { |
31 | next unless $tinfo->{'name'} =~ /$lookfor/ || $tinfo->{'id'} eq $lookfor; |
32 | my $tradition = $dir->lookup( $tinfo->{'id'} ); |
33 | # Try to piece together the majority text. |
34 | my $c = $tradition->collation; |
35 | my $curr = $c->start; |
36 | my @text; |
37 | while( $curr ne $c->end ) { |
38 | my %witnumbers; |
39 | foreach my $candidate( $c->sequence->successors( $curr ) ) { |
40 | my $cobj = $c->reading( $candidate ); |
41 | next if $cobj->is_lacuna; |
42 | my $witnum = scalar keys %{$c->sequence->get_edge_attributes( |
43 | $curr->id, $candidate )}; |
44 | $witnumbers{$witnum} = $cobj; |
45 | } |
46 | my @numbers = sort { $a <=> $b } keys %witnumbers; |
47 | if( @numbers ) { |
48 | $curr = $witnumbers{ pop @numbers }; |
49 | push( @text, $curr ) unless $curr->is_meta; |
50 | } else { |
51 | warn "Did not find non-lacuna successor to $curr"; |
52 | last; |
53 | } |
54 | } |
55 | my $pathtext = ''; |
56 | my $last; |
57 | foreach my $r ( @text ) { |
58 | unless ( $r->join_prior || !$last || $last->join_next ) { |
59 | $pathtext .= ' '; |
60 | } |
61 | $pathtext .= $r->text; |
62 | $last = $r; |
63 | } |
64 | say $pathtext; |
65 | } |