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