lib/App/IMDBtop.pm

   1 package App::IMDBtop;
   2
   3 use 5.014000;
   4 use strict;
   5 use warnings;
   6
   7 use Getopt::Long;
   8 use IMDB::Film;
   9 use IMDB::Persons;
  10
  11 our $VERSION = '0.001001';
  12
  13 our $warned = 0;
  14
  15 our (%cast_cache, %cast_count);
  16 our ($nr, $min_count, $cache, $cache_root);
  17
  18 sub patched_cast {
  19         my IMDB::Film $self = shift;
  20
  21         my (@cast, $tag, $person, $id, $role);
  22         my $parser = $self->_parser(1);
  23
  24         while($tag = $parser->get_tag('table')) {
  25                 last if $tag->[1]->{class} && $tag->[1]->{class} =~ /^cast_list$/i;
  26         }
  27         while($tag = $parser->get_tag()) {
  28                 last if $tag->[0] eq 'a' && $tag->[1]{href} && $tag->[1]{href} =~ /fullcredits/i;
  29         #       if($tag->[0] eq 'td' && $tag->[1]{class} && $tag->[1]{class} eq 'name') {
  30                         $tag = $parser->get_tag('a');
  31                         if($tag->[1]{href} && $tag->[1]{href} =~ m#name/nm(\d+?)/#) {
  32                                 $person = $parser->get_text;
  33                                 $id = $1;
  34                                 my $text = $parser->get_trimmed_text('/tr');
  35                                 ($role) = $text =~ /\.\.\. (.*)$/;
  36                                 push @cast, {id => $id, name => $person, role => $role} if $person;
  37                         }
  38         #       }
  39         }
  40
  41         \@cast
  42 }
  43
  44 sub add_film {
  45         my ($crit) = @_;
  46         chomp $crit;
  47         my @args = (crit => $crit);
  48         push @args, cache => $cache if defined $cache;
  49         push @args, cache_root => $cache_root if defined $cache_root;
  50         my $film = IMDB::Film->new(@args);
  51         my @cast = @{ $film->cast() };
  52         unless (@cast) {
  53                 warn "Installed IMDB::Film is broken, using patched cast() method\n" unless $warned;
  54                 $warned = 1;
  55                 @cast = @{ patched_cast $film };
  56         }
  57         for my $cast (@cast) {
  58                 my ($id, $name) = ($cast->{id}, $cast->{name});
  59                 $cast_cache{$id} = $name;
  60                 $cast_count{$id}++
  61         }
  62 }
  63
  64 sub print_results {
  65         my $cnt = 0;
  66         for (
  67                 sort {
  68                         $cast_count{$b} <=> $cast_count{$a}
  69                           or $cast_cache{$a} cmp $cast_cache{$b}
  70                   }
  71                   grep {
  72                           !$min_count || $cast_count{$_} > $min_count
  73                   } keys %cast_count) {
  74                 last if $nr && $cnt++ >= $nr;
  75                 say $cast_count{$_} . ' ' . $cast_cache{$_}
  76         }
  77 }
  78
  79 sub run {
  80         GetOptions (
  81                 'n|nr=i'        => \$nr,
  82                 'm|min-count=i' => \$min_count,
  83                 'c|cache!'      => \$cache,
  84                 'cache-root=s'  => \$cache_root,
  85         );
  86
  87         add_film $_ while <>;
  88         print_results
  89 }
  90
  91 1;
  92 __END__
  93
  94 =encoding utf-8
  95
  96 =head1 NAME
  97
  98 App::IMDBtop - list actors that are popular in your movie collection
  99
 100 =head1 SYNOPSIS
 101
 102   use App::IMDBtop;
 103   App::IMDBtop->run
 104
 105 =head1 DESCRIPTION
 106
 107 This module solves a simple problem: you have a list of movies you've
 108 watched (in the form of IMDB IDs), and you are looking for the actors
 109 that have starred most often in these movies.
 110
 111 This module is the backend for the B<imdbtop> script.
 112
 113 =head1 SEE ALSO
 114
 115 L<http://imdb.com>, L<imdbtop>
 116
 117 =head1 AUTHOR
 118
 119 Marius Gavrilescu, E<lt>marius@ieval.roE<gt>
 120
 121 =head1 COPYRIGHT AND LICENSE
 122
 123 Copyright (C) 2016 by Marius Gavrilescu
 124
 125 This library is free software; you can redistribute it and/or modify
 126 it under the same terms as Perl itself, either Perl version 5.24.0 or,
 127 at your option, any later version of Perl 5 you may have available.
 128
 129
 130
 131 =cut