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