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

 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");

{

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";

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;
}

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;
}

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;
}

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

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"};
}

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/&nbsp;/ /gm;
    $parser->{__message} .= " $chars";
  }

  return 1;
}

return 1;

}