hpr-tools/Database/find_series

398 lines
11 KiB
Perl
Executable File

#!/usr/bin/env perl
#===============================================================================
#
# FILE: find_series
#
# USAGE: ./find_series
#
# DESCRIPTION: Gathers information from the HPR database to assist with the
# process of placing episodes into series groups
#
# OPTIONS: ---
# REQUIREMENTS: ---
# BUGS: ---
# NOTES: ---
# AUTHOR: Dave Morriss (djm), Dave.Morriss@gmail.com
# VERSION: 0.0.5
# CREATED: 2014-04-25 17:11:21
# REVISION: 2016-06-15 15:51:55
#
#===============================================================================
use v5.16;
use strict;
use warnings;
use utf8;
use Config::General;
use List::MoreUtils qw(uniq);
use YAML::XS qw{LoadFile};
use DBI;
use Data::Dumper;
#
# Version number (manually incremented)
#
our $VERSION = '0.0.5';
#
# Various constants
#
( my $PROG = $0 ) =~ s|.*/||mx;
( my $DIR = $0 ) =~ s|/?[^/]*$||mx;
$DIR = '.' unless $DIR;
#-------------------------------------------------------------------------------
# Declarations
#-------------------------------------------------------------------------------
#
# Constants and other declarations
#
my $basedir = "$ENV{HOME}/HPR/Database";
my $configfile = "$basedir/.hpr_db.cfg";
my $ignorefile = "$basedir/.$PROG.yml";
my $file_template = "${PROG}_%d.out";
my ( $dbh, $sth1, $h1 );
my ( @ignore, $title, @words, $pair );
my ( %eps, %tags, @taglist, %single_words, %double_words );
my ( $phase, $outfile, $outfh );
#
# Enable Unicode mode
#
binmode STDOUT, ":encoding(UTF-8)";
binmode STDERR, ":encoding(UTF-8)";
#
# Load YAML ignore list
#
my $yaml = LoadFile($ignorefile);
@ignore = uniq( @{ $yaml->{ignore} } );
#
# Load database configuration data
#
my $conf = Config::General->new(
-ConfigFile => $configfile,
-InterPolateVars => 1,
-ExtendedAccess => 1
);
my %config = $conf->getall();
#-------------------------------------------------------------------------------
# Connect to the database
#-------------------------------------------------------------------------------
my $dbhost = $config{database}->{host} // '127.0.0.1';
my $dbport = $config{database}->{port} // 3306;
my $dbname = $config{database}->{name};
my $dbuser = $config{database}->{user};
my $dbpwd = $config{database}->{password};
$dbh = DBI->connect( "dbi:mysql:host=$dbhost;port=$dbport;database=$dbname",
$dbuser, $dbpwd, { AutoCommit => 1 } )
or die $DBI::errstr;
#
# Enable client-side UTF8
#
$dbh->{mysql_enable_utf8} = 1;
#
# Prepare to collect episode titles with the series it's related to
#
$sth1 = $dbh->prepare(
q{SELECT
eps.id AS eps_id,
eps.date,
eps.title,
eps.duration,
eps.summary,
eps.notes,
eps.hostid,
eps.series,
eps.explicit,
eps.license,
eps.tags,
eps.version,
eps.downloads,
eps.valid AS eps_valid,
ms.id AS ms_id,
ms.name,
ms.description,
ms.private,
ms.image,
ms.valid AS ms_valid
FROM eps
JOIN miniseries ms ON eps.series = ms.id
WHERE eps.valid = 1}
);
$sth1->execute;
if ( $dbh->err ) {
warn $dbh->errstr;
}
#
# Generate an output file for phase 1
#
$phase = 1;
newOutput( \$outfh, $file_template, $phase++ );
print $outfh "Show (Series) Title\n";
#-------------------------------------------------------------------------------
# Walk through the episode/series list from the database and build structures
# from them.
#-------------------------------------------------------------------------------
# The structures built are:
#
# %eps - a hash indexed by the episode number with an arrayref as the
# value. The arrayref starts with the episode title and is followed by the
# important words from the title in lower case. The term "important" means
# that the word must consist of the allowed characters and not be in the
# 'ignore' list.
#
# %tags - a hash indexed by the episode number with a CSV string of tags
# associated with the episode as the value.
#
# %single_words - a hash indexed by one of the words collected from the title
# (see %eps above). The value of each element is complex. It consists of an
# arrayref, the first element of which is a count of the succeeding elements.
# The next N elements are arrayrefs each of which contains two elements: an
# episode number and an episode title. Here is an example in Data::Dumper
# format:
#
# 'pre-ibm' => [
# 2,
# [
# 687,
# 'pre-IBM PC computer history 1'
# ],
# [
# 691,
# 'pre-IBM PC computer history 2'
# ]
# ],
#
#-------------------------------------------------------------------------------
while ( $h1 = $sth1->fetchrow_hashref ) {
#
# Report what we found
#
printf $outfh "%4d: (%-2d) %s\n", $h1->{eps_id}, $h1->{ms_id},
$h1->{title};
#
# Skip this episode if it already has a series
#
next if $h1->{series} > 0;
#
# Save this episode for later
#
$eps{ $h1->{eps_id} } = [ $h1->{title} ];
#
# Save tag details
#
$tags{ $h1->{eps_id} } = $h1->{tags};
#
# Strip any trailing full stop, and chop the title into words
#
( $title = $h1->{title} ) =~ s/\.$//;
@words = split( /\s+/, $title );
#
# Remove all unwanted characters and force to lowercase (use 'fc' for case
# folding since it's aware of character sets)
#
foreach my $word (@words) {
$word =~ s{[^a-zA-Z./_-]}{}g;
$word = fc($word);
}
#
# Clean up the word list after removing unwanted characters
#
@words = grep { $_ !~ /^-*$/ } @words;
#
# Extract pairs of words before they're made unique and make a hash
# pointing to the episodes they originated from
#
for (my $i = 0; $i < $#words; $i++) {
$pair = "$words[$i] $words[$i+1]";
if ( exists( $double_words{$pair} ) ) {
$double_words{$pair}->[0] += 1;
push( @{ $double_words{$pair} },
[ $h1->{eps_id}, $h1->{title} ] );
}
else {
$double_words{$pair} = [ 1, [ $h1->{eps_id}, $h1->{title} ] ];
}
}
#
# Make the word list unique
#
@words = uniq(@words);
#
# Walk the tidied single word list
#
foreach my $word (@words) {
#
# Ignore very short words and words in the ignore list
#
next if length($word) < 2;
next if grep( /^$word$/, @ignore );
#
# Save this word in the episodes hash
#
push( @{ $eps{ $h1->{eps_id} } }, $word );
#
# If the word is not known initialise the entry containing an arrayref
# with a counter and another arrayref with the saved episode number
# and title. If it's known, increment the counter and stash the
# episode details as another arrayref.
#
if ( exists( $single_words{$word} ) ) {
$single_words{$word}->[0] += 1;
push( @{ $single_words{$word} },
[ $h1->{eps_id}, $h1->{title} ] );
}
else {
$single_words{$word} = [ 1, [ $h1->{eps_id}, $h1->{title} ] ];
}
}
}
#
# We've finished with the database
#
$dbh->disconnect;
#-------------------------------------------------------------------------------
# Done the first pass, prepare for the next
#-------------------------------------------------------------------------------
newOutput( \$outfh, $file_template, $phase++ );
#
# Process the saved data in increasing order of the frequency. Print the word
# and its frequency and follow that by the stashed episode details in the
# order we saw them
#
foreach my $key (
sort { $single_words{$a}->[0] <=> $single_words{$b}->[0] }
sort( keys(%single_words) )
)
{
if ( $single_words{$key}->[0] > 3 ) {
printf $outfh "%15s: %s\n", $key, $single_words{$key}->[0];
for ( my $i = 1; $i <= $single_words{$key}->[0]; $i++ ) {
printf $outfh "%17s%4d: %s", ' ', @{ $single_words{$key}->[$i] };
@taglist
= split( /\s*,\s*/, $tags{ $single_words{$key}->[$i]->[0] } );
if (@taglist) {
print $outfh " [", join( ",", @taglist ), "]\n";
}
else {
print $outfh "\n";
}
}
print $outfh "\n";
}
}
#-------------------------------------------------------------------------------
# Done the second pass, prepare for the next
#-------------------------------------------------------------------------------
newOutput( \$outfh, $file_template, $phase++ );
#
# Look through the collected data from the point of view of the episode, list
# all the (relevant) words in the title in order and report their frequencies
#
for my $key ( sort { $a <=> $b } keys(%eps) ) {
printf $outfh "%4d: %s\n", $key, $eps{$key}->[0];
for ( my $i = 1; $i < scalar( @{ $eps{$key} } ); $i++ ) {
my $word = $eps{$key}->[$i];
printf $outfh " %15s %d\n", $word, $single_words{$word}->[0];
}
print $outfh "\n";
}
#-------------------------------------------------------------------------------
# Done the third pass, prepare for the next
#-------------------------------------------------------------------------------
newOutput( \$outfh, $file_template, $phase++ );
#
# So the pairs of words we collected earlier might show something interesting.
# Let's see.
#
foreach my $key (
sort { $double_words{$a}->[0] <=> $double_words{$b}->[0] }
sort( keys(%double_words) )
)
{
if ( $double_words{$key}->[0] > 3 ) {
printf $outfh "%15s: %s\n", $key, $double_words{$key}->[0];
for ( my $i = 1; $i <= $double_words{$key}->[0]; $i++ ) {
printf $outfh "%17s%4d: %s", ' ', @{ $double_words{$key}->[$i] };
@taglist
= split( /\s*,\s*/, $tags{ $double_words{$key}->[$i]->[0] } );
if (@taglist) {
print $outfh " [", join( ",", @taglist ), "]\n";
}
else {
print $outfh "\n";
}
}
print $outfh "\n";
}
}
close($outfh);
exit;
#=== FUNCTION ================================================================
# NAME: newOutput
# PURPOSE: Generate a new output file
# PARAMETERS: $fh a scalar ref pointing to a variable to hold a
# file handle
# $template a string suitable for sprintf for defining the
# name of the output file
# $phase an integer to be incorporated into the output
# file name
# RETURNS: Nothing
# DESCRIPTION: Closes any existing file and opens a new one with the same
# file handle. The name of the file is derived from the template
# and the phase number.
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub newOutput {
my ( $fh, $template, $phase ) = @_;
if ($$fh) {
close($$fh) if ( tell($$fh) > -1 );
}
my $outfile = sprintf( $template, $phase );
open( $$fh, '>:encoding(UTF-8)', $outfile )
or die "Unable to open $outfile\n";
return;
}
# vim: syntax=perl:ts=8:sw=4:et:ai:tw=78:fo=tcrqn21:fdm=marker