1# Copyright (c) 2003-2004 Timothy Appnel (cpan@timaoutloud.org) 2# http://www.timaoutloud.org/ 3# This code is released under the Artistic License. 4package Net::Trackback::Client; 5use strict; 6use base qw( Class::ErrorHandler ); 7 8use Net::Trackback; 9use Net::Trackback::Data; 10use Net::Trackback::Message; 11 12sub new { 13 my $class = shift; 14 my $self = bless {}, $class; 15 $self->{__timeout} = 15; 16 $self->{__no_proxy} = [ qw(localhost, 127.0.0.1) ]; 17 $self->{__charset} = 'utf-8'; 18 $self; 19} 20 21sub init_agent { 22 my $self = shift; 23 require LWP::UserAgent; 24 my $agent = LWP::UserAgent->new; 25 $agent->agent("Net::Trackback/$Net::Trackback::VERSION"); 26 # $agent->parse_head(0); 27 $agent->protocols_allowed( [ qw(http https) ] ); 28 $agent->proxy([qw(http https)], $self->{__proxy}) if $self->{__proxy}; 29 $agent->no_proxy(@{$self->{__no_proxy}}) if $self->{__no_proxy}; 30 $agent->timeout($self->{__timeout}); 31 $agent; 32} 33 34sub discover { 35 my($self,$url) = @_; 36 my $agent = $self->init_agent; 37 my $req = HTTP::Request->new( GET => $url ); 38 my $res = $agent->request($req); 39 return self->error($url.' '.$res->status_line) 40 unless $res->is_success; 41 my $c = $res->content; 42 my @data; 43 # Theoretically this is bad namespace form and eventually should 44 # be fixed. If you stick to the standard prefixes you're fine. 45 while ( $c =~ m!(<rdf:RDF.*?</rdf:RDF>)!sg ) { 46 if (my $tb = Net::Trackback::Data->parse($url,$1)) { 47 push( @data, $tb ); 48 } 49 } 50 @data ? \@data : $self->error('Nothing to discover.') 51} 52 53sub send_ping { 54 my($self,$ping) = @_; 55 my $ua = $self->init_agent; 56 my $ping_url = $ping->ping_url or 57 return $self->error('No ping URL'); 58 my $req; 59 $ping->timestamp(time); 60 if ( $ping_url =~ /\?/ ) { 61 $req = HTTP::Request->new( GET=>join('&', $ping_url, $ping->to_urlencoded) ); 62 } else { 63 $req = HTTP::Request->new( POST => $ping_url ); 64 $req->content_type('application/x-www-form-urlencoded; charset=' 65 .$self->{__charset}); 66 $req->content( $ping->to_urlencoded ); 67 } 68 my $res = $ua->request($req); 69 return Net::Trackback::Message->new( { 70 code=>$res->code, message=>$res->message } ) 71 unless $res->is_success; 72 Net::Trackback::Message->parse( $res->content ); 73} 74 75sub timeout { $_[0]->{__timeout} = $_[1] if $_[1]; $_[0]->{__timeout}; } 76sub proxy { $_[0]->{__proxy} = $_[1] if $_[1]; $_[0]->{__proxy}; } 77sub no_proxy { $_[0]->{__no_proxy} = $_[1] if $_[1]; $_[0]->{__no_proxy}; } 78sub charset { $_[0]->{__charset} = $_[1] if $_[1]; $_[0]->{__charset}; } 79 801; 81 82__END__ 83 84=begin 85 86=head1 NAME 87 88Net::Trackback::Client - a class for implementing Trackback client 89functionality. 90 91=head1 SYNOPSIS 92 93 use Net::Trackback::Client; 94 my $client = Net::Trackback::Client->new(); 95 my $url ='http://www.foo.org/foo.html'; 96 my $data = $client->discover($url); 97 if (Net::Trackback->is_message($data)) { 98 print $data->to_xml; 99 } else { 100 require Net::Trackback::Ping; 101 my $p = { 102 ping_url=>'http://www.foo.org/cgi/mt-tb.cgi/40', 103 url=>'http://www.timaoutloud.org/archives/000206.html', 104 title=>'The Next Generation of TrackBack: A Proposal', 105 description=>'I thought it would be helpful to draft some 106 suggestions for consideration for the next generation (NG) 107 of the interface.' 108 }; 109 my $ping = Net::Trackback::Ping->new($p); 110 my $msg = $client->send_ping($ping); 111 print $msg->to_xml; 112 113=head1 METHODS 114 115=item Net::Trackback::Client->new 116 117Constructor method. Returns a Trackback client instance. 118 119=item $client->discover($url) 120 121A method that fetches the resource and searches for Trackback ping 122data. If the given resource can not be retreived or Trackback data 123was not found, C<undef> is returned. Use the C<errstr> method to 124get the HTTP status code and message. If successful, returns a 125reference to an array of L<Net::Trackback::Data> objects. 126 127=item $client->send_ping($ping) 128 129Executes a ping according to the L<Net::Trackback::Ping> object 130passed in and returns a L<Net::Trackback::Message> object with the 131results, 132 133=item $client->timeout([$seconds]) 134 135An accessor to the LWP agent timeout in seconds. Default is 15 136seconds. If an optional parameter is passed in the value is set. 137 138=item $client->proxy($proxy) 139 140The URI of the proxy server to route all requests through. The default 141is C<undef> -- no proxy. 142 143=item $client->no_proxy([\@noproxy]) 144 145An ARRAY reference of domains to B<not> request through the proxy. 146If an optional parameter is passed in the value is set. The default 147list includes I<localhost> and I<127.0.0.1>. 148 149=item $client->charset([$charset]) 150 151The charset header parameter to use when sending pings. If an 152optional parameter is passed in the value is set. The default is 153'utf-8'. 154 155=head2 Errors 156 157This module is a subclass of L<Class::ErrorHandler> and inherits 158two methods for passing error message back to a caller. 159 160=item Class->error($message) 161 162=item $object->error($message) 163 164Sets the error message for either the class Class or the object 165$object to the message $message. Returns undef. 166 167=item Class->errstr 168 169=item $object->errstr 170 171Accesses the last error message set in the class Class or the 172object $object, respectively, and returns that error message. 173 174=head1 AUTHOR & COPYRIGHT 175 176Please see the Net::Trackback manpage for author, copyright, and 177license information. 178 179=cut 180 181=end