forked from HPR/hpr-tools
		
	FAQ/FAQ.mkd, FAQ/Makefile: this version of the FAQ is now out of date
    and probably should be deleted.
InternetArchive/repair_item: script to upload missing shows after tie
    out errors during the normal upload; still under development.
InternetArchive/update_state: script to update show state in the
    'reservations' table in the database. Uses the CMS interface.
Link_Checker/scan_links: under development. Not currently usable.
Miscellaneous/fix_tags: audio metadata manipulation script. Recently
    added to this repo for convenience. Updates for 'experimental::try',
    the official Perl try/catch.
PostgreSQL_Database/add_hosts_to_show, PostgreSQL_Database/hpr_schema_2.pgsql,
    PostgreSQL_Database/nuke_n_pave.sh: an old experimental Pg database
    to take over from the previous MySQL version (from before 2023).
    Kept for reference; never implemented.
		
	
		
			
				
	
	
		
			913 lines
		
	
	
		
			28 KiB
		
	
	
	
		
			Perl
		
	
	
		
			Executable File
		
	
	
	
	
			
		
		
	
	
			913 lines
		
	
	
		
			28 KiB
		
	
	
	
		
			Perl
		
	
	
		
			Executable File
		
	
	
	
	
#!/usr/bin/env perl
 | 
						|
#===============================================================================
 | 
						|
#
 | 
						|
#         FILE: add_hosts_to_show
 | 
						|
#
 | 
						|
#        USAGE: ./add_hosts_to_show -show=N -host=H1 [-host=H2 ... -host=Hn]
 | 
						|
#
 | 
						|
#  DESCRIPTION: Adds one or more hosts to an existing show in the 'HPR2'
 | 
						|
#               database.
 | 
						|
#
 | 
						|
#      OPTIONS: ---
 | 
						|
# REQUIREMENTS: ---
 | 
						|
#         BUGS: ---
 | 
						|
#        NOTES: ---
 | 
						|
#       AUTHOR: Dave Morriss (djm), Dave.Morriss@gmail.com
 | 
						|
#      VERSION: 0.0.5
 | 
						|
#      CREATED: 2017-10-28 18:56:21
 | 
						|
#     REVISION: 2019-07-08 22:53:35
 | 
						|
#
 | 
						|
#===============================================================================
 | 
						|
 | 
						|
use 5.010;
 | 
						|
use strict;
 | 
						|
use warnings;
 | 
						|
use utf8;
 | 
						|
 | 
						|
use Getopt::Long;
 | 
						|
use Pod::Usage;
 | 
						|
 | 
						|
use Config::General;
 | 
						|
use List::Util qw( uniqstr );
 | 
						|
use IO::Prompter;
 | 
						|
 | 
						|
use DBI;
 | 
						|
 | 
						|
use Data::Dumper;
 | 
						|
 | 
						|
#
 | 
						|
# Version number (manually incremented)
 | 
						|
#
 | 
						|
our $VERSION = '0.0.5';
 | 
						|
 | 
						|
#
 | 
						|
# Script and directory names
 | 
						|
#
 | 
						|
( 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_pg2.cfg";
 | 
						|
 | 
						|
my ( $dbh1, $sth1, $h1, $rv1 );
 | 
						|
my ( $show_type, $show_number );
 | 
						|
 | 
						|
my %details;
 | 
						|
 | 
						|
my $pfmt = "%-16s: %s\n";
 | 
						|
 | 
						|
#
 | 
						|
# Enable Unicode mode
 | 
						|
#
 | 
						|
binmode STDOUT, ":encoding(UTF-8)";
 | 
						|
binmode STDERR, ":encoding(UTF-8)";
 | 
						|
 | 
						|
#
 | 
						|
# Load database configuration data
 | 
						|
#
 | 
						|
my $conf = Config::General->new(
 | 
						|
    -ConfigFile      => $configfile,
 | 
						|
    -InterPolateVars => 1,
 | 
						|
    -ExtendedAccess  => 1
 | 
						|
);
 | 
						|
my %config = $conf->getall();
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Options and arguments
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my $DEF_DEBUG = 0;
 | 
						|
 | 
						|
#
 | 
						|
# Process options
 | 
						|
#
 | 
						|
my %options;
 | 
						|
Options( \%options );
 | 
						|
 | 
						|
#
 | 
						|
# Default help
 | 
						|
#
 | 
						|
pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1, -verbose => 0 )
 | 
						|
    if ( $options{'help'} );
 | 
						|
 | 
						|
#
 | 
						|
# The -documentation or -man option shows the full POD documentation through
 | 
						|
# a pager for convenience
 | 
						|
#
 | 
						|
pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1, -verbose => 2 )
 | 
						|
    if ( $options{'documentation'} );
 | 
						|
 | 
						|
#
 | 
						|
# Collect options
 | 
						|
#
 | 
						|
my $DEBUG = ( defined( $options{debug} ) ? $options{debug} : $DEF_DEBUG );
 | 
						|
my $verbose   = ( defined( $options{verbose} ) ? $options{verbose} : 0 );
 | 
						|
my $prompting = ( defined( $options{prompt} )  ? $options{prompt}  : 1 );
 | 
						|
 | 
						|
my $show = $options{show};
 | 
						|
my @hosts = ( defined( $options{host} ) ? @{ $options{host} } : () );
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Basic sanity checks
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1, -verbose => 0 )
 | 
						|
    unless ( $show and @hosts );
 | 
						|
 | 
						|
#
 | 
						|
# Check the show spec conforms
 | 
						|
#
 | 
						|
unless ( ( $show_type, $show_number ) = ( $show =~ /^(hpr|twat)?(\d+)$/ ) ) {
 | 
						|
    warn "Invalid show specification: $show\n\n";
 | 
						|
    pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1,
 | 
						|
        -verbose => 0 );
 | 
						|
}
 | 
						|
 | 
						|
#
 | 
						|
# Ensure the default show type is 'hpr' and the show number contains
 | 
						|
# leading zeroes
 | 
						|
#
 | 
						|
$show_type = 'hpr' unless $show_type;
 | 
						|
$show = sprintf( "%s%04d", $show_type, $show_number );
 | 
						|
 | 
						|
#
 | 
						|
# Remove host duplicates and empty strings
 | 
						|
#
 | 
						|
@hosts = uniqstr @hosts;
 | 
						|
@hosts = grep { !/^\s*$/ } @hosts;
 | 
						|
unless ( scalar(@hosts) > 0 ) {
 | 
						|
    warn "No valid hosts provided\n\n";
 | 
						|
    pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1, -verbose => 0  );
 | 
						|
}
 | 
						|
 | 
						|
#
 | 
						|
# Debug the options and what we did with them
 | 
						|
#
 | 
						|
if ( $DEBUG > 2 ) {
 | 
						|
    print "D> Show type:   $show_type\n";
 | 
						|
    print "D> Show number: $show_number\n";
 | 
						|
    print "D> Show key:    $show\n";
 | 
						|
    print "D> Hosts:       ", join( ", ", @hosts ), "\n";
 | 
						|
}
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Connect to the PostgreSQL database
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my $dbtype = $config{database}->{type} // 'Pg';
 | 
						|
my $dbhost = $config{database}->{host} // '127.0.0.1';
 | 
						|
my $dbport = $config{database}->{port} // 5432;
 | 
						|
my $dbname = $config{database}->{name};
 | 
						|
my $dbuser = $config{database}->{user};
 | 
						|
my $dbpwd  = $config{database}->{password};
 | 
						|
$dbh1
 | 
						|
    = DBI->connect( "dbi:$dbtype:host=$dbhost;database=$dbname;port=$dbport",
 | 
						|
    $dbuser, $dbpwd, { PrintError => 0, AutoCommit => 1 } )
 | 
						|
    or die $DBI::errstr;
 | 
						|
 | 
						|
#
 | 
						|
# Enable client-side UTF8
 | 
						|
#
 | 
						|
$dbh1->{pg_enable_utf8} = 1;
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Collect the details for the nominated show
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
#
 | 
						|
# Initialise the hash where we'll keep show and host details
 | 
						|
#
 | 
						|
$details{$show} = {};
 | 
						|
 | 
						|
#
 | 
						|
# Query to check the details of the nominated show. If the show has multiple
 | 
						|
# hosts already we'll get back multiple rows.
 | 
						|
#
 | 
						|
$sth1 = $dbh1->prepare(
 | 
						|
    q{
 | 
						|
        SELECT
 | 
						|
            e.episode_id AS eid,
 | 
						|
            e.episode_key,
 | 
						|
            e.release_date,
 | 
						|
            e.title,
 | 
						|
            h.host_id AS hid,
 | 
						|
            h.host
 | 
						|
        FROM episodes e
 | 
						|
        JOIN episodes_hosts_xref eh ON (e.episode_id = eh.episode_id)
 | 
						|
        JOIN hosts h ON (h.host_id = eh.host_id)
 | 
						|
        WHERE e.episode_key = ?
 | 
						|
    }
 | 
						|
) or die $DBI::errstr;
 | 
						|
if ( $dbh1->err ) {
 | 
						|
    warn $dbh1->errstr;
 | 
						|
}
 | 
						|
 | 
						|
#
 | 
						|
# Run the query
 | 
						|
#
 | 
						|
$rv1 = $sth1->execute($show);
 | 
						|
if ( $dbh1->err ) {
 | 
						|
    die $dbh1->errstr;
 | 
						|
}
 | 
						|
 | 
						|
#
 | 
						|
# Check the result of the query
 | 
						|
#
 | 
						|
$rv1 = 0 if ( $rv1 eq '0E0' );
 | 
						|
die
 | 
						|
    "Problem finding show $show and associated hosts. Database inconsistency?\n"
 | 
						|
    unless $rv1;
 | 
						|
 | 
						|
#
 | 
						|
# Accumulate details in a hash using 'save_details' to remove duplicates
 | 
						|
#
 | 
						|
while ( $h1 = $sth1->fetchrow_hashref ) {
 | 
						|
    save_details( $details{$show}, 'id',           $h1->{eid} );
 | 
						|
    save_details( $details{$show}, 'release_date', $h1->{release_date} );
 | 
						|
    save_details( $details{$show}, 'title',        $h1->{title} );
 | 
						|
    save_details( $details{$show}, 'hosts', {} );
 | 
						|
    save_details( $details{$show}->{hosts}, $h1->{host}, $h1->{hid} );
 | 
						|
}
 | 
						|
 | 
						|
#
 | 
						|
# Report what we collected
 | 
						|
#
 | 
						|
print_details( \%details, $show, $pfmt );
 | 
						|
print '-' x 80, "\n";
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Find details for the host(s) we are to add
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
#
 | 
						|
# Remove hosts who are already linked to the show. This relies on the host
 | 
						|
# names being an exact match with the host details we got back for the show
 | 
						|
# itself.
 | 
						|
#
 | 
						|
@hosts = clean_host_options( \%details, $show, \@hosts );
 | 
						|
 | 
						|
#
 | 
						|
# Find details of hosts to be added and save them
 | 
						|
#
 | 
						|
save_details( $details{$show}, 'new_hosts', find_hosts( $dbh1, \@hosts ) );
 | 
						|
 | 
						|
#
 | 
						|
# Remove hosts from the 'new_hosts' sub-hash if they match the hosts already
 | 
						|
# linked to this show
 | 
						|
#
 | 
						|
clean_details( \%details, $show );
 | 
						|
 | 
						|
_debug($DEBUG > 2, Dumper(\%details));
 | 
						|
 | 
						|
#
 | 
						|
# Abort if we didn't find all the hosts we were given
 | 
						|
#
 | 
						|
die "Cannot continue - some hosts cannot be added\n"
 | 
						|
    unless keys( %{ $details{$show}->{new_hosts} } );
 | 
						|
 | 
						|
#
 | 
						|
# Display what we're going to do
 | 
						|
#
 | 
						|
print "Host(s) to be added\n";
 | 
						|
for my $host ( keys( %{ $details{$show}->{new_hosts} } ) ) {
 | 
						|
    my $ptr = $details{$show}->{new_hosts};
 | 
						|
    printf $pfmt, 'Host',  $host;
 | 
						|
    printf $pfmt, 'Id',    $ptr->{$host}->{id};
 | 
						|
    printf $pfmt, 'Email', $ptr->{$host}->{email};
 | 
						|
    print '-' x 10, "\n";
 | 
						|
}
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Confirm that we are to add the requested hosts(s) if 'prompting' is on, and
 | 
						|
# do it!
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
if ($prompting) {
 | 
						|
    if (prompt(
 | 
						|
            -style   => 'bold',
 | 
						|
            -prompt  => 'Do you wish to continue? [Y/n] ',
 | 
						|
            -default => 'Y',
 | 
						|
            -yes
 | 
						|
        )
 | 
						|
        )
 | 
						|
    {
 | 
						|
        link_hosts( $dbh1, \%details, $show, $verbose );
 | 
						|
    }
 | 
						|
    else {
 | 
						|
        print "No hosts added\n" if ( $verbose > 0 );
 | 
						|
    }
 | 
						|
}
 | 
						|
else {
 | 
						|
    link_hosts( $dbh1, \%details, $show, $verbose );
 | 
						|
}
 | 
						|
 | 
						|
exit;
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: clean_details
 | 
						|
#      PURPOSE: Check the hosts in the %details hash. If any of the hosts who
 | 
						|
#               are already linked to the show are in the list of new hosts to
 | 
						|
#               add, remove them.
 | 
						|
#   PARAMETERS: $details        Hashref containing details
 | 
						|
#               $show           Show key
 | 
						|
#      RETURNS: Nothing
 | 
						|
#  DESCRIPTION: Walks through the hosts that we were asked to add. They have
 | 
						|
#               been expanded by looking them up in the database and stored in
 | 
						|
#               $details->{$show}->{new_hosts}. If we find them in the list of
 | 
						|
#               hosts linked to this show we remove them from the new hosts
 | 
						|
#               list. This may leave no new hosts of course!
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub clean_details {
 | 
						|
    my ( $details, $show ) = @_;
 | 
						|
 | 
						|
    #
 | 
						|
    # Walk through the hosts that we were asked to add. They have been
 | 
						|
    # expanded by looking them up in the database. If we find them in the list
 | 
						|
    # of hosts linked to this show we remove them from the new hosts list.
 | 
						|
    #
 | 
						|
    foreach my $new ( keys( %{ $details->{$show}->{new_hosts} } ) ) {
 | 
						|
        if ( exists( $details->{$show}->{hosts}->{$new} ) ) {
 | 
						|
            delete( $details->{$show}->{new_hosts}->{$new} );
 | 
						|
        }
 | 
						|
    }
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: link_hosts
 | 
						|
#      PURPOSE: Link the requested host(s) to the nominated show
 | 
						|
#   PARAMETERS: $dbh            Database handle
 | 
						|
#               $details        Hashref containing details
 | 
						|
#               $show           Show key
 | 
						|
#               $verbose        Verbosity level
 | 
						|
#      RETURNS: Nothing
 | 
						|
#  DESCRIPTION: Adds new hosts to the nominated show. These are in the
 | 
						|
#               sub-hash $details->{$show}->{new_hosts} as keys, so we simply
 | 
						|
#               need to loop through them. All hosts have their id numbers, as
 | 
						|
#               does the show itself so we have all that is needed to create
 | 
						|
#               the xref row.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub link_hosts {
 | 
						|
    my ( $dbh, $details, $show, $verbose ) = @_;
 | 
						|
 | 
						|
    my ( $sth, $rv, $show_id );
 | 
						|
 | 
						|
    $verbose = 0 unless $verbose;
 | 
						|
 | 
						|
    #
 | 
						|
    # Query to make a link entry in the xref table
 | 
						|
    #
 | 
						|
    $sth = $dbh->prepare(
 | 
						|
        q{
 | 
						|
            INSERT INTO episodes_hosts_xref VALUES (?,?)
 | 
						|
        }
 | 
						|
    );
 | 
						|
 | 
						|
    $show_id = $details->{$show}->{episode_id};
 | 
						|
 | 
						|
    #
 | 
						|
    # Loop through all the hosts to be added and add them
 | 
						|
    #
 | 
						|
    foreach my $host ( keys( %{ $details->{$show}->{new_hosts} } ) ) {
 | 
						|
        print "Adding $host to $show\n" if ( $verbose > 0 );
 | 
						|
 | 
						|
        $rv = $sth->execute( $show_id,
 | 
						|
            $details->{$show}->{new_hosts}->{$host}->{host_id} );
 | 
						|
        if ( $dbh->err ) {
 | 
						|
            die $dbh->errstr;
 | 
						|
        }
 | 
						|
        $rv = 0 if ( $rv eq '0E0' );
 | 
						|
 | 
						|
        warn "Failed to link $host to $show\n"
 | 
						|
            unless ( defined($rv) );
 | 
						|
    }
 | 
						|
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: find_hosts
 | 
						|
#      PURPOSE: Find the requested hosts by a variety of means
 | 
						|
#   PARAMETERS: $dbh            Database handle
 | 
						|
#               $hosts          Arrayref containing the hosts we want to find
 | 
						|
#      RETURNS: A hash containing the host names and details
 | 
						|
#  DESCRIPTION: Loops through the host names in @$hosts and looks for each one
 | 
						|
#               in the 'hosts' table. If found the the local hash %hosts_found
 | 
						|
#               is populated with the host details. A count of matches is
 | 
						|
#               maintained during this phase. If at the end of it the count is
 | 
						|
#               less than the number of elements of @$hosts then we need to
 | 
						|
#               try again. A local array @missing is then populated with the
 | 
						|
#               missing hosts and used in another loop using the names as regular
 | 
						|
#               expressions. The counter is incremented further in this loop,
 | 
						|
#               and if a host is found it is added to %hosts_found. If the
 | 
						|
#               count of hosts equals the number in @$hosts the function exits
 | 
						|
#               with a reference to %hosts_found, otherwise an empty hash is
 | 
						|
#               returned. Failure to find any host is intended to be used by
 | 
						|
#               the caller as a reason to abort the script (though maybe
 | 
						|
#               further searches could be added in the future).
 | 
						|
#               The regex query takes care that it also counts the number of
 | 
						|
#               matches, so that if a  wildcard host name is used which
 | 
						|
#               matches multiple hosts we ignore the result. That way
 | 
						|
#               "-host='A*'" doesn't match all the hosts with an 'a' in their
 | 
						|
#               name. The regex matching is case insensitive.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub find_hosts {
 | 
						|
    my ( $dbh, $hosts ) = @_;
 | 
						|
 | 
						|
    my ( $sth, $h, $hcount, @found, @missing, %hosts_found );
 | 
						|
 | 
						|
    #
 | 
						|
    # Query to find host by name using an exact match
 | 
						|
    #
 | 
						|
    $sth = $dbh->prepare(
 | 
						|
        q{
 | 
						|
            SELECT * FROM hosts where host = ?
 | 
						|
    }
 | 
						|
    ) or die $DBI::errstr;
 | 
						|
    if ( $dbh->err ) {
 | 
						|
        warn $dbh->errstr;
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # Loop through the host names matching exactly
 | 
						|
    #
 | 
						|
    $hcount = 0;
 | 
						|
    for my $host (@$hosts) {
 | 
						|
        $sth->execute($host);
 | 
						|
        if ( $dbh->err ) {
 | 
						|
            die $dbh->errstr;
 | 
						|
        }
 | 
						|
 | 
						|
        if ( $h = $sth->fetchrow_hashref ) {
 | 
						|
            $hcount++;
 | 
						|
            $hosts_found{$host} = {
 | 
						|
                id    => $h->{host_id},
 | 
						|
                email => $h->{email},
 | 
						|
            };
 | 
						|
        }
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # If we didn't find any hosts have another go
 | 
						|
    #
 | 
						|
    if ( $hcount < scalar(@$hosts) ) {
 | 
						|
        #
 | 
						|
        # Isolate the hosts we didn't find (find the items in @hosts that are
 | 
						|
        # not in @found)
 | 
						|
        #
 | 
						|
        @found = keys(%hosts_found);
 | 
						|
        @missing
 | 
						|
            = grep { my $item = $_; !grep( $_ eq $item, @found ) } @$hosts;
 | 
						|
        #print "D> ",join(", ",@missing),"\n";
 | 
						|
 | 
						|
        #
 | 
						|
        # Query to find host by name using a regex match. This one also
 | 
						|
        # returns the count of hosts since if it's not 1 we don't want to
 | 
						|
        # continue because the regex is too vague. TODO: Does this make sense?
 | 
						|
        #
 | 
						|
        $sth = $dbh->prepare(
 | 
						|
            q{
 | 
						|
                SELECT
 | 
						|
                    (SELECT
 | 
						|
                        count(*) AS count
 | 
						|
                    FROM hosts
 | 
						|
                    WHERE host ~* ?),
 | 
						|
                    host_id,
 | 
						|
                    host,
 | 
						|
                    email
 | 
						|
                FROM hosts
 | 
						|
                WHERE host ~* ?
 | 
						|
            }
 | 
						|
        ) or die $DBI::errstr;
 | 
						|
        if ( $dbh->err ) {
 | 
						|
            warn $dbh->errstr;
 | 
						|
        }
 | 
						|
 | 
						|
        #
 | 
						|
        # Try the regex search on all hosts we didn't find with an exact match
 | 
						|
        #
 | 
						|
        for my $host (@missing) {
 | 
						|
            $sth->execute( $host, $host );
 | 
						|
            if ( $dbh->err ) {
 | 
						|
                die $dbh->errstr;
 | 
						|
            }
 | 
						|
 | 
						|
            if ( $h = $sth->fetchrow_hashref ) {
 | 
						|
                if ( $h->{count} == 1 ) {
 | 
						|
                    $hcount++;
 | 
						|
                    $hosts_found{ $h->{host} } = {
 | 
						|
                        id    => $h->{host_id},
 | 
						|
                        email => $h->{email},
 | 
						|
                    };
 | 
						|
                }
 | 
						|
            }
 | 
						|
        }
 | 
						|
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # We didn't find everyone, so better report this
 | 
						|
    #
 | 
						|
    if ( $hcount < scalar(@$hosts) ) {
 | 
						|
        warn "Did not find all of the nominated hosts\n";
 | 
						|
        return {};
 | 
						|
    }
 | 
						|
 | 
						|
    return \%hosts_found;
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: clean_host_options
 | 
						|
#      PURPOSE: Check the requested hosts (as specified in the options)
 | 
						|
#               against the actual hosts linked to the show
 | 
						|
#   PARAMETERS: $details        Hashref containing details
 | 
						|
#               $show           Show key
 | 
						|
#               $hosts          Arrayref of requested hosts
 | 
						|
#      RETURNS: A list of the hosts that aren't already linked
 | 
						|
#  DESCRIPTION: Places all the hosts associated with the show into an array
 | 
						|
#               then compares it with the @$hosts array such that what is left
 | 
						|
#               is all the hosts that do not match hosts linked to the show.
 | 
						|
#               Of course, if any of the hosts given as options are not exact
 | 
						|
#               matches with the names from the database (they are regexes
 | 
						|
#               perhaps) they'll be regarded as different. We have to do
 | 
						|
#               further processing of what's returned from querying the
 | 
						|
#               database for new hosts elsewhere, but this function should
 | 
						|
#               help to save some unnecessary database queries.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub clean_host_options {
 | 
						|
    my ( $details, $show, $hosts ) = @_;
 | 
						|
 | 
						|
    #
 | 
						|
    # Collect the names of the host(s) already linked to this show
 | 
						|
    #
 | 
						|
    my @show_hosts = keys( %{ $details->{$show}->{hosts} } );
 | 
						|
 | 
						|
    #
 | 
						|
    # Return a list of the hosts that aren't in @show_hosts
 | 
						|
    #
 | 
						|
    return grep { my $item = $_; !grep( $_ eq $item, @show_hosts ) } @$hosts;
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: print_details
 | 
						|
#      PURPOSE: Print accumulated show details
 | 
						|
#   PARAMETERS: $details        Hashref containing details
 | 
						|
#               $show           Show key
 | 
						|
#               $pfmt           Format string for printing
 | 
						|
#      RETURNS: Nothing
 | 
						|
#  DESCRIPTION: Prints the show and linked host information from the %details
 | 
						|
#               hash. To be used after these details have been collected and
 | 
						|
#               before the new hosts have been analysed.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub print_details {
 | 
						|
    my ( $details, $show, $pfmt ) = @_;
 | 
						|
 | 
						|
    my $count = 0;
 | 
						|
 | 
						|
    print "Analysis of show and associated host details\n";
 | 
						|
    printf $pfmt, 'Show key', $show;
 | 
						|
 | 
						|
    my $ptr = $details->{$show};
 | 
						|
 | 
						|
    printf $pfmt, 'Episode id',   $ptr->{episode_id};
 | 
						|
    printf $pfmt, 'Release date', $ptr->{release_date};
 | 
						|
    printf $pfmt, 'Title',        $ptr->{title};
 | 
						|
 | 
						|
    foreach my $host ( keys( %{ $ptr->{hosts} } ) ) {
 | 
						|
        $count++;
 | 
						|
        my $ptr2 = $ptr->{hosts};
 | 
						|
        printf $pfmt, "Host $count",    $host;
 | 
						|
        printf $pfmt, "Host id $count", $ptr2->{$host};
 | 
						|
    }
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: save_details
 | 
						|
#      PURPOSE: Save details of the show and related hosts in a hash
 | 
						|
#   PARAMETERS: $ptr            location to store into
 | 
						|
#               $key            key into the hash (under $ptr)
 | 
						|
#               $value          value to store
 | 
						|
#      RETURNS: Nothing
 | 
						|
#  DESCRIPTION: Simplifes the process of saving information in the %details
 | 
						|
#               hash, skipping the saving process if there is already data
 | 
						|
#               stored. This is needed because the query used to find out
 | 
						|
#               about the show and its host(s) returns more than one row. We
 | 
						|
#               want to make it easy to store one set of show information and
 | 
						|
#               all host information.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub save_details {
 | 
						|
    my ( $ptr, $key, $value ) = @_;
 | 
						|
 | 
						|
    unless ( exists( $ptr->{$key} ) ) {
 | 
						|
        $ptr->{$key} = $value;
 | 
						|
    }
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: coalesce
 | 
						|
#      PURPOSE: To find the first defined argument and return it
 | 
						|
#   PARAMETERS: Arbitrary number of arguments
 | 
						|
#      RETURNS: The first defined argument or undef if there are none
 | 
						|
#  DESCRIPTION: Modelled on the SQL function of the same name. It takes a list
 | 
						|
#               of arguments, scans it for the first one that is not undefined
 | 
						|
#               and returns it. If an argument is defined and it's an arrayref
 | 
						|
#               then the referenced array is returned comma-delimited. This
 | 
						|
#               allows calls such as "coalesce($var,'undef')" which returns
 | 
						|
#               the value of $var if it's defined, and 'undef' if not and
 | 
						|
#               doesn't break anything along the way.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub coalesce {
 | 
						|
    foreach (@_) {
 | 
						|
        if ( defined($_) ) {
 | 
						|
            if ( ref($_) eq 'ARRAY' ) {
 | 
						|
                return join( ',', @{$_} );
 | 
						|
            }
 | 
						|
            else {
 | 
						|
                return $_;
 | 
						|
            }
 | 
						|
        }
 | 
						|
    }
 | 
						|
    return;    # implicit undef
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: _debug
 | 
						|
#      PURPOSE: Prints debug reports
 | 
						|
#   PARAMETERS: $active         Boolean: 1 for print, 0 for no print
 | 
						|
#               $message        Message to print
 | 
						|
#      RETURNS: Nothing
 | 
						|
#  DESCRIPTION: Outputs a message if $active is true. It removes any trailing
 | 
						|
#               newline and then adds one in the 'print' to the caller doesn't
 | 
						|
#               have to bother. Prepends the message with 'D> ' to show it's
 | 
						|
#               a debug message.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub _debug {
 | 
						|
    my ( $active, $message ) = @_;
 | 
						|
 | 
						|
    chomp($message);
 | 
						|
    print "D> $message\n" if $active;
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: Options
 | 
						|
#      PURPOSE: Processes command-line options
 | 
						|
#   PARAMETERS: $optref     Hash reference to hold the options
 | 
						|
#      RETURNS: Undef
 | 
						|
#  DESCRIPTION:
 | 
						|
#       THROWS: no exceptions
 | 
						|
#     COMMENTS: none
 | 
						|
#     SEE ALSO: n/a
 | 
						|
#===============================================================================
 | 
						|
sub Options {
 | 
						|
    my ($optref) = @_;
 | 
						|
 | 
						|
    my @options = (
 | 
						|
        "help",   "documentation|man", "debug=i", "verbose+",
 | 
						|
        "show=s", "host=s@",           "prompt!",
 | 
						|
    );
 | 
						|
 | 
						|
    if ( !GetOptions( $optref, @options ) ) {
 | 
						|
        pod2usage(
 | 
						|
            -msg     => "$PROG version $VERSION\n",
 | 
						|
            -exitval => 1,
 | 
						|
            -verbose => 0
 | 
						|
        );
 | 
						|
    }
 | 
						|
 | 
						|
    return;
 | 
						|
}
 | 
						|
 | 
						|
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 | 
						|
#  Application Documentation
 | 
						|
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 | 
						|
#{{{
 | 
						|
 | 
						|
=head1 NAME
 | 
						|
 | 
						|
add_hosts_to_show - add hosts to a pre-existing show
 | 
						|
 | 
						|
=head1 VERSION
 | 
						|
 | 
						|
This documentation refers to add_hosts_to_show version 0.0.5
 | 
						|
 | 
						|
 | 
						|
=head1 USAGE
 | 
						|
 | 
						|
    add_hosts_to_show -show=SHOW -host=HOST1 [-host=HOST2 ... -host=HOSTn]
 | 
						|
        [-[no]prompt] [-debug=N] [-verbose] [-help] [-documentation]
 | 
						|
 | 
						|
Examples:
 | 
						|
 | 
						|
    ./add_hosts_to_show -show=hpr2297 -host='Andrew Conway'
 | 
						|
    ./add_hosts_to_show -show=2297 -host='Andrew Conway'
 | 
						|
    ./add_hosts_to_show -show=2297 -host='Andrew Conway' -noprompt
 | 
						|
 | 
						|
 | 
						|
=head1 OPTIONS
 | 
						|
 | 
						|
=over 8
 | 
						|
 | 
						|
=item B<-show=SHOW>
 | 
						|
 | 
						|
This mandatory option defines the show which is to be adjusted. The argument
 | 
						|
is a show designation which may consist of one of the following:
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
=item B<hprNNNN>
 | 
						|
 | 
						|
The characters 'B<hpr>' must be followed by a show number, and this will select
 | 
						|
the I<Hacker Public Radio> show with that number.
 | 
						|
 | 
						|
=item B<twatNNNN>
 | 
						|
 | 
						|
The characters 'B<twat>' must be followed by a show number, and this will
 | 
						|
select the I<Today with a Techie> show with that number.
 | 
						|
 | 
						|
=item B<NNNN>
 | 
						|
 | 
						|
A plain number is interpreted as a I<Hacker Public Radio> show as if
 | 
						|
B<hprNNNN> had been specified.
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=item B<-host=HOST>
 | 
						|
 | 
						|
This mandatory option defines a host to be added to the list of show hosts.
 | 
						|
The B<HOST> part must consist of the name of the host. If the name contains
 | 
						|
a space then it must be enclosed in quotes (or escaped).
 | 
						|
 | 
						|
The B<-host=HOST> option may be repeated as many times as needed.
 | 
						|
 | 
						|
The B<HOST> part may be shortened so long as it is unambiguous. The script
 | 
						|
attempts an exact match on the name, but if that fails it will use the name as
 | 
						|
a case insensitive regular expression match, which it will use so long as it
 | 
						|
finds only one match.
 | 
						|
 | 
						|
=item B<-[no]prompt>
 | 
						|
 | 
						|
Normally the script prompts to give an opportunity to cancel the process if an
 | 
						|
error has been made. Specifying B<i-noprompt> turns off this feature.
 | 
						|
 | 
						|
=item B<-verbose>
 | 
						|
 | 
						|
This option, which can be repeated, increases the level of verbosity for each
 | 
						|
use. The levels of verbosity are:
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
0 - minimal reporting
 | 
						|
 | 
						|
1 - simple messages shown
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=item B<-help>
 | 
						|
 | 
						|
Prints a brief help message describing the usage of the program, and then exits.
 | 
						|
 | 
						|
=item B<-documentation> or B<-man>
 | 
						|
 | 
						|
Reports full information about how to use the script and exits.
 | 
						|
 | 
						|
Since the formatting used by the POD parser used here seems faulty, an
 | 
						|
alternative way to view the documentation on-screen is:
 | 
						|
 | 
						|
    pod2man add_hosts_to_show | man -l -
 | 
						|
 | 
						|
Alternatively, to generate a PDF version use the I<pod2pdf> tool from
 | 
						|
I<http://search.cpan.org/~jonallen/pod2pdf-0.42/bin/pod2pdf>. This can be
 | 
						|
installed with the cpan tool as App::pod2pdf.
 | 
						|
 | 
						|
=item B<-debug=N>
 | 
						|
 | 
						|
Selects a level of debugging. Debug information consists of a line or series
 | 
						|
of lines prefixed with the characters 'D>':
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
=item B<0>
 | 
						|
 | 
						|
No debug output is generated: this is the default
 | 
						|
 | 
						|
=item B<3>
 | 
						|
 | 
						|
The results of analysing the options are displayed.
 | 
						|
 | 
						|
The B<%details> hash is dumped after capturing show and linked host details
 | 
						|
and new host details. The hash has also been cleaned of host duplicates.
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=item B<-verbose>
 | 
						|
 | 
						|
Makes the script verbose resulting in the production of more information about
 | 
						|
what it is doing.
 | 
						|
 | 
						|
The script always reports the show details, the linked host details and the
 | 
						|
details of the new hosts that have been requested. It needs to do this in
 | 
						|
order to produce a meaningful prompt.
 | 
						|
 | 
						|
The option may be repeated to increase the level of verbosity. The levels are:
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
=item B<0>
 | 
						|
 | 
						|
No output is generated (apart from errors and warnings if appropriate). This
 | 
						|
is the default level.
 | 
						|
 | 
						|
=item B<1>
 | 
						|
 | 
						|
Once the prompt has been given the script will either report on the addition
 | 
						|
of the new host(s) as it adds them iif the prompt was confirmed, or will
 | 
						|
report that no host has been added if the answer to the prompt was "No".
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=head1 DESCRIPTION
 | 
						|
 | 
						|
A full description of the application and its features.
 | 
						|
May include numerous subsections (i.e. =head2, =head3, etc.)
 | 
						|
 | 
						|
 | 
						|
=head1 DIAGNOSTICS
 | 
						|
 | 
						|
A list of every error and warning message that the application can generate
 | 
						|
(even the ones that will "never happen"), with a full explanation of each
 | 
						|
problem, one or more likely causes, and any suggested remedies. If the
 | 
						|
application generates exit status codes (e.g. under Unix) then list the exit
 | 
						|
status associated with each error.
 | 
						|
 | 
						|
 | 
						|
=head1 CONFIGURATION AND ENVIRONMENT
 | 
						|
 | 
						|
A full explanation of any configuration system(s) used by the application,
 | 
						|
including the names and locations of any configuration files, and the
 | 
						|
meaning of any environment variables or properties that can be set. These
 | 
						|
descriptions must also include details of any configuration language used
 | 
						|
 | 
						|
 | 
						|
=head1 DEPENDENCIES
 | 
						|
 | 
						|
A list of all the other modules that this module relies upon, including any
 | 
						|
restrictions on versions, and an indication whether these required modules are
 | 
						|
part of the standard Perl distribution, part of the module's distribution,
 | 
						|
or must be installed separately.
 | 
						|
 | 
						|
=head1 BUGS AND LIMITATIONS
 | 
						|
 | 
						|
There are no known bugs in this module.
 | 
						|
Please report problems to Dave Morriss (Dave.Morriss@gmail.com)
 | 
						|
Patches are welcome.
 | 
						|
 | 
						|
=head1 AUTHOR
 | 
						|
 | 
						|
Dave Morriss (Dave.Morriss@gmail.com)
 | 
						|
 | 
						|
 | 
						|
=head1 LICENCE AND COPYRIGHT
 | 
						|
 | 
						|
Copyright (c) 2017 Dave Morriss (Dave.Morriss@gmail.com). All rights reserved.
 | 
						|
 | 
						|
This module is free software; you can redistribute it and/or
 | 
						|
modify it under the same terms as Perl itself. See perldoc perlartistic.
 | 
						|
 | 
						|
This program is distributed in the hope that it will be useful,
 | 
						|
but WITHOUT ANY WARRANTY; without even the implied warranty of
 | 
						|
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 | 
						|
 | 
						|
=cut
 | 
						|
 | 
						|
#}}}
 | 
						|
 | 
						|
# [zo to open fold, zc to close]
 | 
						|
 | 
						|
# vim: syntax=perl:ts=8:sw=4:et:ai:tw=78:fo=tcrqn21:fdm=marker
 | 
						|
 |