chiark - git - mdw - dvddb/blob - report

   1 #! /usr/bin/perl -w
   2
   3 use open ":utf8";
   4 use strict;
   5
   6 use DBI;
   7 use Encode qw{encode_utf8 decode_utf8};
   8 use File::Find;
   9
  10 BEGIN { binmode STDOUT, ":utf8"; }
  11
  12 my $ROOT = "/mnt/dvd/archive";
  13 my $DB = DBI->connect("dbi:Pg:host=roadstar", "", "",
  14                       { AutoCommit => 0,
  15                         RaiseError => 1,
  16                         ReadOnly => 1 });
  17
  18 my %iso = ();
  19 find(sub {
  20        if (/\.iso$/ && ! -l && -f) {
  21          my $fn = decode_utf8 $File::Find::name;
  22          $fn =~ s:^$ROOT/::;
  23          $iso{$fn} = 1;
  24        }
  25      }, $ROOT);
  26
  27 my %set_path;
  28 my %set_id;
  29 my %box;
  30 my $st_set = $DB->prepare("SELECT id, name, n_disc FROM dvd_set");
  31 my $st_disc = $DB->prepare
  32   ("SELECT disc, path, box FROM dvd_disc WHERE set_id = ? ORDER BY disc");
  33 $st_set->execute;
  34
  35 while (my @r = $st_set->fetchrow_array) {
  36   my ($id, $name, $ndisc) = @r;
  37   my @path;
  38
  39   $st_disc->execute($id);
  40   while (my @r = $st_disc->fetchrow_array) {
  41     my ($disc, $path, $box) = @r;
  42     $disc == @path or die "bad disc sequence for `$name'";
  43     $box{$path} = $box if defined $box;
  44     push @path, $path;
  45   }
  46   @path == $ndisc or die "wrong number of discs for `$name'";
  47   $set_path{$name} = \@path; $set_id{$name} = $id;
  48 }
  49
  50 for my $name (keys %set_path) {
  51   for my $path (@{$set_path{$name}}) {
  52     if (defined $path && exists $iso{$path}) { delete $iso{$path}; }
  53   }
  54 }
  55
  56 my @iso = sort keys %iso;
  57 my $lastbox = "#nil";
  58 sub set_box ($) {
  59   my ($box) = @_;
  60   $box //= "#nil";
  61   if ($box ne $lastbox) { print "!box $box\n"; $lastbox = $box; }
  62 }
  63
  64 sub path_key ($) {
  65   my ($p) = @_;
  66   if ($p =~ m{^ ([a-z]) / ([^/]+) ((?: / .*)?) $}ix) {
  67     my $init = $1;
  68     my $focus = $2;
  69     my $tail = $3;
  70     my $head = undef;
  71     if ($focus =~ /^ (the | a ) \s+ (\S .*) $/x)
  72       { $head = $1; $focus = $2; }
  73     if (lc $init ne lc substr($focus, 0, 1) &&
  74         $focus =~ /^ (.*) \s+ ($init .*) $/x)
  75       { $head .= (defined $head && " ") . $1; $focus = $2; }
  76     if (defined $head) { return "$init/$focus, $head$tail"; }
  77   }
  78   return $p;
  79 }
  80
  81 for my $name (sort { my $pa = $set_path{$a}[0]; my $ba = $box{$pa} // "~~~";
  82                      my $pb = $set_path{$b}[0]; my $bb = $box{$pb} // "~~~";
  83                      $ba cmp $bb || path_key $pa cmp path_key $pb }
  84                 keys %set_path) {
  85   my $paths = $set_path{$name};
  86   my @unk;
  87   set_box $box{$paths->[0]};
  88   printf "[#%d: %d] %s\n", $set_id{$name}, scalar @$paths, $name;
  89   my $i = 0;
  90   for my $path (@$paths) {
  91     $i++;
  92     if (!defined $path) {
  93       printf "\t!! (disc %d)\n", $i;
  94     } else {
  95       my $fn = "$ROOT/$path";
  96       set_box $box{$path};
  97       if (-f $fn && ! -l $fn) { print "\t" . $path . "\n"; }
  98       else { print "\t!! ". $path . "\n"; }
  99     }
 100   }
 101 }
 102
 103 if (@iso) {
 104   print "[#UNK: *]\n";
 105   for my $path (@iso) { print "\t", $path, "\n"; }
 106 }
 107
 108 $DB->disconnect;