XML-RSS-SimpleGen-11.11/ 0000755 0001773 0001773 00000000000 10011101712 015305 5 ustar sburke sburke 0000000 0000000 XML-RSS-SimpleGen-11.11/t/ 0000755 0001773 0001773 00000000000 10011101712 015550 5 ustar sburke sburke 0000000 0000000 XML-RSS-SimpleGen-11.11/t/40_item.t 0000644 0001773 0001773 00000001020 10002402572 017177 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 4 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
use XML::RSS::SimpleGen;
rss_new( 'http://blar.int' );
rss_item("http://blar.int#a", "About A");
rss_item("http://blar.int#b", "About B");
rss_item("http://blar.int#c", "About C");
ok rss_item_count(), 3;
rss_item("http://blar.int#b", "About B");
my $string = rss_as_string();
my $count = 0;
while( $string =~ m/(\#\w)\b/g ) {
print "# Good, found \"$1\"\n";
++$count;
}
ok $count, 3;
print "# bye\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/30_simple_xml.t 0000644 0001773 0001773 00000002423 10002400522 020412 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 16 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
#sub XML::RSS::SimpleGen::DEBUG () {20}
use XML::RSS::SimpleGen ();
sub r ($$) {
my($m,$v) = @_;
my $r = XML::RSS::SimpleGen->new('http://test.int/','blorg');
$r->$m($v);
$r->as_string;
}
ok r('ttl', '30'), '/30/';
ok r('skipHours', 1), '/\s*1\s*/';
ok r('skipDays' , 1), '/\s*Monday\s*/';
ok r('skipDays' , 'Monday'), '/\s*Monday\s*/';
ok r('skipDays' , 'Monday'), '/\s*Monday\s*/';
ok r('language' , 'sgn-us'), '/sgn-us/';
ok r('css', './foo.css'), '/foo\.css/';
ok r('xsl', './foo.xsl'), '/foo\.xsl/';
ok r('webMaster', 'jojo@mojo.int'), '/jojo@mojo.int/';
ok r('docs', 'http://whatever.int'), '/http://whatever\.int/';
ok r('url', 'http://whatever.int'), '/http://whatever.int/';
ok r('title', 'jojo@mojo.int'), '/jojo@mojo.int/';
ok r('description', 'jojo@mojo.int'), '/jojo@mojo.int/';
ok r('item', 'http://whatever.int'), '/http://whatever.int/';
print "# Done at ", scalar(localtime), ".\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/00_about.t 0000644 0001773 0001773 00000001433 10002077154 017363 0 ustar sburke sburke 0000000 0000000
require 5;
use Test;
BEGIN { plan tests => 1; }
use XML::RSS::SimpleGen;
eval "require LWP::Simple; require LWP";
print "#\n#\n",
"# XML::RSS::SimpleGen v$XML::RSS::SimpleGen::VERSION\n",
"# LWP::Simple v", $LWP::Simple::VERSION || "?", "\n",
"# LWP v", $LWP::VERSION || "?", "\n",
"#\n#\n",
;
print "# Running under perl version $] for $^O",
(chr(65) eq 'A') ? "\n" : " in a non-ASCII world\n";
print "# Win32::BuildNumber ", &Win32::BuildNumber(), "\n"
if defined(&Win32::BuildNumber) and defined &Win32::BuildNumber();
print "# MacPerl verison $MacPerl::Version\n"
if defined $MacPerl::Version;
printf
"# Current time local: %s\n# Current time GMT: %s\n",
scalar( gmtime($^T)), scalar(localtime($^T));
print "# Using Test.pm v", $Test::VERSION || "?", "\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/10_html2xmltext.t 0000644 0001773 0001773 00000004436 10007117624 020736 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 32 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
#sub XML::RSS::SimpleGen::DEBUG () {20}
use XML::RSS::SimpleGen;
print "# XML::RSS::SimpleGen version $XML::RSS::SimpleGen::VERSION\n";
sub z ($) { return XML::RSS::SimpleGen->html2text( $_[0] ) }
ok z '' , '' , 'nullstring';
ok z '1' , '1' , 'digit 1';
ok z ' 1 ' , '1' , 'digit 1 with spaces';
ok z ' 1 ', '1' , 'digit 1 with spaces';
ok z "vis-à-vis Beyoncé's naïve papier-mâché résumé",
"vis-à-vis Beyoncé's naïve papier-mâché résumé";
ok z "vis-à-vis Beyoncé's naïve papier-mâché résumé",
"vis-à-vis Beyoncé's naïve papier-mâché résumé";
ok z "上德不德，",
"上德不德，";
ok z "上德不 德 ，",
"上德不 德 ，";
ok z "上丸，",
"上丸，";
ok z "上丸，",
"上丸，";
ok z "上丸，",
"上丸，";
print "# De-Winification test:\n";
ok z "€20 ‘could’ be “fun” - No-body",
'€20 ‘could’ be “fun” - No-body';
ok z "p’yogo!", "p’yogo!";
ok z "p’yogo!", "p’yogo!";
ok z "p’yogo!", "p’yogo!";
ok z "p’yogo!", "p’yogo!";
print "# Tag tests...\n";
ok z "N < 17 => true",
"N < 17 => true";
ok z "Realtime",
"Realtime";
ok z "Realtime",
"Real time";
ok z "Real
time",
"Real time";
ok z "Real
time",
"Real time";
ok z "Real
time",
"Real time";
ok z "Realtime",
"Real time";
ok z "Realtime",
"Realtime";
ok z "Realtime",
"Realtime";
ok z "Realtime",
"Realtime";
ok z "Realtime",
"Realtime";
ok z "Realtime",
"Realtime";
ok z "Real\n\n\n\n\n \t\t time",
"Real time";
ok z "Realtime",
"Realtime";
print "# Quitting...\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/20_http.t 0000644 0001773 0001773 00000001572 10002140720 017224 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 8 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
#sub XML::RSS::SimpleGen::DEBUG () {20}
use XML::RSS::SimpleGen;
sub g ($) {
print "# Test-getting $_[0] at ", scalar(localtime), "...\n";
return defined(eval { get_url $_[0]}), 1, "getting $_[0]";
}
&ok(g 'http://www.perl.com/');
&ok(g 'http://www.yahoo.com/');
&ok(g 'http://www.google.com/');
print "# Now trying with LWP...\n";
if( eval "require LWP::Simple; 1;" and $LWP::Simple::VERSION ) {
print "# Using LWP::Simple v$LWP::Simple::VERSION\n";
&ok(g 'http://www.perl.com/');
&ok(g 'http://www.yahoo.com/');
&ok(g 'http://www.google.com/');
} else {
skip "skipping because LWP not available", 1,1;
skip "skipping because LWP not available", 1,1;
skip "skipping because LWP not available", 1,1;
}
print "# Done at ", scalar(localtime), ".\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/05_xmltext.t 0000644 0001773 0001773 00000001063 10002102654 017754 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 4 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
#sub XML::RSS::SimpleGen::DEBUG () {20}
use XML::RSS::SimpleGen;
print "# XML::RSS::SimpleGen version $XML::RSS::SimpleGen::VERSION\n";
sub z ($) { return XML::RSS::SimpleGen->xmlesc( $_[0] ) }
ok z "vis-à-vis Beyoncé's naïve papier-mâché résumé",
"vis-à-vis Beyoncé's naïve papier-mâché résumé";
ok z "This & That, N < 10, N > 2",
"This & That, N < 10, N > 2";
print "# Quitting...\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/50_history.t 0000644 0001773 0001773 00000001260 10002401700 017741 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 6 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
#sub XML::RSS::SimpleGen::DEBUG () {20}
use XML::RSS::SimpleGen;
my $rss = 'test.rss';
my $history = 'test.hst';
my $last;
{
my @curr;
foreach my $to_add ( qw( morning noon night ) ) {
rss_new( 'http://blar.int' );
rss_history_file( $history );
push @curr, $to_add;
foreach my $c ( sort @curr ) { # yes, sort!!
rss_item("http://blar.int#$c", "About $c");
}
rss_save($rss);
$last = rss_as_string();
ok 1;
sleep 2;
}
}
unlink $rss, $history;
$last =~ s/\n/ /g;
ok $last, '/night.+noon.+morning/';
print "# bye\n";
ok 1;
XML-RSS-SimpleGen-11.11/t/80_basedate.t 0000644 0001773 0001773 00000000746 10002417546 020042 0 ustar sburke sburke 0000000 0000000
require 5;
use strict;
use Test;
BEGIN { plan tests => 9 }
print "# Starting ", __FILE__ , " ...\n";
ok 1;
use XML::RSS::SimpleGen;
rss_new( 'http://blar.int' );
sub r {defined eval { rss_updateBase($_[0]) }; }
# ok r('1997'); nevermind that case
ok r('1997-07');
ok r('1997-07-16');
ok r('1994-11-05T13:15:30Z');
ok r('1997-07-16T19:20+01:00');
ok r('1994-11-05T08:15:30-05:00');
ok r('1997-07-16T19:20:30+01:00');
ok r('1997-07-16T19:20:30.45+01:00');
print "# bye\n";
ok 1;
XML-RSS-SimpleGen-11.11/META.yml 0000644 0001773 0001773 00000000656 10011101711 016564 0 ustar sburke sburke 0000000 0000000 # http://module-build.sourceforge.net/META-spec.html
#XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX#
name: XML-RSS-SimpleGen
version: 11.11
version_from: lib/XML/RSS/SimpleGen.pm
installdirs: site
requires:
Carp: 0
IO::Socket: 0
strict: 0
distribution_type: module
generated_by: ExtUtils::MakeMaker version 6.17
XML-RSS-SimpleGen-11.11/lib/ 0000755 0001773 0001773 00000000000 10011101712 016053 5 ustar sburke sburke 0000000 0000000 XML-RSS-SimpleGen-11.11/lib/XML/ 0000755 0001773 0001773 00000000000 10011101712 016513 5 ustar sburke sburke 0000000 0000000 XML-RSS-SimpleGen-11.11/lib/XML/RSS/ 0000755 0001773 0001773 00000000000 10011101712 017162 5 ustar sburke sburke 0000000 0000000 XML-RSS-SimpleGen-11.11/lib/XML/RSS/SimpleGen.pm 0000644 0001773 0001773 00000224463 10011101077 021422 0 ustar sburke sburke 0000000 0000000
require 5;
package XML::RSS::SimpleGen;
use strict;
use Carp ();
require Exporter;
use vars qw(
@EXPORT %EXPORT_TAGS @ISA $VERSION
%Entities %WinLameEntities %CommonEnts $MIME_Type
$DTD_url $DTD_pubid $Nativize_newlines $DWIM @Hidies $RSS_obj
$Sleepy %IsBlockMarkup $MaybeIndent $MaybeNL %PeriodAsSeconds
$NAMESPACE_SY $CHUNK_MINUTES %BadPorts
@Retry_delays $UserAgentString
);
$VERSION = '11.11';
BEGIN { *DEBUG = sub () {0} unless defined &DEBUG; } # set DEBUG level
@ISA = qw(Exporter);
#$DTD_url ||= 'http://my.netscape.com/publish/formats/rss-0.91.dtd';
#$DTD_pubid ||= '-//Netscape Communications//DTD RSS 0.91//EN';
$NAMESPACE_SY ||= 'http://purl.org/rss/1.0/modules/syndication/';
$CHUNK_MINUTES = 10;
$Nativize_newlines = 1 unless defined $Nativize_newlines;
$DWIM = 1 unless defined $DWIM;
$Sleepy =
$ENV{'MAILTO'} ? 4 # under crontab
: ($ENV{'TERM'} || $ENV{'REQUEST_METHOD'} || $ENV{'COMSPEC'} ) ? 0
# almost definitely not under crontab
: 4 unless defined $Sleepy;
@Retry_delays = (4, 10, 20, 40);
$MaybeIndent = ' ';
$MaybeNL = "\n";
#$MaybeNL = $MaybeIndent = ''; # terser, more grep-worthy
foreach my $p ( # ports we'll refuse to do HTTP on
qw<0 1 7 9 11 13 15 17 19 20 21 22 23 25 37 42 43 53 70 79 95 101 102 103
104 107 109 110 111 113 115 117 119 123 135 137 138 139 143 389 443 512
513 514 515 517 518 526 530 531 532 540 556 6667
>) { $BadPorts{$p} = 1 unless defined $BadPorts{$p}; }
$UserAgentString ||= "XmlRssSimpleGen/$VERSION";
#..........................................................................
sub _hide {push @Hidies, @_ };
_hide qw(init import);
#..........................................................................
=head1 NAME
XML::RSS::SimpleGen - for writing RSS files
=head1 SYNOPSIS
# A complete screen-scraper and RSS generator here:
use strict;
use XML::RSS::SimpleGen;
my $url = q;
rss_new( $url, "eXile", "Moscow-based Alternative Newspaper" );
rss_language( 'en' );
rss_webmaster( 'xxxxx@yourdomain.com' );
rss_twice_daily();
get_url( $url );
while(
m{\s*(.*?);
rss_new( $url, "eXile" );
rss_language( 'en' );
get_url( $url );
...
does the same work as this OO code:
use XML::RSS::SimpleGen ();
my $url = q;
my $rss = XML::RSS::SimpleGen->new( $url, "eXile");
$rss->language( 'en' );
$rss->get_url( $url );
...
(Note that the function C doesn't have a leading "rss_",
so its method name is the same as its function name. It's the
one exception.)
If this talk of objects puzzles you, see
L in the C dist, and/or see
the chapter "User's View of Object-Oriented Modules"
in my book I (L).
(The book is also useful as an extended discussion of screen-scraping.)
Note: in the code below, I use the word "accessor" a lot, to refer
to a function or method that you can call two possible ways:
1) like C)> to set the "foo" attribute to the value I,
or 2) like C to return the value of the "foo" attribute.
=head1 FUNCTIONS
=over
=item C );>
=item C );>
=item C );>
=item I C<< $rss = XML::RSS::SimpleGen->new(...); >>
This function creates a new RSS feed in memory. This should be the first
C> function you call in your program. If you call it
again, it erases the current object (if any) and sets up a new one according
to whatever parameters you pass.
The parameters are the full URL, the title, and the description of the
site (or page) that you're providing an RSS feed of. The description is
optional, but you should provide at least a URL and title.
Examples:
rss_new( $url, "eXile", "Moscow-based Alternative Newspaper" );
rss_new( 'http://www.mybazouki.com/news/', "Bazouki News!" );
(As a method, XML::RSS::SimpleGen->new simply returns a new
RSS object.)
=cut
sub new {
my $class = shift;
$class = ref($class) || $class;
my $new = bless { 'items' => [] }, $class;
$new->init();
@_ and $new->url(shift);
@_ and $new->title(shift);
@_ and $new->description(shift);
$new->item_limit( 0 );
$new->retention( 32 * 24 * 60 * 60 ); # 32 days
(-e "rss.css") ? $new->css("./rss.css")
: $new->css("http://www.interglacial.com/rss/rss.css");
(-e "about_rss.html") ? $new->docs("./about_rss.html")
: $new->docs("http://www.interglacial.com/rss/about.html");
return $new;
}
sub init { return; } # override in subclass as necessary
#..........................................................................
__PACKAGE__->_accessorize(
qw(
title description url language css xsl webMaster docs
item_limit ttl
retention
allow_duplicates
image_title image_link image_url image_width image_height image_description
)
);
=item the accessor C)>
This declares what language this RSS feed is in. It must be
an RFC3066-style language tags like "en", or "en-US", or "zh-TW".
(See I for a list.)
If you don't set the feed's language, it defaults to "en", for generic English.
If you call this function without a parameter, it returns
the current value of the RSS feed's language. For example:
print "I'm making an RSS feed for ", rss_language(), "!\n";
The same is true for all the functions that I label as "accessors".
=item the accessor C)>
This sets the maximum number of items that this feed will show.
The default value is 0, meaning that there is no maximum.
If you set it to a positive number I, then the feed will show only
the first I items that you declare with C. (Or, if you set
C, then the newest I items that you declare
with C.)
If you set it to a negative number I<-N>, then the feed will show only
the last I items that you declare with C. (Or, if you set
C, then the oldest I items you declare with C,
which is unlikely to be useful!)
=item the accessor C)>
This declares what email address you, the RSS generator manager, can be
reached at. Example:
rss_webMaster( 'sburke@bazouki-news.int' );
=cut
#..........................................................................
=item C )>
This declares that you want this RSS feed to keep track of what items are
new, and to list them first when the RSS is emitted. To do this, the RSS
generator has to store information in a file, where it tracks its "history",
i.e., when was the first time it saw given URLs, and the most recent time
it saw given URLs.
Typical usage is:
rss_history_file( 'thisrssfeed.dat' );
You should call C I you make any calls to
C.
The history-file feature is meant for cases where your RSS-generator
program calls C on I link it sees, but only wants the
I links to appear in the RSS output. (This can be a good approach
if you're making an RSS feed of a page like
C where there's some new links (to the
recently added stories), but also links to some days-old stories, and
I links to some always-there things like "Archive Search" and
"Contact Us" pages.
Once you call rss_history_file, the specified file is read in. The
in-memory history (stored in the RSS object) is updated as you
call C. But the file isn't updated until you call rss_save.
(A do-what-I-mean side effect of calling C is that it
sets rss_item_limit to 25 if it is currently 0.)
(Incidentally, if you're using rss_history_file as part of a CGI that
emits RSS data, instead of a program that just saves to an RSS file,
then things will get complicated. You'll need to call an internal method
to explicitly commit the history file to disk, and you'll need a
semaphore file to avoid race conditions. Email me for full info.)
=cut
sub history_file {
my $self = shift;
return $self->{'history_file'} unless @_; # read accession
my $file = $_[0];
unless(defined $file and length $file and $file =~ m/\S/) {
DEBUG and print "Killing $self 's memory-history.\n";
# I don't know if this'd be actually useful for anything tho.
delete $self->{'history_file'};
delete $self->{'_first_seen' };
delete $self->{'_last_seen' };
return undef;
}
DEBUG and print "Considering $file as $self 's history.\n";
$self->{'history_file'} = $file;
$self->_read_history_file;
$self->item_limit( 25 ) if $DWIM and !$self->item_limit();
return $file;
}
#..........................................................................
=item C );>
=item C );>
=item C );>
This adds a new item to the current feed. You will need to specify the
URL to add (and it should be a valid-looking URL, starting with
"I", and not containing any spaces). You may also specify
the title, but it's optional. And finally, you can optionally specify a
description. (You can remember this because it starts with the essential
item first, and progresses toward the most optional.)
Leading and tailing whitespace is removed from whichever of I and I are defined values, and HTML is parsed out.
A simple usage:
rss_item(
"http://www.harpers.org/MostRecentWR.html",
"Harper's Magazine's Weekly Review"
);
Although in practice, a typical call won't have string constants, but
will instead be like the example in the L,
namely:
rss_item("$url$1", $2, $3);
Incidentally, as a do-what-I-mean feature, if the first parameter
doesn't look like a URL but one of the others does, then this error is
silently forgiven. This is so you can occasionally slip up and forget
the order of the parameters.
(In the unlikely event where you I to avoid the HTML-removal
features, you can do this by passing scalar-references instead of
normal strings, like so: C.)
=cut
sub item { # Add an item: (url, title, description)
my($self, @params) = @_;
if( grep defined($_) && length($_), @params ) {
push @{$self->{'items'}},
[
$self->_process_item_params(@params) # DWIM things happen here
]
;
DEBUG and print "Adding item ",
join("|", @{ $self->{'items'}[-1] }), "\n";
# Update history...
if( $self->{'_first_seen'} ) {
my $url = $self->{'items'}[-1][0];
my $now =
$self->{'_virgin_item_timestamp'}
? --$self->{'_virgin_item_timestamp'}
: time()
;
$self->{'_first_seen'}{$url} ||= $now;
$self->{'_last_seen' }{$url} = $now;
}
} else {
DEBUG and print "Not adding item -- empty params\n";
}
return $self;
}
#..........................................................................
=item C
This returns the number of items you've declared. I anticipate that its
main usage will be something like:
die "What, no objects found at $url ?!"
unless rss_item_count();
or, maybe...
exit unless rss_item_count();
...depending on how/whether you'd want to react to cases where you don't
see anything to put into an RSS feed.
Note that the parens are optional, since this command takes no options
(just like Perl's C function).
=cut
sub item_count { scalar @{ $_[0]->{'items'} }; }
sub items_count { shift->item_count } # harmless alias
#..........................................................................
sub _sort_items_newest_first {
my $self = shift;
my $seen = $self->{'_first_seen'};
$seen or Carp::confess(
"Can't sort items by age unless you define a history file!");
my $items = $self->{'items'} || die "NO ITEMS!?";
if( DEBUG ) {
print "\nSorting ", scalar(@$items), " items, newest first. Age dump:\n";
foreach my $i (@$items) {
if( $i->[0] ) {
printf " %s : %s (%s)\n",
$i->[0], $seen->{$i->[0]} || 0, scalar localtime(
$seen->{$i->[0]} || 0)
;
} else {
print " NOURL\n";
}
}
print " (no items)\n" unless @$items;
print "(End history dump.)\n\n";
}
@$items =
sort { ($seen->{$b->[0] ||''} ||0)
<=> ($seen->{$a->[0] ||''} ||0)
or $a->[0] cmp $b->[0] # So it's at least predictable
}
@$items;
return;
}
#..........................................................................
=item C );>
This declares that you want to declare a particular image as the logo for
this feed. Most feeds don't have such a thing, and most readers just ignore
it anyway, but if you want to declare it, this function is how. The
three parameters, which are all required, are: the image's URL, its
height in pixels, and its width in pixels.
According to various specs, the width should/must be between 1 and 144,
an the height should/must be between 1 and 400.
A typical usage:
rss_image("http://interglacial.com/rss/weebl.gif", 106, 140);
Be careful not to mix up the height and width.
=cut
sub image {
my($self, $url, $h, $w) = splice(@_,0,4);
Carp::croak "Usage: \$rss->image(\$url, \$h, \$w)"
unless $url and $h and $w
and $h =~ m/^\d{1,3}$/s
and $w =~ m/^\d{1,3}$/s
;
$self->image_url($url);
$self->image_height($h);
$self->image_width( $w);
# width must (should?) be between 1 and 144
# height must (should?) be between 1 and 400
@_ and $self->image_link( shift);
@_ and $self->image_title( shift);
@_ and $self->image_description( shift);
return;
}
#..........................................................................
=item C );>
=item C );>
This saves the RSS date to the file you specify. If the RSS data hasn't
changed, the file (and its modtime) aren't altered. The optional I
parameter means that if ever the file exists, and its content hasn't changed
for that many days or longer, then the program should die with a warning
message. For example, in the case of a screen-scraper for a site that we
know should (in theory) change its content at least weekly, we might save
the RSS file with:
rss_save("whatever.rss", 17);
# Scream if the feed is unchanged for 17 days.
The seventeen there is gotten by assuming that just maybe the site
might skip two weeks for a vacation now and then, and might even put
out the pre-vacation issue a few days early -- but that if ever the program
notices that the data hasn't changed for 17 days, then it should emit
error messages. If you want to disable this feature on a one-time basis,
just change the modtime (like via C) on the F file.
If you don't specify a C value, then this whole
complain-if-it's-old feature is disabled.
=cut
sub save {
my($self, $filename, $maxage) = @_;
Carp::croak("I need a filename to save to")
unless defined $filename and length $filename;
$self->history_file and $self->_sort_items_newest_first;
$self->_write_history_file;
my $new_content = $self->as_string;
local *RSS;
# See if we can skip writing to disk
if(-e $filename and -f _ and -r _ and -s _) {
DEBUG and print "Comparing to $filename...\n";
open RSS, $filename
or Carp::confess "Can't read-open $filename: $!"; # insanity
local $/;
my $content = ;
close(RSS);
if( $content eq $new_content ) {
DEBUG and print " $filename\'s content is the same.\n";
return $self->_check_age($filename, $maxage);
}
my $new_content_without_builddate = $new_content;
foreach my $c ($new_content_without_builddate, $content) {
$c =~ s{.*?}{};
$c =~ s{.*?}{};
$c =~ tr{\n\r}{}s; # And smash newlines while we're at it...
}
if( $content eq $new_content_without_builddate ) {
DEBUG and print " $filename\'s content is the same, basically.\n";
return $self->_check_age($filename, $maxage);
}
DEBUG and print " $filename\'s content is stale. Overwriting.\n";
}
DEBUG and print "Writing to $filename ...\n";
# OK, we have to actually write it. Let's do it fast.
open(RSS, ">$filename")
or Carp::confess "Can't write-open $filename: $!\nAborting";
print RSS $new_content
or Carp::confess "Can't print to $filename: $!\nAborting";
close(RSS)
or Carp::confess "Can't close $filename: $!\nAborting";
eval { chmod 0644, $filename };
DEBUG and print "Done writing to $filename\n";
return 1;
}
#..........................................................................
=item C
This returns the RSS-XML data as a string. This function is called
internally by the rss_save function; but you might want to call it
explicitly, as in a CGI, where your CGI would probably end like this:
print "Content-type: application/xml\n\n", rss_as_string();
exit;
=cut
sub as_string {
my $self = $_[0];
my $namespaces = $self->_namespaces_as_string;
return join '' =>
qq{\n},
($DTD_pubid and $DTD_url)
? qq{\n} : (),
$self->css ? ( # http://www.w3.org/TR/xml-stylesheet/
qq{xmlesc($self->css),
qq{"?>\n}
) : (),
$self->xsl ? (
qq{xmlesc($self->xsl),
qq{"?>\n}
) : (),
qq{},
$self->_modversion_comment,
$self->_various_comments,
$self->_metadata_as_xml,
$self->_items_as_xml,
"\n\n",
;
}
sub _namespaces_as_string {
my $self = $_[0];
my $ns = $self->{'_namespaces'};
return '' unless $ns and keys %$ns;
return
join '', "\n",
map qq{ xmlns:$_="$$ns{$_}"\n},
sort keys %$ns
;
}
#..........................................................................
sub _metadata_as_xml {
my $self = $_[0];
my($url, $title, $description) = (
map defined($_) ? $_ : '',
$self->url, $self->title, $self->description,
);
if($DWIM) {
# tolerate switching the description/title and the URL
if($url !~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "URL \"$url\" looks fishy...\n";
if( $title =~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "Swapping with title \"$title\"\n";
($url, $title) = ($title, $url);
$self->url($url);
$self->title($title);
} elsif( $description =~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "Swapping with description \"$description\"\n";
($url, $description) = ($description, $url);
$self->url($url);
$self->description($description);
} else {
Carp::croak( "Invalid URL \"$url\" in metadata "
. ($title||$description||"???") . "\nAborting"
);
}
}
}
my $lang = $self->language;
$lang and $lang =~ tr[_][\-]; # tolerate underscores
$lang = 'en' unless defined $lang
# From I18N::LangTags...
and $lang !~ m/^[iIxI]$/s
and $lang =~
m/^(?: # First subtag
[xiIX] | [a-zA-Z]{2,3}
)
(?: # Subtags thereafter
- # separator
[A-Za-z0-9]{1,8} # subtag
)*
$/xs
;
return join '', sprintf( qq{
%s
%s
%s
%s
%s
},
map( $self->html2text($_),
$url || '!!!!DummyURL!!!!',
$title || $description || $url || '!!!!DummyTitle!!!!',
$description || $title || $url || '!!!!DummyDescription!!!!',
),
$lang,
$self->_date_rfc822(),
),
grep $_,
$self->{"skipHours"},
$self->{"skipDays"},
$self->_sy_update_as_xml,
(($self->{"ttl"} || '') =~ m/^(\d+)$/s) && "$1\n",
$self->webMaster &&
("" . $self->html2text($self->webMaster) . "\n"),
$self->docs &&
("" . $self->html2text($self->docs) . "\n"),
$self->_image_as_xml,
$self->{'more_metadata'}, # a hack for sneaking in more things
;
# ...with sanity-checkers
}
#..........................................................................
sub _process_item_params {
my $self = shift;
my($url, $title, $description) =
map {; (defined($_) && m/\S/) ? $_ : '' } # contentfulness filter
map $self->html2text($_), # here's where we de-htmlify things
@_;
;
for($url, $title, $description) {
if(ref $_ ) { } # Okay
elsif(defined $_) { s/^\s+//s; s/\s+$//s }
else { $_ = '' }
}
# Tolerate switching the description/title and the URL
if($DWIM and $url !~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "URL \"$url\" looks fishy...\n";
if( $title =~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "Swapping with title \"$title\"\n";
($url, $title) = ($title, $url);
} elsif( $description =~ m{^[a-z]+[a-z0-9]*:\S+$}s) {
DEBUG and print "Swapping with description \"$description\"\n";
($url, $description) = ($title, $description);
} else {
Carp::confess( "Invalid URL \"$url\" in item "
. ($title||$description||"???") . "\nAborting"
);
}
}
return ($url, $title, $description);
}
#..........................................................................
sub _items_as_xml {
my $self = $_[0];
my @items;
my @xml_out = ($MaybeNL);
if( $self->allow_duplicates ) {
@items = @{ $self->{'items'} || die "NO ITEMS!?!?" };
} else {
my %seen;
foreach my $i (@{ $self->{'items'} || die "NO ITEMS!?!?" }) {
if( $seen{ $i->[0] } ++ ) {
DEBUG and print "Removing duplicate item @$i\n";
} else {
push @items, $i;
}
}
}
my $item_limit = int( $self->item_limit || 0 );
if($item_limit) {
if(@items > abs($item_limit)) {
if($item_limit > 0) { # like 4 to mean just the first 4
DEBUG and print " Killing all but the first $item_limit items.\n";
splice @items, $item_limit;
} else { # like -4 to mean just the last 4
DEBUG and print " Killing all but the last ", 0-$item_limit, " items.\n";
splice @items, 0, @items + $item_limit;
# So if item_limit is -3 and @items has 10 elements,
# then that number will be 7, i.e., to chop the first 7
# elements, leaving the last 3.
}
}
}
DEBUG and print scalar(@items), " items at hand:\n";
foreach my $i (@items) {
my($url, $title, $description) = @$i;
DEBUG > 1 and print "I: (u $url) (t $title) (d $description)\n";
next unless $url or $title or $description;
push @xml_out,
"- $MaybeNL",
(map "$MaybeIndent$_$MaybeNL",
length($title) ? "$title" : (),
length($url) ? "$url" : (),
length($description) ? "$description" : (),
),
"
$MaybeNL\n",
}
DEBUG and print "_items_as_xml returning {\n", join('', @xml_out), "}\n\n";
return join '', @xml_out;
}
#..........................................................................
sub _image_as_xml {
my $self = shift;
return '' unless
$self->image_url and $self->image_height and $self->image_width;
#
return join '',
"\n",
map(" $_\n" =>
$self->xmlelem( 'title' => $self->image_title || $self->html2text($self->title)),
$self->xmlelem( 'url' => $self->image_url), # url of the image
$self->xmlelem( 'link' => $self->image_link || $self->html2text($self->url )),
$self->xmlelem( 'width' => $self->image_width),
$self->xmlelem( 'height' => $self->image_height),
$self->xmlelem( 'description'
=> $self->image_description
|| $self->html2text($self->description)),
),
"\n",
;
}
#==========================================================================
=item C );>
=item C<$content = get_url( I );>
=item I C<< $content = $rss->get_url(...); >>
=item I C<< $content->get_url(...); >>
This tries to get the content of the given url, and returns it.
This is quite like L's C function, but with some
additional features:
=over
=item * If it can't
get the URL's content at first, it will sleep for a few seconds and try
again, up to about five times. (This is to avoid the case of the URL
being temporarily inaccessible simply because the DNS is a bit slow,
or because the server is too busy.)
=item * If it can't get the content, even after several retries,
it will abort the program (like a C). If you want to override this
behavior, then call it as C
=item * If you call the function in void context (i.e., not using its
return value), then the function assigns the URL's content to C<$_>.
That's so you can write nice concise code like this:
get_url $thatsite;
m/Top Stories Tonight/ or die "What, no top stories?";
while( m{(.*?)}g ) {
rss_item("$thatsite/$1", $2);
}
=item * This returns the content of the URL not exactly as-is, but after
changing its newlines to native format. That is, if the contents of the
URL use CR-LF pairs to express newlines, then C changes these
to C<\n>'s before returning the content. (Similarly for old MacOS
newline format.) Clearly this is wrong in you're dealing with binary
data; in that case, use LWP::Simple's C directly.
=item * Finally, as a resource-conversation measure, this function
will also try to call C a few times if it sees several quick
calls to itself coming from a program that seems to be running
under crontab. As most of my RSS-generators are crontabbed, I
find it very useful that I can have however many C's in
my crontabbed programs without worrying that they'll take even a
noticeable part of the server's bandwidth.
=back
=cut
my $last_url_get_time;
sub get_url ($) {
my $self = shift if @_ > 1; # work as a function or method
# Go whip up an object unless one was given:
$self = ($RSS_obj ||= XML::RSS::SimpleGen::->new) unless defined $self;
$self = $self->new unless ref $self;
my $url = $_[0];
Carp::croak "\"$url\" doesn't look like a URL!\nAborting"
unless defined($url) and $url =~ m{^[a-z]+[a-z0-9]*:\S+$}s;
if($Sleepy and $last_url_get_time) {
my $delay = $Sleepy - (time() - $last_url_get_time);
if( $delay > 0 ) {
DEBUG and print "Last URLget was at $last_url_get_time, sleep $delay\n";
sleep $delay;
} else {
DEBUG and print "Last URLget was at $last_url_get_time, so no sleep.\n";
}
}
my $content;
my $count = 0;
foreach my $delay (@Retry_delays, 0) {
delete $self->{'_loops'};
delete $self->{'_http_abort'};
DEBUG and print "Getting $url ...\n";
++$count;
if( defined(
$content = $self->_get($url)
)) {
DEBUG and print "OK, got it (", length($content), " bytes)\n";
last;
}
if( $self->{'_http_abort'} ) {
DEBUG and print "Couldn't get it and won't retry (",
$self->{'_http_abort'}, ")\n";
last;
} else {
DEBUG and print "Odd, couldn't get it.\n";
}
if($delay) { DEBUG and print "Sleeping $delay sec...\n"; sleep $delay; }
}
$last_url_get_time = time();
unless( defined $content ) {
my $headers = $self->{'_http_headers'};
if( $headers and $headers =~ s{^}{ }mg ) {
$headers = "\nResponse headers:\n$headers";
} else {
$headers = '';
}
$count .= ($count == 1) ? " try" : " tries";
Carp::croak("Couldn't get $url in $count$headers\nSo, aborting")
}
if($Nativize_newlines) {
if("\n" eq "\cj") { # CR => LF CR LFLF... => LF LF => LF
$content =~ s/\cm\cj*/\n/g; # most efficient, I dare say
} elsif("\n" eq "\cm") { # CR => CR CR LFLF... => CR LF => CR
$content =~ s/(?:(?:\cm\cj+)|\cj)/\n/g;
} else {
$content =~ s/(?:\n|\r|\n\r)/\n/g;
}
}
$_ = $content unless defined wantarray;
return $content;
}
#==========================================================================
# Things below here are less and less interesting to the casual reader.
#==========================================================================
sub _get {
my $self = shift;
if(
!$LWP::Simple::VERSION
and $_[0] =~ m{^http://([^ \n\r\t/:\@]+)(?::(\d+))?(/\S*)?$}
) {
my $host = $1;
my $path = $3;
my $port = 0 + ($2 || 80);
if( $BadPorts{$port} ) {
DEBUG and print "We don't like port $port from $_[0]\n";
return undef;
}
$path = "/" unless defined($path);
$self = $self->new unless ref($self); # need to be an object method
return $self->_trivial_http_get($host, $port, $path);
} else {
return $self->_lwp_get(@_);
}
}
sub _lwp_get {
require LWP::Simple;
DEBUG and print "Calling LWP::Simple on $_[1]\n";
return LWP::Simple::get($_[1]);
}
sub _trivial_http_get {
my($self, $host, $port, $path) = @_;
DEBUG > 1 and print "Getting HOST=$host, PORT=$port, PATH=$path\n";
$self = $self->new unless ref($self); # need to be an object method
my $seen = ( $self->{'_loops'} ||= {} );
require IO::Socket;
local($^W) = 0;
my $sock = IO::Socket::INET->new(PeerAddr => $host,
PeerPort => $port,
Proto => 'tcp',
Timeout => 60) || return undef;
$sock->autoflush;
my $netloc = $host;
$netloc .= ":$port" if $port != 80;
print $sock join("\015\012" =>
"GET $path HTTP/1.0",
"Host: $netloc",
"User-Agent: $UserAgentString",
"", "");
my $buf = "";
my $n;
while( $n = sysread($sock, $buf, 8*1024, length($buf)) ) {
DEBUG > 10 and print " Got $n bytes...\n";
1;
}
return undef unless defined($n);
if( $buf =~ m{^HTTP/\d+\.\d+\s+(\d+)[^\012]*\012} ) {
my $code = $1;
DEBUG and print " Got HTTP status: $code\n";
if( $code =~ m/^30[1237]/s and $buf =~ m/\012Location:\s*(\S+)/ ) {
# Redirection
my $url = $1;
if( $url =~ m/^(file|mailto):/ # protocols we hate
or $seen->{$url}++
or scalar(keys %$seen) > 20
) {
DEBUG and print "I don't like the redirection response $url\n";
$self->{'_http_abort'} = "Bad HTTP-redirection loop.";
return undef;
}
return $self->_get($url); # Recurse!
}
$buf =~ s/(.+?)\015?\012\015?\012//s; # zap the header
( $self->{'_http_headers'} = $1 ) =~ tr/\015\012/\n/sd;
DEBUG > 10 and print "Headers: $$self{'_http_headers'}\n";
$self->{'_http_abort'} = "HTTP status $code"
if $code eq '404' or $code eq '403';
return undef unless $code =~ m/^2/;
DEBUG and print "Returning ", length($buf), " bytes of content.\n";
} else {
DEBUG and print "Got a headerless response. Returning.\n";
}
return $buf;
}
#==========================================================================
sub _read_history_file {
my $self = $_[0];
my $hf = $self->history_file;
unless(defined $hf and length $hf) {
DEBUG and print "No history_file defined for $self.\n";
return;
}
my(%first, %last); # "last" in the sense of "most recently"
$self->{'_first_seen'} = \%first;
$self->{'_last_seen' } = \%last ;
unless( -e $hf and -s _ ) {
$self->{'_virgin_item_timestamp'} = time() if $DWIM;
return 0;
}
my $now = time();
my $forget_before;
my $in;
{
local *IN;
open(IN, $hf) or Carp::confess "Can't read-open $hf: $!"; # insane
$in = *IN{IO};
}
local $_;
my @f;
while(<$in>) {
tr/\n\r//d;
next unless @f = split "\t", $_, 3 and defined($f[0]) and length($f[0]);
$last{$f[0]} = $f[2] if $f[2];
if( $f[1] ) {
$first{$f[0]} = $f[1];
DEBUG > 3 and print " Learning $f[0] first seen at $f[1]\n";
} else {
$first{$f[0]} = $now;
DEBUG > 3 and print " Prelearning $f[0] first seen at $f[1]\n";
# TODO: is this useful?
}
}
close($in);
return 1;
}
# . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
sub _write_history_file {
my $self = $_[0];
my $hf = $self->history_file;
unless(defined $hf and length $hf) {
DEBUG and print "No history_file defined for $self.\n";
return;
}
my $first = $self->{'_first_seen'};
my $last = $self->{'_last_seen' };
my $now = time();
my $out;
DEBUG and print "Saving to history file $hf\n";
DEBUG > 2 and printf "Time now: %s = %s\n", time(), scalar(localtime);
{
local *HF;
open(HF, ">$hf") or Carp::confess "Can't write-open $hf: $!"; # insane
$out = *HF{IO};
}
{
my(@f, @x);
{
my %x;
@x{keys %$first, keys %$last} = ();
@x = sort keys %x;
}
my $forget_before;
{
my $r = $self->retention;
if( $r and $r > 0 ) { $forget_before = time() - $r }
}
foreach my $key (@x) {
next if $key =~ m/[\t\n\r]/;
if( $forget_before and $last->{$key} < $forget_before ) {
DEBUG and printf(
" Forgetting %s as being too old since last-seen (%s = %s)\n",
$key,
$last->{$key},
scalar(localtime($last->{$key})),
);
next;
}
print $out $key, "\t",
$first->{$key}||'', "\t",
$last->{$key}||'', "\n",
;
if(DEBUG > 2) {
printf " Key %s\n First seen: %s = %s\n Last seen: %s = %s\n",
$key,
$first->{$key}||'-',
scalar(localtime( $first->{$key}||0 )),
$last->{$key}||'-',
scalar(localtime( $last->{$key}||0 )),
}
}
close($out);
}
DEBUG and print "Done saving to $hf\n";
return 1;
}
#-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_-_
=item C I C I C
I C I C I C
Calling one of these functions declares that this feed is usually
generated at the same time(s) every day (or every week, in the case of
C). And, where it's not just once a day/week, these multiple
times a day are evenly spaced. These functions then set the feed's
C, C, C, C,
C, and C elements appropriately, so that RSS readers can know at
at what times there could (or couldn't) be new content in this feed.
In other words: use C if this feed is updated at about the
same time every day and then again 12 hours later. Use C
if this feed is updated at the same time daily, and then 8 hours later, and
then 8 hours later. And use C if the feed updates
at about I minutes past every even numbered hour, or every odd-numbered
hour.
Clearly I mean these functions to be used in programs that are crontabbed
to run at particular intervals, as with a crontab line like one of these:
52 * * * * ~/thingy # => rss_hourly
52 23 * * * ~/thingy # => rss_daily
52 4,16 * * * ~/thingy # => rss_twice_daily
52 5,13,21 * * * ~/thingy # => rss_thrice_daily
52 23 * * 3 ~/thingy # => rss_weekly
52 */2 * * * ~/thingy # => rss_every_other_hour
Clearly there aren't C> functions for all the scheduling
possibilities programs -- if you have a program that has to run at
6am, 8am, 1pm, and 4pm, there's no function for that. However, the above
crontab lines (or with minor changes, like C<1,9,17> instead of C<5,13,21>)
are just fine for almost every RSS feed I've run.
An aside: I recommend running the programs at about 52 minutes past the hour,
generally in series, like so:
52 5,13,21 * * * ~/thingy ; ~/dodad ; ~/makething ; ~/gizmo
However, your mileage may vary.
Incidentally, these functions take no arguments, so the parentheses are
optional. That is, these two lines do the same thing:
rss_hourly;
rss_hourly();
=cut
## Some handy if somewhat arbitrary shortcuts:
#
sub hourly {
my $self = $_[0];
$self->updatePeriod('hourly');
$self->ttl('60');
return;
}
sub daily {
my $self = $_[0];
$self->updateHours();
$self->updatePeriod('daily');
$self->ttl( 24 * 60 );
return;
}
sub twice_daily {
my $self = $_[0];
my $h = (gmtime( $self->_now_rounded_up ))[2];
$self->updateHours( $h, ($h+12) % 24 );
$self->updatePeriod('daily',2);
$self->ttl( 12 * 60 );
return;
}
sub thrice_daily {
my $self = $_[0];
my $h = (gmtime( $self->_now_rounded_up ))[2];
$self->updateHours( $h, ($h+ 8) % 24, ($h+16) % 24 );
$self->updatePeriod('daily',3);
$self->ttl( 8 * 60 );
return;
}
sub weekly {
my $self = $_[0];
$self->updateHours();
$self->updateDays();
$self->updatePeriod('weekly',1);
$self->ttl( 7 * 24 * 60 );
return;
}
{
my(@odds, @evens);
for(0 .. 23) { push @{ ($_ & 1) ? \@odds : \@evens }, $_ }
sub every_other_hour {
my $self = $_[0];
my $h = (gmtime( $self->_now_rounded_up ))[2];
$self->skipHours( ($h & 1) ? @evens : @odds);
$self->updatePeriod('daily',12);
$self->ttl( '120' );
return;
}
}
#..........................................................................
my @day_names = (
"Sunday", "Monday", "Tuesday", "Wednesday", "Thursday", "Friday", "Saturday",
);
my %is_day_name;
@is_day_name{@day_names} = @day_names;
#..........................................................................
sub _now_rounded_up {
my $self = $_[0];
my $now = $_[0]{'_force_now'} # to be used only for testing purposes
|| time();
if( $CHUNK_MINUTES ) {
my $tweak = ($CHUNK_MINUTES * 60) - ($now % ($CHUNK_MINUTES * 60));
DEBUG and print "Tweaking $now (", scalar(gmtime($now)),
" GMT) by $tweak seconds\n so it'll be an even $CHUNK_MINUTES minutes: ";
$now += $tweak;
DEBUG and print "$now (", scalar(gmtime($now)), " GMT)\n";
} else {
# probably not a good idea
DEBUG and print "Archoring timebase to right this moment.\n";
}
return $now;
}
sub _now { return $_[0]{'_force_now'} || time() }
#..........................................................................
=back
=head2 MINOR FUNCTIONS
These are functions that you probably won't need often, or at all. I include
these for the sake of completeness, and so that advanced users might find them
useful in some cases.
=over
=item C );>
This function directly sets the C element's values to the
specified GMT hour numbers.
=cut
sub skipHours {
my($self, @in) = @_;
my @skiphours;
foreach my $hour (@in) {
next unless defined $hour;
Carp::croak "\"$hour\" isn't a valid hour number (must be 0-23)"
unless $hour <= 24 and $hour >= 0;
push @skiphours, ($hour == 24) ? 0 : (0 + $hour);
# tolerate "24" to mean 0h.
}
DEBUG and print "Skipdays: @skiphours\n";
$self->{'skipHours'} = join '',
"", map( "$_", @skiphours), "\n"
;
return;
}
#--------------------------------------------------------------------------
=item C
=item C );>
This function is a wrapper around C -- you call
C with a list of GMT hour numbers, and
C will call C except I
whatever hour numbers you specified.
If you call with an empty list (i.e., C), then
we uses C to find out the current hour (and rounds it up
if it's after 50 minutes past), basically just as if you'd called:
rss_updateHours( (gmtime(600+time()))[2] );
=cut
sub updateHours { # Just the complement of skipHours.
# Feeding it () means updates only at this hour of day
# (This is fine since you'd never mean to actually declare
# a feed whose updateHours is never, i.e. whose skipHours
# is all of 0-23)
my $self = shift;
my %hours;
@hours{ @_ ? (map $_+0, @_) :
( gmtime( $self->_now_rounded_up ) )[2] } = ();
# might as well count 10:57 as 11h, etc
DEBUG and print "HOURS UPDATEY :", join(' ', sort keys %hours), "\n";
$self->skipHours( grep !exists($hours{$_}), 0 .. 23 );
return;
}
#..........................................................................
=item C
=item C );>
=item C );>
This function directly sets the C element's values to the
specified weekdays. Note that this accepts either integers (like
6 for Saturday, Sunday being either 0 or 7), or their exact
English names.
If you use the C field, consider that it refers to days
figured by GMT, not local time. For example, if I say to skip Saturdays,
that means Saturdays GMT, which in my timezone (Alaska) starts
in the middle of Friday afternoon.
=cut
sub skipDays {
my($self,@in) = @_;
my @skipdays;
foreach my $day (@in) {
next unless defined $day;
if($day =~ m/^[0-7]$/s) { # tolerate numeric day specs
$day = 0 if $day == 7;
$day = $day_names[$day]
|| Carp::croak "Day number \"$day\" is out of range (0-6)";
} else {
Carp::croak "\"$day\" isn't a valid day name (use 0-6 or one of: @day_names)"
unless $is_day_name{$day};
}
push @skipdays, $day;
};
DEBUG and print "Skipdays: @skipdays\n";
$self->{'skipDays'} = join '',
"", map( "$_", @skipdays), "\n"
;
return;
}
#..........................................................................
=item C
=item C );>
=item C );>
This function is a wrapper around C -- you call
C with a list of GMT day names/numbers, and
C will call C except I
whatever days you specified.
If you call with an empty list (i.e., C), then
we uses C to find out the current day (GMT!), basically
just as if you'd called:
rss_updateDays( (gmtime(600+time()))[6] );
=cut
sub updateDays { # just the complement of skipDays
# Feeding it () means updates only at this day of the week
# (This is fine since you'd never mean to actually declare
# a feed whose updateDays is never, i.e., whose updateDays
# is all of Monday thru Sunday)
my $self = shift;
my %days;
@days{
map {;
m/^[0-7]$/ ? $day_names[ ($_ == 7) ? 0 : $_ ]
: $is_day_name{$_} ? $_
: Carp::croak "\"$_\" isn't a valid day name (use 0-6 or one of: @day_names)"
}
@_ ? @_ : ( gmtime( $self->_now_rounded_up ) )[6]
} = ();
DEBUG and print "DAYS UPDATEY :", join(' ', sort keys %days), "\n";
$self->skipDays( grep !exists($days{$_}), @day_names );
return;
}
#--------------------------------------------------------------------------
=item C );>
This function directly sets the C element's value to the
period specified. You must specify one of the strings:
"yearly", "monthly", "weekly", "daily", "hourly".
I advise using "weekly" only if you know what you're doing, and
"yearly", "monthly" only if you I know what you're doing.
=item C, I, I );>
This is a shortcut for
C<<
rss_updatePeriod(I); rss_updateFrequency(I)
>>
=item C, I, I );>
This is a shortcut for
C<<
rss_updatePeriod(I); rss_updateFrequency(I);
rss_updateBase(I)
>>
=cut
sub updatePeriod {
return $_[0]->{'updatePeriod'} if @_ == 1;
# Else we're a write accessor:
my($self, $period) = @_;
$period or Carp::confess(
"What period? yearly/monthly/weekly/daily/hourly?");
if($period =~ m/^(yearly|monthly|weekly|daily|hourly)$/s) {
$self->{'updatePeriod'} = $period;
$self->updateFrequency($_[2]) if @_ > 2;
$self->updateBase($_[3]) if @_ > 3;
$self->{'_namespaces'}{'sy'} = $NAMESPACE_SY;
return $period;
} else {
Carp::confess(
"What kind of period is \"$period\"? Use one of: yearly|monthly|weekly|daily|hourly");
}
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
=item C );>
=item C );>
This function directly sets the C element's value to the
moment specified. If you pass in an epoch time, it is converted to
an ISO date string.
=cut
sub updateBase {
return $_[0]->{'updateBase'} if @_ == 1;
# Else we're a write accessor:
my($self, $then) = @_;
if( $then =~ m/^-?\d+$/s ) {
$self->{'updateBase'} = $self->_epoch2isodate($then);
} elsif ( $then =~ # basically ISO8601
m<^
\d\d\d\d # year
(?:
-\d\d # month
(?:
-\d\d # day
(?:
T\d\d:\d\d # hh:mm
(?:
:\d\d # seconds
(?:
\.\d+ # fractions of a second
)?
)?
(?: # TZ offset
Z # Zulu
|
(?: # or by offset:
[-+]
\d\d:\d\d # hh:mm, with leading '+' or '-'
)
)?
)?
)?
)?
# The month was optional, but that
# makes "1994" ambiguous -- a year or an epoch time?
# I doubt anyone wants to write 2000,
# esp as the default is basically == 1970.
$
>sx
) {
$self->{'updateBase'} = $then;
} else {
Carp::confess("What kind of updateBase is \"$then\"?");
}
return $self->{'updateBase'};
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
sub _epoch2isodate {
my($self, $time) = @_;
my(@timelist) = gmtime($time);
++$timelist[4];
$timelist[5] += 1900;
return sprintf("%04d-%02d-%02dT%02d:%02d+00:00",
@timelist[ 5, 4, 3 , 2 ,1 ]);
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
%PeriodAsSeconds = (
'hourly' => 60 * 60,
'daily' => 60 * 60 * 24,
'weekly' => 60 * 60 * 24 * 7,
);
sub _updateBase_init {
# What to do? Peg it on now plus Interval, rounded up to next M-minute interval?
my $self = $_[0];
my $now = $self->_now_rounded_up;
my $period_type = $self->updatePeriod;
if( $period_type eq 'monthly' or $period_type eq 'yearly') {
$now = $self->_epoch2isodate( $now );
if($period_type eq 'yearly') {
$now =~ s/^....-/2000-/s || die "SPORK93931!"; # sanity
} elsif($period_type eq 'monthly') {
$now =~ s/^....-..-/2000-01-/s || die "SPORK35286!"; # sanity
} else {
die "SPORK!!!!!94829045"; #sanity
}
DEBUG > 1and print "Using $now as updateBase.\n";
} else {
# It's a plain ol' interval.
DEBUG > 1 and print "Slapping $now (", gmtime($now). " into 1970.\n";
my $freq = $self->updateFrequency();
my $interval_as_seconds = int(
($PeriodAsSeconds{$period_type} ||die "SPORK84258 on '$period_type'!")
/ $freq)
;
DEBUG > 1 and print
"So, $freq times $period_type is $interval_as_seconds seconds...\n";
$now %= $interval_as_seconds;
DEBUG > 1 and print "Using $now (", gmtime($now). " as updateBase.\n";
}
$self->updateBase($now);
return;
}
# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
=item the accessor C );>
This function directly sets the C element's value to the
value specified. The value has to be a nonzero positive integer.
For example, this means that this feed updates at/by the start of every hour
and 30 minutes past:
rss_updateBase('2000-01-01T00:00-00:00');
rss_updateFrequency(2);
rss_updatePeriod('hourly'); # 2*hourly means "twice an hour"
Recall that this can also be done with the
the C, I, I )> shortcut, like so:
rss_updateBase('hourly', 2, '2000-01-01T00:00-00:00');
=cut
sub updateFrequency { # simple accessor, plus the int() thing
if(@_ > 1) {
$_[0]->{'updateFrequency'} = int($_[1]) || 1;
} else {
$_[0]->{'updateFrequency'}
}
}
sub _updateFrequency_init { $_[0]->{'updateFrequency'} ||= 1 }
#--------------------------------------------------------------------------
sub _sy_update_as_xml {
my $self = $_[0];
return '' unless $self->{'updatePeriod'};
$self->_updateFrequency_init();
$self->_updateBase_init();
return sprintf(
q{%s
%s
%s
},
$self->updateFrequency,
$self->updatePeriod,
$self->updateBase,
);
}
#--------------------------------------------------------------------------
# Aliases:
sub skip_hours {shift->skipHours( @_)}
sub skip_days {shift->skipDays( @_)}
sub update_days {shift->updateDays( @_)}
sub update_hours {shift->updateHours( @_)}
sub update_period {shift->updatePeriod( @_)}
sub update_base {shift->updateBase( @_)}
sub update_frequency {shift->updateFrequency( @_)}
sub webmaster {shift->webMaster( @_)}
#--------------------------------------------------------------------------
=item the accessor C)>
If you are using an C)>, the history file will
accrete a list of all URLs it has seen. But to keep this file from potentially
getting immense, items that haven't been seen for a while are thrown out.
The period of time a feed's items go unseen before each is forgotten is
called that feed's B, and is expressed in seconds.
The default retention value is 32 days (i.e., 32*24*60*60, the number
of seconds in 32 days). If you wanted to change it to just a week,
you would do this with C.
As a special case, a zero or negative value for the retention means
to never clear anything from the history file, no matter how long
it has gone unseen.
=cut
#..........................................................................
=item C );>
Call this function if you want to add extra XML comments to this RSS file.
For example, if you call this:
rss_add_comment(
"Our terms of use: http://wherever.int/rsstou.html",
"Any questions? Ask jimmy@wherever.int",
);
...then this RSS feed will contain this XML fairly early on in the file:
=cut
sub add_comment {
my $self = shift;
foreach my $c (@_) {
push @{ $self->{'_comments'} }, $c
if defined $c and length $c and $c =~ m/\S/;
# no point in having contentless comments
}
return;
}
#--------------------------------------------------------------------------
=item the accessor C )>
This defines the given URL as being the XML-CSS stylesheet for this RSS
feed. The default value is "./rss.css" if C<-e "rss.css"> is true, otherwise
is the value http://www.interglacial.com/rss/rss.css
=item the accessor C )>
This defines the given URL as being the XML-XSL stylesheet for this RSS
feed. The default value is none.
=item The accessors
C<<
rss_url( I ), rss_title( I ), rss_description( I )
>>
These define this feed's URL, title, and description. These functions
are just for completeness, since it's simpler to just specify any/all of
these parameters in the call to C.
=item the accessor C )>
This sets the parameter of this RSS feed's C element, which
suggests how long (in minutes, not seconds!) an RSS reader should wait after it polls
a feed until it polls it again. For example, C would suggest
that a reader should not poll this feed more often than every 90 minutes.
(This element is somewhat obsolescent next to the newer and more
informative C elements, but is included for backward
compatability.)
=item the accessor C )>
This controls whether or not duplicate items are filtered out out the
feed. By default this is I. Note that duplicates are detected only
by their URL, so if you call this:
rss_item('http://foo.int/donate', "Give!");
rss_item('http://foo.int/donate', "We need money!");
rss_save('begging.rss');
...then only the first will appear in the feed, since the second item
has a URL that is already being saved in this feed. (However,
C is still 2, because filtering out duplicates is
something that only happens as the feed is saved.)
=item the accessor C )>
This sets the value of the not-generally-useful C RSS element.
The default value is "./about_rss.html" if C<-e "about_rss.html"> is
true, otherwise "http://www.interglacial.com/rss/about.html".
=item the accessors
C<<
rss_image_url(I), rss_image_width(I),
rss_image_height(I),
rss_image_title(I), rss_image_link(I),
rss_image_description(I)
>>
These are for manually setting the values of this feed's image element's
subelements:
(rss_image_url)
(rss_image_width)
(rss_image_height)
(rss_image_title)
(rss_image_link)
(rss_image_description)
You rarely need to call any of these C> functions --
usually just calling C );> is enough.
=cut
#..........................................................................
my @DoW = qw(Sun Mon Tue Wed Thu Fri Sat);
my @Month = qw(Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
sub _date_rfc822 {
my $self = shift;
my @timelist = (@_ == 0) ? gmtime : (@_ == 1) ? gmtime($_[0]) : @_;
$timelist[5] += 1900;
return sprintf(
"%s, %02d %s %04d %02d:%02d:%02d GMT",
$DoW[$timelist[6]],
$timelist[3],
$Month[$timelist[4]],
@timelist[5, 2,1,0],
);
}
sub _check_age {
my($self, $filename, $maxage) = @_;
my $age;
if($filename and $maxage and $maxage < ($age = -M $filename)) {
Carp::carp(
sprintf "%s warning - %s is getting old -- it hasn't changed in %0.1f days!",
ref($self) || $self,
$filename,
$age,
);
}
return 0;
}
#..........................................................................
sub _various_comments {
my $self = $_[0];
my $x;
return
join '',
map {; $x = $_; $x =~ s/--/__/g; "\n"; }
@{ $self->{'_comments'} || [] }
;
}
#..........................................................................
sub _modversion_comment {
my $self = $_[0];
my $selfclass = ref($self);
my $v = eval { $selfclass->VERSION } || $VERSION;
return "\n\n";
}
#..........................................................................
sub _accessorize { # A simple-minded method-maker
no strict 'refs';
foreach my $attrname (@_) {
next if $attrname =~ m/::/; # a hack
*{caller() . '::' . $attrname} = sub {
use strict;
unless((@_ == 1 or @_ == 2) and ref $_[0] ) {
$Carp::CarpLevel = 1;
Carp::croak(
"Accessor usage: \$obj->$attrname() or \$obj->$attrname(\$new_value)"
);
}
(@_ == 1) ? $_[0]->{$attrname}
: ($_[0]->{$attrname} = $_[1]);
};
}
# Ya know, they say accessories make the ensemble!
return;
}
#..........................................................................
sub xmlesc {
my $self = shift;
my $out = join '', @_;
$out =~ s<([^\x20\x21\x23\x24\x25\x27-\x3b\x3d\x3f-\x7e])>
<$CommonEnts{$1} || ('&#'.(ord($1)).';') >seg;
return $out;
}
sub xmlelem {
my $self = shift;
my $gi = shift;
return "<$gi>" . $self->xmlesc(@_) . "";
}
#..........................................................................
sub html2text {
# A rudimentary HTML tokenizer, adapted and simplified
# from Gisle Aas's HTML::Parser v2.25...
local $_;
my($self, @out);
($self, $_) = @_;
return undef unless defined $_;
return $$_ if ref($_) eq 'SCALAR'; # Pass a scalar ref to bypass!
return '' unless length $_;
if( m/^[\x00-\x7e]+$/s and ! m/[<>&]/s) {
# Most common case: a simple string needing no HTML parsing.
# So just compact and trim whitespace, and move on.
tr/\n\r\f\t / /s;
s/ $//s;
s/^ //s;
return $_;
}
while( length($_) ) {
if ( s@^([^&<]+)@@s) { # Any plaintext
DEBUG > 5 and print ":: Plaintext {$1}\n";
push @out, $1;
} elsif ( s@^
(
&\#
(?:
(?: # dec
([0-9]{1,7})
)|(?: # or hex
[xX]([0-9a-fA-F]{1,7})
)
)
)
\b
;?
@@sx
) {
DEBUG > 5 and print ":: Numeric ent {$1}",
defined($2) ? " (dec $2)"
: defined($3) ? " (hex $3)"
: " (weird!)",
"\n";
if( defined $3 and exists $WinLameEntities{hex($3)} ) {
# it's a winlame ent, in hex
DEBUG > 6 and print " Correcting that to &#$WinLameEntities{hex($3)};\n";
push @out, \"&#$WinLameEntities{hex($3)};" ;
} elsif( defined $2 and exists $WinLameEntities{0 + $2} ) {
# it's a winlame ent, in decimal
DEBUG > 6 and print " Correcting that to &#$WinLameEntities{0 + $2};\n";
push @out, \"&#$WinLameEntities{0 + $2};" ;
} else {
# it's a normal entity
DEBUG > 6 and print " Passing it thru as \"$1;\"\n";
push @out, \"$1;";
}
} elsif ( s@^&([A-Za-z][A-Za-z0-9]{0,10})\b(;?)@@s) {
DEBUG > 5 and print ":: Named entity {$1}\n";
if(exists $Entities{$1}) {
push @out, \ $Entities{$1};
} elsif(exists $Entities{ ucfirst(lc($1)) }) {
DEBUG > 6 and print "::: Treating as if it were &",
ucfirst(lc($1)), ";\n";
push @out, \ $Entities{ ucfirst(lc($1)) };
} else {
DEBUG > 6 and print "::: Unresolvable! Treating as plaintext\n";
push @out, "&$1" . ($2 || '');
}
# Things we just ignore:
} elsif( s@^()@@s ) { # "Netscape" comments
DEBUG > 5 and print ":: Simple comment {$1}\n";
} elsif( s@^(<[!?][^>]*>)@@s ) { # doctype, PI, or a weird comment
DEBUG > 5 and print ":: Directive/PI {$1}\n";
} elsif( s@^@@ ) {
# End-tag, or a simple start-tag
push @out, ' ' if $IsBlockMarkup{lc $1};
DEBUG > 5 and print ":: Simple tag {$1}",
$IsBlockMarkup{lc $1} ? " +breaky": (), "\n";
} elsif ( # complex start-tag
s@
^
(
<
([a-zA-Z][a-zA-Z0-9\.\:\_\-]{0,72}) # the G.I.
(?:
\s+
[a-zA-Z][a-zA-Z0-9\.\:\_\-]{0,72}
(?: # Attributes can be valueless!
\s*
=
\s*
(?: # Attribute value...
(?:
"[^"]*" # "foo bar"
)|(?:
'[^']*' # 'foo bar'
)|(?:
[^<>\n\r\t ]{0,90} # foobarbaz
# 90 is my sane length-limit on unquoted attrvalues
)
)
)?
)* # any nubmer of attribs
\s* # optional ending whitespace
/? # optional emptiness flag
>
)
@@x
) {
push @out, ' ' if $IsBlockMarkup{lc $2};
DEBUG > 5 and print ":: Complex start-tag {$2}",
$IsBlockMarkup{lc $2} ? " +breaky": (), "\n";
# Gets called only on aberrant input, I think:
} elsif( s@^(.)@@s ) {
DEBUG > 5 and print ":: Last-resort single character {$1}\n";
push @out, $1;
} else {
die "IMPOSSIBLE {$_}\n !!! "; # sanity-check
}
}
foreach my $x (@out) {
if( ref $x ) {
$x = $$x;
} else { # do necessary escaping
$x =~ tr/\n\r\f\t / /s; # smash whitespace
$x = $self->xmlesc($x) unless $x =~ m/^[a-zA-Z0-9_'",\. ]*$/s
# Dodge calling on the most common case, i.e., text
# that really doesn't need any excuse at all.
}
}
return join '', @out;
}
#..........................................................................
$MIME_Type = 'application/rss+xml';
%WinLameEntities = (
do {;
my $c = 0x80;
map {; $c++ => (hex($_) || 0x007e) }
qw(
20ac 0000 201a 0192 201e 2026 2020 2021 02c6 2030 0160 2039 0152 00 017d 0000
0000 2018 2019 201c 201d 2022 2013 2014 02dc 2122 0161 203a 0153 00 017e 0178
)# | # |
});
_init_common_ents();
sub _init_common_ents {
%CommonEnts = (
'&' => '&',
'<' => '<',
'>' => '>',
'"' => '"',
( map {; chr($_) => " " } 0 .. 31 ),
( map {; chr($_) => "&#$WinLameEntities{$_};" } keys %WinLameEntities ),
);
return;
}
%Entities = (
# HTML entities gotten from the HTML DTDs
'Aacute' => 'Á', 'aacute' => 'á', 'Acirc' => 'Â',
'acirc' => 'â', 'acute' => '´', 'AElig' => 'Æ',
'aelig' => 'æ', 'Agrave' => 'À', 'agrave' => 'à',
'alefsym' => 'ℵ', 'Alpha' => 'Α', 'alpha' => 'α',
'amp' => '&', 'and' => '∧', 'ang' => '∠',
'apos' => ''', 'Aring' => 'Å', 'aring' => 'å',
'asymp' => '≈', 'Atilde' => 'Ã', 'atilde' => 'ã',
'Auml' => 'Ä', 'auml' => 'ä', 'bdquo' => '„',
'Beta' => 'Β', 'beta' => 'β', 'brvbar' => '¦',
'bull' => '•', 'cap' => '∩', 'Ccedil' => 'Ç',
'ccedil' => 'ç', 'cedil' => '¸', 'cent' => '¢',
'Chi' => 'Χ', 'chi' => 'χ', 'circ' => 'ˆ',
'clubs' => '♣', 'cong' => '≅', 'copy' => '©',
'crarr' => '↵', 'cup' => '∪', 'curren' => '¤',
'dagger' => '†', 'Dagger' => '‡', 'darr' => '↓',
'dArr' => '⇓', 'deg' => '°', 'Delta' => 'Δ',
'delta' => 'δ', 'diams' => '♦', 'divide' => '÷',
'Eacute' => 'É', 'eacute' => 'é', 'Ecirc' => 'Ê',
'ecirc' => 'ê', 'Egrave' => 'È', 'egrave' => 'è',
'empty' => '∅', 'emsp' => ' ', 'ensp' => ' ',
'Epsilon' => 'Ε', 'epsilon' => 'ε', 'equiv' => '≡',
'Eta' => 'Η', 'eta' => 'η', 'ETH' => 'Ð',
'eth' => 'ð', 'Euml' => 'Ë', 'euml' => 'ë',
'euro' => '€', 'exist' => '∃', 'fnof' => 'ƒ',
'forall' => '∀', 'frac12' => '½', 'frac14' => '¼',
'frac34' => '¾', 'frasl' => '⁄', 'Gamma' => 'Γ',
'gamma' => 'γ', 'ge' => '≥', 'gt' => '>',
'harr' => '↔', 'hArr' => '⇔', 'hearts' => '♥',
'hellip' => '…', 'Iacute' => 'Í', 'iacute' => 'í',
'Icirc' => 'Î', 'icirc' => 'î', 'iexcl' => '¡',
'Igrave' => 'Ì', 'igrave' => 'ì', 'image' => 'ℑ',
'infin' => '∞', 'int' => '∫', 'Iota' => 'Ι',
'iota' => 'ι', 'iquest' => '¿', 'isin' => '∈',
'Iuml' => 'Ï', 'iuml' => 'ï', 'Kappa' => 'Κ',
'kappa' => 'κ', 'Lambda' => 'Λ', 'lambda' => 'λ',
'lang' => '〈', 'laquo' => '«', 'larr' => '←',
'lArr' => '⇐', 'lceil' => '⌈', 'ldquo' => '“',
'le' => '≤', 'lfloor' => '⌊', 'lowast' => '∗',
'loz' => '◊', 'lrm' => '', 'lsaquo' => '‹',
'lsquo' => '‘', 'lt' => '<', 'macr' => '¯',
'mdash' => '—', 'micro' => 'µ', 'middot' => '·',
'minus' => '−', 'Mu' => 'Μ', 'mu' => 'μ',
'nabla' => '∇', 'nbsp' => ' ', 'ndash' => '–',
'ne' => '≠', 'ni' => '∋', 'not' => '¬',
'notin' => '∉', 'nsub' => '⊄', 'Ntilde' => 'Ñ',
'ntilde' => 'ñ', 'Nu' => 'Ν', 'nu' => 'ν',
'Oacute' => 'Ó', 'oacute' => 'ó', 'Ocirc' => 'Ô',
'ocirc' => 'ô', 'OElig' => 'Œ', 'oelig' => 'œ',
'Ograve' => 'Ò', 'ograve' => 'ò', 'oline' => '‾',
'Omega' => 'Ω', 'omega' => 'ω', 'Omicron' => 'Ο',
'omicron' => 'ο', 'oplus' => '⊕', 'or' => '∨',
'ordf' => 'ª', 'ordm' => 'º', 'Oslash' => 'Ø',
'oslash' => 'ø', 'Otilde' => 'Õ', 'otilde' => 'õ',
'otimes' => '⊗', 'Ouml' => 'Ö', 'ouml' => 'ö',
'para' => '¶', 'part' => '∂', 'permil' => '‰',
'perp' => '⊥', 'Phi' => 'Φ', 'phi' => 'φ',
'Pi' => 'Π', 'pi' => 'π', 'piv' => 'ϖ',
'plusmn' => '±', 'pound' => '£', 'prime' => '′',
'Prime' => '″', 'prod' => '∏', 'prop' => '∝',
'Psi' => 'Ψ', 'psi' => 'ψ', 'quot' => '"',
'radic' => '√', 'rang' => '〉', 'raquo' => '»',
'rarr' => '→', 'rArr' => '⇒', 'rceil' => '⌉',
'rdquo' => '”', 'real' => 'ℜ', 'reg' => '®',
'rfloor' => '⌋', 'Rho' => 'Ρ', 'rho' => 'ρ',
'rlm' => '', 'rsaquo' => '›', 'rsquo' => '’',
'sbquo' => '‚', 'Scaron' => 'Š', 'scaron' => 'š',
'sdot' => '⋅', 'sect' => '§', 'shy' => '',
'Sigma' => 'Σ', 'sigma' => 'σ', 'sigmaf' => 'ς',
'sim' => '∼', 'spades' => '♠', 'sub' => '⊂',
'sube' => '⊆', 'sum' => '∑', 'sup' => '⊃',
'sup1' => '¹', 'sup2' => '²', 'sup3' => '³',
'supe' => '⊇', 'szlig' => 'ß', 'Tau' => 'Τ',
'tau' => 'τ', 'there4' => '∴', 'Theta' => 'Θ',
'theta' => 'θ', 'thetasym' => 'ϑ','thinsp' => ' ',
'THORN' => 'Þ', 'thorn' => 'þ', 'tilde' => '˜',
'times' => '×', 'trade' => '™', 'Uacute' => 'Ú',
'uacute' => 'ú', 'uarr' => '↑', 'uArr' => '⇑',
'Ucirc' => 'Û', 'ucirc' => 'û', 'Ugrave' => 'Ù',
'ugrave' => 'ù', 'uml' => '¨', 'upsih' => 'ϒ',
'Upsilon' => 'Υ', 'upsilon' => 'υ', 'Uuml' => 'Ü',
'uuml' => 'ü', 'weierp' => '℘', 'Xi' => 'Ξ',
'xi' => 'ξ', 'Yacute' => 'Ý', 'yacute' => 'ý',
'yen' => '¥', 'yuml' => 'ÿ', 'Yuml' => 'Ÿ',
'Zeta' => 'Ζ', 'zeta' => 'ζ', 'zwj' => '',
'zwnj' => '',
);
foreach my $tagname ( qw{
br
address applet area base bgsound blockquote body button caption center col
colgroup dd del dir div dl dt fieldset form frame frameset h1 h2 h3 h4 h5
h6 head hr html iframe ilayer input ins isindex label layer legend li link
listing map menu meta multicol noframes nolayer noscript object ol
optgroup option p param plaintext pre script select style table tbody td
textarea tfoot th thead title tr ul xmp
}) { $IsBlockMarkup{$tagname} = 1 unless exists $IsBlockMarkup{$tagname} }
#..........................................................................
# Now the function generators:
@EXPORT = ( 'get_url' );
$EXPORT_TAGS{'functions'} = \@EXPORT; # just for my own backward compat
foreach my $method (
do {
no strict 'refs';
my %to_hide;
@to_hide{@Hidies} = ();
sort
grep !exists $to_hide{$_} && !m/^rss_/s
&& m/^[a-z][_A-Za-z0-9]+$/s && defined &{"XML::RSS::SimpleGen::$_"},
keys %XML::RSS::SimpleGen::
}
) {
my $function = "rss_$method";
DEBUG > 20 and print "$method => $function\n";
push @EXPORT, $function;
no strict 'refs';
unless( defined &{$function} ) {
DEBUG > 20 and print " Defining $function => $function\n";
*{$function} = sub {
use strict 'refs';
unshift @_, ($RSS_obj ||= XML::RSS::SimpleGen::->new);
goto &{
$_[0]->can($method)
|| die "Where's $method for $_[0]?!"
# insane error, should never happen, unless somebody
# goes undefining existing methods!
};
};
}
}
sub rss_new { $RSS_obj = XML::RSS::SimpleGen->new(@_) }
DEBUG > 20 and print "Done compiling ", __PACKAGE__, ".\n";
#--------------------------------------------------------------------------
1;
__END__
=back
=head1 RSS VERSION
RSS feeds emitted by this module are basically according to v0.92 RSS,
with a very few extensions from v2.0 RSS. They are not RDF files.
=head1 SEE ALSO
L
L
L
L
L
You might also like my book I, which discusses the many
screen-scraping techniques that you would use for extracting data from
HTML to make into RSS feeds:
=over
=item L
=item L
=item L
=item L -- examples of Perl
programs that produce RSS's (which are visible at
L )
=back
=head1 COPYRIGHT AND DISCLAIMERS
Copyright (c) 2003,4 Sean M. Burke. All rights reserved.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
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.
Portions of the data tables in this module are derived from the
entity declarations in the W3C XHTML specification.
Currently (January 2004), that's these three:
http://www.w3.org/TR/xhtml1/DTD/xhtml-lat1.ent
http://www.w3.org/TR/xhtml1/DTD/xhtml-special.ent
http://www.w3.org/TR/xhtml1/DTD/xhtml-symbol.ent
Portions of the code in this module were adapted from parts of
Gisle Aas's L and the old (v2.x) version of his
L.
=head1 AUTHOR
Sean M. Burke C
=cut
* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
On Babbage's Disease:
Charles Babbage, as (necessarily) the first person to work with machines
that can attack problems at arbitrary levels of abstraction, fell into a
trap familiar to toolsmiths since, as described here by the English
ethicist, Lord Moulton:
"One of the sad memories of my life is a visit to the celebrated
mathematician and inventor, Mr Babbage. He was far advanced in age, but
his mind was still as vigorous as ever. He took me through his
work-rooms. In the first room I saw parts of the original Calculating
Machine, which had been shown in an incomplete state many years before
and had even been put to some use. I asked him about its present form.
'I have not finished it because in working at it I came on the idea of
my Analytical Machine, which would do all that it was capable of doing
and much more. Indeed, the idea was so much simpler that it would have
taken more work to complete the Calculating Machine than to design and
construct the other in its entirety, so I turned my attention to the
Analytical Machine.'"
"After a few minutes' talk, we went into the next work-room, where he
showed and explained to me the working of the elements of the Analytical
Machine. I asked if I could see it. 'I have never completed it,' he
said, 'because I hit upon an idea of doing the same thing by a different
and far more effective method, and this rendered it useless to proceed
on the old lines.' Then we went into the third room. There lay scattered
bits of mechanism, but I saw no trace of any working machine. Very
cautiously I approached the subject, and received the dreaded answer,
'It is not constructed yet, but I am working on it, and it will take
less time to construct it altogether than it would have token to
complete the Analytical Machine from the stage in which I left it.' I
took leave of the old man with a heavy heart."
"When he died a few years later, not only had he constructed no machine,
but the verdict of a jury of kind and sympathetic scientific men who
were deputed to pronounce upon what he had left behind him, either in
papers or in mechanism, was that everything was too incomplete of be
capable of being put to any useful purpose."
[Lord Moulton, "The invention of algorithms, its genesis, and growth",
in G. C. Knott, ed., "Napier tercentenary memorial volume" (London,
1915), p. 1-24; quoted in Charles Babbage "Passage from the Life of a
Philosopher", Martin Campbell-Kelly, ed. (Rutgers U. Press and IEEE
Press, 1994), p. 34].
-*-
XML-RSS-SimpleGen-11.11/MANIFEST 0000644 0001773 0001773 00000000425 10011101666 016447 0 ustar sburke sburke 0000000 0000000 ChangeLog
lib/XML/RSS/SimpleGen.pm
Makefile.PL
MANIFEST
MANIFEST.SKIP
README
t/00_about.t
t/05_xmltext.t
t/10_html2xmltext.t
t/20_http.t
t/30_simple_xml.t
t/40_item.t
t/50_history.t
t/80_basedate.t
META.yml Module meta-data (added by MakeMaker)
XML-RSS-SimpleGen-11.11/ChangeLog 0000644 0001773 0001773 00000002563 10011101656 017074 0 ustar sburke sburke 0000000 0000000 Revision history for Perl extension XML::RSS::SimpleGen
Time-stamp: "2004-02-06 21:20:30 AST"
2004-02-06 Sean M. Burke sburke@cpan.org
* Release 11.11
* Added some DWIM logic so that when you feed items to a feed that
you've declared a history file for, but where that history file
doesn't exist on disc yet (or exists but is 0-length), then items
you feed it get their date-stamps fiddled with so that the first
things you feed it look like the most recent, and so are the first
things to appear in the output RSS file.
This doesn't affect feeds with no history files, nor does it
affect feeds that already have contentful history files. It just
makes things work nicer when setting up new feeds with history
files.
2004-01-31 Sean M. Burke sburke@cpna.org
* Release 11.10
* Previous version failed to correct decimal-entities for Win-lame
characters. (E.g., "’" wasn't getting corrected to
"’", atho its hex version, "“", was.)
Fixed.
And added tests to 10_html2xmltext.t for this.
2004-01-24 Sean M. Burke sburke@cpan.org
* Release 11.09
* Previous version generated incorrect ttl figures for rss_daily,
rss_twice_daily, rss_thrice_daily, and rss_weekly. Fixed.
2004-01-17 Sean M. Burke sburke@cpan.org
* Release 11.08
* After many many development versions, this is the first
public release.
XML-RSS-SimpleGen-11.11/MANIFEST.SKIP 0000644 0001773 0001773 00000000151 10002412553 017210 0 ustar sburke sburke 0000000 0000000 ^MANIFEST\.bak$
^[-_a-zA-Z0-9]+[0-9]+\.[0-9]+(?:_[0-9]+)?$
Makefile(\.old)?$
t/.*.rtf$
\.rej$
CVS
blib
~
XML-RSS-SimpleGen-11.11/Makefile.PL 0000644 0001773 0001773 00000001435 10002421136 017267 0 ustar sburke sburke 0000000 0000000
# Run this program to generate a makefile. See "perldoc perlmodinstall"
# and "perldoc ExtUtils::MakeMaker" for more details.
#
# Time-stamp: "2004-01-17 21:06:22 AST"
require 5.004;
use strict;
use ExtUtils::MakeMaker;
WriteMakefile(
'NAME' => 'XML::RSS::SimpleGen',
'VERSION_FROM' => 'lib/XML/RSS/SimpleGen.pm', # finds $VERSION
'ABSTRACT_FROM' => 'lib/XML/RSS/SimpleGen.pm',
'PREREQ_PM' => {
'strict' => 0,
'IO::Socket' => 0,
'Carp' => 0,
# It's good in LWP::Simple is installed, but not necessary
},
'dist' => { COMPRESS => 'gzip -6f', SUFFIX => 'gz', },
);
package MY;
sub libscan
{ # Determine things that should *not* be installed
my($self, $path) = @_;
return '' if $path =~ m/~/;
$path;
}
__END__
XML-RSS-SimpleGen-11.11/README 0000644 0001773 0001773 00000005205 10002422322 016172 0 ustar sburke sburke 0000000 0000000 README for XML::RSS::SimpleGen
Time-stamp: "2004-01-17 21:16:50 AST"
[Excerpted from the POD...]
NAME
XML::RSS::SimpleGen -- for writing RSS files
SYNOPSIS
# A complete example screen-scraper and RSS generator here:
use strict;
use XML::RSS::SimpleGen;
my $url = q;
rss_new( $url, "eXile", "Moscow-based Alternative Newspaper" );
rss_language( 'en' );
rss_webmaster( 'xxxxx@yourdomain.com' );
rss_twice_daily();
get_url( $url );
while(
m{\s*(.*?) to find a CPAN site near you.