Author: dylan
Date: 2005-08-06 01:14:10 -0400 (Sat, 06 Aug 2005)
New Revision: 908
Added:
trunk/perl/client/lib/Haver/Client/Failures.pm
Removed:
trunk/perl/client/examples/cmod.pl
Modified:
trunk/
trunk/perl/client/Build.PL
trunk/perl/client/lib/Haver/Client.pm
trunk/perl/core/Build.PL
trunk/perl/core/lib/Haver/Core.pm
trunk/perl/server/Build.PL
trunk/perl/server/MANIFEST.SKIP
trunk/perl/server/lib/Haver/Server.pm
Log:
* Lots of changes relating to the up-coming release;
Build.PL now sets sign => 1 if $ENV{USER} is me.
This is so that when I build the modules for CPAN they'll be signed.
This would need to be changed if someone else takes over pushing stuff up to
the CPAN.
Also lots of doc fixes. One of these is the removal of my middle name from
stuff,
mainly for aestheticreasons.
* Code clean ups. I refactored some of bd_'s failure code into
Haver::Client::Failures (yeek, need a better name).
I also removed underscores from names. Now states begin with either msg_
or on_. The single utility function "_dispatch()" is now dispatch()
and the event __dispatch is now on_dispatch(). Everyone is happy.
Well, I am anyway.
Property changes on: trunk
___________________________________________________________________
Name: svk:merge
- 1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/havercurs-objc:43089
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk:11166
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk-merge-10131:11178
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/winch/trunk:43192
27e50396-46e3-0310-8b22-ae223a1f35ce:/local:212
e9404bb1-7af0-0310-a7ff-e22194cd388b:/haver/local:1349
edfcd8bd-4ce7-0310-a97e-bb1efd40edf3:/local:238
+ 1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/havercurs-objc:43089
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk:11166
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk-merge-10131:11178
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/winch/trunk:43192
27e50396-46e3-0310-8b22-ae223a1f35ce:/local:212
e9404bb1-7af0-0310-a7ff-e22194cd388b:/haver/local:1352
edfcd8bd-4ce7-0310-a97e-bb1efd40edf3:/local:238
Modified: trunk/perl/client/Build.PL
===================================================================
--- trunk/perl/client/Build.PL 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/client/Build.PL 2005-08-06 05:14:10 UTC (rev 908)
@@ -3,17 +3,21 @@
my $build = Module::Build->new(
module_name => 'Haver::Client',
dist_version_from => 'lib/Haver/Client.pm',
- dist_author => 'Bryan Donlan <[EMAIL PROTECTED]>',
+ dist_author => [
+ 'Dylan Hardison <[EMAIL PROTECTED]>',
+ 'Bryan Donlan <[EMAIL PROTECTED]>',
+ ],
license => 'gpl',
requires => {
'perl' => '5.8.0',
'Haver::Core' => 0.08,
'Digest::SHA1' => 2.01,
'Data::Dumper' => 2.121,
-
},
create_makefile_pl => 'passthrough',
script_files => [ glob ('bin/*.pl') ],
+ # XXX: This is a hack, feel free to remove it...
+ ($ENV{USER} eq 'dylan') ? (sign => 1) : (),
);
$build->create_build_script;
Deleted: trunk/perl/client/examples/cmod.pl
===================================================================
--- trunk/perl/client/examples/cmod.pl 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/client/examples/cmod.pl 2005-08-06 05:14:10 UTC (rev 908)
@@ -1,354 +0,0 @@
-#!/usr/bin/perl
-# vim: set ft=perl ts=4 sw=4:
-# cmod.pl - Conspiracy game engine for Haver
-# Rules: http://norinel.aftran.com/stuff/usingcmod.html
-#
-# Copyright (C) 2004 Bryan Donlan, Dylan William Hardison.
-#
-# This module is free software; you can redistribute it and/or modify
-# it under the terms of the GNU General Public License as published by
-# the Free Software Foundation; either version 2 of the License, or
-# (at your option) any later version.
-#
-# This module is distributed in the hope that it will be useful,
-# but WITHOUT ANY WARRANTY; without even the implied warranty of
-# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-# GNU General Public License for more details.
-#
-# You should have received a copy of the GNU General Public License
-# along with this module; if not, write to the Free Software
-# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-
-use strict;
-use warnings;
-use constant {
- STATE_IDLE => 0,
- STATE_REGISTER => 1,
- STATE_MAIN => 2,
- STATE_VOTE => 3,
-};
-
-
-#sub POE::Kernel::ASSERT_DEFAULT { 1 }
-
-use Haver::Config;
-use Haver::OS;
-use POE qw(Component::Client::Haver);
-use Getopt::Mixed;
-use Data::Dumper;
-
-my $conf;
-my $debug = 0;
-my $PACKAGE = __PACKAGE__;
-
-sub _dprint {
- my ($thresh, @stuff) = @_;
- return unless $thresh <= $debug;
- print STDERR @stuff, "\n";
-}
-
-sub _dprintf {
- my ($thresh, $fmt, @stuff) = @_;
- return unless $thresh <= $debug;
- printf STDERR "$fmt\n", @stuff;
-}
-
-sub _msg ($) {
- my $message = $_[0];
- POE::Kernel->post('haver', 'msg', q{"}, $conf->{Channel}, $message);
-}
-
-sub _pmsg ($$) {
- my ($rcpt, $msg) = @_;
- POE::Kernel->post('haver', 'pmsg', q{"}, $rcpt, $msg);
-}
-{
- my $file;
- my ($option, $value);
- $file = Haver::OS->config_find(scope => 'user', name => 'haver-cmod',
type => 'file');
- Getopt::Mixed::init(qw(h c=s d:i));
- while(($option, $value) = Getopt::Mixed::nextOption()) {
- if($option eq 'h') {
- print STDERR "Usage: $0 [-h] [-c file] [-d [level]]\n",
- "A conspiracy moderator bot for Haver\n",
- "\n",
- "-h\tShow this help\n",
- "-c file\tUse configuration file specified
instead of the default.\n",
- "-d [level]\tActivate debugging, default
level is 1\n";
- exit 0;
- } elsif ($option eq 'c') {
- $file = $value;
- } elsif ($option eq 'd') {
- $debug = (defined($value) ? $value : 1);
- }
- }
- Getopt::Mixed::cleanup();
- $conf = new Haver::Config(
- file => $file,
- default => {
- Host => 'hardison.net',
- Port => 7070,
- Channel => 'lobby',
- UID => 'cmod',
- Register_wait => 30,
- Discuss_wait => 600,
- Reconnect_delay => 30,
- }
- ) || die "Can't load configuration file: $!";
- _dprint 1, "Loaded configuration file $file.";
-}
-
-POE::Component::Client::Haver->new('haver');
-POE::Session->create(package_states => [$PACKAGE => [qw{
- _start
- haver_login
- haver_connect_fail
- haver_login_fail
- haver_disconnected
- haver_part
- haver_joined
- haver_msg
- haver_pmsg
- haver_raw_in
- haver_raw_out
- cmd_start
- cmd_register
- cmd_abort
- cmd_hurry
- cmd_snoop
- end_registration
- abort
- start_vote
- finish_vote
- reset
- }]]);
-
-POE::Kernel->run();
-
-sub _start {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- _dprint 1, "Kernel running, doing connect";
- $kernel->post('haver', 'register', 'all');
- $kernel->post('haver', 'connect',
- Host => $conf->{Host},
- Port => $conf->{Port},
- UID => $conf->{UID},
- (defined($conf->{Password}) ? (Password => $conf->{Password}) :
())
- );
- $heap->{state} = STATE_IDLE;
-}
-
-sub haver_login {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- _dprint 1, "Logged in, joining $conf->{Channel}";
- $kernel->post('haver', 'join', $conf->{Channel});
-}
-
-sub haver_connect_fail {
- my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0];
- _dprint 0, "Connect failure, error $args->[1]";
- # XXX: Reconnection logic here
- exit 1;
-}
-
-sub haver_login_fail {
- my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0];
- _dprint 0, "Login failure, error $args->[2]";
- # XXX: Reconnection logic here
- exit 1;
-}
-
-sub haver_disconnected {
- _dprint 0, "Disconnected";
- # XXX: Reconnection logic here
- exit 1;
-}
-
-sub haver_joined {
- _dprint 1, "Joined channel.";
-}
-
-sub haver_part {
- # ...
-}
-
-sub haver_msg {
- my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0];
- my $line = $args->[2];
- _dprint 3, "got msg type $args->[0] line $line source $args->[1]";
- $args->[0] eq q{"} or return;
- $line =~ /^!(\S+)\s*(.*)$/ or return;
- _dprint 3, "got msg type $1 arg $2 source $args->[1]";
- $kernel->yield("cmd_$1", $args->[1], $2);
-}
-
-
-sub haver_raw_in {
- _dprint 3, "S: ", join "\t", @{$_[ARG0]};
-}
-
-sub haver_raw_out {
- _dprint 3, "C: ", join "\t", @{$_[ARG0]};
-}
-
-sub cmd_start {
- my ($kernel, $heap, $who) = @_[KERNEL,HEAP,ARG0];
- if($heap->{state} != STATE_IDLE) {
- $kernel->post("haver", "pmsg", q{"}, $who, "A game is already
running, sorry.");
- }
- _dprint 1, "Game start by $who";
- $heap->{players} = {};
- $kernel->delay(end_registration => $conf->{Register_wait});
- $kernel->post("haver", "msg", q{"}, $conf->{Channel}, "A game of
conspiracy has begun. Type !register within the next $conf->{Register_wait}
seconds to register.");
- $heap->{state} = STATE_REGISTER;
-}
-
-sub end_registration {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- if(keys(%{$heap->{players}}) < 3) {
- $kernel->post("haver", "msg", q{"}, $conf->{Channel}, "Not
enough players.");
- $kernel->yield("abort");
- return;
- }
- _dprint 1, "Game start.";
- $heap->{state} = STATE_MAIN;
- my $conspiracy = int rand 2;
- if($conspiracy) {
- $heap->{innocent} = (keys %{$heap->{players}})[int rand scalar
keys %{$heap->{players}}];
- }
- for(keys %{$heap->{players}}) {
- if($conspiracy && $_ ne $heap->{innocent}) {
- _pmsg($_, "You are a conspirator, and the innocent is
$heap->{innocent}");
- } else {
- _pmsg($_, "You are an innocent in this game");
- }
- }
- _msg("A game of conspiracy has begun! Game ends in
$conf->{Discuss_wait} seconds");
- $kernel->delay(start_vote => $conf->{Discuss_wait});
-}
-
-sub cmd_abort {
- $_[KERNEL]->yield('abort');
-}
-
-sub cmd_register {
- my ($kernel, $heap, $who) = @_[KERNEL,HEAP,ARG0];
- if($heap->{state} == STATE_IDLE) {
- $kernel->post("haver", "msg", q{"}, $conf->{Channel}, "A game
is not running. Type !start to start one.");
- return;
- } elsif ($heap->{state} == STATE_REGISTER) {
- if(exists $heap->{players}->{$who}) {
- $kernel->post("haver", "pmsg", q{"}, $who, "You have
already joined.");
- return;
- }
- $heap->{players}->{$who} = -1;
- $kernel->post("haver", "msg", q{"}, $conf->{Channel}, "$who has
joined the game.");
- } else {
- $kernel->post("haver", "pmsg", q{"}, $who, "A game is already
running, wait until it's finished.");
- }
-}
-
-sub cmd_snoop {
-# ?
-}
-sub cmd_hurry {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- if($heap->{state} == STATE_REGISTER) {
- $kernel->yield('end_registration');
- $kernel->delay('end_registration' => undef);
- }
- if($heap->{state} == STATE_MAIN) {
- $kernel->yield('start_vote');
- $kernel->delay('start_vote' => undef);
- }
-}
-
-sub abort {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- $kernel->delay('start_vote' => undef);
- $kernel->delay('end_registration' => undef);
- $kernel->yield('reset');
- _msg("Game aborted.");
-}
-
-sub start_vote {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- _msg("Pencils down, please. Discussion ends. If you think there's a
conspiracy, private message me with 'yes'. Otherwise, 'no'.");
- _msg("This goes for you conspirators, too.");
- _msg("That is, if there were any.");
- _msg("Which there aren't.");
- _msg("Maybe.");
- $heap->{state} = STATE_VOTE;
- $heap->{tally} = 0;
-}
-
-sub haver_pmsg {
- my ($kernel, $heap, $args) = @_[KERNEL,HEAP,ARG0];
- my ($type, $who, $text) = @$args;
- return unless $type eq q{"};
- return unless $heap->{state} == STATE_VOTE;
- return unless exists $heap->{players}->{$who};
- if($heap->{players}->{$who} != -1) {
- _pmsg($who, "You've already had your say.");
- return;
- }
- $text = lc $text;
- unless($text =~ /^\s*(y|yes|n|no)\s*$/){
- _pmsg($who, "Please use 'yes' or 'no'");
- return;
- }
- if($1 =~ /^y/) {
- $heap->{players}->{$who} = 1;
- } else {
- $heap->{players}->{$who} = 0;
- }
- _pmsg($who, "Okay.");
- $heap->{tally}++;
- _dprint 3, "tally = $heap->{tally}, pcnt=", scalar keys
%{$heap->{players}};
- if($heap->{tally} == scalar keys %{$heap->{players}}) {
- $kernel->yield('finish_vote');
- }
-}
-
-sub finish_vote {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- _msg("All responses received.");
- _dprint 3, Dumper $heap;
-# if(grep { $_ eq 'innocent' } keys %$heap) {
- if($heap->{innocent}) {
- _msg("There was a conspiracy, and the innocent was
$heap->{innocent}.");
- } else {
- _msg("There was no conspiracy.");
- }
- my $fstr = "%-16s|%2s|%-4s";
- my $header = sprintf $fstr, "UID", "R", "WIN";
- my $sep = '-'x(length $header);
- _msg($header);
- _msg($sep);
- my $iv = $heap->{innocent} && $heap->{players}->{$heap->{innocent}};
- for(keys %{$heap->{players}}) {
- my $win;
- if(!$heap->{innocent}) {
- $win = !$heap->{players}->{$_};
- } else {
- if($_ eq $heap->{innocent}) {
- $win = $iv;
- } else {
- $win = !$iv;
- }
- }
- my $line = sprintf $fstr, $_,
- ($heap->{players}->{$_} ? 'Y' : 'N'),
- ($win ? 'Y' : 'N');
- _msg($line);
- }
- _msg($sep);
- _msg('Thanks for playing!');
- $kernel->yield('reset');
-}
-
-sub reset {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- %$heap = ( state => STATE_IDLE );
-}
-
Added: trunk/perl/client/lib/Haver/Client/Failures.pm
===================================================================
--- trunk/perl/client/lib/Haver/Client/Failures.pm 2005-08-02 19:24:49 UTC
(rev 907)
+++ trunk/perl/client/lib/Haver/Client/Failures.pm 2005-08-06 05:14:10 UTC
(rev 908)
@@ -0,0 +1,108 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Client::Failures;
+use strict;
+use warnings;
+
+use Haver::Base -base;
+
+our $VERSION = 0.08;
+
+field messages => {
+ '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 add_message {
+ my ($self, $code, $msg) = @_;
+ $self->{messages}{$code} = $msg;
+}
+
+sub format {
+ my ($self, @args) = @_;
+ my $code = $args[0];
+
+ unless (exists $self->{messages}{$code}) {
+ return "Unknown error: " . join(' ', @args);
+ }
+
+ my $msg = $Failures{$code};
+ $msg =~ s/%(\d+)/$args[$1] || "[MISSING ARGUMENT $1]"/eg;
+ return $msg;
+}
+
+
+
+1;
+__END__
+=head1 NAME
+
+Haver::Client::Failures - description
+
+=head1 SYNOPSIS
+
+ use Haver::Client::Failures;
+ my $failures = new Haver::Client::Failures;
+ my $desc = $failures->format('IDENT', 'invalid.name', '^fooo^');
+
+ $desc eq "The server rejected the name ^fooo^."; # True
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 INHERITENCE
+
+Haver::Client::Failures extends blaa blaa blaa
+
+=head1 CONSTRUCTOR
+
+List required parameters for new().
+
+=head1 METHODS
+
+This class implements the following methods:
+
+=head2 method1(Z<>)
+
+...
+
+=head1 BUGS
+
+None known. Bug reports are welcome. Please use our bug tracker at
+L<http://gna.org/bugs/?func=additem&group=haver>.
+
+=head1 AUTHOR
+
+Dylan William Hardison, E<lt>[EMAIL PROTECTED]<gt>
+
+=head1 SEE ALSO
+
+L<http://www.haverdev.org/>.
+
+=head1 COPYRIGHT and LICENSE
+
+Copyright (C) 2005 by Dylan William Hardison. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this module; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
Modified: trunk/perl/client/lib/Haver/Client.pm
===================================================================
--- trunk/perl/client/lib/Haver/Client.pm 2005-08-02 19:24:49 UTC (rev
907)
+++ trunk/perl/client/lib/Haver/Client.pm 2005-08-06 05:14:10 UTC (rev
908)
@@ -1,7 +1,7 @@
# vim: set ft=perl ts=4 sw=4:
-# Haver::Client::POE - POE component haver client.
+# Haver::Client - A POE::Component for haver clients.
#
-# Copyright (C) 2004, 2005 Bryan Donlan, Dylan William Hardison.
+# Copyright (C) 2004, 2005 Bryan Donlan, Dylan Hardison.
#
# This module is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -17,6 +17,7 @@
# along with this module; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+# XXX Is this accurate? Does it even belong here? XXX
# heap fields:
# heap => {
# version => client version
@@ -32,10 +33,13 @@
package Haver::Client;
use strict;
use warnings;
-use Data::Dumper;
+
use Haver::Session -base;
+use POE;
+use POE::Wheel::ReadWrite;
+use POE::Wheel::SocketFactory;
+use Haver::Protocol::Filter;
-
use constant {
S_IDLE => 0, # not connected, not connecting
S_CONN => 1, # establishing socket connection
@@ -45,79 +49,46 @@
S_DYING => 5, # C: BYE sent, socket still open
};
-use POE qw(Wheel::ReadWrite
- Wheel::SocketFactory);
-
-use Haver::Protocol::Filter;
-
our $VERSION = 0.08;
-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;
- (undef, @args) = @_;
- 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 dispatch {
+ call('dispatch', @_);
}
-sub _dispatch {
- _call('__dispatch', @_);
-}
-
-sub _dprint {
- my ($level, @text) = @_;
- 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()->{debug} >=
$level;
- printf STDERR $fmt, @text;
-}
-
### SETUP
sub states {
- [qw{
- _start _default
- connect _conn_fail
- _conn_ok _input disconnect
- send_raw send join part
- public private
- list destroy
- _ev_HAVER _ev_HELLO
- _ev_JOIN _ev_PART
- _ev_IN _ev_FROM
- _ev_PING _ev_BYE
- _ev_FAIL __dispatch
- register unregister
- _cleanup _err
- _force_down _dns_resp
- _do_connect
- }]
+ local *prefix = sub {
+ my $prefix = shift;
+ map { ($_ => $prefix . $_) } @_;
+ };
+
+
+ return {
+ prefix('on_', qw(
+ _start _default _stop
+ connect connect_fail
+ connect_ok disconnect
+ input send_raw send
+ join part public private
+ list destroy
+ dispatch
+ register unregister
+ cleanup error
+ force_down dns_response
+ do_connect
+ )),
+ map { ("msg_$_", "msg_$_") } qw(
+ HAVER HELLO
+ JOIN PART
+ IN FROM
+ PING BYE
+ FAIL
+ )
+ };
}
-sub _start {
+sub on__start {
my ($kernel, $heap, $opt) = @_[KERNEL, HEAP, ARG0];
croak "No alias" unless $opt->{alias};
$heap->{reg} = {};
@@ -129,9 +100,17 @@
$kernel->alias_set($opt->{alias});
}
+sub on__default {
+ my ( $kernel, $state, $event, $args, $self ) = @_[ KERNEL, STATE, ARG0,
ARG1, OBJECT ];
+ $args ||= []; # Prevents uninitialized-value warnings.
+ return 0;
+}
+
+sub on__stop { }
+
### SESSION MANAGEMENT
-sub connect {
+sub on_connect {
my ($kernel, $heap, %opts) = @_[KERNEL,HEAP,ARG0..$#_];
$opts{port} ||= 7575;
@@ -147,32 +126,32 @@
$heap->{name} = $opts{name};
$heap->{port} = $opts{port};
if (!$heap->{resolver}) {
- call('_do_connect', $opts{host});
+ call('do_connect', $opts{host});
} else {
my $resp = $heap->{resolver}->resolve(
host => $opts{host},
context => {},
- event => '_dns_resp',
+ event => 'dns_response',
);
if ($resp) {
- call('_dns_resp', $resp);
+ call('dns_response', $resp);
}
}
}
}
-sub _do_connect {
+sub on_do_connect {
my ($heap, $addr) = @_[HEAP,ARG0];
my $port = delete $heap->{port};
if ($heap->{state} == S_DYING) {
- call('_cleanup');
+ call('cleanup');
return;
}
$heap->{wheel} = POE::Wheel::SocketFactory->new(
RemoteAddress => $addr,
RemotePort => $port,
- SuccessEvent => '_conn_ok',
- FailureEvent => '_conn_fail',
+ SuccessEvent => 'connect_ok',
+ FailureEvent => 'connect_fail',
);
}
@@ -189,7 +168,7 @@
}
}
-sub _dns_resp {
+sub on_dns_response {
my ($heap, $packet) = @_[HEAP,ARG0];
if ($packet->{response}) {
my $resp = $packet->{response};
@@ -197,74 +176,75 @@
foreach my $record (@answer) {
if ($record->type eq 'A') {
# XXX: ipv6 support
- $poe_kernel->yield('_do_connect', $record->address);
+ $poe_kernel->yield('do_connect', $record->address);
return;
}
}
# dns fail
- _dispatch('connect_fail', 'dns');
- call('_cleanup');
+ dispatch('connect_fail', 'dns');
+ call('cleanup');
} else {
- _dispatch('connect_fail', 'dns', $packet->{error});
+ dispatch('connect_fail', 'dns', $packet->{error});
}
}
-sub _conn_fail {
+sub on_connect_fail {
my $heap = $_[HEAP];
- _dispatch('connect_fail', @_[ARG0..ARG2]);
- call('_cleanup');
+ dispatch('connect_fail', @_[ARG0..ARG2]);
+ call('cleanup');
}
-sub _conn_ok {
+sub on_connect_ok {
my ($kernel, $heap, $sock) = @_[KERNEL,HEAP,ARG0];
if ($heap->{state} == S_DYING) {
- call('_cleanup');
+ call('cleanup');
return;
}
- _dispatch('connected');
+ dispatch('connected');
$heap->{state} = S_INIT;
$heap->{wheel} = new POE::Wheel::ReadWrite(
Handle => $sock,
Filter => new Haver::Protocol::Filter,
- InputEvent => '_input',
- ErrorEvent => '_err',
+ InputEvent => 'input',
+ ErrorEvent => 'error',
);
$heap->{wheel}->put( ['HAVER', $heap->{version}] );
# XXX: timeout
}
-sub _input {
+sub on_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);
+ dispatch('raw_in', @$arg);
my $cmd = $arg->[0];
- $kernel->yield("_ev_$cmd", @$arg);
+ $cmd =~ tr/:/_/;
+ $kernel->yield("msg_$cmd", @$arg);
}
-sub _err {
- _dispatch('disconnected', @_[ARG0..ARG2]);
- call('_cleanup');
+sub on_error {
+ dispatch('disconnected', @_[ARG0..ARG2]);
+ call('cleanup');
}
-sub disconnect {
+sub on_disconnect {
my $heap = $_[HEAP];
call('send_raw', 'BYE');
$heap->{state} = S_DYING;
- $poe_kernel->delay('_force_down', 5);
+ $poe_kernel->delay('force_down', 5);
}
-sub _force_down {
+sub on_force_down {
my $heap = $_[HEAP];
$heap->{state} = S_IDLE;
- call('_cleanup');
+ call('cleanup');
}
-sub _cleanup {
+sub on_cleanup {
my $heap = $_[HEAP];
- $poe_kernel->delay('_force_down');
+ $poe_kernel->delay('force_down');
if ($heap->{pending}) {
my @opts = %{delete $heap->{pending}};
$poe_kernel->yield('connect', @opts);
@@ -274,7 +254,7 @@
$heap->{state} = S_IDLE;
}
-sub send_raw {
+sub on_send_raw {
my ($heap, @args) = @_[HEAP,ARG0..$#_];
if ($heap->{state} == S_IDLE || $heap->{state} == S_CONN ||
$heap->{state} == S_DYING) {
@@ -284,40 +264,40 @@
$heap->{wheel}->put([EMAIL PROTECTED]);
}
-sub send {
+sub on_send {
my ($kernel, @args) = @_[KERNEL,ARG0..$#_];
call('send_raw', @args);
}
-sub join {
+sub on_join {
my $channel = $_[ARG0];
call('send', 'JOIN', $channel);
}
-sub part {
+sub on_part {
my $channel = $_[ARG0];
call('send', 'PART', $channel);
}
-sub public {
+sub on_public {
my ($kernel, $heap, $c, $t, @a) = @_[KERNEL,HEAP,ARG0..$#_];
call('send', 'IN', $c, $t, @a);
}
-sub private {
+sub on_private {
my ($kernel, $heap, $d, $t, @a) = @_[KERNEL,HEAP,ARG0..$#_];
call('send', 'TO', $d, $t, @a);
}
-sub list {
+sub on_list {
my ($chan, $type) = @_[ARG0, ARG1];
$type = defined $type ? $type : 'user';
call('send', 'LIST', $chan, $type);
}
-sub destroy {
+sub on_destroy {
my ($kernel, $heap) = @_[KERNEL,HEAP];
- _dispatch('destroyed');
+ dispatch('destroyed');
delete $heap->{pending};
my $reg = $heap->{reg};
foreach my $ehash (values %$reg) {
@@ -332,7 +312,7 @@
## server-response stuff
-sub _ev_HAVER {
+sub msg_HAVER {
my ($kernel, $heap) = @_[KERNEL,HEAP];
return if ($heap->{state} != S_INIT); # should never happen, unless the
# server is non-compliant
@@ -340,87 +320,83 @@
$heap->{state} = S_LOGIN;
}
-sub _ev_HELLO {
+sub msg_HELLO {
my $heap = $_[HEAP];
$heap->{state} = S_ONLINE;
- _dispatch('ready');
+ dispatch('ready');
}
-sub _ev_JOIN {
+sub msg_JOIN {
my ($heap, $chan, $name) = @_[HEAP,ARG1,ARG2];
if ($name eq $heap->{name}) {
- _dispatch('ijoined', $chan);
+ dispatch('ijoined', $chan);
} else {
- _dispatch('join', $chan, $name);
+ dispatch('join', $chan, $name);
}
}
-sub _ev_PART {
+sub msg_PART {
my ($heap, $chan, $name) = @_[HEAP,ARG1,ARG2];
if ($name eq $heap->{name}) {
- _dispatch('iparted', $chan);
+ dispatch('iparted', $chan);
} else {
- _dispatch('part', $chan, $name);
+ dispatch('part', $chan, $name);
}
}
-sub _ev_LIST {
+sub msg_LIST {
my ($heap, $chan, $ns, @things) = @_[HEAP,ARG1..$#_];
return unless defined $ns;
- _dispatch('list', $chan, $ns, @things);
+ dispatch('list', $chan, $ns, @things);
}
-sub _ev_IN {
- _dispatch('public', @_[ARG1..$#_]);
+sub msg_IN {
+ dispatch('public', @_[ARG1..$#_]);
}
-sub _ev_FROM {
- _dispatch('private', @_[ARG1..$#_]);
+sub msg_FROM {
+ dispatch('private', @_[ARG1..$#_]);
}
-sub _ev_PING {
+sub msg_PING {
call('send_raw', 'PONG', @_[ARG1..$#_]);
}
-sub _ev_BYE {
+sub msg_BYE {
my ($type, $detail) = @_[ARG2,ARG3];
- _dispatch('bye', $detail);
- call('_cleanup');
+ dispatch('bye', $detail);
+ call('cleanup');
}
-sub _ev_FAIL {
- my $msg = _format(@_[ARG0..$#_]);
- _dispatch('fail', $msg, @_[ARG0..$#_]);
- my $code = $_[ARG1];
+sub msg_FAIL {
+ my ($kernel, $heap, $cmd, $code, @args) = @_[KERNEL, HEAP, ARG0 .. $#_];
+
+ dispatch('fail', $cmd, $code, [EMAIL PROTECTED]);
$code =~ tr/./_/;
- _dispatch("fail_$code", $msg, @_[ARG0..$#_]);
+ dispatch("fail_$code", $cmd, [EMAIL PROTECTED]);
}
-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 register {
- my ($kernel, $heap, $session, @events) =
@_[KERNEL,HEAP,SENDER,ARG0..$#_];
+sub on_register {
+ my ($kernel, $heap, $sender, @events) =
@_[KERNEL,HEAP,SENDER,ARG0..$#_];
my $reg = $heap->{reg};
- my $id = $session->ID;
+ my $id = $sender->ID;
+
foreach my $event (@events) {
$event = uc $event;
next if exists $reg->{$event}{$id};
- # XXX: Do refcount tags need to be unique?
- my $tag = '1' . $reg->{$event} . '\0' . $id . '\0' . rand;
+ # Tags don't need to be anything special...
+ #my $tag = '1' . $reg->{$event} . '\0' . $id . '\0' . rand;
+ my $tag = __PACKAGE__;
$reg->{$event}{$id} = $tag;
$kernel->refcount_increment( $id, $tag );
}
}
-sub unregister {
- my ($kernel, $heap, $session, @events) =
@_[KERNEL,HEAP,SENDER,ARG0..$#_];
+sub on_unregister {
+ my ($kernel, $heap, $sender, @events) = @_[KERNEL, HEAP, SENDER,
ARG0..$#_];
my $reg = $heap->{reg};
- my $id = $session->ID;
+ my $id = $sender->ID;
+
foreach my $event (@events) {
$event = uc $event;
my $tag;
@@ -430,7 +406,7 @@
}
-sub __dispatch {
+sub on_dispatch {
my ($kernel, $heap, $evname, @args) = @_[KERNEL,HEAP,ARG0..$#_];
$evname = uc $evname;
my $reg = $heap->{reg};
@@ -472,7 +448,8 @@
=head1 DESCRIPTION
-FIXME
+This module eases the creation of Haver clients. It provides a POE::Component
in the style of
+L<POE::Component::IRC>, with some improvements.
=head1 METHODS
@@ -513,7 +490,7 @@
=head1 AUTHOR
Bryan Donlan E<lt>[EMAIL PROTECTED]<gt>,
-Dylan William Hardison E<lt>[EMAIL PROTECTED]<gt>.
+Dylan Hardison E<lt>[EMAIL PROTECTED]<gt>.
=head1 SEE ALSO
@@ -521,7 +498,7 @@
=head1 COPYRIGHT and LICENSE
-Copyright (C) 2004, 2005 by Bryan Donlan, Dylan William Hardison. All Rights
Reserved.
+Copyright (C) 2004, 2005 by Bryan Donlan, Dylan Hardison. All Rights Reserved.
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
Modified: trunk/perl/core/Build.PL
===================================================================
--- trunk/perl/core/Build.PL 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/core/Build.PL 2005-08-06 05:14:10 UTC (rev 908)
@@ -2,20 +2,23 @@
use Module::Build;
my $build = Module::Build->new(
module_name => 'Haver::Core',
- dist_version_from => 'lib/Haver/Core.pm',
dist_author => 'Dylan William Hardison <[EMAIL PROTECTED]>',
license => 'gpl',
requires => {
'perl' => '5.6.1',
YAML => '0.35',
'Filter::Simple' => 0,
+ Spiffy => 0.21,
+ POE => 0.29,
},
suggests => {
- 'Haver::Server' => 0.06,
- 'Haver::Client' => 0.06,
- 'POE' => 0.28,
+ 'Haver::Server' => 0.08,
+ 'Haver::Client' => 0.08,
+ 'POE' => 0.30,
},
create_makefile_pl => 'passthrough',
+ # XXX: This is a hack, feel free to remove it...
+ ($ENV{USER} eq 'dylan') ? (sign => 1) : (),
);
Modified: trunk/perl/core/lib/Haver/Core.pm
===================================================================
--- trunk/perl/core/lib/Haver/Core.pm 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/core/lib/Haver/Core.pm 2005-08-06 05:14:10 UTC (rev 908)
@@ -1,6 +1,73 @@
# vim: set ts=4 sw=4 si ai sta tw=100:
-# This module is copyrighted, see end of file for details.
+# Haver::Core - Modules used by both Haver::Client and Haver::Server.
+#
+# Copyright (C) 2005 Dylan Hardison.
+#
+# This module is free software; you can redistribute it and/or modify
+# it under the terms of the GNU General Public License as published by
+# the Free Software Foundation; either version 2 of the License, or
+# (at your option) any later version.
+#
+# This module is distributed in the hope that it will be useful,
+# but WITHOUT ANY WARRANTY; without even the implied warranty of
+# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+# GNU General Public License for more details.
+#
+# You should have received a copy of the GNU General Public License
+# along with this module; if not, write to the Free Software
+# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
package Haver::Core;
our $VERSION = 0.08;
+1;
+__END__
+
+=head1 NAME
+
+Haver::Core - Modules used by both Haver::Client and Haver::Server.
+
+=head1 SYNOPSIS
+
+ # This module doesn't really do anything.
+ # It is just a place holder for documentation...
+
+=head1 DESCRIPTION
+
+The Haver-Core CPAN distribution contains several modules used by both
L<Haver::Client>
+and L<Haver::Server>. They are listed in the L</SEE ALSO> section below.
+
+=head1 BUGS
+
+None known. Bug reports are welcome. Please use our bug tracker at
+L<http://gna.org/bugs/?func=additem&group=haver>.
+
+=head1 AUTHOR
+
+Dylan Hardison E<lt>[EMAIL PROTECTED]<gt>.
+
+=head1 SEE ALSO
+
+L<Haver::Base>, L<Haver::Session>, L<Haver::Wheel>, L<Haver::Config>,
+L<Haver::Protocol>, L<Haver::Protocol::Filter>, L<Haver::Logger>.
+
+L<http://www.haverdev.org/>.
+
+=head1 COPYRIGHT and LICENSE
+
+Copyright (C) 2005 by Dylan Hardison. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this module; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
Modified: trunk/perl/server/Build.PL
===================================================================
--- trunk/perl/server/Build.PL 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/server/Build.PL 2005-08-06 05:14:10 UTC (rev 908)
@@ -3,18 +3,17 @@
use Module::Build;
my $build = Module::Build->new(
module_name => 'Haver::Server',
- dist_version_from => 'lib/Haver/Server.pm',
- dist_author => 'Dylan William Hardison <[EMAIL PROTECTED]>',
- dist_abstract => 'POE-based simple chat server',
+ dist_author => 'Dylan Hardison <[EMAIL PROTECTED]>',
license => 'gpl',
requires => {
'perl' => '5.8.0',
POE => 0.27,
'Digest::SHA1' => 2.01,
- Spiffy => 0.21,
'Haver::Core' => 0.08,
},
create_makefile_pl => 'passthrough',
script_files => [glob('bin/*.pl')],
+ # XXX: This is a hack, feel free to remove it...
+ ($ENV{USER} eq 'dylan') ? (sign => 1) : (),
);
$build->create_build_script();
Modified: trunk/perl/server/MANIFEST.SKIP
===================================================================
--- trunk/perl/server/MANIFEST.SKIP 2005-08-02 19:24:49 UTC (rev 907)
+++ trunk/perl/server/MANIFEST.SKIP 2005-08-06 05:14:10 UTC (rev 908)
@@ -11,3 +11,4 @@
^conf
.*-stamp
^debian/files
+^debian/lib
Modified: trunk/perl/server/lib/Haver/Server.pm
===================================================================
--- trunk/perl/server/lib/Haver/Server.pm 2005-08-02 19:24:49 UTC (rev
907)
+++ trunk/perl/server/lib/Haver/Server.pm 2005-08-06 05:14:10 UTC (rev
908)
@@ -1,7 +1,7 @@
# vim: set ft=perl ts=4 sw=4:
# Haver::Server - description
#
-# Copyright (C) 2004 Dylan William Hardison.
+# Copyright (C) 2005 Dylan Hardison.
#
# This module is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
@@ -63,6 +63,7 @@
# Add &lobby to the Store if not already there.
unless ($store->exists('lobby', '&lobby')) {
+ Log('debug', 'Initializing &lobby');
my $lobby = new Haver::Server::Entity::Lobby;
$store->insert($lobby);
}
@@ -107,3 +108,84 @@
}
1;
+
+__END__
+
+=head1 NAME
+
+Haver::Server - Reference implementation of the Haver chat server.
+
+=head1 SYNOPSIS
+
+ use Haver::Server;
+ create Haver::Server (
+ config => 'haverd.yml',
+ )
+ POE::Kernel->run;
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 METHODS
+
+There is only one method, create(), which is a class method.
+
+=head2 create(alias => $alias, resolver => $resolver, version => $version)
+
+This creates a new Haver::Client session. The only required parameter
+is $alias, which is how you'll talk to the client session using
L<POE::Kernel>'s post().
+
+If given, $resolver should be a L<POE::Component::Client::DNS> object.
+
+Finally, $version is what we will advertize as the client name and version
number to the
+server. It defaults to C<Haver::Client/0.08>.
+
+=head1 STATES
+
+While these are listed just like methods, you must post() to them, and not
call them
+directly.
+
+=head2 connect(host => $host, name => $name, [ port => 7575 ])
+
+Connect to $host on port $port (defaults to 7575) with the user name $name.
+If already connected to a server, Haver::Client will disconnect and re-connect
using the
+new settings.
+
+=head2 register(@events)
+
+This summons the sun god Ra and makes him eat your liver.
+
+FIXME: This is inaccurate.
+
+=head1 BUGS
+
+None known. Bug reports are welcome. Please use our bug tracker at
+L<http://gna.org/bugs/?func=additem&group=haver>.
+
+=head1 AUTHOR
+
+Dylan Hardison E<lt>[EMAIL PROTECTED]<gt>.
+
+=head1 SEE ALSO
+
+L<http://www.haverdev.org/>.
+
+=head1 COPYRIGHT and LICENSE
+
+Copyright (C) 2005 by Dylan Hardison. All Rights Reserved.
+
+This module is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This module is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this module; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+
