50edeccc88
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
|
|
|