File Coverage

blib/lib/E2/Ticker.pm

Criterion	Covered	Total	%
statement	45	236	19.0
branch	10	98	10.2
condition	2	6	33.3
subroutine	9	42	21.4
pod	17	18	94.4
total	83	400	20.7

# E2::Ticker
# Jose M. Weeks
# 17 June 2003
#
# See bottom for pod documentation.

package E2::Ticker;

use 5.006;
use strict;
use warnings;
use Carp;
use E2::Interface;

our @ISA = ("E2::Interface");
our $VERSION = "0.32";
our $DEBUG; *DEBUG = *E2::Interface::DEBUG;

our %xml_title = (
	interfaces	=> "XML Interfaces Ticker",
	clientversions	=> "Client Version XML Ticker",
	messages	=> "Universal Message XML Ticker",
	session		=> "Personal Session XML Ticker",
	search		=> "E2 XML Search Interface",
	scratch		=> "Scratch Pad XML Ticker",
	vars		=> "Raw VARS XML Ticker",
	timesince	=> "Time Since XML Ticker",
	usersearch	=> "User Search XML Ticker II",
	heaven		=> "Node Heaven XML Ticker",
	bestusers	=> "Everything's Best Users XML Ticker",
	coolnodes	=> "Cool Nodes XML Ticker II",
	edcools		=> "Editor Cools XML Ticker",
	random		=> "Random Nodes XML Ticker",
	rooms		=> "Available Rooms XML Ticker",
	otherusers	=> "Other Users XML Ticker II",
	newwriteups	=> "New Writeups XML Ticker"
);

# Prototypes

sub new;

sub new_writeups;
sub other_users;
sub random_nodes;
sub cool_nodes;
sub editor_cools;
sub time_since;

sub random_nodes_wit;
sub time_since_now;

# Private

sub parse;

# Methods

sub new {
	my $arg   = shift;
	my $class = ref( $arg ) || $arg;
	my $self  = $class->SUPER::new();

	$self->{xml_interfaces} = \%xml_title;

	$self->{ticker_string} = undef;

	bless( $self, $class );
	return $self;
}

sub use_string {
	my $self = shift or croak "Usage: use_string E2TICKER, STRING";
	my $string = shift;

	$self->{ticker_string} = $string;
}

# This method is private (undocumented). It should not be called from
# anywhere except internally or in derived classes.
#
# It takes the following parameters:
# 	E2TICKER	- $self
# 	TYPE		- Type of ticker to load
# 	HANDLERS	- a reference to a hash of twig parsers
# 	LISTREF		- a reference to the list we want to return
#	OPTIONS		- set of attr, val pairs used in the POST request

sub parse {
	croak "Usage: parse E2TICKER, TYPE, HANDLERS, LISTREF, [ OPTIONS ]"
		if @_ < 4;

	my $self = shift;
	my $type = shift;
	my $handlers = shift;
	my $listref = shift;

	warn "E2::Ticker::parse\n"	if $DEBUG > 1;
	warn "Parsing $type ticker:\n" . Dumper( $handlers )
		if $DEBUG > 2;

	# Sanity check

	if( ref $handlers ne 'HASH' || ref $listref ne 'ARRAY' ) {
		croak "Usage: parse E2TICKER, TYPE, HANDLERS, LISTREF, " .
			"[ OPTIONS ]";
	}

	# Note: The exception below will only be raised if there are
	# bugs in e2interface, unless applications are calling
	# E2::Ticker::parse on their own, which they shouldn't be
	# doing. This exception is undocumented (it is not
	# thrown by any documented methods).

	my $title = $self->{xml_interfaces}->{$type};
	if( !$title ) {
		croak "Invalid ticker type: $type";
	}

	# This is here in case (for some oddball reason) someone wants
	# to load a ticker from a text string. This is used for the test
	# cases, and probably for cacheing and so on...

	if( my $s = $self->{ticker_string} ) {
		$self->{ticker_string} = undef;
		$self->parse_twig( $s, $handlers );
		return @$listref;
	}

	# Otherwise, do the normal thing, which is to load the
	# node from e2.

	return $self->thread_then(
		[
			\&E2::Interface::process_request,
			$self,
			node => $title,
			@_
		],
		sub {
			$self->parse_twig(shift, $handlers);
			return @$listref;
		}
	);
}

sub load_interfaces {
	my $self = shift or croak "Usage: interfaces E2TICKER";

	warn "E2::Ticker::load_interfaces\n"	if $DEBUG > 1;

	my $handlers = {
		'this' => sub {
			(my $a, my $b) = @_;
			$self->{xml_interfaces}->{interfaces} =
				$b->text;
		},
		'xmlexport' => sub {
			(my $a, my $b) = @_;
			my $c = $b->{att}->{iface};
			$self->{xml_interfaces}->{$c} = $b->text;
		}
	};

	# Since we're loading a URL instead of a node or node_id,
	# we're going to have to do this one without the help
	# of E2::Interface::process_request, and therefore without
	# E2::Ticker::parse.

	# If we're working threaded, we have to do it the hard way

	if( $self->{threads} ) {
		return thread_then(
			[
				\&E2::Interface::start_job,
				$self,
				'POST',
				"http://$self->{domain}/interfaces.xml",
				$self->{cookie},
				$self->{agentstring},
				links_noparse => $self->{links_noparse},
			],
		sub {
			my $response = shift;

			$self->{xml_interfaces} = {};

			$self->parse_twig( $response, $handlers );

			return 1;

		});
	}

	# Otherwise, do the same as above, but without passing the work off
	# to another thread.

	my $response = process_request_raw(
				'POST',
				"http://$self->{domain}/interfaces.xml",
				$self->{cookie},
				$self->{agentstring},
				links_noparse => $self->{links_noparse},
		       );

	$self->cookie( extract_cookie( $response ) );

	my $xml = post_process( $response );

	$self->{xml_interfaces} = {};

	$self->parse_twig( $xml, $handlers );

	return 1;
}

sub new_writeups {
	my $self = shift or croak "Usage: new_writeups E2TICKER [, COUNT ]";
	my $count = shift;

	my %opt;

	my @writeups;

	warn "E2::Ticker::new_writeups"		if $DEBUG > 1;

	$opt{count} = $count	if $count;

	my $handlers = 	{
		'wu' => sub {
			(my $a, my $b) = @_;
			my $wu = {};

			$wu->{type} = $b->{att}->{wrtype};

			my $c = $b->first_child('e2link');

			$wu->{title} = $c->text;
			$wu->{id} = $c->{att}->{node_id};

			$c = $b->first_child('author')->first_child('e2link');
			$wu->{author} = $c->text;
			$wu->{author_id} = $c->{att}->{node_id};

			$c = $b->first_child('parent')->first_child('e2link');
			$wu->{parent} = $c->text;
			$wu->{parent_id} = $c->{att}->{node_id};

			push @writeups, $wu;
		}
	};

	return $self->parse( 'newwriteups', $handlers, \@writeups, %opt );
}

sub other_users {
	my $self = shift or croak "Usage: other_users E2TICKER [, ROOM_ID ]";
	my $room = shift;

	my @users;

	warn "E2::Ticker::other_users"		if $DEBUG > 1;

	my %opt = ( nosort => 1 );
	$opt{in_room} = $room	if $room;

	my $handlers = {
		'user' => sub {
			(my $a, my $b) = @_;
			my $user = {};

			$user->{god}	= $b->{att}->{e2god};
			$user->{editor}	= $b->{att}->{ce};
			$user->{edev}	= $b->{att}->{edev};
			$user->{xp}	= $b->{att}->{xp};
			$user->{borged}	= $b->{att}->{borged};

			my $c = $b->first_child('e2link');
			$user->{name}	= $c->text;
			$user->{id}	= $c->{att}->{node_id};

			if( $c = $b->first_child('room' ) ) {
				$user->{room} = $c->text;
				$user->{room_id} = $c->{att}->{node_id};
			}

			push @users, $user;
		}
	};

	return $self->parse( 'otherusers', $handlers, \@users, %opt );
}

sub random_nodes {
	my $self = shift or croak "Usage: random_nodes E2TICKER";

	my @random;

	warn "E2::Ticker::random_nodes"		if $DEBUG > 1;

	my $handlers = {
		'e2link' => sub {
			(my $a, my $b) = @_;
			push @random, {
				title => $b->text,
				id =>    $b->{att}->{node_id}
			};
		},
		'wit' => sub {
			(my $a, my $b) = @_;
			$self->{wit} = $b->text;
		}
	};

	return $self->parse( 'random', $handlers, \@random );
}

sub cool_nodes {
	my $self = shift or croak "Usage: cool_nodes E2TICKER [, WRITTEN_BY ] [, COOLED_BY ] [, COUNT ] [, OFFSET ]";
	my $written_by = shift;
	my $cooled_by = shift;
	my $count = shift;
	my $offset = shift;

	my @cools;

	warn "E2::Ticker::cool_nodes"		if $DEBUG > 1;

	my %opt;

	$opt{writtenby}		= $written_by	if $written_by;
	$opt{cooledby}		= $cooled_by	if $cooled_by;
	$opt{limit}		= $count	if $count;
	$opt{startat}		= $offset	if $offset;

	my $handlers = {
		'cool' => sub {
			(my $a, my $b) = @_;
			my $cool = {};
			my $c = $b->first_child('writeup')->first_child('e2link');

			$cool->{title}	= $c->text;
			$cool->{id}	= $c->{att}->{node_id};

			$c = $b->first_child('author')->first_child('e2link');

			$cool->{author}		= $c->text;
			$cool->{author_id}	= $c->{att}->{node_id};

			$c = $b->first_child('cooledby')->first_child('e2link');

			$cool->{cooledby}	= $c->text;
			$cool->{cooledby_id}	= $c->{att}->{node_id};

			push @cools, $cool;
		}
	};

	return $self->parse( 'coolnodes', $handlers, \@cools, %opt );
}

sub editor_cools {
	my $self = shift or croak "Usage: editor_cools E2TICKER [, COUNT ]";
	my $count = shift;

	my @edcools;

	warn "E2::Ticker::editor_cools"		if $DEBUG > 1;

	my %opt;

	$opt{count} = $count		if $count;

	my $handlers = {
		'edselection' => sub {
			(my $a, my $b) = @_;
			my $cool = {};
			my $c = $b->first_child('endorsed');

			$cool->{editor} = $c->text;
			$cool->{editor_id} = $c->{att}->{node_id};

			$c = $b->first_child('e2link');

			$cool->{title}	= $c->text;
			$cool->{id}	= $c->{att}->{node_id};

			push @edcools, $cool;
		}
	};

	return $self->parse( 'edcools', $handlers, \@edcools, %opt );
}

sub time_since {
	my $self = shift or croak "Usage: time_since E2TICKER [, USER1 [, USER2 [, ... ] ] ]";
	my @users = @_;
	my $string = undef;

	my @timesince;

	my %opt;

	warn "E2::Ticker::time_since"		if $DEBUG > 1;

	my $handlers = {
		'now' => sub {
			(my $a, my $b) = @_;
			$self->{now} = $b->text;
		},
		'user' => sub {
			(my $a, my $b) = @_;
			my $user = {};

			my $c = $b->first_child( 'e2link' );

			$user->{time} = $b->{att}->{lasttime};
			$user->{name} = $c->text;
			$user->{id} = $c->{att}->{node_id};

			push @timesince, $user;
		}
	};

	# If they've passed a list of users, determine
	# whether the list is of usernames or user_ids
	# and set %opt accordingly.

	if( @users ) {
		foreach my $u (@users) {
			if( ! int $u ) {
				$string = 1;
			}
		}

		my $key = $string ? 'node' : 'node_id';
		%opt = ( $key => join ',', @users );
	}

	return $self->parse( 'timesince', $handlers, \@timesince, %opt );
}

sub available_rooms {
	my $self = shift or croak "Usage: available_rooms E2TICKER";

	my @rooms = ( { title => 'outside', id => undef } );

	warn "E2::Ticker::available_rooms"		if $DEBUG > 1;

	my $handlers = {
		'outside/e2link' => sub {
			(my $a, my $b) = @_;
			$rooms[0] = {
				title	=> $b->text,
				id	=> $b->{att}->{node_id}
			};
		},
		'roomlist/e2link' => sub {
			(my $a, my $b) = @_;
			push @rooms, {
				title	=> $b->text,
				id	=> $b->{att}->{node_id}
			};
		}
	};

	return $self->parse( 'rooms', $handlers, \@rooms );
}

sub best_users {
	my $self = shift or croak "Usage: best_users E2TICKER [, NOGODS ]";
	my $nogods = shift;

	my @bestusers;

	warn "E2::Ticker::best_users"		if $DEBUG > 1;

	my %opt;
	$opt{ebu_noadmins} = 1	if $nogods;

	my $handlers = {
		'bestuser' => sub {
			(my $a, my $b) = @_;
			my $exp = $b->first_child( 'experience' );
			my $wri = $b->first_child( 'writeups' );
			my $usr = $b->first_child( 'e2link' );
			my $lvl = $b->first_child( 'level' );

			push @bestusers, {
				experience   => $exp->text,
				writeups     => $wri->text,
				id           => $usr->{att}->{node_id},
				user         => $usr->text,
				level        => $lvl->{att}->{value},
				level_string => $lvl->text
			};
		}
	};

	return $self->parse( 'bestusers', $handlers, \@bestusers, %opt );
}

sub node_heaven {
	my $self = shift or croak "Usage: node_heaven E2TICKER [, NODE_ID ]";
	my $node_id = shift;

	my @heaven;

	warn "E2::Ticker::node_heaven"		if $DEBUG > 1;

	if( !$self->logged_in ) { return undef; }

	my %opt;

	$opt{visitnode_id} = $node_id	if $node_id;

	my $handlers = {
		'nodeangel' => sub {
			(my $a, my $b) = @_;
			push @heaven, {
				title => $b->{att}->{title},
				id    => $b->{att}->{node_id},
				reputation => $b->{att}->{reputation},
				createtime => $b->{att}->{createtime},
				text  => $b->text
			};
		}
	};

	return $self->parse( 'heaven', $handlers, \@heaven, %opt );
}

sub maintenance_nodes {
	my $self = shift	or croak "Usage: maintenance_nodes E2TICKER";

	my @maintenance;

	warn "E2::Ticker::maintenance_nodes"		if $DEBUG > 1;

	my $handlers = {
		'e2link' => sub {
			(my $a, my $b) = @_;
			push @maintenance, {
				title	=> $b->text,
				id	=> $b->{att}->{node_id}
			};
		}
	};

	return $self->parse( 'maintenance', $handlers, \@maintenance );
}

sub raw_vars {
	my $self = shift	or croak "Usage: raw_vars E2TICKER";

	my $vars = {};

	warn "E2::Ticker::raw_vars"		if $DEBUG > 1;

	# Another method that doesn't return a list. Again, we'll have
	# to thread_then

	my $handlers = {
		'key' => sub {
			(my $a, my $b) = @_;
			$vars->{$b->{att}->{name}} = $b->text;
		}
	};

	return $self->thread_then(
		[
			\&parse,
			$self,
			'vars',
			$handlers,
			[]		# dummy value for array
		],
		sub { return $vars }
	);
}

sub interfaces {
	my $self = shift	or croak "Usage: interfaces E2TICKER";

	return $self->{xml_interfaces};
}

sub random_nodes_wit {
	my $self = shift 	or croak "Usage: random_wit_now E2TICKER";
	return $self->{wit};
}

sub time_since_now {
	my $self = shift	or croak "Usage: time_since_now E2TICKER";
	return $self->{now};
}

1;
__END__