Author: bdonlan
Date: 2005-07-18 00:42:57 -0400 (Mon, 18 Jul 2005)
New Revision: 870
Modified:
trunk/perl/client/lib/Haver/Client/POE.pm
Log:
Revert data changes from r869
Modified: trunk/perl/client/lib/Haver/Client/POE.pm
===================================================================
--- trunk/perl/client/lib/Haver/Client/POE.pm 2005-07-18 04:34:36 UTC (rev
869)
+++ trunk/perl/client/lib/Haver/Client/POE.pm 2005-07-18 04:42:57 UTC (rev
870)
@@ -17,37 +17,16 @@
# along with this module; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-# object fields:
-# self => {
-# [persistent data]
-# options => { key => value },
-# handlers => {
-# type => {
-# event name => {
-# reverse => {
-# stringified $subref => index
-# },
-# forward => [
-# $subref,
-# ...
-# ]
-# } # event name =>
-# } # type =>
-# }, # handlers =>
-# connection => {
-# [connection data]
-# UID => $uid,
-# authmethods => [ acceptable auth methods ],
-# state => STATE_NAME,
-# want => 'CURRENTLY_WANTED',
-# pending => [
-# ['WAITING', 'FOR', 'WANT'],
-# ],
-# POE => {
-# connwheel => POE::Wheel::ConnectionFactory,
-# sockwheel => POE::Wheel::ReadWrite
-# },
-# } # connection =>
+# heap fields:
+# heap => {
+# name => user name,
+# reg => {
+# event name => { session ID => 1 }
+# },
+# wheel => active wheel,
+# state => see below constants,
+# # for connect events sent while still shutting down
+# pending => { Host => host, Port => port, Name => name ] | nonexistent
# }
=head1 NAME
@@ -62,7 +41,7 @@
$conn->register(connected => \&on_connect);
$conn->connect( Host => 'example.com',
Port => 7070,
- UID => 'example');
+ Name => 'example');
=head1 DESCRIPTION
@@ -77,53 +56,72 @@
package Haver::Client::POE;
use strict;
use warnings;
+use Carp;
+use Data::Dumper;
+use Regexp::Shellish;
use constant {
- TRUE => 1,
- FALSE => 0,
- STATE_IDLE => 0, # not connected or connecting
- STATE_CONNECT => 1, # establishing connection
- STATE_AUTH => 2, # authenticating
- STATE_READY => 3, # ready for user control
- STATE_DISCON => 4, # disconnecting
+ S_IDLE => 0, # not connected, not connecting
+ S_CONN => 1, # establishing socket connection
+ S_INIT => 2, # C: HAVER sent
+ S_LOGIN => 3, # S: HAVER recieved, C: IDENT sent
+ S_ONLINE => 4, # S: HELLO received
+ S_DYING => 5, # C: BYE sent, socket still open
};
-use Carp;
-
use POE qw(Wheel::ReadWrite
Wheel::SocketFactory);
-use POE::Filter::Haver;
-use Haver::Preprocessor;
-use Haver::Formats::Error;
+use Haver::Protocol::Filter;
our $VERSION = 0.06;
+our %failures = (
+ 'invalid.name' => "The server rejected the name %1%.",
+ 'reserved.name' => "The name %1% is reserved for internal use by the
server.",
+ 'exists.user' => "The name %1% is in use.",
+ 'unknown.user' => "The user %1% is not online.",
+ 'unknown.channel' => "The channel %1% does not exist.",
+ 'unknown.namespace' => "The namespace %1% does not exist. This is probably
an application bug.",
+ 'invalid.type' => "The type of a message was invalid. This is almost
certainly an application error.",
+ 'already.joined' => "Tried to join %1% when already in it.",
+ 'already.parted' => "Tried to leave %1% when not in it.",
+);
+
+sub _format {
+ my @args = @_;
+ shift @args; # S: FAIL
+ my $code = $args[0];
+
+ if (!$failures{$code}) {
+ return "Unknown error: " . join(' ', @args);
+ }
+
+ my $msg = $failures{$code};
+ $msg = s{%(\d+)%}{$args[$1] || "MISSING ARGUMENT $1"}eg;
+ return $msg;
+}
+
sub _call {
return POE::Kernel->call(POE::Kernel->get_active_session(), @_);
}
+sub _dispatch {
+ _call('__dispatch', @_);
+}
+
sub _dprint {
my ($level, @text) = @_;
- return unless
POE::Kernel->get_active_session()->get_heap()->{object}{debug} >= $level;
+ return unless POE::Kernel->get_active_session()->get_heap()->{debug} >=
$level;
print STDERR @text;
}
sub _dprintf {
my ($level, $fmt, @text) = @_;
- return unless
POE::Kernel->get_active_session()->get_heap()->{object}{debug} >= $level;
+ return unless POE::Kernel->get_active_session()->get_heap()->{debug} >=
$level;
printf STDERR $fmt, @text;
}
-sub _object_states {
- my ($self, $ehash) = @_;
- $ehash = {qw{
- _start _start
- _default _default
- }, %$ehash};
- return $self->SUPER::_object_states($ehash);
-}
-
### SETUP
=head2 spawn($alias [, $Z<>resolver])
@@ -138,12 +136,10 @@
sub spawn {
my ($pkg, $alias, $resolver) = @_;
- my $self = {
- options => {
- version => "Haver::Client::POE/$VERSION",
- },
- handlers => {
- },
+ my $heap = {
+ reg => {},
+ state => S_IDLE,
+ alias => $alias,
resolver => $resolver
};
@@ -191,22 +187,16 @@
}
sub _start {
- die "STUB";
+ my ($kernel, $alias) = @_[KERNEL,ARG0];
+ $kernel->alias_set($alias);
}
-# Internal: _init_event_type($type)
-# Prepares to register events of type $type
+### SESSION MANAGEMENT
-sub _init_event_type {
- my $self = shift;
- $self->{handlers}{shift} = {
- hhash => {},
- byname => {},
- }
-}
+=head2 connect(Host => $Z<>host, Name => $Z<>name, [Port => $Z<>port])
-# Internal: _init_wants
-# Sets up default handlers for wants
+Connects to the haver server. The Host option is mandatory, all others are
optional.
+If it is already connected, it will disconnect, then connect with the new
parameters.
=cut
@@ -311,41 +301,19 @@
# XXX: timeout
}
-
-
-=head2 setoptions(option => value [, ...])
-
-Sets one or more options to the given value. The following options are
available:
-
-=head3 debug => level
-
-Sets debugging to the given level. 0 will disable debugging.
-
-=head3 autorespond => [ ... ]
-
-Enables autoresponding to certain types of messages. Currently only PING? and
TIME? are supported.
-
-=head3 version => "foobar/0.1"
-
-Sets the string sent in response to S: WANT VERSION
-
-=cut
-
-sub setoptions {
- die "STUB";
+sub _input {
+ my ($kernel, $heap, $arg) = @_[KERNEL,HEAP,ARG0];
+ return if (ref $arg ne 'ARRAY' || @$arg == 0);
+ print STDERR "S: ", join "\t", @$arg;
+ print STDERR "\n";
+ _dispatch('raw_in', @$arg);
+ my $cmd = $arg->[0];
+ $kernel->yield("_ev_$cmd", @$arg);
}
-### SESSION MANAGEMENT
-
-=head2 connect(Host => $Z<>host, [Port => $Z<>port])
-
-Connects to the haver server. The Host option is mandatory, all others are
optional.
-If it is already connected, it will disconnect, then connect with the new
parameters.
-
-=cut
-
-sub connect {
- die "STUB";
+sub _err {
+ _dispatch('disconnected', @_[ARG0..ARG2]);
+ _call('_cleanup');
}
=head2 disconnect(Z<>)
@@ -362,9 +330,27 @@
$poe_kernel->delay('_force_down', 5);
}
+sub _force_down {
+ my $heap = $_[HEAP];
+ $heap->{state} = S_IDLE;
+ _call('_cleanup');
+}
+
+sub _cleanup {
+ my $heap = $_[HEAP];
+ $poe_kernel->delay('_force_down');
+ if ($heap->{pending}) {
+ my @opts = %{delete $heap->{pending}};
+ $poe_kernel->yield('connect', @opts);
+ }
+ delete $heap->{wheel};
+ delete $heap->{name};
+ $heap->{state} = S_IDLE;
+}
+
=head2 send_raw(@args)
-Sends the arguments specified to the haver server. No checking is performed,
though escaping may occur.
+Sends the arguments specified to the haver server. No checking is performed,
though escaping will be done.
=cut
@@ -386,34 +372,12 @@
=cut
sub send {
- die "STUB"
+ my ($kernel, @args) = @_[KERNEL,ARG0..$#_];
+ _call('send_raw', @args);
}
### CLIENT EVENTS
-=head2 login(UID => $Z<>uid)
-
-Specifies the UID to use to log in. If authentication is already complete,
-this has no effect.
-
-=cut
-
-sub login {
- die "STUB";
-}
-
-=head2 authenticate($Z<>method, @Z<>args)
-
-Authenticates to the server. $method must be an object of type
-Haver::Client::POE::Auth capable of handling an authentication
-type listed in the auth_request() message.
-
-=cut
-
-sub authenticate {
- die "STUB";
-}
-
=head2 join($Z<>channel)
Attempts to join $channel
@@ -421,7 +385,8 @@
=cut
sub join {
- die "STUB";
+ my $channel = $_[ARG0];
+ _call('send', 'JOIN', $channel);
}
=head2 part($Z<>channel)
@@ -431,367 +396,205 @@
=cut
sub part {
- die "STUB";
+ my $channel = $_[ARG0];
+ _call('send', 'PART', $channel);
}
-=head2 make($Z<>channel)
+=head2 in($Z<>channel, $Z<>type, @Z<>args)
-Ask the server to create a channel $channel.
+Sends a message with specified type and arguments to $channel.
=cut
-sub make {
- die "STUB";
+sub public {
+ my ($kernel, $heap, $c, $t, @a) = @_[KERNEL,HEAP,ARG0..$#_];
+ _call('send', 'IN', $c, $t, @a);
}
-=head2 msg($Z<>channel, $Z<>type, $Z<>text)
+=head2 to($Z<>uid, $Z<>type, @Z<>args)
-Sends a message with specified type and text to $channel.
+Sends a private message with specified type and arguments to $uid.
=cut
-sub msg {
- die "STUB";
+sub private {
+ my ($kernel, $heap, $d, $t, @a) = @_[KERNEL,HEAP,ARG0..$#_];
+ _call('send', 'TO', $d, $t, @a);
}
-=head2 pmsg($Z<>uid, $Z<>type, $Z<>text)
+=head2 list($Z<>channel [, $Z<>type])
-Sends a private message with specified type and text to $uid.
+Ask the server which entities of $type are in $channel. If $type is not
+given, it defaults to 'user'.
=cut
-sub pmsg {
- die "STUB";
+sub list {
+ my ($chan, $type) = @_[ARG0, ARG1];
+ $type = defined $type || 'user';
+ _call('send', 'LIST', $chan, $type);
}
-=head2 users($Z<>channel)
+=head2 destroy(Z<>)
-Ask the server which users are on $channel.
+Disconnects from the Haver server, and destroys the session.
=cut
-sub users {
- die "STUB";
+sub destroy {
+ my ($kernel, $heap) = @_[KERNEL,HEAP];
+ _dispatch('destroyed');
+ delete $heap->{pending};
+ my $reg = $heap->{reg};
+ foreach my $ehash (values %$reg) {
+ foreach my $id (keys %$ehash) {
+ $poe_kernel->refcount_decrement($id, $ehash->{$id});
+ }
+ }
+ $heap->{reg} = {};
+ _call('disconnect');
+ $kernel->alias_remove($heap->{alias});
}
-=head2 chans(Z<>)
+## server-response stuff
-Ask the server for a list of all channels
+sub _ev_HAVER {
+ my ($kernel, $heap) = @_[KERNEL,HEAP];
+ return if ($heap->{state} != S_INIT); # should never happen, unless the
+ # server is non-compliant
+ $kernel->yield('send_raw', 'IDENT', $heap->{name});
+ $heap->{state} = S_LOGIN;
+}
-=cut
+sub _ev_HELLO {
+ my $heap = $_[HEAP];
+ $heap->{state} = S_ONLINE;
+ _dispatch('ready');
+}
-sub chans {
- die "STUB";
+sub _ev_JOIN {
+ my ($heap, $chan, $name) = @_[HEAP,ARG1,ARG2];
+ if ($name eq $heap->{name}) {
+ _dispatch('ijoined', $chan);
+ } else {
+ _dispatch('join', $chan, $name);
+ }
}
-=head2 destroy(Z<>)
+sub _ev_PART {
+ my ($heap, $chan, $name) = @_[HEAP,ARG1,ARG2];
+ if ($name eq $heap->{name}) {
+ _dispatch('iparted', $chan);
+ } else {
+ _dispatch('part', $chan, $name);
+ }
+}
-Disconnects from the Haver server, and destroys the session. This event may
not complete
-immediately, so you should not attempt to create another session with the same
alias
-until it finishes.
+sub _ev_LIST {
+ my ($heap, $chan, $ns, @things) = @_[HEAP,ARG1..$#_];
+ return unless defined $ns;
+ _dispatch('list', $chan, $ns, @things);
+}
-=cut
+sub _ev_IN {
+ _dispatch('public', @_[ARG1..$#_]);
+}
-sub destroy {
- die "STUB";
+sub _ev_FROM {
+ _dispatch('private', @_[ARG1..$#_]);
}
-sub _default {
- my ( $kernel, $state, $event, $args, $self ) = @_[ KERNEL, STATE, ARG0,
ARG1, OBJECT ];
- $args ||= []; # Prevents uninitialized-value warnings.
- # DEBUG: "default: $state = $event. Args:\n", Dumper $args;
- return 0;
+sub _ev_PING {
+ _call('send_raw', 'PONG', @_[ARG1..$#_]);
}
-=head1 HANDLERS
-
-Handlers are subroutines called to handle some event from the server. Any
-number of handlers may be registered to an event, and they will be called
-in reverse order of registration until one indicates that it has handled the
-event.
-
-The handler prototype is as follows:
-
- sub handler {
- my ($handled, $type, $name, $args) = @_;
- # ...
- $handled = 1; # To handle the event
- }
-
-$type is the type of event, $name is the event name, and $args is an array ref
-of arguments for the event.
-
-If $$handled is 0 when the handler returns, the next handler in the chain will
-be called. Any changes to the contents of $args will be passed on.
-
-If no handler in a chain handles the event, an event with the same type and
-a name of '_default' will be generated, with the old event name prepended
-to @args. If no handler in the _default chain handles the event, it will be
-discarded.
-
-=head2 METHODS FOR HANDLER MANIPULATION
-
-=head3 register_handler($Z<>type, $Z<>event, $Z<>handler)
-
-Register a handler $handler for an event of type $type, name $event. If such
-a handler already exists, does nothing.
-
-=cut
-
-sub register_handler {
- my ($self, $type, $event, $handler) = @_;
- my $htype = $self->{handlers}{$type}
- or croak "Unknown event type $type";
- my $hevent = $htype->{$event};
- if (!$hevent) {
- $hevent = $htype->{$event} = {
- forward => {},
- reverse => {},
- };
- }
- return if (exists $hevent->{reverse}{$handler});
- my $index = @{$hevent->{forward}};
- push @{$hevent->{forward}}, $handler;
- $hevent->{reverse}{$handler} = $index;
+sub _ev_BYE {
+ my ($type, $detail) = @_[ARG2,ARG3];
+ _dispatch('bye', $detail);
+ _call('_cleanup');
}
-=head3 unregister_handler($Z<>type, $Z<>event, $Z<>handler)
-
-Unregisters a handler previously registered by passing the same arguments
-to register_handler. If such a handler does not exist, does nothing.
-
-=cut
-
-sub unregister_handler {
- my ($self, $type, $event, $handler) = @_;
- my $htype = $self->{handlers}{$type}
- or croak "Unknown event type $type";
- my $hevent = $self->{handlers}{$type}{$event} or return;
- my $index = $hevent->{reverse}{$handler} or return;
- # Remove the item
- splice @{$hevent->{forward}}, $index, 1;
- # and renumber the ones afterward
- my $len = @{$hevent->{forward}};
- for (; $index < $len; $index++) {
- my $handler = $hevent->{forward}[$index];
- $hevent->{reverse}{$handler} = $index;
- }
- # and delete the reverse mapping
- delete $hevent->{reverse}{$handler};
+sub _ev_FAIL {
+ my $msg = _format(@_[ARG0..$#_]);
+ _dispatch('fail', $msg, @_[ARG0..$#_]);
+ my $code = $_[ARG1];
+ $code =~ tr/./_/;
+ _dispatch("fail_$code", $msg, @_[ARG0..$#_]);
}
-# Internal: _event_dispatch($type, $event, @args)
-# dispatches event $event
-
-sub _event_dispatch {
- my ($self, $type, $event, @args) = @_;
- my $etype = $self->{handlers}{$type}
- or croak "Unknown event type $etype";
- my $ev = $etype->{$event};
- if (!$ev) {
- if ($event eq '_default') {
- return; # Nobody seems to be interested.
- }
- $self->_event_dispatch($type, '_default', $event, @args);
- }
- for my $handler (@{$ev->{forward}}) {
- my $handled = 0;
- $handler->(\$handled, $type, $event, [EMAIL PROTECTED]);
- return if $handled;
- }
- if ($event ne '_default') {
- $self->_event_dispatch($type, '_default', $event, @args);
- }
+sub _default {
+ my ( $kernel, $state, $event, $args, $self ) = @_[ KERNEL, STATE, ARG0,
ARG1, OBJECT ];
+ $args ||= []; # Prevents uninitialized-value warnings.
+ # DEBUG: "default: $state = $event. Args:\n", Dumper $args;
+ return 0;
}
-
-
-1;
-__END__
-
-=head2 TYPES OF HANDLERS
-
-=head3 want
-
-Handlers of type 'want' are invoked when the server sends a S: WANT message.
The
-first argument of the S: WANT is the event name, the rest are used as
-arguments for the first handler.
-
-The default action, should all handlers pass the event, is to send a
-C: CANT $event to the server.
-
-=head3 smsg
-
-Handlers of type 'smsg' are invoked whenever a command is received from the
server.
-The command name is used for the event name, and the arguments are passed for
-the first handler's @args.
-
-Note that adding a handler with $type of smsg, and $event of 'WANT' may
-prevent handlers of $type want from being called.
-
=head1 EVENTS
-Events are sent to inform multiple handlers of some happening on the server.
-Any number of event callbacks may be registered to an event, and they will all
-be invoked in an undefined order when the event is dispatched.
+docme
=cut
-# implementation notes:
-# events are implemented with handlers, with type 'event'
-# register and unregister create an anonymous wrapper closure to hide the
-# details. These subs are stored in %{$self->{evwrap}}
-# TODO: expire evwrap entries
-
=head2 EVENT MANIPULATION FUNCTIONS
-=head3 register(event => handler)
+=head3 register(@Z<>events)
-Registers to receive a specified event with the specified handler function.
-The special event 'all' may be used to receive all events.
-
=cut
sub register {
- my ($self, @events) = @_;
- while (@events) {
- my ($ev, $handler) = splice @events, 0, 2;
- my $wrap = $self->{evwrap}{$handler} || sub {
- my ($handled, $type, $name, $args) = @_[1..3];
- if ($type ne 'event') {
- die "Impossible: event handler on non-event
type!";
- }
- $handler->($name, @$args);
- };
- $self->{evwrap}{$handler} = $wrap;
- $self->register_handler('event', $ev, $wrap);
- }
+ my ($kernel, $heap, $session, @events) =
@_[KERNEL,HEAP,SENDER,ARG0..$#_];
+ my $reg = $heap->{reg};
+ my $id = $session->ID;
+ foreach my $event (@events) {
+ $event = uc $event;
+ next if exists $reg->{$event}{$id};
+ my $tag = '1' . $reg->{$event} . '\0' . $id . '\0' . rand;
+ $reg->{$event}{$id} = $tag;
+ $kernel->refcount_increment( $id, $tag );
+ }
}
-=head3 unregister(event => handler)
+=head3 unregister(@Z<>events)
-Unregisters the given handler for the specified event.
=cut
sub unregister {
- my ($self, @events) = @_;
- while (@events) {
- my ($ev, $handler) = splice @events, 0, 2;
- my $wrap = $self->{evwrap}{$handler} or next;
- $self->unregister_handler('event', $ev, $wrap);
- }
+ my ($kernel, $heap, $session, @events) =
@_[KERNEL,HEAP,SENDER,ARG0..$#_];
+ my $reg = $heap->{reg};
+ my $id = $session->ID;
+ foreach my $event (@events) {
+ $event = uc $event;
+ my $tag;
+ next unless $tag = delete $reg->{$event}{$id};
+ $kernel->refcount_decrement( $id, $tag );
+ }
}
-=head2 TYPES OF EVENTS
+sub __dispatch {
+ my ($kernel, $heap, $evname, @args) = @_[KERNEL,HEAP,ARG0..$#_];
+ $evname = uc $evname;
+ my $reg = $heap->{reg};
+ $reg->{$evname} ||= {};
+ $reg->{ALL} ||= {};
+ my %targ = (%{$reg->{$evname}}, %{$reg->{ALL}});
+ my @ids = keys %targ;
-Client events have the following prototype:
+ unshift @args, [$heap->{alias}];
foreach my $id (@ids) {
$kernel->post($id, "haver_$evname", @args);
}
}
-The contents of @args vary depending on the event name, and are documented
-below.
+=head2 TYPES OF EVENTS
-=head4 connected(Z<>)
+docme
-This event is sent when a connection is established (but before it is logged
in)
-
-=head4 connect_fail($Z<>enum, $Z<>estr)
-
-The connection could not be established. An error code is in $enum, and the
human-readable
-version is in $estr
-
-=head4 disconnected($Z<>enum, $Z<>estr)
-
-The connection has been lost. If the server closed the connection, $enum will
be 0 and $estr will
-be meaningless. If the user closed the connection, and the server failed to
respond, $enum will be -1.
-Otherwise, $enum will contain an error code, and $estr the human-readable
version.
-
-=head4 raw_in(@data)
-
-The client has received @data from the Haver server. Mostly useful for
debugging.
-
-=head4 raw_out(@data)
-
-The client has sent @data to the Haver server. Mostly useful for debugging.
-
-=head4 login_request(Z<>)
-
-The server is asking for a UID, and one was not provided in connect().
-The authentication will not proceed until login() is invoked with the UID.
-
-=head4 auth_request(@Z<>methods)
-
-The server requests authentication using one of the listed methods. The
-authentication will not proceed until authenticate() is invoked with a
-suitable authentication handler.
-
-=head4 login(Z<>)
-
-The client has successfully logged in.
-
-=head4 close($Z<>etyp, $Z<>estr)
-Z<XXX: Describe args>
-
-Server is closing connection, and sent $etyp and $estr
-
-=head4 join(Z<>)
-
-$uid has joined $cid
-
-=head4 joined(Z<>)
-
-The client has joined $cid.
-
-=head4 part(Z<>)
-
-$uid has left $cid.
-
-=head4 parted(Z<>)
-
-The client has left $Z<>cid.
-
-=head4 msg($Z<>type, @Z<>msg)
-
-A public message with type $type and contents @msg was sent on channel $cid by
user $uid.
-
-=head4 pmsg($Z<>type, @Z<>text)
-
-A private message with type $type and contents @msg was sent to you by user
$uid.
-
-=head4 users(@Z<>who)
-
-Channel $cid has the users listed in @who in it. Sent in response to message
users().
-
-=head4 bye($Z<>why)
-
-The server is disconnecting you due to the reason in $why
-
-=head4 chans(@Z<>channels)
-
-The server has the channels listed in @channels. Sent in response to message
chans()
-
-=head4 warn($Z<>err, $Z<>short, $Z<>long, @Z<>args)
-
-The server has sent a non-fatal error message with code $err and arguments
@args. $short and $long have the
-short and long human-readable forms, respectively.
-
-=head4 die($Z<>err, $Z<>short, $Z<>long, @Z<>args)
-
-The server has sent a fatal error message with code $err and arguments @args.
$short and $long have the
-short and long human-readable forms, respectively. The connection will be
closed shortly.
-
-=head4 quit($Z<>why)
-
-UID $uid has disconnected due to the reason in $why.
-
=head1 SEE ALSO
-L<http://wiki.chani3.com/wiki/ProjectHaver/>
+L<http://haverdev.org>
=head1 AUTHOR
@@ -818,3 +621,5 @@
=cut
+
+1;
