From af9129f1e069552a075ca4845f07b1e1fe317b40 Mon Sep 17 00:00:00 2001 From: Guilhem Moulin Date: Mon, 9 Jan 2012 21:45:07 +0100 Subject: videorm --- videorm.pl | 206 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 206 insertions(+) create mode 100755 videorm.pl diff --git a/videorm.pl b/videorm.pl new file mode 100755 index 0000000..f94a52e --- /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 [B<-q>] [B<-f>] I + +=head1 DISCLAIMER + +Your collection is assumed to have the following structure: two +folders, I and I, that have the same parent. +I contains one subdirectory for each director, and each movie +lies (B) in the subdirectory of its director. +The folder I contains symlinks - one for each movie - that target +to I<../DIRECTORS/director_of_the_movie/movie>. +The behavior of B 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 provides a way to safely remove movies from your collection. +More precisely, if I is the basename of its argument, B +will remove the symlink I, its target +I, and the corresponding entry in the database. + +If your collection is not detected as being sane that is, if there is no +symlink I, 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 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 prints every action it performs, with the +return status. This flag supresses this behavior. Use at your own risk. + +=back + +=head1 CONFIGURATION + +B 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 2011 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; + } +} -- cgit v1.2.3