forked from HPR/hpr-tools
		
	
		
			
				
	
	
		
			865 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			Perl
		
	
	
		
			Executable File
		
	
	
	
	
			
		
		
	
	
			865 lines
		
	
	
		
			26 KiB
		
	
	
	
		
			Perl
		
	
	
		
			Executable File
		
	
	
	
	
#!/usr/bin/env perl
 | 
						|
#===============================================================================
 | 
						|
#
 | 
						|
#         FILE: reserve_cnews
 | 
						|
#
 | 
						|
#        USAGE: ./reserve_cnews [-from[=DATE]] [-count=COUNT] [-[no]dry-run]
 | 
						|
#                       [-[no]silent] [-config=FILE] [-help] [-debug=N]
 | 
						|
#
 | 
						|
#  DESCRIPTION: Reserve a series of slots from a given date for the Community
 | 
						|
#               News shows by computing the dates for the reservations and
 | 
						|
#               then working out the show numbers from there.
 | 
						|
#
 | 
						|
#      OPTIONS: ---
 | 
						|
# REQUIREMENTS: ---
 | 
						|
#         BUGS: ---
 | 
						|
#        NOTES: ---
 | 
						|
#       AUTHOR: Dave Morriss (djm), Dave.Morriss@gmail.com
 | 
						|
#      VERSION: 0.0.14
 | 
						|
#      CREATED: 2014-04-29 22:16:00
 | 
						|
#     REVISION: 2023-04-10 16:05:36
 | 
						|
#
 | 
						|
#===============================================================================
 | 
						|
 | 
						|
use 5.010;
 | 
						|
use strict;
 | 
						|
use warnings;
 | 
						|
use utf8;
 | 
						|
 | 
						|
use Getopt::Long;
 | 
						|
use Pod::Usage;
 | 
						|
 | 
						|
use Config::General;
 | 
						|
 | 
						|
use Date::Parse;
 | 
						|
use Date::Calc qw{:all};
 | 
						|
 | 
						|
use DBI;
 | 
						|
 | 
						|
use Data::Dumper;
 | 
						|
 | 
						|
#
 | 
						|
# Version number (manually incremented)
 | 
						|
#
 | 
						|
our $VERSION = '0.0.14';
 | 
						|
 | 
						|
#
 | 
						|
# Script name
 | 
						|
#
 | 
						|
( my $PROG = $0 ) =~ s|.*/||mx;
 | 
						|
( my $DIR  = $0 ) =~ s|/?[^/]*$||mx;
 | 
						|
$DIR = '.' unless $DIR;
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Declarations
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
#
 | 
						|
# Constants and other declarations
 | 
						|
#
 | 
						|
my $basedir    = "$ENV{HOME}/HPR/Community_News";
 | 
						|
my $configfile = "$basedir/.hpr_db.cfg";
 | 
						|
 | 
						|
my $hostname   = 'HPR Volunteers';
 | 
						|
my $seriesname = 'HPR Community News';
 | 
						|
my $tags       = 'Community News';
 | 
						|
 | 
						|
my $titlefmt   = 'HPR Community News for %s %d';
 | 
						|
my $summaryfmt = 'HPR Volunteers talk about shows released and comments '
 | 
						|
    . 'posted in %s %d';
 | 
						|
 | 
						|
my ( $dbh, $sth1, $sth2, $sth3, $h1, $h2, $rv );
 | 
						|
my (@startdate, @rdate,  @lastmonth, $show,
 | 
						|
    $hostid,    $series, $title,     $summary
 | 
						|
);
 | 
						|
 | 
						|
#
 | 
						|
# Enable Unicode mode
 | 
						|
#
 | 
						|
binmode STDOUT, ":encoding(UTF-8)";
 | 
						|
binmode STDERR, ":encoding(UTF-8)";
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Options and arguments
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my $DEFDEBUG  = 0;
 | 
						|
my $DEF_COUNT = 12;
 | 
						|
 | 
						|
#
 | 
						|
# Process options
 | 
						|
#
 | 
						|
my %options;
 | 
						|
Options( \%options );
 | 
						|
 | 
						|
#
 | 
						|
# Default help
 | 
						|
#
 | 
						|
pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1 )
 | 
						|
    if ( $options{'help'} );
 | 
						|
 | 
						|
#
 | 
						|
# Collect options
 | 
						|
#
 | 
						|
my $DEBUG = ( $options{'debug'} ? $options{'debug'} : $DEFDEBUG );
 | 
						|
my $cfgfile
 | 
						|
    = ( defined( $options{config} ) ? $options{config} : $configfile );
 | 
						|
my $dry_run = ( defined( $options{'dry-run'} ) ? $options{'dry-run'} : 0 );
 | 
						|
my $silent  = ( defined( $options{silent} )    ? $options{silent}    : 0 );
 | 
						|
my $count = ( defined( $options{count} ) ? $options{count} : $DEF_COUNT );
 | 
						|
my $from = $options{from};
 | 
						|
 | 
						|
_debug( $DEBUG >= 1, 'Host name: ' . $hostname );
 | 
						|
_debug( $DEBUG >= 1, 'Series name: ' . $seriesname );
 | 
						|
_debug( $DEBUG >= 1, 'Tags: ' . $tags );
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Configuration file - load data
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my $conf = new Config::General(
 | 
						|
    -ConfigFile      => $cfgfile,
 | 
						|
    -InterPolateVars => 1,
 | 
						|
    -ExtendedAccess  => 1
 | 
						|
);
 | 
						|
my %config = $conf->getall();
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Connect to the database
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my $dbhost = $config{database}->{host} // '127.0.0.1';
 | 
						|
my $dbport = $config{database}->{port} // 3306;
 | 
						|
my $dbname = $config{database}->{name};
 | 
						|
my $dbuser = $config{database}->{user};
 | 
						|
my $dbpwd  = $config{database}->{password};
 | 
						|
$dbh = DBI->connect( "dbi:mysql:host=$dbhost;port=$dbport;database=$dbname",
 | 
						|
    $dbuser, $dbpwd, { AutoCommit => 1 } )
 | 
						|
    or die $DBI::errstr;
 | 
						|
 | 
						|
#
 | 
						|
# Enable client-side UTF8
 | 
						|
#
 | 
						|
$dbh->{mysql_enable_utf8} = 1;
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Find the latest show for reference purposes
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
$sth1 = $dbh->prepare(
 | 
						|
#    q{SELECT id, date FROM eps
 | 
						|
#        WHERE DATEDIFF(date,CURDATE()) <= 0 AND DATEDIFF(date,CURDATE()) >= -2
 | 
						|
#        ORDER BY date DESC LIMIT 1}
 | 
						|
    q{SELECT id, date FROM eps
 | 
						|
        WHERE DATEDIFF(date,CURDATE()) BETWEEN -2 AND 0
 | 
						|
        ORDER BY date DESC LIMIT 1}
 | 
						|
);
 | 
						|
$sth1->execute;
 | 
						|
if ( $dbh->err ) {
 | 
						|
    warn $dbh->errstr;
 | 
						|
}
 | 
						|
 | 
						|
$h1 = $sth1->fetchrow_hashref;
 | 
						|
 | 
						|
my $ref_date = $h1->{date};
 | 
						|
my $ref_show = $h1->{id};
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Find the required hostid
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
$sth1 = $dbh->prepare(q{SELECT hostid FROM hosts WHERE host = ?});
 | 
						|
$sth1->execute($hostname);
 | 
						|
if ( $dbh->err ) {
 | 
						|
    warn $dbh->errstr;
 | 
						|
}
 | 
						|
 | 
						|
unless ( $h1 = $sth1->fetchrow_hashref ) {
 | 
						|
    warn "Unable to find host '$hostname' - cannot continue\n";
 | 
						|
    exit 1;
 | 
						|
}
 | 
						|
 | 
						|
$hostid = $h1->{hostid};
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Find the required series
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
$sth1 = $dbh->prepare(q{SELECT id FROM miniseries WHERE name = ?});
 | 
						|
$sth1->execute($seriesname);
 | 
						|
if ( $dbh->err ) {
 | 
						|
    warn $dbh->errstr;
 | 
						|
}
 | 
						|
 | 
						|
unless ( $h1 = $sth1->fetchrow_hashref ) {
 | 
						|
    warn "Unable to find series '$seriesname' - cannot continue\n";
 | 
						|
    exit 1;
 | 
						|
}
 | 
						|
 | 
						|
$series = $h1->{id};
 | 
						|
 | 
						|
_debug( $DEBUG >= 2, 'Reference date: ' . $ref_date );
 | 
						|
_debug( $DEBUG >= 2, 'Reference show: ' . $ref_show );
 | 
						|
_debug( $DEBUG >= 2, 'Host id: ' . $hostid );
 | 
						|
_debug( $DEBUG >= 2, 'Series id: ' . $series );
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# The start date comes from the -from=DATE option, the database or is defaulted
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
#
 | 
						|
# Use the date provided or the default
 | 
						|
#
 | 
						|
if ( ! defined( $from ) ) {
 | 
						|
    #
 | 
						|
    # Compute the first of the current month
 | 
						|
    #
 | 
						|
    _debug($DEBUG >= 3, "From date: Default");
 | 
						|
    @startdate = ( ( Today() )[ 0 .. 1 ], 1 );
 | 
						|
}
 | 
						|
elsif ( $from =~ /^$/ ) {
 | 
						|
    _debug($DEBUG >= 3, "From date: Database");
 | 
						|
    @startdate = get_next_date( $dbh, $series );
 | 
						|
}
 | 
						|
else {
 | 
						|
    #
 | 
						|
    # Parse the date, convert to start of month
 | 
						|
    #
 | 
						|
    _debug($DEBUG >= 3, "From date: Explicit");
 | 
						|
    @startdate = convert_date( $from, 0 );
 | 
						|
}
 | 
						|
_debug($DEBUG >= 3,"Start date: " . ISO8601_Date(@startdate));
 | 
						|
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
# Set up for date manipulation
 | 
						|
#-------------------------------------------------------------------------------
 | 
						|
my @cdate  = @startdate;
 | 
						|
my $monday = 1;            # Day of week number 1-7, Monday-Sunday
 | 
						|
print "Start date: ", ISO8601_Date(@startdate), "\n" unless ($silent);
 | 
						|
 | 
						|
#
 | 
						|
# The reference show, taken from the database
 | 
						|
#
 | 
						|
my @ref_date = split( /-/, $ref_date );
 | 
						|
print "Reference show: hpr$ref_show on ", ISO8601_Date(@ref_date), "\n\n"
 | 
						|
    unless ($silent);
 | 
						|
 | 
						|
#
 | 
						|
# Prepare some SQL (Note stopgap fix for the INSERT statement associated with $sth3)
 | 
						|
#
 | 
						|
$sth1 = $dbh->prepare(q{SELECT id FROM eps where id = ?});
 | 
						|
$sth2 = $dbh->prepare(q{SELECT id, date FROM eps where title = ?});
 | 
						|
$sth3 = $dbh->prepare(
 | 
						|
    q{
 | 
						|
    INSERT INTO eps (id,date,hostid,title,summary,series,tags,
 | 
						|
        duration,notes,downloads)
 | 
						|
    VALUES(?,?,?,?,?,?,?,0,'',0)
 | 
						|
}
 | 
						|
);
 | 
						|
 | 
						|
#
 | 
						|
# Compute a series of dates from the start date
 | 
						|
#
 | 
						|
for my $i ( 1 .. $count ) {
 | 
						|
    #
 | 
						|
    # Determine the next first Monday of the month and the show number that
 | 
						|
    # goes with it
 | 
						|
    #
 | 
						|
    @rdate = make_date( \@cdate, $monday, 1, 0 );
 | 
						|
    $show = $ref_show + Delta_Business_Days( @ref_date, @rdate );
 | 
						|
    _debug($DEBUG >= 3,"Date: " . ISO8601_Date(@rdate) . " Show: $show");
 | 
						|
 | 
						|
    #
 | 
						|
    # Make the text strings for this month
 | 
						|
    #
 | 
						|
    @lastmonth = Add_Delta_YM( @rdate, 0, -1 );
 | 
						|
    $title
 | 
						|
        = sprintf( $titlefmt, Month_to_Text( $lastmonth[1] ), $lastmonth[0] );
 | 
						|
    $summary
 | 
						|
        = sprintf( $summaryfmt, Month_to_Text( $lastmonth[1] ),
 | 
						|
        $lastmonth[0] );
 | 
						|
    _debug($DEBUG >= 3,"Title: $title");
 | 
						|
    _debug($DEBUG >= 3,"Summary: $summary");
 | 
						|
 | 
						|
    #
 | 
						|
    # Do we already have a show with this title?
 | 
						|
    #
 | 
						|
    $rv = $sth2->execute($title);
 | 
						|
    if ( $dbh->err ) {
 | 
						|
        warn $dbh->errstr;
 | 
						|
    }
 | 
						|
    if ( $rv > 0 ) {
 | 
						|
        $h2 = $sth2->fetchrow_hashref;
 | 
						|
        unless ($silent) {
 | 
						|
            printf
 | 
						|
                "Skipping; an episode already exists with title '%s' (hpr%s, %s)\n",
 | 
						|
                $title, $h2->{id}, $h2->{date};
 | 
						|
        }
 | 
						|
        @cdate = Add_Delta_YM( @cdate, 0, 1 );
 | 
						|
        next;
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # Is this show number taken?
 | 
						|
    #
 | 
						|
    $rv = $sth1->execute($show);
 | 
						|
    if ( $dbh->err ) {
 | 
						|
        warn $dbh->errstr;
 | 
						|
    }
 | 
						|
    if ( $rv > 0 ) {
 | 
						|
        #
 | 
						|
        # Find a free slot
 | 
						|
        #
 | 
						|
        print "Slot $show for '$title' is allocated. " unless ($silent);
 | 
						|
        until ( $rv == 0 && ( Day_of_Week(@rdate) < 6 ) ) {
 | 
						|
            $show++ if ( Day_of_Week(@rdate) < 6 );
 | 
						|
            @rdate = Add_Delta_Days( @rdate, 1 );
 | 
						|
            $rv = $sth1->execute($show);
 | 
						|
            if ( $dbh->err ) {
 | 
						|
                warn $dbh->errstr;
 | 
						|
            }
 | 
						|
        }
 | 
						|
        print "Next free slot is $show\n" unless ($silent);
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # Reserve the slot or pretend to
 | 
						|
    #
 | 
						|
    unless ($dry_run) {
 | 
						|
        $rv = $sth3->execute( $show, ISO8601_Date(@rdate), $hostid,
 | 
						|
            $title, $summary, $series, $tags );
 | 
						|
        if ( $dbh->err ) {
 | 
						|
            warn $dbh->errstr;
 | 
						|
        }
 | 
						|
        if ( $rv > 0 ) {
 | 
						|
            printf "Reserved show hpr%d on %s for '%s'\n",
 | 
						|
                $show, ISO8601_Date(@rdate), $title
 | 
						|
                unless ($silent);
 | 
						|
        }
 | 
						|
        else {
 | 
						|
            print "Error reserving slot for '$title'\n" unless ($silent);
 | 
						|
        }
 | 
						|
    }
 | 
						|
    else {
 | 
						|
        printf "Show hpr%d on %s for '%s' not reserved - dry run\n",
 | 
						|
            $show, ISO8601_Date(@rdate), $title
 | 
						|
            unless ($silent);
 | 
						|
    }
 | 
						|
 | 
						|
    @cdate = Add_Delta_YM( @cdate, 0, 1 );
 | 
						|
}
 | 
						|
 | 
						|
for my $sth ( $sth1, $sth2, $sth3 ) {
 | 
						|
    $sth->finish;
 | 
						|
}
 | 
						|
 | 
						|
$dbh->disconnect;
 | 
						|
 | 
						|
exit;
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: convert_date
 | 
						|
#      PURPOSE: Convert a textual date (ideally YYYY-MM-DD) to a Date::Calc
 | 
						|
#               date for the start of the given month.
 | 
						|
#   PARAMETERS: $textdate       date in text form
 | 
						|
#               $force          Boolean defining whether to skip validating
 | 
						|
#                               the date
 | 
						|
#      RETURNS: The start of the month in the textual date in Date::Calc
 | 
						|
#               format
 | 
						|
#  DESCRIPTION: Parses the date string and makes a Date::Calc date from the
 | 
						|
#               result where the day part is 1. Optionally checks that the
 | 
						|
#               date isn't in the past, though $force = 1 ignores this check.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: Requires Date::Calc and Date::Parse
 | 
						|
#               Note the validation 'die' has a non-generic message
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub convert_date {
 | 
						|
    my ( $textdate, $force ) = @_;
 | 
						|
 | 
						|
    my ( @today, @parsed, @startdate );
 | 
						|
 | 
						|
    #
 | 
						|
    # Reference date
 | 
						|
    #
 | 
						|
    @today = Today();
 | 
						|
 | 
						|
    #
 | 
						|
    # Parse and perform rudimentary validation on the $textdate date. Function
 | 
						|
    # 'strptime' returns "($ss,$mm,$hh,$day,$month,$year,$zone,$century)".
 | 
						|
    #
 | 
						|
    # The Date::Calc date $startdate[0] gets the returned year or the current
 | 
						|
    # year if no year was parsed, $startdate[1] gets the parsed month or the
 | 
						|
    # current month if no month was parsed, and $startdate[2] gets a day of 1.
 | 
						|
    #
 | 
						|
    @parsed    = strptime($textdate);
 | 
						|
    die "Unable to parse date '$textdate'\n" unless @parsed;
 | 
						|
 | 
						|
    @startdate = (
 | 
						|
        ( defined( $parsed[5] ) ? $parsed[5] + 1900 : $today[0] ),    # year
 | 
						|
        ( defined( $parsed[4] ) ? $parsed[4] + 1 : $today[1] ), 1
 | 
						|
    );
 | 
						|
 | 
						|
    #
 | 
						|
    # Unless we've overridden the check there should be a positive or zero
 | 
						|
    # difference in days between the target date and today's date to prevent
 | 
						|
    # going backwards in time.
 | 
						|
    #
 | 
						|
    unless ($force) {
 | 
						|
        unless ( Delta_Days( @today[ 0, 1 ], 1, @startdate ) ge 0 ) {
 | 
						|
            warn "Invalid date $textdate (in the past)\n";
 | 
						|
            die "Use -force to create a back-dated calendar\n";
 | 
						|
        }
 | 
						|
    }
 | 
						|
 | 
						|
    return @startdate;
 | 
						|
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: get_next_date
 | 
						|
#      PURPOSE: Find the next unused date from the database
 | 
						|
#   PARAMETERS: $dbh            Database handle
 | 
						|
#               $series         The id of the Community News series (from
 | 
						|
#                               a previous query)
 | 
						|
#      RETURNS: The start of the month of the next free date in Date::Calc
 | 
						|
#               format
 | 
						|
#  DESCRIPTION: Finds the latest reservation in the database. Uses the date
 | 
						|
#               associated with this reservation, converts to Date::Calc
 | 
						|
#               format, adds a month to it and ensures it's the first Monday
 | 
						|
#               of that month (in case a non-standard reservation had been
 | 
						|
#               made)
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: TODO: do we need the show number of the latest reservation?
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub get_next_date {
 | 
						|
    my ( $dbh, $series ) = @_;
 | 
						|
 | 
						|
    my ( $sth, $h );
 | 
						|
    my ( $id, $lastdate, @startdate );
 | 
						|
 | 
						|
    #
 | 
						|
    # Find the last reservation in the database
 | 
						|
    #
 | 
						|
    $sth = $dbh->prepare( q{
 | 
						|
        SELECT id, date
 | 
						|
        FROM eps WHERE series = ?
 | 
						|
        ORDER BY id DESC LIMIT 1;
 | 
						|
    }
 | 
						|
    );
 | 
						|
    $sth->execute($series);
 | 
						|
    if ( $dbh->err ) {
 | 
						|
        warn $dbh->errstr;
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # Get the values returned
 | 
						|
    #
 | 
						|
    $h        = $sth->fetchrow_hashref;
 | 
						|
    $id       = $h->{id};
 | 
						|
    $lastdate = $h->{date};
 | 
						|
 | 
						|
    #
 | 
						|
    # Convert the date to Date::Calc format, increment by a month and ensure
 | 
						|
    # it's the first Monday of the month (in case the last reservation is not
 | 
						|
    # on the right day for some reason - such as the day being reserved by
 | 
						|
    # some other mechanism)
 | 
						|
    #
 | 
						|
    @startdate = convert_date( $lastdate, 0 );
 | 
						|
    @startdate = Add_Delta_YM( @startdate, 0, 1 );
 | 
						|
    @startdate = make_date( \@startdate, 1, 1, 0 );
 | 
						|
 | 
						|
    return @startdate;
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: make_date
 | 
						|
#      PURPOSE: Make the event date for recurrence
 | 
						|
#   PARAMETERS: $refdate
 | 
						|
#                       An arrayref to the reference date array (usually
 | 
						|
#                       today's date)
 | 
						|
#               $dow    Day of week for the event date (1-7, 1=Monday)
 | 
						|
#               $n      The nth day of the week in the given month required
 | 
						|
#                       for the event date ($dow=1, $n=1 means first Monday)
 | 
						|
#               $offset Number of days to offset the computed date
 | 
						|
#      RETURNS: The resulting date as a list for Date::Calc
 | 
						|
#  DESCRIPTION: We want to compute a simple date with an offset, such as
 | 
						|
#               "the Saturday before the first Monday of the month". We do
 | 
						|
#               this by computing a pre-offset date (first Monday of month)
 | 
						|
#               then apply the offset (Saturday before).
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: TODO Needs more testing to be considered truly universal
 | 
						|
#     SEE ALSO:
 | 
						|
#===============================================================================
 | 
						|
sub make_date {
 | 
						|
    my ( $refdate, $dow, $n, $offset ) = @_;
 | 
						|
 | 
						|
    #
 | 
						|
    # Compute the required date: the "$n"th day of week "$dow" in the year and
 | 
						|
    # month in @$refdate. This could be a date in the past.
 | 
						|
    #
 | 
						|
    my @date = Nth_Weekday_of_Month_Year( @$refdate[ 0, 1 ], $dow, $n );
 | 
						|
 | 
						|
    #
 | 
						|
    # If the computed date plus the offset is before the base date advance
 | 
						|
    # a month
 | 
						|
    #
 | 
						|
    if ( Day_of_Year(@date) + $offset < Day_of_Year(@$refdate) ) {
 | 
						|
        #
 | 
						|
        # Add a month and recompute
 | 
						|
        #
 | 
						|
        @date = Add_Delta_YM( @date, 0, 1 );
 | 
						|
        @date = Nth_Weekday_of_Month_Year( @date[ 0, 1 ], $dow, $n );
 | 
						|
    }
 | 
						|
 | 
						|
    #
 | 
						|
    # Apply the day offset
 | 
						|
    #
 | 
						|
    @date = Add_Delta_Days( @date, $offset ) if $offset;
 | 
						|
 | 
						|
    #
 | 
						|
    # Return a list
 | 
						|
    #
 | 
						|
    return (@date);
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: Delta_Business_Days
 | 
						|
#      PURPOSE: Computes the number of weekdays between two dates
 | 
						|
#   PARAMETERS: @date1 - first date in Date::Calc format
 | 
						|
#               @date2 - second date in Date::Calc format
 | 
						|
#      RETURNS: The business day offset
 | 
						|
#  DESCRIPTION: This is a direct copy of the routine of the same name on the
 | 
						|
#               Date::Calc manpage.
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: Lifted from the manpage for Date::Calc
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub Delta_Business_Days {
 | 
						|
    my (@date1) = (@_)[ 0, 1, 2 ];
 | 
						|
    my (@date2) = (@_)[ 3, 4, 5 ];
 | 
						|
    my ( $minus, $result, $dow1, $dow2, $diff, $temp );
 | 
						|
 | 
						|
    $minus = 0;
 | 
						|
    $result = Delta_Days( @date1, @date2 );
 | 
						|
    if ( $result != 0 ) {
 | 
						|
        if ( $result < 0 ) {
 | 
						|
            $minus  = 1;
 | 
						|
            $result = -$result;
 | 
						|
            $dow1   = Day_of_Week(@date2);
 | 
						|
            $dow2   = Day_of_Week(@date1);
 | 
						|
        }
 | 
						|
        else {
 | 
						|
            $dow1 = Day_of_Week(@date1);
 | 
						|
            $dow2 = Day_of_Week(@date2);
 | 
						|
        }
 | 
						|
        $diff = $dow2 - $dow1;
 | 
						|
        $temp = $result;
 | 
						|
        if ( $diff != 0 ) {
 | 
						|
            if ( $diff < 0 ) {
 | 
						|
                $diff += 7;
 | 
						|
            }
 | 
						|
            $temp -= $diff;
 | 
						|
            $dow1 += $diff;
 | 
						|
            if ( $dow1 > 6 ) {
 | 
						|
                $result--;
 | 
						|
                if ( $dow1 > 7 ) {
 | 
						|
                    $result--;
 | 
						|
                }
 | 
						|
            }
 | 
						|
        }
 | 
						|
        if ( $temp != 0 ) {
 | 
						|
            $temp /= 7;
 | 
						|
            $result -= ( $temp << 1 );
 | 
						|
        }
 | 
						|
    }
 | 
						|
    if   ($minus) { return -$result; }
 | 
						|
    else          { return $result; }
 | 
						|
}
 | 
						|
 | 
						|
#===  FUNCTION  ================================================================
 | 
						|
#         NAME: ISO8601_Date
 | 
						|
#      PURPOSE: Format a Date::Calc date in ISO8601 format
 | 
						|
#   PARAMETERS: @date   - a date in the Date::Calc format
 | 
						|
#      RETURNS: Text string containing a YYYY-MM-DD date
 | 
						|
#  DESCRIPTION: Just a convenience to allow a simple call like
 | 
						|
#               $str = ISO8601_Date(@date)
 | 
						|
#       THROWS: No exceptions
 | 
						|
#     COMMENTS: None
 | 
						|
#     SEE ALSO: N/A
 | 
						|
#===============================================================================
 | 
						|
sub ISO8601_Date {
 | 
						|
    my (@date) = (@_)[ 0, 1, 2 ];
 | 
						|
 | 
						|
    if ( check_date(@date) ) {
 | 
						|
        return sprintf( "%04d-%02d-%02d", @date );
 | 
						|
    }
 | 
						|
    else {
 | 
						|
        return "*Invalid Date*";
 | 
						|
    }
 | 
						|
}
 | 
						|
 | 
						|
#===  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",    "debug=i",  "config=s", "from:s",
 | 
						|
        "count=i", "dry-run!", "silent!",
 | 
						|
    );
 | 
						|
 | 
						|
    if ( !GetOptions( $optref, @options ) ) {
 | 
						|
        pod2usage( -msg => "$PROG version $VERSION\n", -exitval => 1 );
 | 
						|
    }
 | 
						|
 | 
						|
    return;
 | 
						|
}
 | 
						|
 | 
						|
__END__
 | 
						|
 | 
						|
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 | 
						|
#  Application Documentation
 | 
						|
#%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
 | 
						|
#{{{
 | 
						|
 | 
						|
=head1 NAME
 | 
						|
 | 
						|
reserve_cnews - reserve Community News shows in the HPR database
 | 
						|
 | 
						|
=head1 VERSION
 | 
						|
 | 
						|
This documentation refers to B<reserve_cnews> version 0.0.14
 | 
						|
 | 
						|
=head1 USAGE
 | 
						|
 | 
						|
    ./reserve_cnews [-help] [-from[=DATE]] [-count=COUNT]
 | 
						|
        [-[no]dry-run] [-[no]silent] [-config=FILE] [-debug=N]
 | 
						|
 | 
						|
    Examples:
 | 
						|
 | 
						|
        ./reserve_cnews -help
 | 
						|
        ./reserve_cnews
 | 
						|
        ./reserve_cnews -from=1-June-2014 -dry-run
 | 
						|
        ./reserve_cnews -from=15-Aug-2015 -count=6
 | 
						|
        ./reserve_cnews -from=2015-12-06 -count=1 -silent
 | 
						|
        ./reserve_cnews -from -count=1
 | 
						|
        ./reserve_cnews -from -count=2 -debug=4
 | 
						|
        ./reserve_cnews -config=.hpr_livedb.cfg -from=1-March-2019 -dry-run
 | 
						|
 | 
						|
=head1 OPTIONS
 | 
						|
 | 
						|
=over 8
 | 
						|
 | 
						|
=item B<-help>
 | 
						|
 | 
						|
Prints a brief help message describing the usage of the program, and then exits.
 | 
						|
 | 
						|
=item B<-from=DATE> or B<-from>
 | 
						|
 | 
						|
This option defines the starting date from which reservations are to be
 | 
						|
created. The program ignores the day part, though it must be provided, and
 | 
						|
replaces it with the first day of the month.
 | 
						|
 | 
						|
The date format should be B<DD-Mon-YYYY> (e.g. 12-Jun-2014), B<DD-MM-YYYY>
 | 
						|
(e.g. 12-06-2014) or B<YYYY-MM-DD> (e.g. 2014-06-12).
 | 
						|
 | 
						|
If this option is omitted the current date is used.
 | 
						|
 | 
						|
If the B<DATE> part is omitted the script will search the database for the
 | 
						|
reservation with the latest date and will use it as the starting point to
 | 
						|
generate B<-count=COUNT> (or the default 12) reservations.
 | 
						|
 | 
						|
=item B<-count=COUNT>
 | 
						|
 | 
						|
This option defines the number of slots to reserve.
 | 
						|
 | 
						|
If this option is omitted then 12 slots are reserved.
 | 
						|
 | 
						|
=item B<-[no]dry-run>
 | 
						|
 | 
						|
This option in the form B<-dry-run> causes the program omit the step of adding
 | 
						|
reservations to the database. In the form B<-nodry-run> or if omitted, the
 | 
						|
program will perform the update(s).
 | 
						|
 | 
						|
=item B<-[no]silent>
 | 
						|
 | 
						|
This option in the form B<-silent> causes the program omit the reporting of
 | 
						|
what it has done. In the form B<-nosilent> or if omitted, the program will
 | 
						|
report what it is doing.
 | 
						|
 | 
						|
=item B<-config=FILE>
 | 
						|
 | 
						|
This option defines a configuration file other than the default
 | 
						|
I<.hpr_db.cfg>. The file must be formatted as described below in the section
 | 
						|
I<CONFIGURATION AND ENVIRONMENT>.
 | 
						|
 | 
						|
=item B<-debug=N>
 | 
						|
 | 
						|
Sets the level of debugging. The default is 0: no debugging.
 | 
						|
 | 
						|
Values are:
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
=item 1
 | 
						|
 | 
						|
Produces details of some of the built-in values used.
 | 
						|
 | 
						|
=item 2
 | 
						|
 | 
						|
Produces any output defined for lower levels as well as details of the values
 | 
						|
taken from the database for use when reserving the show(s).
 | 
						|
 | 
						|
=item 3
 | 
						|
 | 
						|
Produces any output defined for lower levels as well as:
 | 
						|
 | 
						|
=over 4
 | 
						|
 | 
						|
=item .
 | 
						|
 | 
						|
Details of how the `-from` date is being interpreted: default, computed from
 | 
						|
the database or explicit. The actual date being used is reported.
 | 
						|
 | 
						|
=item .
 | 
						|
 | 
						|
Details of all dates chosen and their associated sho numbers using the
 | 
						|
algorithm "first Monday of the month".
 | 
						|
 | 
						|
=item .
 | 
						|
 | 
						|
The show title chosen for each reservation is displayed as well as the summary.
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
=head1 DESCRIPTION
 | 
						|
 | 
						|
Hacker Public Radio produces a Community News show every month. The show is
 | 
						|
recorded on the Saturday before the first Monday of the month, and should be
 | 
						|
released as soon as possible afterwards.
 | 
						|
 | 
						|
This program reserves future slots in the database for upcoming shows. It
 | 
						|
computes the date of the first Monday of all of the months in the requested
 | 
						|
sequence then determines which show number matches that date. It writes rows
 | 
						|
into the I<reservations> table containing the episode number, the host
 | 
						|
identifier ('HPR Admins') and the reason for the reservation.
 | 
						|
 | 
						|
It is possible that an HPR host has already requested the slot that this
 | 
						|
program determines it should reserve. When this happens the program increments
 | 
						|
the episode number and checks again, and repeats this process until a free
 | 
						|
slot is discovered.
 | 
						|
 | 
						|
It is also possible that a reservation has previously been made in the
 | 
						|
I<reservations> table. When this case occurs the program ignores this
 | 
						|
particular reservation.
 | 
						|
 | 
						|
=head1 DIAGNOSTICS
 | 
						|
 | 
						|
=over 8
 | 
						|
 | 
						|
=item B<Invalid date ...>
 | 
						|
 | 
						|
The date element of the B<-from=DATE> option is not valid. See the description
 | 
						|
of this option for details of what formats are acceptable.
 | 
						|
 | 
						|
=item B<Various database messages>
 | 
						|
 | 
						|
The program can generate warning messages from the database.
 | 
						|
 | 
						|
=item B<Unable to find host '...' - cannot continue>
 | 
						|
 | 
						|
The script needs to find the id number relating to the host that will be used
 | 
						|
for Community News episodes. It does this by looking in the hosts table for
 | 
						|
the name "HPR Volunteers". If this cannot be found, perhaps because it has
 | 
						|
been changed, then the script cannot continue. The remedy is to change the
 | 
						|
variable $hostname to match the new name.
 | 
						|
 | 
						|
=item B<Unable to find series '...' - cannot continue>
 | 
						|
 | 
						|
The script needs to find the id number relating to the series that will be
 | 
						|
used for Community News episodes. It does this by looking in the miniseries
 | 
						|
table for the name "HPR Community News". If this cannot be found, perhaps
 | 
						|
because it has been changed, then the script cannot continue. The remedy is to
 | 
						|
change the variable $seriesname to match the new name.
 | 
						|
 | 
						|
=back
 | 
						|
 | 
						|
 | 
						|
=head1 CONFIGURATION AND ENVIRONMENT
 | 
						|
 | 
						|
The program obtains the credentials it requires for connecting to the HPR
 | 
						|
database by loading them from a configuration file. The file is called
 | 
						|
B<.hpr_db.cfg> and should contain the following data:
 | 
						|
 | 
						|
    <database>
 | 
						|
        host = 127.0.0.1
 | 
						|
        port = PORT
 | 
						|
        name = DBNAME
 | 
						|
        user = USER
 | 
						|
        password = PASSWORD
 | 
						|
    </database>
 | 
						|
 | 
						|
=head1 DEPENDENCIES
 | 
						|
 | 
						|
    Config::General
 | 
						|
    Data::Dumper
 | 
						|
    Date::Calc
 | 
						|
    Date::Parse
 | 
						|
    DBI
 | 
						|
    Getopt::Long
 | 
						|
    Pod::Usage
 | 
						|
 | 
						|
=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) 2014 - 2023 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.
 | 
						|
 | 
						|
=cut
 | 
						|
 | 
						|
#}}}
 | 
						|
 | 
						|
# [zo to open fold, zc to close]
 | 
						|
 | 
						|
# vim: syntax=perl:ts=8:sw=4:et:ai:tw=78:fo=tcrqn21:fdm=marker
 | 
						|
 |