script/dblookup.pl

   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 }