#!/usr/bin/perl -w
# OPML.pl
# by: Andrew Burton (tuglyraisin@aol.com)
##########
# The main namespace
package OpmlWeb;
use strict;
sub new
{
my $class = shift;
my $self = {};
$self->{HEAD} = '';
$self->{BODY} = '';
$self->{OPML} = '';
bless ($self, $class);
return $self;
}
sub BuildOpml
{
my $self = shift;
my ($name, $filename, $userid, $outline) = @_;
$self->Head($name, $filename, $userid);
$self->Body($outline);
my $opml = '' . "\r\n" .
$self->{HEAD} . $self->{BODY} .
"\t";
$self->{OPML} = $opml;
}
sub Head
{
my $self = shift;
my ($name, $filename, $email) = @_;
my $thisdate = $self->gmt_date();
my $head = "\t\r\n" .
"\t\t" . $filename . "\r\n" .
"\t\t" . $thisdate . "\r\n" .
"\t\t" . $thisdate . "\r\n" .
"\t\t" . $name . "\r\n" .
"\t\t" . $email . "\r\n" .
"\t\t1\r\n" .
"\t\t7\r\n" .
"\t\t10\r\n" .
"\t\t10\r\n" .
"\t\t300\r\n" .
"\t\t300\r\n" .
"\t\t\r\n";
$self->{HEAD} = $head;
}
sub Body
{
my $self = shift;
my ($text) = @_;
my $parse = OpmlWeb::Convert->new();
$self->{BODY} = $parse->parse($text);
}
sub Send
{
my $self = shift;
my ($userid, $passwd, $host, $filename) = @_;
my $opml = $self->{OPML};
my $transmit = OpmlWeb::Send->new($userid, $passwd, $host, $filename,
$opml);
return $transmit->send();
}
sub gmt_date
{
my $self = shift;
# this part is used to get the date and time of the entry.
my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday) = gmtime(time);
my @weekdays = ('Sun', 'Mon', 'Tue', 'Wed', 'Thu', 'Fri', 'Sat');
my @months = ('Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec');
my $weekday = $weekdays[$wday];
my $month = $months[$mon];
if ($hour < 10) { $hour = "0$hour"; }
if ($min < 10) { $min = "0$min"; }
if ($sec < 10) { $sec = "0$sec"; }
if ($mday < 10) { $mday = "0$mday"; }
$year = $year + 1900;
# Mon, 08 Aug 2005 23:36:34 GMT
my $gmt = $weekday . ', ' . $mday . ' ' . $month . ' ' . $year . ' ' .
$hour . ':' . $min . ':' . $sec . ' GMT';
return $gmt;
}
##########
# Builds an OPML file
package OpmlWeb::Convert;
use strict;
sub new
{
my $class = shift;
my $self = {};
my ($string) = @_;
$self->{STRING} = $string;
bless ($self, $class);
return $self;
}
# Parse OPML
sub parse
{
my $self = shift;
my $string;
if ($self->{STRING})
{
$string = $self->{STRING};
}
elsif ($_[0])
{
$string = $_[0];
}
else
{
die "No text to parse";
}
my @raw = $self->get_data($string);
my @opml = $self->build_dom(@raw);
my $opml = $self->build_opml(@opml);
return $opml;
}
#####
# Build OPML
sub build_opml
{
my $self = shift;
my (@opml_array) = @_;
my $lastindent = 0;
my $opencount = 0;
my $opml = "\t\r\n";
foreach my $entry (@opml_array)
{
# Closes "outline" tags
if ($opencount > 0)
{
if ($lastindent > $entry->{indent})
{
$opencount--;
$opml .= $self->add_tab($entry->{indent} + 1);
$opml .= "\r\n";
}
}
# Add indentation tabs
$opml .= $self->add_tab($entry->{indent});
# Decides what kind of tag to use
if ($entry->{haschild} == 1)
{
$opencount++;
$opml .= '' . "\r\n";
}
elsif ($entry->{haschild} == 0)
{
$opml .= '' . "\r\n";
}
# This should be obvious
$lastindent = $entry->{indent};
}
if ($opencount > 0)
{
$opml .= $self->add_tab($lastindent);
$opml .= "\r\n";
}
$opml .= "\t\t\r\n";
return $opml;
}
#####
# Adds the tabs
sub add_tab
{
my $self = shift;
my ($tcnt) = @_;
my $tabs = '';
for (0 ... $tcnt)
{
$tabs .= "\t";
}
return $tabs;
}
#####
# Builds OPML array
sub build_dom
{
my $self = shift;
my (@raw) = @_;
my @temp_opml = ();
my $lastcnt = 1;
my $entrycnt = 0;
foreach my $entry (@raw)
{
my ($stars, $text) = split(/ /, $entry, 2);
my $count = length($stars);
if ($self->just_stars($stars) == 1)
{
# If it's the first entry
if ($entrycnt > 0)
{
if ($count > $lastcnt)
{
$temp_opml[$entrycnt-1]->{haschild} = 1;
}
}
push(@temp_opml, {'text' => $text,
'haschild' => 0,
'indent' => $count});
$lastcnt = $count;
}
# If there are more than asterisks in your indentation
else
{
die "There was text in your asterisk markup";
}
# Counter
$entrycnt++;
}
return @temp_opml;
}
#####
# Checks a variable to make sure it only has stars
sub just_stars
{
my $self = shift;
my ($stars) = @_;
my $passfail = 1;
for (0 ... length($stars) - 1)
{
if (substr($stars, $_, 1) ne '*')
{
$passfail = 0;
die ("Burp: " . $stars);
# last;
}
}
return $passfail;
}
# Gets the OPML
sub get_data
{
my $self = shift;
my ($opml) = @_;
my @opml = split(/\n/, $opml);
my @raw = ();
foreach my $line (@opml)
{
$line =~ s/(\n|\r)//g;
$line =~ s/\&/\&\;/g;
$line =~ s/\"/\"\;/g;
if ($line)
{
push(@raw, $line);
}
}
return @raw;
}
##########
# Transmits the OPML file
package OpmlWeb::Send;
use HTTP::Request;
use LWP::UserAgent;
use strict;
sub new
{
my $class = shift;
my $self = {};
my ($uid, $pwd, $host, $file, $opml) = @_;
# XML-RPC stuff
$self->{url} = 'support.opml.org';
$self->{cmd} = 'RPC2';
$self->{mtd} = 'opmlCommunityServer.saveFile';
# User data
$self->{USER} = $uid; # User ID
$self->{PASS} = $pwd; # Password
# Post data
$self->{HOST} = $host; # Host address (hosting.opml.org)
$self->{FILE} = $file; # File path and file name
# Post
$self->{OPML} = $opml;
bless ($self, $class);
return $self;
}
#####
# send function
sub send
{
my $self = shift;
my $xmlrpc = 'http://' . $self->{url} . '/' . $self->{cmd};
my $envelope = '' . "\r\n" .
"\r\n" .
"\t" . $self->{mtd} . "\r\n" .
"\t\r\n";
$envelope .= $self->make_param($self->{HOST});
$envelope .= $self->make_param($self->{USER});
$envelope .= $self->make_param($self->{PASS});
$envelope .= $self->make_param($self->{FILE});
$envelope .= $self->make_param($self->fix_opml($self->{OPML}));
$envelope .= "\t\n";
# Builds the HTTP request
my $ua = LWP::UserAgent->new();
my $request = HTTP::Request->new(POST => $xmlrpc);
$request->content_type('text/xml');
$request->content($envelope);
# Fires off the HTTP Request
my $result = $ua->request($request);
if ($result->is_success)
{
print $result->content;
}
else
{
return $result->status_line . "\r\n";
}
}
#####
# builds the opml package to deliver
sub fix_opml
{
my $self = shift;
my ($opml) = @_;
my @opml = split(/\n/, $opml);
undef($opml);
foreach my $line (@opml)
{
$line =~ s/\&/\&\;/g;
$line =~ s/\\r\n" .
"\t\t\t" . $param . "\r\n" .
"\t\t\r\n";
return $param;
}
##########
# Need this
1;