File Coverage

blib/lib/POE/Component/Client/Pastebot.pm

Criterion	Covered	Total	%
statement	7	9	77.7
branch			n/a
condition			n/a
subroutine	3	3	100.0
pod			n/a
total	10	12	83.3

package POE::Component::Client::Pastebot;

use strict;
use warnings;
use POE qw(Component::Client::HTTP);
use HTTP::Request::Common;
use URI;
use HTML::TokeParser;
use vars qw($VERSION);

$VERSION = '1.16';

# Stolen from POE::Wheel. This is static data, shared by all
my $current_id = 0;
my %active_identifiers;

sub _allocate_identifier {
  while (1) {
    last unless exists $active_identifiers{ ++$current_id };
  }
  return $active_identifiers{$current_id} = $current_id;
}

sub _free_identifier {
  my $id = shift;
  delete $active_identifiers{$id};
}

sub spawn {
  my $package = shift;
  my %opts = @_;
  $opts{lc $_} = delete $opts{$_} for keys %opts;
  my $options = delete $opts{options};
  my $self = bless \%opts, $package;
  $self->{session_id} = POE::Session->create(
	object_states => [
	   $self => { shutdown => '_shutdown',
		      paste    => '_command',
		      fetch    => '_command',
	   },
	   $self => [ qw(_start _dispatch _http_request _http_response) ],
	],
	heap => $self,
	( ref($options) eq 'HASH' ? ( options => $options ) : () ),
  )->ID();
  return $self;
}

sub session_id {
  return $_[0]->{session_id};
}

sub shutdown {
  my $self = shift;
  $poe_kernel->post( $self->{session_id}, 'shutdown' );
}

sub _start {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $self->{session_id} = $_[SESSION]->ID();
  if ( $self->{alias} ) {
     $kernel->alias_set( $self->{alias} );
  }
  else {
     $kernel->refcount_increment( $self->{session_id} => __PACKAGE__ );
  }
  $self->{_httpc} = 'httpc-' . $self->{session_id};
  POE::Component::Client::HTTP->spawn(
     Alias           => $self->{_httpc},
     FollowRedirects => 2,
  );
  undef;
}

sub _shutdown {
  my ($kernel,$self) = @_[KERNEL,OBJECT];
  $kernel->alias_remove( $_ ) for $kernel->alias_list();
  $kernel->refcount_decrement( $self->{session_id} => __PACKAGE__ ) unless $self->{alias};
  $self->{_shutdown} = 1;
  $kernel->post( $self->{_httpc}, 'shutdown' );
  undef;
}

sub _dispatch {
  my ($kernel,$self,$input) = @_[KERNEL,OBJECT,ARG0];
  my $session = delete $input->{sender};
  my $event = delete $input->{event};
  $kernel->post( $session, $event, $input );
  $kernel->refcount_decrement( $session => __PACKAGE__ );
  undef;
}

sub _command {
  my ($kernel,$self,$state) = @_[KERNEL,OBJECT,STATE];
  my $sender = $_[SENDER]->ID();
  return if $self->{_shutdown};
  my $args;
  if ( ref( $_[ARG0] ) eq 'HASH' ) {
	$args = { %{ $_[ARG0] } };
  } else {
	$args = { @_[ARG0..$#_] };
  }

  $args->{lc $_} = delete $args->{$_} for grep { $_ !~ /^_/ } keys %{ $args };

  unless ( $args->{event} ) {
	warn "No 'event' specified for $state";
	return;
  }

  unless ( $args->{url} ) {
	warn "No 'url' specified for $state";
	return;
  }

  if ( $state eq 'paste' and !$args->{paste} ) {
	warn "No 'paste' specified for paste";
	return;
  }

  if ( $state eq 'paste' and ref ( $args->{paste} ) eq 'ARRAY' ) {
	my $paste = delete $args->{paste};
	$args->{paste} = join "\n", @{ $paste };
  }

  $args->{sender} = $sender;
  $args->{command} = $state;
  $kernel->refcount_increment( $sender => __PACKAGE__ );
  $kernel->yield( '_http_request', $args );
  undef;
}

sub _http_request {
  my ($kernel,$self,$req) = @_[KERNEL,OBJECT,ARG0];
  if ( $req->{command} eq 'paste' ) {
    my $url =
	URI->new(
    	 $req->{'url'} . ( ( $req->{'url'} !~ m,/$, ) ? '/' : '' ) . 'paste' )
   	   ->canonical;
    unless ( defined $url ) {
	$req->{error} = "could not determine url from $req->{url}";
	$kernel->yield( '_dispatch', $req );
    }
    else {
	$req->{'channel'} =~ s/^/#/ if $req->{'channel'} and $req->{'channel'} !~ /^#/;
	my %postargs = map {
       	 ( defined $req->{$_} and $req->{$_} ne '' )
       	 ? ( $_ => $req->{$_} )
       	 : ()
    	} qw(channel nick summary);
	$postargs{'paste'} = $req->{paste};
	my $id = _allocate_identifier();
	$self->{_requests}->{ $id } = $req;
	$kernel->post(
		$self->{_httpc},
		'request',
		'_http_response',
		POST( $url, \%postargs ),
		"$id",
	);
    }
    return;
  }
  if ( $req->{command} eq 'fetch' ) {
    my $url;
    my $urltmp = URI->new( $req->{url} . ( ( $req->{url} !~ m,\?tx=on$, ) ? '?tx=on' : '' ) );
    if ( defined $urltmp and defined $urltmp->scheme and $urltmp->scheme =~ /http/ ) {
 	$url = $urltmp->canonical;
	my $id = _allocate_identifier();
	$self->{_requests}->{ $id } = $req;
	$kernel->post(
		$self->{_httpc},
		'request',
		'_http_response',
		GET( $url ),
		"$id",
	);
    }
    else {
	$req->{error} = 'problem with url provided';
	$kernel->yield( '_dispatch', $req );
    }
    return;
  }
  return;
}

sub _http_response {
  my ($kernel,$self,$request_packet,$response_packet) = @_[KERNEL,OBJECT,ARG0,ARG1];
  my $id = $request_packet->[1];
  my $req = delete $self->{_requests}->{ $id };
  _free_identifier( $id );
  my $response = $response_packet->[0];
  $req->{response} = $response;
  unless ( $response->is_success ) {
    if ( $response->is_error ) {
      $req->{error} = $response->as_string;
    }
    else {
      $req->{error} = 'unknown error';
    }
  }
  else {
    if ( $req->{command} eq 'paste' and $response->content ) {
	my $p = HTML::TokeParser->new( \$response->content );
	$p->get_tag('a');
	$req->{pastelink} = $p->get_text('/a');
    }
    if ( $req->{command} eq 'fetch' and $response->content ) {
	$req->{content} = $response->content;
    }
  }
  $kernel->yield( '_dispatch', $req );
  return;
}

'Paste and cut';
__END__