#!/usr/bin/perl -CS -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, 18 February 2012";

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 utf8;
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 userid imdb url/;
$config{prefix} = "" unless exists $config{prefix};

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/\/*$//;

################################################################################

=head1 NAME

videoadd.pl - add movies to your collection

=head1 SYNOPSIS

B<videoadd.pl> [B<-s>] [B<-u>] [B<--ignore-db>] [B<--dont-sort>] [B<-i> I<crit>]
[B<-o> I<key=value>...] [B<--only=>I<field,field,>...] [B<--exclude=>I<field,field,>...]
[B<-q>] (I<filename>|I<title>|I<id>|I<IMDBID>)

=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<videoadd.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<videoadd.pl> add the given movie to your collection. Various data such
as the movie length, the A/V codecs, etc. are read from the metadata of
the movie. One can fetch other data (e.g., year, director, cast, etc.)
from IMDB (option B<-i>). If there is a clash (e.g., language) the metadata
take precedence.
The database is then updated with the new movie (unless B<--ignore-db>
is set), which in turn is put in the right place of the above hierarchy
(unless B<--dont-sort> is set).

The argment is matched against the file names, titles, IDs and IMDBIDs
of your database. If found, then the database is merely updated (and the
hierachy is unchanged) with the new data.

=head1 OPTIONS

=over 8

=item B<-s>, B<--seen>

Mark the movie as seen for the I<userid> of the configuration file.

=item B<-u>, B<--unseen>

Mark the movie as unseen for the I<userid> of the configuration file.

=item B<--ignore-db>

Do not connect to the database, hence do not update it with the new
movie. Note that it may break the sanity of your collection.

=item B<--dont-sort>

Do not put the new movie in I<DIRECTORS/director/movie>, with a
symlink I<MOVIES/movie> -> I<DIRECTORS/director/movie>.
Note that it may break the sanity of your collection.

=item B<-i> I<crit>, B<--imdb=>I<crit>

Search for the given criterion (e.g., a movie title or an IMDB ID) on
IMDB. The retrieved data (such as year, director, cast, etc.) will be
added to the database (unless overriden by B<-o> I<key=value>).

=item B<-o> I<key=value>

Override data with the I<value> provided.
Valid I<key>s are I<title>, I<language >, I<imdbid>, I<year>, I<imgurl>,
I<director>, I<genres>, I<country>, I<plot>, I<rating>, I<istv>.

=item B<--only=>I<field,field,>...

Update only the given fields of the database. Known fields are
I<title>, I<subtitle>, I<language>, I<imdbid>, I<year>, I<imgurl>,
I<director>, I<actors>, I<country>, I<plot>, I<genres>, I<rating>, I<istv>,
I<filename>, I<filesize>, I<filedate>, I<video_codec>, I<audio_codec>,
I<video_width>, I<video_height>, I<runtime>, I<custom1>, I<custom2>,
I<custom3>, I<custom4>.

Two meta-fields are also available:

=over 4

=item *

I<imdb>, which stands for
I<title>, I<subtitle>, I<language>, I<imdbid>, I<year>, I<imgurl>,
I<director>, I<actors>, I<country>, I<plot>, I<genres>, I<rating>,
I<istv>, and

=item *

I<file>, which stands for
I<filename>, I<filesize>, I<filedate>, I<video_codec>, I<audio_codec>,
I<video_width>, I<video_height>, I<runtime>, I<language>.

=back

=item B<--exclude=>I<field,field,>...

Do not update the given fields of the database. See B<--only> above for
details.

=item B<-q>, B<--quiet>

Do not print the final URL for the freshly added movie.

=back

=head1 CONFIGURATION

B<videoadd> 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  => '******',
  prefix    => "videodb_",
  userid    => 1,
  imdb      => 'akas.imdb.com',
  url       => 'https://videodb.example.org',

=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


################################################################################

my $ignoredb_flag;
my $seen_flag;
my $unseen_flag;
my $sort_flag = 1;
my %options;
my @only;
my @exclude;
GetOptions( "s|seen"    => \$seen_flag
          , "u|unseen"  => \$unseen_flag
          , "ignore-db" => \$ignoredb_flag
          , "dont-sort" => sub { undef $sort_flag }
          , "i|imdb=s"  => sub { $imdb{crit} = $_[1] }
          , "o=s"       => sub { my ($k,$v) = split /=/, $_[1], 2;
                                 $options{lc $k} = $v; }
          , "only=s"    => sub { @only = &keywords (split /,/, $_[1]) }
          , "exclude=s" => sub { @exclude = &keywords (split /,/, $_[1]) }
          , "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);

################################################################################
# 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}";
    if (exists $config{dbi_misc}) {
        while (my ($k,$v) = each $config{dbi_misc}) {
            $dsn .= ";$k=$v";
        }
    }
    $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";
}

my $id;
my $file = &getfile ($ARGV[0]);
my %new = ( owner_id => $config{userid}
          , customs  => {});


################################################################################
# Look on-line for information on the movie

if ( defined ($imdb{crit}) and &runIMDB() ) {
    # Look up the title/ID on IMDB

    my $single;
    my $movie;

    do {
        $movie = new IMDB::Film(%imdb);
        die "Error: " .$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 {&mkcast($_)} @{$movie->full_cast()};
    $new{country}  = join ', ', @{$movie->country()};
    $new{plot}     = $movie->storyline(); # TODO; plot vs. full_plot vs. storyline?
    $new{genres}   = $movie->genres();
    $new{rating}   = $movie->rating(); # Ignoring #votes and awards
    $new{istv}     = 1 if $movie->kind() =~ /tv/;

    # Convert the retrieved data to UTF-8
    map { utf8::encode($new{$_})
          if exists ($new{$_}) and defined ($new{$_}) and $new{$_} ne ""
             and not utf8::is_utf8($new{$_}) }
        qw/title subtitle language diskid comment disklabel imgurl director
           actors country filename plot/;
    map { utf8::encode($_) unless utf8::is_utf8($_) } @{$new{genres}};
}
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 my $k (keys %options) {
    die "Error: Unknown key `" .$k. "'.\n"
        unless grep { $_ eq $k }
                    qw/title language imdbid year imgurl genres
                       director country plot rating istv/;
    $new{$k} = $options{$k};
    $new{$k} = [ split /,\s*/, $new{$k} ] if $k eq 'genres';
}


################################################################################
# Run mplayer on the given file to get A/V codecs, etc.

if ( defined($file) and &runMplayer() ) {
    $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};
    # The "Subtitles" field is not hard-coded: insert it in the "custom" field instead
    $new{customs}->{subtitles} = lc join (', ', @slang);
}
 

################################################################################
# Insertion into the database

unless ( defined $ignoredb_flag ) {
    # Handle custom fields
    my $customs = $dbh->selectall_arrayref ( "SELECT opt,value FROM $config{prefix}config
                                             WHERE opt REGEXP '^custom[1-9]+\$'" )
                      or die "Can't select: $!\n";
    foreach my $c (@$customs) {
        if (grep {lc $_ eq lc $c->[1]} (keys %{$new{customs}})) {
            $new{$c->[0]} = $new{customs}->{lc $c->[1]};
        }
    }
    delete $new{customs};

    # Get the (first found) mediatype for files on the hard disk
    my $mediatype = $dbh->selectrow_arrayref( "SELECT id FROM $config{prefix}mediatypes
                                               WHERE name = ?", undef, 'HDD' )
                        or die "Can't select. (Unknown mediatype `HDD'?)\n";

    # Get the genre IDs
    my @genres;
    if (&include('genres') and @{$new{genres}}) {
        my $sth_selgenre = $dbh->prepare( "SELECT id FROM $config{prefix}genres WHERE name = ?" )
                               or die "Error: " .$dbh->errstr;
        my $sth_insgenre = $dbh->prepare( "INSERT INTO $config{prefix}genres SET name = ?" )
                               or die "Error: " .$dbh->errstr;
        foreach my $g (@{$new{genres}}) {
            $sth_selgenre->execute ($g);
            my @gids = $sth_selgenre->fetchrow_array;
            die $sth_selgenre->errstr if $sth_selgenre->err;
            unless (@gids) {
                # Insert non existing genres
                $sth_insgenre->execute ($g);
                die $sth_insgenre->errstr if $sth_insgenre->err;
                $sth_selgenre->execute ($g);
                @gids = $sth_selgenre->fetchrow_array;
                die $sth_selgenre->errstr if $sth_selgenre->err;
            }
            push @genres, @gids;
        }
        $sth_selgenre->finish;
        $sth_insgenre->finish;
    }
    delete $new{genres};

    my @SET;
    if (&include('filedate') && defined $new{filedate}) {
        push @SET, "filedate = FROM_UNIXTIME($new{filedate})";
        delete $new{filedate};
    }
    push @SET, "mediatype = $mediatype->[0]"
        if defined ($mediatype) and defined ($mediatype->[0]);

    while (my ($k,$v) = each %new) {
        next unless &include ($k);
        push @SET, $k. " = " .$dbh->quote ($v) if defined $v;
    }

    my $ok = 1;
    if (defined $id) {
        # We got an already existing movie
        push @SET, "lastupdate = NOW()";
        $dbh->do( "UPDATE $config{prefix}videodata
                   SET " .join (', ', @SET). "
                   WHERE id = $id" )
            or die "Can't update: $!\n";

        if (&include ('genres')) {
            $dbh->do( "DELETE FROM $config{prefix}videogenre
                       WHERE video_id = $id" )
                or die "Can't delete: $!\n";
        }
        if (defined $unseen_flag) {
            $dbh->do( "DELETE FROM $config{prefix}userseen
                       WHERE video_id = $id
                         AND user_id = $config{userid}" )
                or die "Can't delete: $!\n";
        }
    }
    else {
        # We got a fresh movie to insert
        push @SET, "created = NOW()";
        $dbh->do( "INSERT INTO $config{prefix}videodata
                   SET " .join (', ', @SET) )
            or die "Can't insert: $!\n";

        my $ids = $dbh->selectall_arrayref ( "SELECT id FROM $config{prefix}videodata
                                              WHERE filename = ? ",
                                             undef, $new{filename} )
                      or die "Can't select: $!\n";
    
        if ($#$ids == 0) {
            $id = $ids->[0]->[0];
        }
        else {
            $ok = 0;
            warn "Warning: Something weird happened during the INSERT. You should probably check the sanity of your collection.\n";
        }
    }
    
    if ($ok) {
        # Update the userseen & videogenre tables
        if (defined $seen_flag) {
            $dbh->do( "INSERT INTO $config{prefix}userseen
                       SET video_id = $id,
                           user_id = $config{userid}" )
                or die "Can't insert: $!\n";
        }
        if (&include ('genres')) {
            my $sth_insgenre = $dbh->prepare( "INSERT INTO $config{prefix}videogenre
                                               SET video_id = $id,
                                                   genre_id = ?" )
                                   or die "Error: " .$dbh->errstr;
            foreach (@genres) {
                $sth_insgenre->execute ($_);
                die $sth_insgenre->errstr if $sth_insgenre->err;
            }
            $sth_insgenre->finish;
        }

        print LOG "Check it out! ", $config{url}. "/show.php?id=" .$id, "\n"
            or die "Can't print: $!";
    }

    $dbh->disconnect;
}



################################################################################
# Sort the file

if ( defined ($file) and defined ($sort_flag) ) {
    if (defined $new{director}) {
        my $dir = catdir ( $directors, $new{director} );
        unless (-d $dir) {
            print STDERR "Directory `$dir' does not exist. ";
            until (-d $dir) {
                print STDERR "Should I create it? (Y/n) ";
                my $a = lc <STDIN>;
                chomp $a;
                if ($a eq 'y' or $a eq '') {
                    mkdir $dir
                        or die "Error: Cannot mkdir `$dir': $!\n";
                }
                elsif ($a eq 'n') {
                    exit 0;
                }
            }
        }
        move ( $file, catfile ( $dir, $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;
}

sub mkcast {
    no warnings 'uninitialized'; 
    return $_->{name}. '::' .$_->{role}. '::imdb:' .$_->{id};
}

# Try to find a matching entry in the database.
sub getfile {
    my $crit = $_[0];
    return $crit if defined $ignoredb_flag;
    
    my $SELECT = "SELECT id, imdbid, filename FROM $config{prefix}videodata
                  WHERE ";
    if ($crit =~ /^[0-9]+$/) {
        $SELECT .= "id = $crit OR imdbid = 'imdb:$crit'"; 
    }
    elsif ($crit =~ /.(avi|ogm|ogg|bin|mpe?g|ra?m|mov|asf|wmv|mkv)$/i) {
        $SELECT .= "filename = " .$dbh->quote (basename ($crit));
    }
    else {
        $SELECT .= "title LIKE " .$dbh->quote ('%'.$crit.'%');
    }

    my $res = $dbh->selectall_arrayref( $SELECT ) or die "Can't select: $!\n";

    # TODO: print the list and ask the user to choose instead?
    die "Error: Multiple entries found in the database. Try to refine your search.\n"
        if $#$res > 0;

    if ($#$res == 0) {
        $id = $res->[0]->[0];
        my $imdbid = $res->[0]->[1];
        print STDERR "Updating ID $id...\n";

        unless (defined $imdb{crit}) {
            warn "Warning: No imdbID found for ID $id. Try `--imdb'.\n"
                unless defined $imdbid;
            $imdb{crit} = $imdbid;
        }
        undef $sort_flag;

        return catfile($config{videodir}, 'MOVIES', $res->[0]->[2]);
    }

    # We have a new file to add to the database
    die "Error: No such file `" .$crit. "' (and I can't find a matching entry in the database).\n"
        unless -f $crit;
    return $crit;
}

sub keywords {
    my @ret;
    foreach my $k (@_) {
        if (lc $k eq 'imdb') {
            push @ret, qw/title subtitle language imdbid year imgurl
                          director actors country plot genres rating istv/;
        }
        elsif (lc $k eq 'file') {
            push @ret, qw/filename filesize filedate
                          video_codec audio_codec video_width video_height
                          runtime language/;
        }
        else {
            die "Error: Unknown field `" .$k. "'.\n"
                unless grep { $_ eq $k }
                            qw/title subtitle language imdbid year imgurl
                               director actors country plot genres rating istv
                               filename filesize filedate video_codec
                               audio_codec video_width video_height runtime
                               custom1 custom2 custom3 custom4/;
            push @ret, lc $k;
        }
    }
    return @ret;
}

sub include {
    # Returns 1 if the key should be included, 0 otherwise
    my $k = $_[0];
    return 0 if grep {$_ eq $k} @exclude;
    return 0 if @only and not (grep {$_ eq $k} @only);
    return 1;
}

sub runIMDB {
    # Returns 1 if there is need to retrieve some data online, 0 otherwise

    foreach (qw/title subtitle language imdbid year imgurl
                director actors country plot genres rating istv
                custom1 custom2 custom3 custom4/) {
        return 1 if &include($_);
    }
    return 0;
}

sub runMplayer {
    # Returns 1 if there is need to run mplayer, 0 otherwise

    foreach ( qw/filename filesize filedate
                 video_codec audio_codec video_width video_height
                 runtime language
                 custom1 custom2 custom3 custom4/) {
        return 1 if &include($_);
    }
    return 0;
}