summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rwxr-xr-xvideorm.pl206
1 files changed, 206 insertions, 0 deletions
diff --git a/videorm.pl b/videorm.pl
new file mode 100755
index 0000000..c4046e4
--- /dev/null
+++ b/videorm.pl
@@ -0,0 +1,206 @@
+#! /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, 09 January 2012";
+
+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
+
+videorm.pl - remove movies from your collection without altering its sanity
+
+=head1 SYNOPSIS
+
+B<videorm.pl> [B<-q>] [B<-f>] I<path/to/file>
+
+=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<videorm.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<videorm> provides a way to safely remove movies from your collection.
+More precisely, if I<file> is the basename of its argument, B<videorm>
+will remove the symlink I<MOVIES/file>, its target
+I<DIRECTORS/director/file>, and the corresponding entry in the database.
+
+If your collection is not detected as being sane that is, if there is no
+symlink I<MOVIES/file>, or if its target I<../DIRECTORS/director/file> is
+not a regular file, or if there is not exactly one entry in the database,
+B<videorm> will stop. See the flag B<--force> to go through anyway.
+
+=head1 OPTIONS
+
+=over 8
+
+=item B<-f>, B<--force>
+
+Force the removal even if the collection is not detected as being sane.
+Use at your own risk.
+
+=item B<-q>, B<--quiet>
+
+By default, B<videorm.pl> prints every action it performs, with the
+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 the file, the symlink and the corresponding
+entry in the database have all been deleted.
+The exit status is 1 otherwise.
+
+=head1 REQUIREMENTS
+
+The imported modules are available on CPAN. See the source for details.
+
+=head1 AUTHOR
+
+Copyright 2012 Guilhem Moulin. See the source for copying conditions.
+
+=cut
+
+################################################################################
+
+
+#TODO: explore depth>1 in DIRECTORS/
+
+my $force;
+
+# Get options
+GetOptions( "f|force" => \$force,
+ "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);
+*LOG = *STDERR unless defined (fileno LOG);
+
+my $file = basename ($ARGV[0]);
+
+my $file_s = catfile ($symlinks, $file);
+my $file_d;
+$file_d = catfile ($symlinks, readlink $file_s) if -l $file_s;
+
+
+# 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;
+
+
+# Lookup for the file in the videodb database
+my $res = $dbh->selectall_arrayref ( "SELECT id FROM $config{videodata} WHERE filename = ?",
+ undef, $file )
+ or die "Can't select: " .$dbh->errstr. "\n";
+
+die "Error: Your collection is not sane! (and `--force' is not set).\n"
+ unless ( (-l $file_s and (defined ($file_d) and -f $file_d) and $#$res == 0)
+ or (defined $force) );
+
+
+my $r = 0;
+
+&ack ( "Updating database... ",
+ $dbh->do ( "DELETE FROM $config{videodata} WHERE filename = ?", undef, $file ) > 0);
+
+&ack ( "Deleting symlink... ",
+ -l $file_s && unlink $file_s );
+
+# TODO: if $ARGV[0] is in DIRECTORS, then --force could suppress it even
+# if the database is not sane.
+&ack ( "Deleting target... ",
+ (defined $file_d) && -f $file_d && unlink $file_d );
+
+$dbh->disconnect();
+
+exit $r;
+
+
+
+################################################################################
+
+
+
+# Acknowledge the result of a test
+sub ack {
+ print LOG $_[0];
+ if ($_[1]) {
+ print LOG "OK\n";
+ } else {
+ print LOG "failed!\n";
+ $r = 1;
+ }
+}