Author: bdonlan
Date: 2004-07-18 20:27:06 -0400 (Sun, 18 Jul 2004)
New Revision: 315
Modified:
branches/new-poe-client/main/client/lib/Haver/Client/POE.pm
Log:
* main/client/lib/Haver/Client/POE.pm - Removed all code, and created
a possible API spec.
Modified: branches/new-poe-client/main/client/lib/Haver/Client/POE.pm
===================================================================
--- branches/new-poe-client/main/client/lib/Haver/Client/POE.pm 2004-07-19
00:18:55 UTC (rev 314)
+++ branches/new-poe-client/main/client/lib/Haver/Client/POE.pm 2004-07-19
00:27:06 UTC (rev 315)
@@ -17,6 +17,39 @@
# 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 },
+# wants => {
+# want => {
+# hhash => {
+# stringified $handler => $index_of_handler
+# },
+# harray => [
+# $handler
+# ],
+# }
+# },
+# handlers => {
+# [same as wants]
+# }
+# }
+# heap => {
+# [connection data]
+# auth => {
+# UID => $uid,
+# methods => {
+# TODO: OO authentication handler interface
+# pass => 'password',
+# },
+# }
+# state => STATE_NAME,
+# want => 'CURRENTLY_WANTED',
+# pending => [
+# ['WAITING', 'FOR', 'WANT'],
+# ],
+# }
=head1 NAME
@@ -45,6 +78,16 @@
use strict;
use warnings;
+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
+};
+
use POE qw(Wheel::ReadWrite
Wheel::SocketFactory);
use Haver::Preprocessor;
@@ -78,55 +121,6 @@
my ($self, $ehash) = @_;
$ehash = {(map {$_ => $_} qw{
_start
- setoptions
-
- dispatch
- dispatch_ref
-
- connect
- connected
- connectfail
-
- net_in
- input
- send_raw
- send
- _flush_msgq
- net_error
-
- destroy
- disconnect
- force_close
- flushed
- cleanup
-
- login
- join
- part
- msg
- pmsg
- users
- make
- chans
-
- event_WANT
- event_ACCEPT
- event_REJECT
- event_PING
- event_CLOSE
- event_IN
- event_OF
-
- event_JOIN
- event_PART
- event_MSG
- event_USERS
- event_BYE
- event_QUIT
- event_CHANS
- event_WARN
- event_DIE
-
_default
}), %$ehash};
return $self->SUPER::_object_states($ehash);
@@ -142,23 +136,11 @@
=cut
sub new {
- my ($class, $alias, %options) = @_;
- my $self = $class->SUPER::new(prefix => delete($options{prefix}) ||
'haver_', args => [$alias, %options]);
- return 1;
+ die "STUB";
}
sub _start {
- my ($kernel, $self, $session, $alias, @args) =
@_[KERNEL,OBJECT,SESSION,ARG0..$#_];
- $_[HEAP]->{object} = $self;
- $self->{alias} = $alias;
- $kernel->alias_set($self->{alias});
- $self->{scope} = undef;
- $self->{debug} = 0;
- $self->{autorespond} = { 'PING?' => 1, 'TIME?' => 1 };
- $self->{version} = "Haver::Client::POE/$VERSION";
- if (@args) {
- _call('setoptions', @args);
- }
+ die "STUB";
}
=head1 MESSAGES
@@ -182,15 +164,7 @@
=cut
sub setoptions {
- my ($kernel, $self, %args) = @_[KERNEL,OBJECT,ARG0..$#_];
- my %setters = (
- debug => sub { $self->{debug} = $_[0]; },
- autorespond => sub { $self->{autorespond} = map { ($_ => 1) }
@_ },
- version => sub { $self->{version} = $_[0]; },
- );
- for (keys %args) {
- $setters{$_}->($args{$_}) if exists $setters{$_};
- }
+ die "STUB";
}
### DISPATCH
@@ -205,13 +179,38 @@
Unregisters from the specified event. Events registered using 'all' must be
unregistered using 'all'.
+=head2 register_want($Z<>wantname => sub { ... } [,...])
+
+Registers handlers to be called if the given command is requested from the
+server. The most recently registered handler is called first, with its
+arguments being the full command received (including WANT $wantname). Each
+handler must return undef if it has handled the want, or a list containing the
+arguments for the next handler. If the last handler does not return undef,
+CANT $wantname will be sent to the server.
+
=cut
+sub register_want { die "STUB" }
+
+=head2 unregister_want($subrev [,...])
+
+Unregisters one or more handler previously registered with register_want().
+
+=cut
+
+sub unregister_want { die "STUB" }
+
+# Internal: dispatch_ref($event, $args)
+# dispatches $event to clients, with $args
+
sub dispatch_ref {
my ($kernel, $self, $event, $args) = @_[KERNEL,OBJECT,ARG0,ARG1];
$kernel->yield('_dispatch', $event, $args, $self->{IN}, $self->{OF});
}
+# Internal: dispatch($event, @args)
+# calls dispatch_ref($event, [EMAIL PROTECTED])
+
sub dispatch {
my @pre = @_[0..ARG0];
my $payload = [EMAIL PROTECTED];
@@ -219,41 +218,22 @@
goto &dispatch_ref;
}
+# Internal: dispatch_want($want, @args)
+# dispatches handlers for $want
+
+sub dispatch_want { die "STUB" }
+
### SESSION MANAGEMENT
-=head2 B<connect(Host => $Z<>host, [Port => $Z<>port, UID => $Z<>uid, Password
=> $Z<>password])
+=head2 B<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.
-Password is deprecated, and will be removed some time after SSL is supported.
-
=cut
sub connect {
- my ($kernel, $self, %args) = @_[KERNEL,OBJECT,ARG0..$#_];
-# XXX: Better error reporting
- croak "Missing required parameter Host" unless exists $args{Host};
- if (exists $self->{conn}) {
- $kernel->yield('disconnect') unless exists
$self->{pending_connection};
- $self->{pending_connection} = [%args];
- return;
- }
- $self->{UID} = $args{UID};
- $self->{PASS} = $args{Password};
- $self->{Host} = $args{Host};
- undef $self->{want};
- $self->{enabled} = 1; # Set to 0 when graceful shutdown
begins, to block user input
- $self->{accepted} = 0; # Set to 1 when login is successful
- $self->{dead} = 0; # Set to 1 when the socket
fails, to drop messages
- $args{Port} ||= 7070;
- $self->{connect_wheel} =
- POE::Wheel::SocketFactory->new(
- RemoteAddress => $args{Host},
- RemotePort => $args{Port},
- SuccessEvent => 'connected',
- FailureEvent => 'connectfail'
- );
+ die "STUB";
}
=head2 disconnect(Z<>)
@@ -264,68 +244,9 @@
=cut
sub disconnect {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- $self->{enabled} = 0;
- return if $self->{closing};
- $self->{closing} = 1;
- if ($self->{want}) {
- $kernel->yield('cleanup');
- } else {
- $kernel->yield('send', 'QUIT');
- $kernel->delay('force_close', 5);
- }
+ die "STUB";
}
-sub connected {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- my ($handle, $id) = @_[ARG0,ARG3];
- if (!exists $self->{connect_wheel} ||
- $self->{connect_wheel}->ID() != $id){
- close $handle;
- return;
- }
- binmode $handle, ':utf8';
- $self->{conn} =
- POE::Wheel::ReadWrite->new(
- Handle => $handle,
- Driver => POE::Driver::SysRW->new(),
- Filter => POE::Filter::Haver->new(),
- InputEvent => 'net_in',
- FlushedEvent => 'flushed',
- ErrorEvent => 'net_error'
- );
- delete $self->{connect_wheel};
- $self->{flushed} = 1;
- _call('dispatch', 'connected');
-}
-
-sub connectfail {
- my ($kernel, $self, $enum, $estr) = @_[KERNEL,OBJECT,ARG1,ARG2];
- _call('dispatch', 'connect_fail', $enum, $estr);
- delete $self->{connect_wheel};
-}
-
-sub net_error {
- my ($kernel, $self, $enum, $estr) = @_[KERNEL,OBJECT,ARG1,ARG2];
- _call('dispatch', 'disconnected', $enum, $estr);
- $kernel->yield('cleanup');
-}
-
-### IO
-
-sub net_in {
- my ($kernel, $self, $event) = @_[KERNEL,OBJECT,ARG0];
- _dprint 1, "S: ", join("\t", @$event), "\n";
- _call('dispatch', 'raw_in', @$event);
- goto &input;
-}
-
-sub input {
- my ($kernel, $self, $event) = @_[KERNEL,OBJECT,ARG0];
- my $ename = shift @$event;
- _call("event_$ename", @$event);
-}
-
=head2 send_raw(@args)
Sends the arguments specified to the haver server. No checking is performed,
though escaping may occur.
@@ -333,261 +254,43 @@
=cut
sub send_raw {
- my ($kernel, $self, @message) = @_[KERNEL,OBJECT,ARG0..$#_];
- return if ($self->{dead});
- eval { $self->{conn}->put([EMAIL PROTECTED]); };
- if ($@) {
- # Ack, lost connection unexpectedly!
- # Hopefully we get net_error soon
- $self->{dead} = 1;
- return;
- }
- _dprint 1, "C: ", join("\t", map { defined($_) ? $_ : '~UNDEF~' }
@message), "\n";
- _call('dispatch', 'raw_out', @message);
- $self->{flushed} = 0;
+ die "STUB";
}
-sub send {
- my ($kernel, $self, @message) = @_[KERNEL,OBJECT,ARG0..$#_];
- my $block = 0;
-
- if (!$self->{enabled}) {
- $block = 1;
- } elsif ($self->{accepted} && !$self->{want}) {
- $block = 0;
- } elsif (!$self->{want}) {
- # Before we get a S: ACCEPT we can't send anything not in
response to a S: WANT
- $block = 1;
- } elsif ($message[0] eq 'CANT') {
- $block = ($message[1] ne $self->{want});
- } elsif ($message[0] ne $self->{want}) {
- $block = 1;
- }
-
- if ($block) {
- _dprint 1, "(blocked) C: ", join("\t", @message), "\n";
- push @{$self->{messageq} ||= []}, [EMAIL PROTECTED];
- return;
- }
-
- delete $self->{want};
-
- $kernel->yield('send_raw', @message);
-
- $kernel->yield('_flush_msgq');
-}
+=head2 send(@args)
-sub _flush_msgq {
- my ($kernel, $self) = @_[KERNEL,OBJECT];
- if (exists $self->{messageq}) {
- for (@{$self->{messageq}}) {
- $kernel->yield('send', @$_);
- }
- delete $self->{messageq};
- }
-}
+Sends the arguments specified to the Haver server. If authentication is not
+yet completed, it will be queued until authentication is completed.
-### SERVER EVENTS
+=cut
-# XXX: Make a more extensible WANT system later
-#
-# hmm, I reformatted this a bit so it is possible
-# to easily edit in vim. :P (dylan)
-sub event_WANT {
- my ($kernel, $self, $wanted, @arg) = @_[KERNEL,OBJECT,ARG0,ARG1];
- $wanted = uc $wanted;
- $self->{want} = $wanted;
- my %wants = (
- IDENT => sub {
- $kernel->yield('send', 'IDENT', $self->{UID}, 'user',
$self->{version});
- },
- AUTH => sub {
- # XXX: More extensible AUTH system later too
- my @methods = split ',', $arg[0];
- # XXX: only pass for now
- unless(grep { $_ eq 'pass' } @methods) {
- $kernel->yield('send', 'CANT', 'AUTH');
- return;
- }
- $kernel->yield('send', 'AUTH', 'pass');
- $self->{auth} = 'pass';
- },
- 'AUTH:PASS' => sub {
- # XXX: Better support for namespaces
- if($self->{PASS}) {
- $kernel->yield('login', $self->{PASS});
- return;
- }
- $kernel->yield('dispatch', 'login_request');
- },
- );
- if (exists $wants{$wanted}) {
- $wants{$wanted}->();
- } else {
- $kernel->yield('send', 'CANT', $wanted);
- }
+sub send {
+ die "STUB"
}
-sub event_ACCEPT {
- my ($kernel, $self) = @_[KERNEL,OBJECT];
- $self->{logged_in} = 1;
- $self->{accepted} = 1;
- _call('dispatch', 'login');
- $kernel->yield('_flush_msgq');
-}
+### CLIENT EVENTS
-sub event_REJECT {
- my ($kernel, $self, $uid, $err) = @_[KERNEL,OBJECT,ARG0,ARG1];
- my $e = new Haver::Formats::Error;
- _call('dispatch', 'login_fail',
- $err,
- $e->get_short_desc($err),
- $e->format( $e->get_long_desc($err), $uid )
- );
- delete $self->{UID};
- delete $self->{PASS};
- $self->{want} = 'UID';
-}
+=head2 login(UID => $Z<>uid)
-sub event_PING {
- my ($kernel, $self, @junk) = @_[KERNEL,OBJECT,ARG0..$#_];
- $kernel->yield('send', 'PONG', @junk);
-}
+Specifies the UID to use to log in. If authentication is already complete,
+this has no effect.
-sub event_CLOSE {
- my ($kernel, $self, $etyp, $estr) = @_[KERNEL,OBJECT,ARG0,ARG1];
- _call('dispatch', 'close', $etyp, $estr);
-}
+=cut
-sub event_JOIN {
- my ($kernel, $self) = @_[KERNEL,OBJECT,ARG0,ARG1];
- my $event = 'join';
- if (!defined($self->{OF}) ||
- $self->{OF} eq '.' ||
- $self->{OF} eq $self->{UID}) {
- $event = 'joined';
- }
- _call('dispatch', $event);
+sub login {
+ die "STUB";
}
-sub event_PART {
- my ($kernel, $self) = @_[KERNEL,OBJECT,ARG0,ARG1];
- my $event = 'part';
- if (!defined($self->{OF}) ||
- $self->{OF} eq '.' ||
- $self->{OF} eq $self->{UID}) {
- $event = 'parted';
- }
- _call('dispatch', $event);
-}
+=head2 authenticate($Z<>method, @Z<>args)
-my %autorespond = (
- 'PING?' => sub {
- my ($kernel, $self, $who, @junk) = @_[KERNEL,OBJECT,ARG0..$#_];
- if ([EMAIL PROTECTED]) {
- @junk = (''); # This silences a warning elsewhere
- }
- $kernel->yield('pmsg', 'PING', $who, @junk);
- },
- 'TIME?' => sub {
- my ($kernel, $self, $who) = @_[KERNEL,OBJECT,ARG0];
- $kernel->yield('pmsg', 'TIME', $who, format_datetime(time()));
- },
-);
+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.
-sub event_MSG {
- my ($kernel, $self, $type, @text) = @_[KERNEL,OBJECT,ARG0..$#_];
- if ($self->{autorespond}->{$type} && exists $autorespond{$type}) {
- $autorespond{$type}->(@_[0..ARG0-1], @text);
- return if ($self->{supress_auto});
- }
-
- if ($self->{IN}) {
- _call('dispatch', 'msg', $type, @text);
- } else {
- _call('dispatch', 'pmsg', $type, @text);
- }
-
-}
-
-sub event_USERS {
- my ($kernel, $self, @who) = @_[KERNEL,OBJECT,ARG0..$#_];
-
- _call('dispatch_ref', 'users', [EMAIL PROTECTED]);
-}
-
-sub event_BYE {
- my ($kernel, $self, $why) = @_[KERNEL,OBJECT,ARG0];
- _call('dispatch', 'bye', $why);
-}
-
-sub event_QUIT {
- my ($kernel, $self, $who, $why) = @_[KERNEL,OBJECT,ARG0,ARG1];
- _call('dispatch', 'quit', $who, $why);
-}
-
-sub event_CHANS {
- my ($kernel, $self, @channels) = @_[KERNEL,OBJECT,ARG0..$#_];
- _call('dispatch', 'chans', @channels);
-}
-
-sub event_WARN {
- my ($kernel, $err, @args) = @_[KERNEL,ARG0..$#_];
- my $e = new Haver::Formats::Error;
- _call('dispatch', 'warn',
- $err,
- $e->get_short_desc($err),
- $e->format( $e->get_long_desc($err), @args ),
- @args
- );
-}
-
-sub event_DIE {
- my ($kernel, $err, @args) = @_[KERNEL,ARG0..$#_];
- my $e = new Haver::Formats::Error;
- _call('dispatch', 'die',
- $err,
- $e->get_short_desc($err),
- $e->format( $e->get_long_desc($err), @args ),
- @args
- );
-}
-
-sub event_IN {
- my ($kernel, $self, $cid, @cmd) = @_[KERNEL,OBJECT,ARG0..$#_];
- my $save = $self->{IN};
- $self->{IN} = $cid;
- _call('input', [EMAIL PROTECTED]);
- $self->{IN} = $save;
-}
-
-sub event_OF {
- my ($kernel, $self, $uid, @cmd) = @_[KERNEL,OBJECT,ARG0..$#_];
- my $save = $self->{OF};
- $self->{OF} = $uid;
- _call('input', [EMAIL PROTECTED]);
- $self->{OF} = $save;
-}
-
-### CLIENT EVENTS
-
-=head2 login($Z<>pass)
-
-Specify a password to use for the next login. If already logged in, this takes
effect on the next connection
-unless overridden by connect(). If the server is waiting for a login, takes
effect immediately.
-
=cut
-sub login {
- my ($kernel, $self, $pass) = @_[KERNEL,OBJECT,ARG0,ARG1];
- $self->{PASS} = $pass if $pass;
- if ($self->{want} eq 'AUTH:PASS') {
- if (defined $self->{PASS}) {
- $kernel->yield('send', 'AUTH:PASS',
sha1_base64($self->{UID} . $self->{PASS} . $self->{Host}));
- } else {
- $kernel->yield('send', 'CANT', 'AUTH:PASS');
- }
- }
+sub authenticate {
+ die "STUB";
}
=head2 join($Z<>channel)
@@ -597,8 +300,7 @@
=cut
sub join {
- my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0];
- $kernel->yield('send', 'JOIN', $where);
+ die "STUB";
}
=head2 part($Z<>channel)
@@ -608,8 +310,7 @@
=cut
sub part {
- my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0];
- $kernel->yield('send', 'PART', $where);
+ die "STUB";
}
=head2 make($Z<>channel)
@@ -619,8 +320,7 @@
=cut
sub make {
- my ($kernel, $self, $cid) = @_[KERNEL,OBJECT,ARG0];
- $kernel->yield('send', 'MAKE', $cid);
+ die "STUB";
}
=head2 B<msg($Z<>channel, $Z<>type, $Z<>text)>
@@ -630,8 +330,7 @@
=cut
sub msg {
- my ($kernel, $self, $where, $type, $message) =
@_[KERNEL,OBJECT,ARG0..ARG2];
- $kernel->yield('send', 'IN', $where, 'MSG', $type, $message);
+ die "STUB";
}
=head2 B<pmsg($Z<>uid, $Z<>type, $Z<>text)>
@@ -641,8 +340,7 @@
=cut
sub pmsg {
- my ($kernel, $self, $where, $type, $message) =
@_[KERNEL,OBJECT,ARG0..ARG2];
- $kernel->yield('send', 'TO', $where, 'MSG', $type, $message);
+ die "STUB";
}
=head2 users($Z<>channel)
@@ -652,8 +350,7 @@
=cut
sub users {
- my ($kernel, $self, $where) = @_[KERNEL,OBJECT,ARG0];
- $kernel->yield('send', 'IN', $where, 'USERS');
+ die "STUB";
}
=head2 chans(Z<>)
@@ -663,47 +360,9 @@
=cut
sub chans {
- my $kernel = $_[KERNEL];
- $kernel->yield('send', 'CHANS');
+ die "STUB";
}
-### SHUTDOWN
-
-sub force_close {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- return if $self->{closing} == 3;
- if ($self->{closing} == 2 || $self->{flushed}){ # Flushed or flush
timeout
- $kernel->yield('cleanup');
- _call('dispatch', 'disconnected', -1, 'Disconnected');
- $kernel->delay('force_close');
- $self->{closing} = 3;
- return;
- }
- $self->{closing} = 2;
- $kernel->delay('force_close', 5);
-}
-
-sub flushed {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- if (defined $self->{closing} && $self->{closing} == 2) {
- $kernel->yield('force_close');
- }
- $self->{flushed} = 1;
-}
-
-sub cleanup {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- delete $self->{$_} for qw(conn flushed closing UID PASS want messageq
enabled accepted dead);
- $kernel->delay('force_close');
-
- if ($self->{destroy_pending}) {
- $kernel->yield('destroy');
- } elsif (exists $self->{pending_connection}) {
- $kernel->yield('connect', @{$self->{pending_connection}});
- delete $self->{pending_connection};
- }
-}
-
=head2 destroy(Z<>)
Disconnects from the Haver server, and destroys the session. This event may
not complete
@@ -713,14 +372,7 @@
=cut
sub destroy {
- my ($kernel, $self) = @_[KERNEL, OBJECT];
- _dprint 1, "Destroying.\n";
- if (exists $self->{conn}){
- $self->{destroy_pending} = 1;
- $kernel->yield('disconnect');
- return;
- }
- $kernel->alias_remove($self->{alias});
+ die "STUB";
}
sub _default {
@@ -730,22 +382,25 @@
return 0;
}
-
1;
__END__
-=head1 EVENTS
+=head1 MESSAGES
-Event callbacks are called with the frist argument being the event arguments,
-the second argument being the channel set by IN (or undef if not set), and the
-thirs argument being the UID set by OF. Example:
+Message callbacks are called with the first argument being the message
+arguments, and the second argument being a hash reference containing context
+information sent by the server.
sub haver_connect_fail {
- my ($args, $cid, $uid) = @_[ARG0..ARG2];
+ my ($args, $context) = @_[ARG0..ARG2];
my ($enum, $estr) = @$args;
# ...
}
+Context fields are as follows:
+* IN - Indicates the channel set by S: IN
+* ON - Indicated the UID set by S: ON
+
=head2 haver_connected(Z<>)
This event is sent when a connection is established (but before it is logged
in)
@@ -771,18 +426,19 @@
=head2 haver_login_request(Z<>)
-The server is asking for a login, and one was not provided in connect(). The
connection will not proceed until
-login() is sent with the password.
+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.
+=head2 haver_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.
+
=head2 haver_login(Z<>)
The client has successfully logged in.
-=head2 haver_login_fail($Z<>error, $Z<>error_short, $Z<>error_long, $Z<>uid)
-
-Login with UID $uid has failed with error $error. Human-readable short and
long versions, respectively, are
-in $error_short and $error_long.
-
=head2 haver_close($Z<>etyp, $Z<>estr)
Z<XXX: Describe args>
