diff options
| -rwxr-xr-x | videoadd.pl | 311 | ||||
| -rwxr-xr-x | videodb-check.pl | 257 | ||||
| -rw-r--r-- | videodb.rc | 2 | ||||
| -rwxr-xr-x | videomv.pl | 686 |
4 files changed, 1256 insertions, 0 deletions
diff --git a/videoadd.pl b/videoadd.pl new file mode 100755 index 0000000..add8f2a --- /dev/null +++ b/videoadd.pl @@ -0,0 +1,311 @@ +#!/usr/bin/perl -w + +use Getopt::Long qw/:config noauto_abbrev nogetopt_compat no_ignore_case + permute bundling auto_version auto_help/; +use Pod::Usage; +use IMDB::Film; +use Locale::Language qw /code2language LOCALE_LANG_ALPHA_2 + LOCALE_LANG_ALPHA_3/; +use DBI; + +use IPC::Open3; +use File::Basename qw /basename/; +use File::Spec::Functions; +use File::Copy qw /move/; +use Env qw /HOME/; +use Switch qw /Perl6/; +use strict; + +################################################################################ + +# Configuration +my $confile = catfile ($HOME, '.videodb.rc'); +die "Error: Can't read `" .$confile. "'.\n" unless -f $confile; +my %config = do $confile; +die "Error in `" .$confile. "'.\n" if $@ || not %config; + +map { exists $config{$_} || die "Error: Missing `${_}'.\n" } + qw /videodir driver database hostname user port password videodata + imdb url/; + +my $symlinks = catdir($config{videodir},'MOVIES'); # Symlinks folder +die "Error: No such directory: `" .$symlinks. "'.\n" unless -d $symlinks; + +my $directors = catdir($config{videodir},'DIRECTORS'); # Directors folder +die "Error: No such directory: `" .$directors. "'.\n" unless -d $symlinks; + +my %imdb = ( host => $config{imdb}, debug => 0 ); +$config{url} =~ s/\/*$//; + +################################################################################ + +# videoadd [--seen] [--dont-sort] [--search=(title|imdbid)] +# [-o title=...] [ -o year=...] +# file + +################################################################################ + +my $ignoredb_flag; +my $sort_flag = 1; +my %options; +GetOptions( "seen" => sub { $options{seen} = 1 } + , "s|search=s"=> sub { $imdb{crit} = $_[1] } +# , "u|update=s"=> update id/filename + , "o=s" => sub { my ($k,$v) = split /=/, $_[1], 2; + $options{lc $k} = $v; } + , "dont-sort" => sub { undef $sort_flag } + , "ignore-db" => \$ignoredb_flag + , "q|quiet=s" => sub { open LOG, '>', '/dev/null' + or die "Cannot open `/dev/null': $!" } + , "man" => sub { pod2usage(-exitstatus => 0, -verbose => 2) } + ) + or pod2usage(2); +pod2usage(2) if $#ARGV != 0; +*LOG = *STDERR unless defined (fileno LOG); + +my $file = $ARGV[0]; +my %new; + + +################################################################################ +# Connection to the database + +my $dbh; +unless ( defined $ignoredb_flag ) { + # Connect to database + my $dsn = "DBI:$config{driver}:database=$config{database};host=$config{hostname};port=$config{port}"; + $dbh = DBI->connect($dsn, $config{user}, $config{password}) + or die "Error: Can't connect do database.\n"; + $dbh->do( "SET NAMES UTF8" ) or die "Error: Can't set names to UTF-8.\n"; +} + + +################################################################################ +# Look on-line for information on the movie + +if (defined $imdb{crit}) { + # Look up the title/ID on IMDB + + my $single; + my $movie; + + do { + # Bug, see https://rt.cpan.org/Public/Bug/Display.html?id=71429 + open my $STDOUT, '>&', \*STDOUT or die "Can't dup: $!"; + open STDOUT, '>', '/dev/null' or die "Cannot open `/dev/null': $!"; + $movie = new IMDB::Film(%imdb); + close STDOUT or die "Can't close"; + open STDOUT, '>>&', $STDOUT or die "Cannot open: $!"; + die "Something wrong happened: " .$movie->error. "\n" + unless $movie->status; + + my @matches = @{$movie->matched}; + if (@matches) { + # Got several results; Print them, and ask the user to pick up an ID + die "No result found.\n" unless defined $matches[0]->{id}; + + $imdb{crit} = $matches[0]->{id}; + + foreach ( @matches ) { + print $_->{id}. ' - ' .$_->{title}. "\n" + or die "Can't print: $!"; + } + for (my $i=0; $i<72; $i++) {print '=' or die "Can't print: $!"}; + print "\n" or die "Can't print: $!"; + + print "Choose an ID above: [$matches[0]->{id}] " + or die "Can't print: $!"; + if ( <STDIN> =~ /(.+)/ ) { $imdb{crit} = $1 }; + } + else { + $single = 1; + } + } until defined $single; + + # Got a single result; Process the movie + $new{title} = $movie->title(); + $new{language} = lc join (', ', @{$movie->language()}); + $new{imdbid} = $movie->id(); + $new{year} = $movie->year(); + $new{imgurl} = $movie->cover(); + $new{director} = join ', ', map {$_->{name}} @{$movie->directors()}; + $new{actors} = join "\n", map {$_->{name}. '::' .$_->{role}. '::imdb:' .$_->{id}} + @{$movie->cast()}; + $new{country} = join ', ', @{$movie->country()}; + $new{plot} = $movie->storyline(); + $new{rating} = $movie->rating(); # Ignoring #votes and awards + + $new{istv} = 1 if $movie->kind() =~ /tv/; +} +elsif (defined $file) { + # Fill in at least the title, based on the file name... + $new{title} = basename ($file); + $new{title} =~ s/.(avi|ogm|ogg|bin|mpe?g|ra?m|mov|asf|wmv|mkv)$//i; +} + + +# Override imdDB's information with the ones provided +foreach (keys %options) { + $new{$_} = $options{$_}; +} + + +################################################################################ +# Run mplayer on the given file to get A/V codecs, etc. + +if ( defined($file) ) { + $new{filename} = basename ($file); + $new{filesize} = (stat $file)[7]; + $new{filedate} = (stat $file)[9]; # Last modify time in seconds since epoch + + + my @cmd = ('mplayer', '-identify', + '-ao', 'null', '-vo', 'null', '-frames', '0', + $file); + open NULL, '+<', '/dev/null' or die "Can't open `/dev/null': $!"; + open3 '<&NULL', my $OUT, ">&NULL", @cmd or die "Can't run mplayer"; + + + my (@alang, @slang); + foreach my $line (<$OUT>) { + next unless $line =~ m/^ID_/; + chomp $line; + + if ( $line =~ m/^ID_VIDEO_FORMAT=(.*)/ ) { + $new{video_codec} = &video_codec($1); + } + elsif ( $line =~ m/^ID_AUDIO_FORMAT=(.*)/ ) { + $new{audio_codec} = &audio_codec($1); + } + elsif ( $line =~ m/^ID_VIDEO_WIDTH=(.*)/ ) { + $new{video_width} = $1; + } + elsif ( $line =~ m/^ID_VIDEO_HEIGHT=(.*)/ ) { + $new{video_height} = $1; + } + elsif ( $line =~ m/^ID_LENGTH=(.*)/ ) { + $new{runtime} = $1; + die "I won't mess up the db with your crappy empty movie.\n" + if $new{runtime} =~ /^0*\.?0*$/; + $new{runtime} = sprintf "%d", $new{runtime}/60; + } + elsif ( $line =~ m/^ID_AID_\d+_LANG=(.*)/ ) { + push @alang, &code2lang ($1); + } + elsif ( $line =~ m/^ID_SID_\d+_LANG=(.*)/ ) { + push @slang, &code2lang ($1); + } + }; + $new{language} = lc join (', ', @alang) + unless $#alang < 0 and defined $imdb{crit}; + $new{custom1} = lc join (', ', @slang); +} + + +################################################################################ +# Insertion into the database + +unless ( defined $ignoredb_flag ) { + my $INSERT = "INSERT INTO $config{videodata} + SET mediatype = 14"; + if (defined $new{filedate}) { + $INSERT .= ", filedate = FROM_UNIXTIME($new{filedate})"; + delete $new{filedate}; + } + + while (my ($k,$v) = each %new) { + $INSERT .= ", " .$k. " = " .$dbh->quote ($v); + } + $dbh->do($INSERT) or die "Can't insert: $!\n"; +# print $INSERT, "\n"; + + my $ids = $dbh->selectall_arrayref ( "SELECT id FROM $config{videodata} + WHERE filename = ? ", + undef, $new{filename} ); + if ($#$ids == 0) { + print LOG "Check it out! ", + $config{url}, "/show.php?id=", $ids->[0]->[0], "\n" + or die "Can't print: $!"; + } + else { + warn "Warning: Something weird happened during the INSERT.\n"; + } + + $dbh->disconnect; +} + + + +################################################################################ +# Sort the file + +if ( defined ($file) and defined ($sort_flag) ) { + if (defined $new{director}) { + move ( $file, catfile ( $directors, $new{director}, $new{filename} ) ) + or warn "Warning: Cannot move file: $!.\n"; + + symlink catfile( updir(), 'DIRECTORS', $new{director}, $new{filename} ), + catfile( $symlinks, $new{filename} ) + or warn "Warning: Cannot create symlink: $!.\n"; + } + else { + warn "Warning: Cannot move file (no director found).\n" + } +} + + +################################################################################ + + +exit 0; +# Useless, but Perl doesn't see that this filehandle is used more than once +close NULL; # Automatically closed by `open3' + + +################################################################################ + + +# Transform codec codes into proper names +# TODO: Find more codes +sub video_codec { + given ($_[0]) { + when /^0x10000001$/i { return 'MPEG-1'; } + when /^0x10000002$/i { return 'MPEG-2'; } + when /^(MPG4|MP4V)$/i { return 'MPEG-4'; } + when /^MP42$/i { return 'MS MPEG-4 v2'; } + when /^MP43$/i { return 'MS MPEG-4 v3'; } + when /^div3$/i { return 'DivX3'; } + when /^DIV(4|X)$/i { return 'DivX4'; } + when /^DX50$/i { return 'DivX5'; } + when /^XVID$/i { return 'XviD'; } + when /^(avc1|H264)$/i { return 'H.264'; } + when /^VP62$/i { return 'VP6'; } + when /^RV40$/i { return 'rv40'; } + default { return $_[0]; } + } +} + +sub audio_codec { + given ($_[0]) { + when /^1$/i { return 'PCM'; } + when /^2$/i { return 'MS ADPCM'; } + when /^85$/i { return 'MP3'; } + when /^8192$/i { return 'AC-3'; } + when /^353$/i { return 'WMA v2'; } + when /^MP4A$/i { return 'AAC'; } + when /^22127$/i { return 'Vorbis'; } + default { return $_[0]; } + } +} + + +# Convert ISO 639 language codes into full names +sub code2lang { + my $code = $_[0]; + my $lang; + $lang = code2language ($code, LOCALE_LANG_ALPHA_2); + return $lang if defined $lang; + $lang = code2language ($code, LOCALE_LANG_ALPHA_3); + return $lang if defined $lang; + return $code; +} diff --git a/videodb-check.pl b/videodb-check.pl new file mode 100755 index 0000000..8acff46 --- /dev/null +++ b/videodb-check.pl @@ -0,0 +1,257 @@ +#!/usr/bin/perl -w + +# This program is free software. It comes without any warranty, to the +# extent permitted by applicable law. You can redistribute it and/or +# modify it under the terms of the Do What The Fuck You Want To Public +# License, Version 2, as published by Sam Hocevar. +# See http://sam.zoy.org/wtfpl/COPYING for more details. + +$VERSION = "0.1, 27 November 2011"; + +use DBI; +use Pod::Usage; +use File::Spec::Functions; +use Cwd; +use Env qw /HOME/; +use strict; + +################################################################################ + +# Configuration +my $confile = catfile ($HOME, '.videodb.rc'); +die "Can't read `" .$confile. "'\n" unless -f $confile; +my %config = do $confile; +die "Error in `" .$confile. "'\n" if $@ || not %config; + +map { exists $config{$_} || die "Error: Missing `${_}'.\n" } + qw /videodir driver database hostname user port password videodata/; + +my $symlinks = catdir($config{videodir},'MOVIES'); # Symlinks folder +die "Error: No such directory: `" .$symlinks. "'.\n" unless -d $symlinks; + +################################################################################ + +=head1 NAME + +videodb-check.pl - a sanity check for your video collection + +=head1 SYNOPSIS + +B<videodb-check.pl> + +=head1 DISCLAIMER + +Your collection is assumed to have the following structure: two +folders, I<DIRECTORS> and I<MOVIES>, that have the same parent. +I<DIRECTORS> contains one subdirectory for each director, and each movie +lies (B<as a regular file>) in the subdirectory of its director. +The folder I<MOVIES> contains symlinks - one for each movie - that target +to I<../DIRECTORS/director_of_the_movie/movie>. +The behavior of B<videodb-check.pl> is NOT specified if your collection does +not verify these conventions! + + |- ... + |- DIRECTORS + | |- director1 + | |- |- movie11 + | | `- movie12 + | |- director2/ + | `- ... + `- MOVIES + |- movie11 -> ../DIRECTORS/director1/movie1 + |- movie12 -> ../DIRECTORS/director1/movie2 + `- ... + +=head1 DESCRIPTION + +B<videodb-check> performs the following sanity checks on your database +and collection: + +=over 4 + +=item * + +Each entry in the database has a corresponding symlink under the +directory I<MOVIES> of your collection, that in turn has a valid target +in the directory I<DIRECTORS>. + +=item * + +The directory in I<DIRECTORS> coincides with the director(s) found in +the database. + +=item * + +Each symlink in the directory I<MOVIES> of your collection has exactly +one corresponding entry in the database. + +=item * + +No movie in the database has invalid release date, empty title or empty +language. + +=back + +=head1 CONFIGURATION + +B<videodb-check> reads its database configuration from the file +I<$HOME/.videodb.rc>. This file has to be the content of a Perl hash +e.g., + + videodir => catdir($HOME,'video'), + driver => 'mysql', + database => 'videodb', + hostname => '127.0.0.1', + user => 'username', + port => 3306, + password => '******', + videodata => "videodb_videodata", + +=head1 EXIT STATUS + +The exit status is 0 if your collection and database are sane, and 1 +otherwise. + +=head1 REQUIREMENTS + +The imported modules are available on CPAN. See the source for details. + +=head1 AUTHOR + +Copyright 2011-2012 Guilhem Moulin. See the source for copying conditions. + +=cut + +################################################################################ + +if (@ARGV) { + pod2usage(-exitstatus => 0, -verbose => 2) if $ARGV[0] eq '--man'; + pod2usage(2); +} +*LOG = *STDOUT; + +################################################################################ + +# Connect to database +my $dsn = "DBI:$config{driver}:database=$config{database};host=$config{hostname};port=$config{port}"; +my $dbh = DBI->connect($dsn, $config{user}, $config{password}) + or die "Can't connect do database\n"; +$dbh->do( "set names utf8" ) or die; + +################################################################################ + +# Check that all entries in the DB have a symlink, that in turn have a +# valid target + +my $r = 0; # Exit status +my $res = $dbh->selectall_arrayref ( "SELECT filename,director FROM $config{videodata}" ) + or die "Can't select: " .$dbh->errstr. "\n"; + + +my @links; # List of missing symlinks +my @files; # List of symlinks that have a non existing/valid target +my @dirs; # List of symlinks that target to a wrong director +foreach (@$res) { + my @ls = File::Spec->splitdir($_->[0]); + my $l = File::Spec->catfile ($symlinks, $ls[0]); + + unless (-l $l) { + push @links, $_->[0]; + next; + } + + my @target = File::Spec->splitdir (readlink $l); + push @files, $_->[0] + unless ( $target[0] eq File::Spec->updir() + and $target[1] eq "DIRECTORS" + and -f File::Spec->catfile ($symlinks, $_->[0]) ); + + if ( not (defined $_->[1]) or $_->[1] eq '' ) { + push @dirs, $_->[0]. " (no director)"; + } + elsif ( $target[2] ne $_->[1] ) { + push @dirs, $_->[0]. " (" .$target[2]. " <> " .$_->[1]. ")"; + } +} + + +&report ("The following entries are in the DB, but I can't find the files", \@links); +&report ("The following entries don't have a valid target", \@files); +&report ("The following entries target to a wrong director", \@dirs); + + +################################################################################ + +# Check that each symlink has exactly one entry in the DB + +my @filelist; # List of filenames that have <> 1 entry in the DB +opendir (DIR, $symlinks) or die "Can't open dir `" .$symlinks. ".:" .$!. "\n"; +while (my $l = readdir(DIR)) { + next if $l eq File::Spec->curdir(); + next if $l eq File::Spec->updir(); + + my $f = File::Spec->catfile($symlinks, $l); + if ( -d Cwd::realpath($f) ) { + opendir (SUBDIR, Cwd::realpath($f)) + or die "Can't open dir `" .Cwd::realpath($f). ".:" .$!. "\n"; + while (my $d = readdir(SUBDIR)) { + next if $d eq File::Spec->curdir(); + next if $d eq File::Spec->updir(); + push @filelist, File::Spec->catfile($l,$d); + } + closedir(SUBDIR) or die "Can't close: $!\n"; + } + elsif ( -l $f or -f $f ) { + push @filelist, $l; + } +} +closedir(DIR) or die "Can't close: $!\n"; + + +undef @files; +my $sth = $dbh->prepare ( "SELECT id FROM $config{videodata} WHERE filename = ?" ) + or die "Error: " .$dbh->errstr; +foreach (@filelist) { + $sth->execute ($_) or die "Can't select: " .$dbh->errstr. "\n"; + my @res = $sth->fetchrow_array; + die $sth->errstr if $sth->err; + + push @files, $_ unless $#res == 0; +} +$sth->finish; +&report ("The following files have <> 1 corresponding entries in the DB", \@files); + + +&check ( "no release date", "year = 0" ); +&check ( "no language set", "language IS NULL OR language =''" ); +&check ( "no title set", "title IS NULL OR title =''" ); + + +################################################################################ + + +$dbh->disconnect; +exit $r; + + +################################################################################ + + +sub report { + my ($str, $bad) = @_; + if (@$bad) { + print LOG "* " .$str. ":\n"; + foreach (@$bad) { + print LOG " ", $_, "\n"; + } + $r = 1; + } +} + +sub check { + my $bad = $dbh->selectall_arrayref( "SELECT filename + FROM $config{videodata} + WHERE " .$_[1] ) + or die "Can't select: " .$dbh->errstr. "\n"; + &report ("The following files have " .$_[0], [map {$_->[0]} @$bad]); +} @@ -11,3 +11,5 @@ user => 'username', port => 3306, password => '******', videodata => "videodb_videodata", +imdb => 'akas.imdb.com', +url => 'https://videodb.example.org' diff --git a/videomv.pl b/videomv.pl new file mode 100755 index 0000000..a21bc33 --- /dev/null +++ b/videomv.pl @@ -0,0 +1,686 @@ +#! /usr/bin/perl -w + +# This program is free software. It comes without any warranty, to the +# extent permitted by applicable law. You can redistribute it and/or +# modify it under the terms of the Do What The Fuck You Want To Public +# License, Version 2, as published by Sam Hocevar. +# See http://sam.zoy.org/wtfpl/COPYING for more details. + + +$VERSION = "0.2, 10 August 2011"; + +use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat + bundling auto_version auto_help/; +use Pod::Usage; +use DBI; +use File::Basename; +use File::Spec::Functions qw /catfile catdir splitdir updir/; +use File::Copy; +use Cwd qw /realpath/; +use Env qw /HOME/; +use strict; + +################################################################################ + +# Configuration +my $confile = catfile ($HOME, '.videodb.rc'); +die "Can't read `" .$confile. "'\n" unless -f $confile; +my %config = do $confile; +die "Error in `" .$confile. "'\n" if $@ || not %config; + +map { exists $config{$_} || die "Error: Missing `${_}'.\n" } + qw /videodir driver database hostname user port password videodata/; + +my $symlinks = catdir($config{videodir},'MOVIES'); # Symlinks folder +die "Error: No such directory: `" .$symlinks. "'.\n" unless -d $symlinks; + +my $directors = catdir($config{videodir},'DIRECTORS'); # Directors folder +die "Error: No such directory: `" .$directors. "'.\n" unless -d $symlinks; + + +################################################################################ + +=head1 NAME + +videomv.pl - move your videos to or within your collection + +=head1 SYNOPSIS + +B<videomv.pl> [B<--lookup-db>] [B<--ignore-db>] [B<-q>] +I<path/to/oldfile> [{I<MOVIES>,I<DIRECTORS/director/>}I</>[I<newfile>]] + +=head1 DISCLAIMER + +Your collection is assumed to have the following structure: two +folders, I<DIRECTORS> and I<MOVIES>, that have the same parent. +I<DIRECTORS> contains one subdirectory for each director, and each movie +lies (B<as a regular file>) in the subdirectory of its director. +The folder I<MOVIES> contains symlinks - one for each movie - that target +to I<../DIRECTORS/director_of_the_movie/movie>. +The behavior of B<videomv.pl> is NOT specified if your collection does +not verify these conventions! + + |- ... + |- DIRECTORS + | |- director1 + | |- |- movie11 + | | `- movie12 + | |- director2/ + | `- ... + `- MOVIES + |- movie11 -> ../DIRECTORS/director1/movie1 + |- movie12 -> ../DIRECTORS/director1/movie2 + `- ... + +=head1 DESCRIPTION + +Depending on whether I<path/to/> is I<MOVIES/>, +I<DIRECTORS/*/>, or something +else, you will get one of the six behaviors below. For the sake of +readability the paths are relative to the root of your video collection +here, but hopefully other origins or +paths that contain symlinks are fine as well. + +=over 4 + +=item B<videomv.pl> [B<--lookup-db>] I<MOVIES/oldfile> I<MOVIES/newfile> + +I<oldfile> is expected to be an existing symlink in I<MOVIES/>, +which targets to I<../DIRECTORS/director/oldfile>. If +I<oldfile>=I<newfile>, an error will be raised. Otherwise, the following +actions will be performed: + +=over 4 + +=item * + +The old target will be renamed to I<DIRECTORS/director/newfile>, + +=item * + +The old symlink will be deleted, + +=item * + +A new symlink I<MOVIES/newfile> -> I<../DIRECTORS/director/newfile> +will be created, and + +=item * + +The filename in the database will be updated. + +=back + +If the B<--lookup-db> flag is set, the new I<director> will be found on the +database instead of by parsing the path of the old target. + + +=item B<videomv.pl> I<MOVIES/oldfile> I<DIRECTORS/newdirector/>[I<newfile>] + +I<oldfile> is expected to be an existing symlink in I<MOVIES/>, +which targets to I<../DIRECTORS/olddirector/oldfile>. If +I<olddirector/oldfile>=I<newdirector/newfile> +(or if I<olddirector>=I<newdirector> and I<newfile> was not given), +an error will be raised. +Otherwise, the following actions will be performed: + +=over 4 + +=item * + +The old target will be moved to I<DIRECTORS/newdirector/newfile>, +(or to I<DIRECTORS/newdirector/oldfile> if I<newfile> was not given), + +=item * + +The old symlink will be deleted, + +=item * + +A new symlink I<MOVIES/newfile> -> I<../DIRECTORS/newdirector/newfile> +(or -> I<../DIRECTORS/newdirector/oldfile> if I<newfile> was not given) +will be created, and + +=item * + +The filename in the database will be updated unless I<oldfile>=I<newfile>. + +=back + + +=item B<videomv.pl> [B<--lookup-db>] I<DIRECTORS/director/oldfile> I<MOVIES/newfile> + +A symlink I<MOVIES/oldfile> -> I<../DIRECTORS/director/oldfile> is +expected to exist. +If I<oldfile>=I<newfile>, an error will be raised. Otherwise, the following +actions will be performed: + +=over 4 + +=item * + +The old target I<DIRECTORS/director/oldfile> will be renamed to +I<DIRECTORS/director/newfile>, + +=item * + +The old symlink will be deleted, + +=item * + +A new symlink I<MOVIES/newfile> -> I<../DIRECTORS/director/newfile> +will be created, and + +=item * + +The filename in the database will be updated. + +=back + +If the B<--lookup-db> flag is set, the new I<director> will be found on the +database instead of by parsing the path of the old target. + + +=item B<videomv.pl> I<DIRECTORS/olddirector/oldfile> I<DIRECTOR/newdirector/>[I<newfile>] + +A symlink I<MOVIES/oldfile> -> I<../DIRECTORS/olddirector/oldfile> is +expected to exist. +If I<olddirector/oldfile>=I<newdirector/newfile> +(or if I<olddirector>=I<newdirector> and I<newfile> was not given), +an error will be raised. +Otherwise, the following actions will be performed: + +=over 4 + +=item * + +The old target I<../DIRECTORS/olddirector/oldfile> will be moved to +I<../DIRECTORS/newdirector/newfile>, + +=item * + +The old symlink will be deleted, + +=item * + +A new symlink I<MOVIES/newfile> -> I<../DIRECTORS/newdirector/newfile> +will be created, and + +=item * + +The filename in the database will be updated unless I<oldfile>=I<newfile>. + +=back + + +=item B<videomv.pl> B<--lookup-db> I<path/to/oldfile> [I<MOVIES>[I</newfile>]] + +Where I<path/to/> is neither of I<MOVIES/> nor I<DIRECTORS/*/>, +and I<oldfile> is a regular file. +The I<director> will found in the database, and and error will be +raised if no entry is (or multiple entries are) found. +In case of success, the following actions will be performed: + +=over 4 + +=item * + +I<oldfile> will be moved to I<DIRECTORS/director/newfile> +(or to I<DIRECTORS/director/oldfile> if I<newfile> was not given), + +=item * + +A symlink I<MOVIES/newfile> -> I<../DIRECTORS/director/newfile> +(or I<MOVIES/oldfile> -> I<../DIRECTORS/director/oldfile> if I<newfile> +was not given) will be created, and + +=item * + +The filename in the database will be updated unless I<oldfile>=I<newfile>. + +=back + +Note that the B<--lookup-db> flag has to be set for this to work; if not, an error +will be raised. + + +=item B<videomv.pl> I<path/to/oldfile> I<DIRECTOR/director/>[I<newfile>] + +Where I<path/to/> is neither of I<MOVIES/> nor I<DIRECTORS/*/>, +and I<oldfile> is a regular file. +The following actions will be performed: + +=over 4 + +=item * + +I<oldfile> will be moved to I<DIRECTORS/director/newfile> +(or to I<DIRECTORS/director/oldfile> if I<newfile> was not given), + +=item * + +A symlink I<MOVIES/newfile> -> I<../DIRECTORS/director/newfile> +(or I<MOVIES/oldfile> -> I<../DIRECTORS/director/oldfile> if the second +argument was not given) will be created, + +=item * + +The filename in the database will be updated unless I<oldfile>=I<newfile>. + +=back + +=back + +The actions above will be performed in the given order. If some action +fails, B<videomv.pl> will try to revert the successful ones (in reverse +order). + +=head1 OPTIONS + +=over 8 + +=item B<--lookup-db> + +If the second argument is in I<MOVIES/*/> and this flag is set, B<videomv.pl> +will search the I<director> in the data base. An error will be raied if +no entry is (or multiple entries are) found. Look above for details. + +=item B<--ignore-db> + +Do not connect to the database, (thus do not update it with the new +filename). This flag is incompatible with B<--lookup-db>. + +=item B<-q>, B<--quiet> + +By default, B<videomv.pl> prints each action it performs, with their +return status. This flag supresses this behavior. Use at your own risk. + +=back + +=head1 CONFIGURATION + +B<videodb-check> reads its database configuration from the file +I<$HOME/.videodb.rc>. This file has to be the content of a Perl hash +e.g., + + videodir => catdir($HOME,'video'), + driver => 'mysql', + database => 'videodb', + hostname => '127.0.0.1', + user => 'username', + port => 3306, + password => '******', + videodata => "videodb_videodata", + +=head1 EXIT STATUS + +The exit status is 0 if all the actions went through, 1 if some error +happened, and 2 if some action fails and the successful ones have been +smoothly reverted. + +=head1 REQUIREMENTS + +The imported modules are available on CPAN. See the source for details. + +=head1 AUTHOR + +Copyright 2011 Guilhem Moulin. See the source for copying conditions. + +=cut + +################################################################################ + + +#TODO: overwrite existing files? +#TODO: explore depth>1 in DIRECTORS/ + +my $lookupdb_flag; +my $ignoredb_flag; + +# Get options +GetOptions( "lookup-db"=> \$lookupdb_flag, + "ignore-db"=> \$ignoredb_flag, + "q|quiet" => sub { open LOG, '>', '/dev/null' + or die "Cannot open `/dev/null': $!" }, + "man" => sub { pod2usage(-exitstatus => 0, -verbose => 2) } + ) + or pod2usage(2); +pod2usage(2) if ($#ARGV < 0 or $#ARGV > 1); +*LOG = *STDERR unless defined (fileno LOG); + +my ($old_path,$new_path) = @ARGV; +$new_path = $symlinks unless defined $new_path; + +die "Error: incompatible options.\n" if + (defined $lookupdb_flag) and (defined $ignoredb_flag); + +die "Error: `" .$old_path. "' is neither a symlink nor a plain file.\n" + unless (-l $old_path or -f $old_path); + +$new_path = catfile ($new_path, basename($old_path)) + if -d realpath($new_path); +die "Error: `" .$new_path. "' exists.\n" + if (-l $new_path or -f $new_path); + +my $old_filename = basename($old_path); +my $new_filename = basename($new_path); + +# Get the real paths, {..,symlink}-collapse and so on +my $real_old_path = catfile (realpath (dirname($old_path)), $old_filename); +my $real_new_path = catfile (realpath (dirname($new_path)), $new_filename); + +my $real_symlinks = realpath($symlinks); +my @real_symlinks = splitdir($real_symlinks); +my $real_directors = realpath($directors); +my @real_directors = splitdir($real_directors); + + +# Connect to database +my ($dsn, $dbh, $RES, $nRES, $id); +unless (defined $ignoredb_flag) { + $dsn = "DBI:$config{driver}:database=$config{database};host=$config{hostname};port=$config{port}"; + $dbh = DBI->connect($dsn, $config{user}, $config{password}) + or die "Can't connect do database"; + $dbh->do( "set names utf8" ) or die; + + + # Lookup for the file in the videodb database + $RES = + $dbh->selectall_hashref ( "SELECT id,director,title FROM $config{videodata} + WHERE filename = ?", + 'id', undef, $old_filename + ) + or die "Can't select: " .$dbh->errstr. "\n"; + $nRES = scalar (keys %$RES); + + # The ID of the first movie found in the database, if any + $id = each %$RES; +} + +my $r = 0; +my ($old_director, $new_director); +my ($old_symlink, $new_symlink, $new_target, $old_target); + +if (&is_symlink($real_new_path)) { + + # The destination is under $symlinks + + if (defined $lookupdb_flag) { + # Find the new director on the database + + # Ensure there is exactly one entry in the db + die "Error: No entry found in the database while the flag `--lookup-db' was set.\n" + if $nRES == 0; + die "Error: Multiples entries found in the database while the flag `--lookup-db' was set.\n" + if $nRES > 1; + + $new_director = $RES->{$id}->{director}; + $new_director =~ s/ ?: ?/ -/; + $new_director =~ tr@/@_@; + $new_director =~ s/[[:cntrl:]]//; + + # Create directory if it doesn't exist + my $new_dirname = catfile ($directors, $new_director); + unless (-d $new_dirname) { + print STDERR "Directory `$new_dirname' does not exist. "; + until (-d $new_dirname) { + print STDERR "Should I create it? (Y/n) "; + my $a = lc <STDIN>; + chomp $a; + if ($a eq 'y' or $a eq '') { + mkdir $new_dirname + or die "Error: Cannot mkdir `$new_dirname': $!\n"; + } + elsif ($a eq 'n') { + exit 0; + } + } + } + } + + $new_symlink = $new_path; + + if (&is_symlink($real_old_path)) { + + $old_symlink = $old_path; + + # Source is presumably a symlink: ensure it is + die "Error: `" .$old_path. "' is expected to be a symlink.\n" + unless -l $real_old_path; + + $old_target = realpath ($old_path); + die "Error: `" .$old_path. "' is expected to target to `" + .catfile(updir(),'DIRECTORS','*',$old_filename). "'.\n" + unless (defined $new_director + || &is_director(\$new_director, $old_target)); + $new_target = catfile ($directors, $new_director, $new_filename); + } + + elsif (&is_director(\$old_director, $real_old_path)) { + + $old_symlink = catfile ($symlinks, $old_filename); + die "Error: `" .$old_symlink. "' is expected to be a symlink.\n" + unless -l $old_symlink; + die "Error: `" .$old_symlink. "' is expected to target to `" + .catfile(updir(),'DIRECTORS',$old_director,$old_filename) + ."'.\n" + unless realpath($old_symlink) eq realpath($old_path); + + $old_target = $old_path; + + $new_director = $old_director unless defined $new_director; + $new_target = catfile ($directors, $new_director, $new_filename); + } + + else { + $old_target = $old_path; + die "Error: `" .$old_path. "' is expected to be a regular file.\n" + unless -f $old_path; + die "Error: Dunno where to put this file. Try the `--lookup-db' flag.\n" + unless defined $new_director; + + $new_target = catfile ($directors, $new_director, $new_filename); + } +} + +elsif (&is_director(\$new_director, $real_new_path)) { + + # The destination is under $directors/* + + $new_target = $new_path; + $new_symlink = catfile ($symlinks, $new_filename); + + if (&is_symlink($real_old_path)) { + + # Source is presumably a symlink: ensure it is + die "Error: `" .$old_path. "' is expected to be a symlink.\n" + unless -l $real_old_path; + + $old_symlink = $old_path; + $old_target = realpath ($old_path); + } + + elsif (&is_director(\$old_director, $real_old_path)) { + + $old_symlink = catfile ($symlinks, $old_filename); + die "Error: `" .$old_symlink. "' is expected to be a symlink.\n" + unless -l $old_symlink; + die "Error: `" .$old_symlink. "' is expected to target to `" + .catfile(updir(),'DIRECTORS',$old_director,$old_filename) + ."'.\n" + unless realpath($old_symlink) eq realpath($old_path); + + $old_target = $old_path; + } + + else { + $old_target = $old_path; + die "Error: `" .$old_path. "' is expected to be a regular file.\n" + unless -f $old_path; + } +} +else { + die "Error: destination has to be in `" + .$symlinks. "' or in `" .catfile($directors,'*'). "'.\n" + ."See `" .$0. " --man' for details\n"; +} + + +my @actions; # Successful actions + +if (dirname (realpath $old_target) eq dirname (realpath $new_target)) { + &perform ("Renaming target... ", rename $old_target, $new_target) + unless ($old_filename eq $new_filename); +} +else { + &perform ("Moving target... ", move $old_target, $new_target); +} + +my $old_tar; +if (defined $old_symlink) { + $old_tar = readlink $old_symlink; + &perform ("Deleting old symlink... ", unlink $old_symlink); +} + + +&perform ("Creating new symlink... ", + symlink catfile(updir(),'DIRECTORS',$new_director,$new_filename), + $new_symlink); + + +unless (defined $ignoredb_flag || $old_filename eq $new_filename) { + print LOG "Updating database... "; + if ($nRES == 0) { + $r = 2; + print LOG "failed!: no entry found.\n"; + &revert(@actions); + } + elsif ($nRES > 1) { + $r = 2; + print LOG "failed!: multiple entries found.\n"; + &revert(@actions); + } + else { + my $rv = $dbh->do ( "UPDATE $config{videodata} SET filename = ? WHERE id = ?", + undef, $new_filename, $id + ); + &ack (\$r, $rv); + } +} + + +# Disconnect +$dbh->disconnect() unless defined $ignoredb_flag; + +exit $r; + + + +################################################################################ + + + +# Acknowledge the result of a test +sub ack { + my ($r, $test) = @_; + if ($test) { + print LOG "OK\n"; + return 0; + } else { + print LOG "failed!: $!\n"; + $$r = 2 if defined $r; + return 1; + } +} + +# Perform the given action; revert successful changes in case of failing +sub perform { + return if $r; + + my ($action,$test) = @_; + + print LOG $action; + if (&ack (\$r, $test)) { + &revert(@actions); + } + else { + push @actions, $action; + } +} + +# Revert successful changes +sub revert { + my @actions = reverse @_; + + return if $#actions < 0; + + print LOG "\n"; + print STDERR "Failed!: reverting successful changes...\n"; + + while ($#actions >= 0) { + my $rev; + if ($actions[0] =~ /^(Renaming target)(\.{3}) {5}( *)/) { + $actions[0] = $1 .' back'. $2.$3; + $rev = rename $new_target, $old_target; + } + elsif ($actions[0] =~ /^(Moving target)(\.{3}) {5}( *)/) { + $actions[0] = $1 .' back'. $2.$3; + $rev = move $new_target, $old_target; + } + elsif ($actions[0] =~ /^Deleting( old symlink.*)/) { + $actions[0] = 'Creating'. $1; + $rev = symlink $old_tar, $old_symlink; + } + elsif ($actions[0] =~ /^Creating( new symlink.*)/) { + $actions[0] = 'Deleting'. $1; + $rev = unlink $new_symlink; + } + else { + print STDERR "Error: unknown action `" .$actions[0]. "'!\n"; + $actions[0] = undef; + $r = 1; + } + + if (defined $actions[0]) { + print LOG $actions[0]; + &ack (\$r, $rev); + } + shift @actions; + } +} + +# Check wether a path starts with $movies +sub is_symlink { + my @path = splitdir ($_[0]); + my @real_symlinks = @real_symlinks; #local copy + + while ($#real_symlinks>=0 && $#path>=0 && $real_symlinks[0] eq $path[0]) { + shift @real_symlinks; + shift @path; + }; + + if ($#real_symlinks<0 && $#path==0) { + return 1; # That's a "symlink" + } else { + return 0; # That's not a "symlink" + } +} + +# Check wether a path starts with $director/dir, and put `dir' in the +# first argument if that's the case +sub is_director { + my @path = splitdir ($_[1]); + my @real_directors = @real_directors; #local copy + + while ($#real_directors>=0 && $#path>=0 && $real_directors[0] eq $path[0]) { + shift @real_directors; + shift @path; + }; + + if ($#real_directors<0 && $#path>=0) { + ${$_[0]} = $path[0] if defined $_[0]; + return 1; # That's a "director" + } else { + return 0; # That's not a "director" + } +} |