davmo/Free_Culture_Podcasts
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Generated new reports and HTML

Browse Source
This commit is contained in:
Dave Morriss
2023-01-24 22:44:11 +00:00
parent db39655199
commit 6f20932290
8 changed files with 454 additions and 186 deletions
Download Patch File Download Diff File Expand all files Collapse all files

280
feedWatcher
View File

@@ -211,8 +211,9 @@ my $silent = ( defined( $options{silent} ) ? $options{silent} : 0 );
my $loadfile = $options{'load'};
my $deletefile = $options{'delete'};
my $scan = ( defined( $options{scan} ) ? $options{scan} : 0 );
my $html = ( defined( $options{html} ) ? $options{html} : 0 );
my $scan = ( defined( $options{scan} ) ? $options{scan} : 0 );
my $refresh = ( defined( $options{refresh} ) ? $options{refresh} : 0 );
my $html = ( defined( $options{html} ) ? $options{html} : 0 );
my $check = $options{check};
my $outfile = $options{out};
@@ -231,6 +232,9 @@ my $template = $options{template};
#
die "Choose either -load or -delete, not both\n"
if (defined($loadfile) && defined($deletefile));
die "Options -load and -delete should not be combined with -scan or -refresh\n"
if ( ( defined($loadfile) || defined($deletefile) )
&& ( $scan || $refresh ) );
#
# Check the configuration file
@@ -378,8 +382,8 @@ my $work = (
|| ( defined($report)
|| defined($json)
|| defined($opml)
|| defined($template)
|| $scan && $rows > 0 )
|| defined($template) )
|| ( ( $scan || $refresh ) && $rows > 0 )
);
unless ($work) {
@@ -556,9 +560,18 @@ elsif ($action_mode eq 'delete') {
# TODO: Needs to be developed; does nothing at the moment.
#-------------------------------------------------------------------------------
if ($scan) {
$LOG->warning( "Scan is not fully implemented yet" );
warn "Refresh is not implemented yet\n";
#$LOG->warning( "Scan is not fully implemented yet" );
# Testing. Processes the first two feeds
scanDB($dbh, \%keymap, $dry_run);
# TODO: Currently broken
#scanDB($dbh, \%keymap, $dry_run);
}
#-------------------------------------------------------------------------------
# Perform a feed refresh
#-------------------------------------------------------------------------------
if ($refresh) {
warn "Refresh is not implemented yet";
}
#-------------------------------------------------------------------------------
@@ -861,7 +874,7 @@ sub loadUrls {
# Perform a check on the copyright. The routine sets
# $uridata{SAVE} = 0 if the copyright is not acceptable.
#
$uridata{CHECKMODE} = $check;
$uridata{CHECKTYPE} = $check;
if ( $check ne 'none' ) {
unless (checkCopyright( $check, \%uridata )) {
#
@@ -1027,6 +1040,67 @@ sub searchTitle {
}
}
#=== FUNCTION ================================================================
# NAME: refreshFeeds
# PURPOSE: To refresh the episodes on all feeds
# PARAMETERS: $dbh database handle
# RETURNS: Nothing
# DESCRIPTION:
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
sub refreshFeeds {
my ($dbh) = @_;
my ( $sql1, $sth1, $rv1, $h1 );
my ( $aref, @urls, $DT, $stream, $feed );
my ( %uridata, $encref, $enc_changes );
#
# Query to return all feed URLs
#
$sql1 = q{SELECT id, url FROM urls WHERE urltype = 'Feed' ORDER BY title};
$sth1 = $dbh->prepare($sql1);
$rv1 = $sth1->execute();
if ( $dbh->err ) {
warn $dbh->errstr;
}
#
# Collect everything as an arrayref pointing to a bunch of arrayrefs
# containing the column details requested
#
$aref = $sth1->fetchall_arrayref;
#
# Extract just the URL strings
#
@urls = map { $_->[1] } @{$aref};
#
# Loop through the feed URLs
#
foreach my $url (@urls) {
#
# Get the feed as XML
#
$stream = getFeed($url);
next unless $stream;
#
# Parse the feed as an XML::Feed object
#
$feed = parseFeed($url,$stream);
next unless $feed;
#
# Turn the enclosures in the feed into an array of anonymous hashes
#
$encref = extractEnclosures($feed);
}
}
#=== FUNCTION ================================================================
# NAME: scanDB
@@ -1215,7 +1289,6 @@ sub scanDB {
return;
}
#=== FUNCTION ================================================================
# NAME: scanFeed
# PURPOSE: Performs a scan on a single feed
@@ -1485,8 +1558,8 @@ sub reportFeed {
'urls_urltype' => 'URL type',
'urls_parent_id' => 'Parent ID',
'urls_child_count' => 'Child count',
);
@seq1 = (
'urls_title',
'urls_url',
@@ -1509,6 +1582,7 @@ sub reportFeed {
'urls_parent_id',
'urls_child_count',
);
@seq2 = (
'ep_title',
'ep_enclosure',
@@ -1527,8 +1601,22 @@ sub reportFeed {
if ($feed) {
print $fh "Channel:\n";
foreach my $key (@seq1) {
printf $fh " %-*s: %s\n", $lwidth, $keys{$key},
coalesce( $feed->{$key}, '--' );
#
# Format the feed description with a left margin using textFormat.
# Everything else gets a simpler layout.
#
if ($key eq 'urls_description') {
printf $fh "%s\n",
textFormat(
coalesce( $feed->{$key}, '--' ),
sprintf( " %-*s:", $lwidth, $keys{$key} ),
'L', $lwidth + 4, 80
);
}
else {
printf $fh " %-*s: %s\n", $lwidth, $keys{$key},
coalesce( $feed->{$key}, '--' );
}
}
print $fh "\nLatest episode:\n";
@@ -2011,38 +2099,6 @@ sub getFeed {
}
}
#=== FUNCTION ================================================================
# NAME: start_handler
# PURPOSE: HTTP::Parser handler for <title> events
# PARAMETERS: <first> the name of the tag found
# <second> the object being processed
# RETURNS: Nothing (ignored anyway)
# DESCRIPTION:
# THROWS: No exceptions
# COMMENTS: None
# SEE ALSO: N/A
#===============================================================================
#sub start_handler {
#
# #
# # Ignore any tags which are not 'title'
# #
# return if shift ne "title";
#
# #
# # Define more handlers if we have a title. One to collect the title string
# # and the other to abort the parse on encountering the end of the title.
# #
# my $self = shift;
# $self->handler(text => sub { $main::html_title = shift }, "dtext");
# $self->handler(
# end => sub {
# shift->eof if shift eq "title";
# },
# "tagname,self"
# );
#}
#=== FUNCTION ================================================================
# NAME: getHTMLTitle
# PURPOSE: Parse an HTML page to get data. At the moment this is just the
@@ -2144,44 +2200,6 @@ sub parseFeed {
}
##=== FUNCTION ================================================================
## NAME: parseFeedPP
## PURPOSE: Parse a podcast feed that has already been downloaded
## PARAMETERS: $feed_url URL of the feed previously downloaded
## $feed_content String containing the content of the feed, for
## parsing
## RETURNS: An XML::FeedPP object containing the parsed feed or undef if the
## parse failed
## DESCRIPTION:
## THROWS: No exceptions
## COMMENTS: None
## SEE ALSO: N/A
##===============================================================================
#sub parseFeedPP {
# my ( $feed_url, $feed_content ) = @_;
#
# my $feed;
#
# try {
# $feed = XML::FeedPP->parse( \$feed_content, -type => 'string' );
# unless ($feed) {
# #
# # Something went wrong. Abort this feed
# #
# warn "Failed to parse $feed_url: ", XML::Feed->errstr, "\n";
# return; # undef
# }
# }
# catch {
# warn "Failed to parse $feed_url: ", $@, "\n";
# return;
# }
#
# return $feed;
#
#}
#=== FUNCTION ================================================================
# NAME: storeFeed
# PURPOSE: Stores feed attributes in a hash
@@ -2259,10 +2277,10 @@ sub checkCopyright {
$decision = 0;
};
#
# If accepted we want a reason
#
if ($decision) {
#
# If accepted we want a reason for this manual check
#
try {
$reason = prompt(
-in => *STDIN,
@@ -2652,6 +2670,90 @@ sub optionalFile {
return 0;
}
#=== FUNCTION ================================================================
# NAME: textFormat
# PURPOSE: Formats a block of text in an indented, wrapped style with
# a label in the left column
# PARAMETERS: $text The text to be formatted, as a scalar string
# $tag The label to be added to the left of the top
# line
# $align Tag alignment, 'L' for left, otherwise right
# $lmargin Width of the left margin (assumed to be big
# enough for the tag)
# $textwidth The width of all of the text plus left margin
# (i.e. the right margin)
# RETURNS: The formatted result as a string
# DESCRIPTION: Chops the incoming text into words (thereby removing any
# formatting). Removes any leading spaces. Loops through the
# wordlist building them into lines of the right length to fit
# between the left and right margins. Saves the lines in an
# array. Adds the tag to the first line with the alignment
# requested then returns the array joined into a string.
# THROWS: No exceptions
# COMMENTS: Inspired by Text::Format but *much* simpler. In fact T::F is
# a nasty thing to have to use; I couldn't get it to do what
# this routine does.
# TODO Make the routine more resilient to silly input values.
# SEE ALSO:
#===============================================================================
sub textFormat {
my ( $text, $tag, $align, $lmargin, $textwidth ) = @_;
my ( $width, $word );
my ( @words, @buff, @wrap );
#
# Build the tag early. If there's no text we'll just return the tag.
#
$tag = sprintf( "%*s",
( $align =~ /L/i ? ( $lmargin - 1 ) * -1 : $lmargin - 1 ), $tag );
return $tag unless $text;
$text =~ s/(^\s+|\s+$)//g;
return $tag unless $text;
#
# Chop up the incoming text removing leading spaces
#
@words = split( /\s+/, $text );
shift(@words) if ( @words && $words[0] eq '' );
#
# Compute the width of the active text
#
$width = $textwidth - $lmargin;
#
# Format the words into lines with a blank left margin
#
while ( defined( $word = shift(@words) ) ) {
if ( length( join( ' ', @buff, $word ) ) < $width ) {
push( @buff, $word );
}
else {
push( @wrap, ' ' x $lmargin . join( ' ', @buff ) );
@buff = ($word);
}
}
#
# Append any remainder
#
push( @wrap, ' ' x $lmargin . join( ' ', @buff ) ) if @buff;
#
# Insert the tag into the first line
#
substr( $wrap[0], 0, $lmargin - 1 ) = $tag;
#
# Return the formatted array as a string
#
return join( "\n", @wrap );
}
#=== FUNCTION ================================================================
# NAME: equal
# PURPOSE: Compare two strings even if undefined
@@ -2824,11 +2926,11 @@ sub Options {
my ($optref) = @_;
my @options = (
"help", "manpage", "debug=i", "dry-run!",
"silent!", "load:s", "delete:s", "scan!",
"report:s", "html!", "check:s", "json:s",
"opml:s", "config=s", "out=s", "rejects:s",
"template:s",
"help", "manpage", "debug=i", "dry-run!",
"silent!", "load:s", "delete:s", "scan!",
"refresh!", "report:s", "html!", "check:s",
"json:s", "opml:s", "config=s", "out=s",
"rejects:s", "template:s",
);
if ( !GetOptions( $optref, @options ) ) {