File Coverage

blib/lib/WebService/weblogUpdates.pm

Criterion	Covered	Total	%
statement	90	217	41.4
branch	23	98	23.4
condition	2	30	6.6
subroutine	21	31	67.7
pod	6	7	85.7
total	142	383	37.0

{

=head1 NAME

WebService::weblogUpdates - methods supported by the UserLand weblogUpdates framework.

=head1 SUMMARY

 use WebService::weblogUpdates;

 my $weblogs = WebService::weblogUpdates->new(transport=>"SOAP",debug=>0);
 $weblogs->ping("Perlblog","http://www.nospum.net/perlblog");

 # Since the 'rssUpdate' method has only been
 # documented for the XML-RPC transport, we switch
 # the internal widget.

 $weblogs->Transport("XMLRPC");
 $weblogs->rssUpdate("Aaronland","http://www.aaronland.net/weblog/rss");

=head1 DESCRIPTION

This package implements methods supported by the UserLand weblogUpdates framework,
for the weblogs.com website.

=head1 ON NAMING THINGS

This package was originally named to reflect the class that the original I
method lives in, weblogUpdates.

Since then, other methods have been added that live in different classes or don't
have any parent class at all. I have no idea why, especially since the equivalent
serTalk methods live in a 'weblogUpdates' class themselves. [1]

So it goes.

=cut

use strict;
package WebService::weblogUpdates;

$WebService::weblogUpdates::VERSION = '0.35';

use Carp;

use constant HOST    => "http://rpc.weblogs.com";
use constant RSSHOST => "http://rssrpc.weblogs.com";

use constant PATH  => "/RPC2";
use constant CLASS => "weblogUpdates";

use constant PING      => "ping";
use constant RSSUPDATE => "rssUpdate";

=head1 PACKAGE METHODS

=head2 $pkg = __PACKAGE__->new(%args)

Valid arguments are

=over 4

=item *

B

String. Valid transports are SOAP and XMLRPC and REST. I

=item *

B

Boolean. Enable transport-specific debugging.

=back

=cut

sub new {
    my $pkg = shift;

    my $self = {};
    bless $self;

    $self->init(@_) || return undef;
    return $self;
}

sub init {
    my $self = shift;
    my $args = { @_ };

    if (! $args->{'transport'}) {
	carp "You must specify a transport.";
	return 0;
    }

    $self->Transport($args->{'transport'},debug=>$args->{'debug'})
	|| return 0;

    return 1;
}

=head1 OBJECT METHODS

=head2 $pkg->ping(\%args)

Ping the Userland servers and tell them your weblog has been updated.

Valid arguments are a hash reference whose keys are :

=over 4

=item *

B

String. The name of your weblog. I

=item *

B

String. The URI of your weblog. I

=item *

B

String.

This key may be specified if

=over 4

=item *

The object's transport is REST and the site in question "need two urls, one that we can verify changes for, and the other to be included in changes.xml."

=item *

You are passing a I key with your ping. In fact, it's required if you're doing that.

=back

=item *

B

String.

Categories are not supported if the object's transport is REST.

=back

Returns true or false. This means that, unlike the Userland server itself, a successful ping returns 1 and a failed ping returns 0.

=cut

sub ping {
    my $self = shift;
    my $args = shift;

    delete $self->{'_message'};

    #

    if ((! $args->{name}) || (! $args->{url})) {
	carp "You must specify both a weblog name and url";
	return 0;
    }

    my $meth = undef;
    my @args = ();

    if ($self->{'__ima'} eq "Frontier::Client") {

      $meth = join(".",CLASS,PING);
      @args = (
	       $self->_client()->string($args->{name}),
	       $self->_client()->string($args->{url}),
	      );

      #

      if (($args->{changesurl}) && ($args->{category})) {
	push (@args,
	      $self->_client()->string($args->{changesurl}),
	      $self->_client()->string($args->{category}));
      }
    }

    elsif ($self->{'__ima'} eq "XMLRPC::Lite") {
	$meth = join(".",CLASS,PING);
	@args = (
		 SOAP::Data->type(string=>$args->{name}),
		 SOAP::Data->type(string=>$args->{url}),
		 );

	if (($args->{changesurl}) && ($args->{category})) {
	  push (@args,
		SOAP::Data->type(string=>$args->{changesurl}),
		SOAP::Data->name(string=>$args->{category}));
	}

   }

    elsif ($self->{'__ima'} eq "SOAP::Lite") {
	$meth = PING;
	@args = (
		 SOAP::Data->name(weblogname=>$args->{name}),
		 SOAP::Data->name(weblogurl=>$args->{url}),
		 );

	if (($args->{changesurl}) && ($args->{category})) {
	  push (@args,
		SOAP::Data->name(changesurl=>$args->{changesurl}),
		SOAP::Data->name(categoryname=>$args->{category}));
	}

    }

    elsif ($self->{'__ima'} eq "LWP::Simple") {
      $meth = PING;
      @args = ($args);
    }

    if (! $meth) {
	carp "Unable to determine transport and method.";
	return 0;
    }

    my $res = $self->_do($meth,@args)
	|| &{ carp "Returned undef. Not good."; return 0; };

    $self->{'_message'} = $res->{message};
    (! $res->{'flerror'}) ? return 1 : return 0;
}

=head2 $pkg->rssUpdate(\%args)

Ping the Userland servers and tell them your RSS feed has been updated.

Valid arguments are a hash reference whose keys are :

=over 4

=item *

B

String. The name of your weblog. I

=item *

B

String. The URI of your weblog. I

=back

This method is B supported for the SOAP transport, although
it will be as soon as it is documented by UserLand.

This method is B supported for the REST transport.

=cut

sub rssUpdate {
  my $self = shift;
  my $args = shift;

  delete $self->{'_message'};

  #

  if ((! $args->{name}) || (! $args->{url})) {
    carp "You must specify both a weblog name and url";
    return 0;
  }

  my $meth = undef;
  my @args = ();

  if ($self->{'__ima'} eq "Frontier::Client") {

    # grrrrr....
    $self->_client()->{'url'} = RSSHOST.PATH;
    $self->_client()->{'rq'}->url(RSSHOST.PATH);

    $meth = join(".",RSSUPDATE);
    @args = (
	     $self->_client()->string($args->{name}),
	     $self->_client()->string($args->{url}),
	    );
  }

  elsif ($self->{'__ima'} eq "XMLRPC::Lite") {

    $self->_client()->proxy(RSSHOST.PATH);
    $meth = join(".",RSSUPDATE);
    @args = (
	     SOAP::Data->type(string=>$args->{name}),
	     SOAP::Data->type(string=>$args->{url}),
	    );
  }

  elsif ($self->{'__ima'} eq "SOAP::Lite") {
    carp "This method will be supported as soon as it is documented by UserLand.\n";
    return 0;
    #      $meth = RSSUPDATE;
    #      @args = (
    #	       SOAP::Data->name(weblogname=>$args->{name}),
    #	       SOAP::Data->name(weblogurl=>$args->{url}),
    #	      );
  }

  elsif ($self->{'__ima'} eq "LWP::Simple") {
    carp "This method is not supported for the REST transport.\n";
    return 0;
  }

  if (! $meth) {
    carp "Unable to determine transport and method.";
    return 0;
  }

  my $res = $self->_do($meth,@args)
    || &{ carp "Returned undef. Not good."; return 0; };

  $self->{'_message'} = $res->{message};
  (! $res->{'flerror'}) ? return 1 : return 0;
}

=head2 $pkg->LastMessage()

Return the response message that was sent with your last method call.

=cut

sub LastMessage {
  my $self = shift;
  (exists($self->{'_message'})) ? return $self->{'_message'} : return undef;
}

=head2 $pkg->Transport($transport,%args)

Set the transport for use with the package. Valid transports are SOAP, XMLRPC and REST. This field is required.

Valid arguments are

=over 4

=item *

B

Boolean. Enable transport-specific debugging.

=back

=cut

sub Transport {
  my $self      = shift;
  my $transport = shift;
  my $args      = { @_ };

  if (defined $transport) {

    if (! $transport =~ /^(xmlrpc|soap|rest)$/i) {
      delete $self->{"_transport"};
      return undef;
    }

    $self->{"_transport"} = lc $transport;

    if (! $self->_client(debug=>$args->{'debug'})) {
      delete $self->{"_transport"};
      return undef;
    }
  }

  return $self->{"_transport"};
}

=head1 DEPRECATED METHODS

=head2 $pkg->ping_message()

B Please use $pkg->LastMessage() instead.

=cut

sub ping_message {
  my $self = shift;
  return $self->LastMessage();
}

# Private methods

sub _do {
    my $self = shift;
    my $meth = shift;
    my @args = @_;

    if ($self->{'__ima'} eq "Frontier::Client") {
      my $res = undef;

      eval { $res = $self->_client()->call($meth,@args); };

      if ($@) {
	carp $@;
	return 0;
      }

      # Hack.
      if ($res->{'flerror'}) {
	$res->{'flerror'} = $res->{'flerror'}->value();
      }

      return $res;
    }

    # We don't bother wrapping this in an eval block
    # since we've already set a fault method for the
    # SOAP::Lite object.

    elsif ($self->{'__ima'} =~ /^(SOAP|XMLRPC)::Lite$/){
	return $self->_client()->call($meth,@args)->result();
    }

    elsif ($self->{'__ima'} eq "LWP::Simple") {
      return $self->_client()->call($meth,@args);
    }

    else {
      return {flerror=>1,message=>"unknown transport"};
    }
}

sub _client {
    my $self   = shift;
    my $client = "_".$self->Transport();
    return $self->$client(@_);
}

sub _xmlrpc {
  my $self = shift;
  my $args = { @_ };

  if (! $self->{"_xmlrpc"}) {

    if (&_require("Frontier::Client")) {
      $self->{"_xmlrpc"} = Frontier::Client->new(url=>HOST.PATH,debug=>$args->{'debug'})
	|| &{ carp $!; return 0; };
    }

    elsif (&_require("XMLRPC::Lite")) {
      my $xmlrpc = XMLRPC::Lite->new()
	|| &{ carp $!; return 0; };

      &_setup_soaplite($xmlrpc,$args);

      #

      $xmlrpc->proxy(HOST.PATH);
      $self->{"_xmlrpc"} = $xmlrpc;
    }

    else {
      return 0;
    }

    $self->{'__ima'} = ref($self->{"_xmlrpc"});
  }

  return $self->{"_xmlrpc"};
}

sub _soap {
  my $self = shift;
  my $args = { @_ };

  if (! $self->{"_soap"}) {

    my $class = "SOAP::Lite";
    &_require($class) || return 0;

    if ($SOAP::Lite::VERSION < 0.55) {
      carp
	"SOAP::Lite version is $SOAP::Lite::VERSION\n".
	  "Please upgrade to version 0.55 or higher.\n";
    }

    carp
      my $soap = $class->new() ||
	&{ carp $!; return 0; };

    &_setup_soaplite($soap,$args);

    #

    $soap->proxy(join("/",HOST,CLASS));

    $soap->on_action(
		     sub{
		       "\"/".CLASS."\""
		     }
		    );

    $self->{"_soap"} = $soap;
    $self->{'__ima'} = ref($self->{"_soap"});
  }

  return $self->{"_soap"};
}

sub _setup_soaplite {
  my $lite = shift;
  my $args = shift;

  # What if it doesn't work?
  $lite->on_fault(
		  sub{
		    my ($lite,$res) = @_;
		    carp (ref $res) ? $res->faultstring : $lite->transport->status();
		    return 0;
		  }
		 );

  # Who's on first?
  if ($args->{'debug'}) {
    $lite->on_debug(sub { print @_; });
  }
}

sub _rest {
  my $self = shift;
  my $class = "LWP::Simple";
  &_require($class) || return 0;

  $self->{'__ima'} = $class;
  return "REST";
}

sub _require {
    my $class = shift;

    eval "require $class" ||
	&{ carp $@; return 0; };

    return 1;
}

sub DESTROY {
    return 1;
}

package REST;
use constant PINGSITEFORM        => "http://newhome.weblogs.com/pingSiteForm";
use constant PINGSITEFORMTWOURLS => "http://newhome.weblogs.com/pingSiteFormTwoUrls";

my $html_parser = undef;

sub call {
  my $pkg  = shift;
  my $meth = shift;
  my $args = shift;

  my $ping = undef;

  if ($args->{changesurl}) {
    $ping = PINGSITEFORMTWOURLS."?name=$args->{name}&url=$args->{url}&changesUrl=$args->{changesurl}";
  }

  else {
    $ping = PINGSITEFORM."?name=$args->{name}&url=$args->{url}";
  }

  #

  my $html = LWP::Simple::get($ping);

  if (! $html) {
    return {flerror=>1,message=>"Failed to ping: ".LWP::Simple::getprint($ping)};
  }

  #

  eval "require HTML::Parser";

  if ($@) {
    return {flerror=>0,message=>"Failed to parse HTML, $@"};
  }

  #

  if (! $html_parser) {
    $html_parser = HTML::Parser->new(
				     start_h       => [\&start_element, "self,tagname, attr"],
				     text_h        => [\&characters,    "self,text"],
				    );
    $html_parser->unbroken_text(1);
  }

  $html_parser->parse($html);

  return {flerror=>0,message=>$html_parser->{__message}};
}

#

sub start_element {
  my $parser = shift;
  my $tag  = shift;

  if ($tag eq "html") {
    $parser->{'__ok'}      = 0;
    $parser->{'__message'} = undef;
  }
}

sub characters {
  my $parser = shift;
  my $chars = shift;

  return if (! $chars);

  $chars =~ s/^\s+//;
  $chars =~ s/\s+$//;
  return if (! $chars);

  # Ugh.

  if ($chars eq "Enter the name and URL of a weblog that has been updated.") {
    $parser->{'__ok'} = 1;
    return;
  }

  # Double ugh.

  if ($chars =~ /^Name:/) {
    $parser->{'__ok'} = 0;
  }

  if ($parser->{'__ok'}) {
    $chars =~ s/ / /gm;
    $parser->{__message} .= " $chars";
  }

  return 1;
}

=head1 VERSION

0.35

=head1 DATE

October 31, 2002

=head1 SEE ALSO

http://www.weblogs.com

http://www.xmlrpc.com/weblogsComForRss

http://www.xmlrpc.com/discuss/msgReader$2014?mode=day

=head1 FOOTNOTES

[1] http://www.xmlrpc.com/weblogsComForRss#changes103002ByDw

=head1 REQUIREMENTS

These packages are required in order to support the following transports :

=head2 XMLRPC

One of the following :

=over 4

=item *

B

Default

=item *

B

(part of SOAP::Lite)

=back

=head2 SOAP

=over 4

=item *

B

=back

=head2 REST

=over 4

=item *

B

=item *

B

This is optional, but required if you want this package to try and return a short and sweet message instead of raw HTML.

=back

=head1 LICENSE

Copyright (c) 2001-2002, Aaron Straup Cope. All Rights Reserved.

This is free software, you may use it and distribute it under the same terms as Perl itself.

=cut

return 1;

}