Commit | Line | Data |
041d760c |
1 | #!/usr/bin/env perl |
2 | |
3 | use lib 'lib'; |
4 | use strict; |
5 | use warnings; |
6 | use File::Basename; |
7 | use Getopt::Long; |
8 | use Text::Tradition; |
9 | use Text::Tradition::Directory; |
10 | |
11 | binmode( STDOUT, ':utf8' ); |
12 | binmode( STDERR, ':utf8' ); |
13 | |
14 | my( $name, $delete, $list, $dsn ) = |
15 | ( undef, undef, 1, 'dbi:SQLite:dbname=db/traditions.db' ); |
16 | |
17 | GetOptions( |
18 | 'r|rename=s' => \$name, |
19 | 'd|delete' => \$delete, |
20 | 'dsn=s' => \$dsn, |
21 | ); |
22 | |
23 | my @uuids = @ARGV; # UUID is whatever is left over |
24 | my $kdb = Text::Tradition::Directory->new( 'dsn' => $dsn ); |
25 | $list = !$delete; |
26 | |
27 | if( $delete ) { |
28 | print STDERR "Must specify the UUID of a tradition to delete\n" unless @uuids; |
29 | my $scope = $kdb->new_scope(); |
30 | foreach my $uuid ( @uuids ) { |
31 | if( $kdb->exists( $uuid ) ) { |
32 | $kdb->delete( $uuid ); |
33 | } else { |
34 | print STDERR "No object found with ID $uuid\n"; |
35 | } |
36 | } |
37 | } |
38 | |
39 | if( $name ) { |
40 | print STDERR "Must specify the UUID of a tradition to rename\n" unless @uuids; |
41 | if( @uuids > 1 ) { |
42 | print STDERR "Multiple traditions given for rename - do you really want to do that?\n"; |
43 | } else { |
44 | my $scope = $kdb->new_scope(); |
45 | my $tradition = $kdb->lookup( $uuids[0] ); |
46 | if( $tradition ) { |
47 | $tradition->name( $name ); |
48 | $kdb->save( $tradition ); |
49 | } else { |
50 | print STDERR "Unable to find tradition @uuids to rename\n"; |
51 | } |
52 | } |
53 | } |
54 | |
55 | # Now list the DB contents if appropriate. |
56 | if( $list ) { |
57 | my $scope = $kdb->new_scope(); |
58 | foreach my $tref ( $kdb->traditionlist ) { |
59 | my $tid = $tref->{'id'}; |
60 | # If no IDs were given on the command line, list all traditions. |
61 | if( @uuids ) { |
62 | next unless grep { $_ eq $tid } @uuids; |
63 | } |
64 | my $t = $kdb->lookup( $tid ); |
65 | print STDERR "$tid: Tradition '" . $t->name . "'\n"; |
66 | my @wits = map { $_->sigil } $t->witnesses; |
67 | print STDERR "...with witnesses @wits\n"; |
68 | my $c = $t->collation; |
69 | print STDERR "...collation has " . scalar( $c->readings ) . " readings\n"; |
70 | print STDERR "...collation has " . scalar( $c->paths ) . " paths\n"; |
71 | print STDERR "...collation has " . scalar( $c->relationships ) . " relationship links\n"; |
72 | foreach my $s ( $t->stemmata ) { |
73 | print STDERR "...associated stemma has graph " . $s->graph . "\n"; |
74 | } |
75 | } |
76 | } |