Author: dylan
Date: 2004-06-27 22:37:38 -0400 (Sun, 27 Jun 2004)
New Revision: 264
Added:
trunk/main/server/lib/Haver/Server/Object/POE.pm
trunk/main/server/lib/Haver/Server/POE/Broadcaster.pm
Modified:
trunk/main/server/bin/haverd.pl
trunk/main/server/lib/Haver/Server/Object.pm
trunk/main/server/lib/Haver/Server/Object/Channel.pm
trunk/main/server/lib/Haver/Server/Object/Index.pm
trunk/main/server/lib/Haver/Server/Object/User.pm
trunk/main/server/lib/Haver/Server/POE.pm
trunk/main/server/lib/Haver/Server/POE/Commands.pm
trunk/main/server/lib/Haver/Server/POE/Connection.pm
trunk/main/server/lib/Haver/Server/POE/Listener.pm
trunk/main/server/lib/Haver/Server/Registry.pm
Log:
Oy vey. I've re-written the server to be a bit
cleaner. it is still a mess, though.
haverd.pl should work, though.
Modified: trunk/main/server/bin/haverd.pl
===================================================================
--- trunk/main/server/bin/haverd.pl 2004-06-27 20:57:14 UTC (rev 263)
+++ trunk/main/server/bin/haverd.pl 2004-06-28 02:37:38 UTC (rev 264)
@@ -18,19 +18,9 @@
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
use strict;
use warnings;
-use Haver::Preprocessor qw( :verbose :assert :dump :debug );
+use Haver::Preprocessor qw( -verbose -assert -debug );
use Haver::Server::POE;
-use Getopt::Long;
-my $confdir = './conf';
-my $datadir = './data';
-GetOptions (
- "confdir=s" => \$confdir,
- "datadir=s" => \$datadir,
-);
+Haver::Server::POE->boot('config.yml');
-
-Haver::Server::POE->boot(
- confdir => $confdir,
- datadir => $datadir,
-);
+POE::Kernel->run;
Modified: trunk/main/server/lib/Haver/Server/Object/Channel.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object/Channel.pm 2004-06-27
20:57:14 UTC (rev 263)
+++ trunk/main/server/lib/Haver/Server/Object/Channel.pm 2004-06-28
02:37:38 UTC (rev 264)
@@ -21,9 +21,9 @@
use Haver::Server::Object;
use Haver::Server::Object::Index;
-use base qw( Haver::Server::Object Haver::Server::Object::Index );
+use base qw( Haver::Server::Object );
-our $VERSION = '0.05';
+our $VERSION = 0.09;
sub namespace {
return 'channel';
@@ -35,12 +35,5 @@
!$obj->isa(__PACKAGE__);
}
-sub send {
- my $me = shift;
- foreach my $user ($me->list_vals('user')) {
- $user->send(@_);
- }
-}
-
1;
Modified: trunk/main/server/lib/Haver/Server/Object/Index.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object/Index.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/Object/Index.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -23,99 +23,11 @@
our $VERSION = 0.05;
our $RELOAD = 1;
-our $IdPattern ||= qr/[a-z][a-z0-9_'.-]+/;
+
sub namespace {
return 'container';
}
-sub has_namespace {
- my ($me, $ns) = @_;
- return exists $me->{".$ns"};
-}
-sub is_valid_id {
- my ($this, $uid) = @_;
-
- if (defined $uid && $uid =~ /^$IdPattern$/) {
- return 1;
- } else {
- return 0;
- }
-}
-
-sub namespaces {
- my ($me) = @_;
- my @ns = ();
-
- @ns = grep(s/^\.//, keys %{ $me });
-
- return wantarray ? @ns : [EMAIL PROTECTED];
-}
-
-sub add {
- my ($me, $object) = @_;
- my $id = $object->id;
- my $ns = $object->namespace;
-
- if (not($me->contains($ns, $id)) && $me->can_contain($object)) {
- $me->{".$ns"}{$id} = $object;
- $me->{".$ns"}{$id}
- } else {
- return undef;
- }
-}
-
-sub fetch {
- my ($me, $ns, $id) = @_;
- if (@_ != 3) {
- croak "fetch must be called with exactly three arguments!";
- }
-
- return $me->{".$ns"}{$id} if $me->contains($ns, $id);
-}
-
-sub contains {
- my ($me, $ns, $id) = @_;
- if (@_ != 3) {
- croak "contains must be called with exactly three arguments!";
- }
-
- delete $me->{".$ns"}{$id} unless defined $me->{".$ns"}{$id};
- return exists $me->{".$ns"}{$id};
-}
-
-sub remove {
- my $me = shift;
- my ($ns, $id);
-
- if (@_ == 1 && ref $_[0]) {
- my $o = $_[0];
- $ns = $o->namespace;
- $id = $o->id;
- } elsif (@_ == 2) {
- ($ns, $id) = @_;
- } else {
- die "Wrong number of arguments.";
- }
- delete $me->{".$ns"}{$id};
-}
-
-sub list_ids {
- my ($me, $ns) = @_;
- my $h = $me->{".$ns"};
-
- wantarray ? keys %$h : [ keys %$h ];
-}
-sub list_vals {
- my ($me, $ns) = @_;
- my $h = $me->{".$ns"};
-
- wantarray ? values %$h : [ values %$h ];
-}
-sub can_contain {
- # Can contain anything, really.
- 1;
-}
-
1;
Added: trunk/main/server/lib/Haver/Server/Object/POE.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object/POE.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/Object/POE.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -0,0 +1,53 @@
+# vim: set ft=perl ts=4 sw=4:
+# Haver::Server::Object::POE - Add poe methods to Haver::Server::Objects
+#
+# Copyright (C) 2004 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
+package Haver::Server::Object;
+use strict;
+use warnings;
+
+use POE;
+
+our $VERSION = 0.01;
+
+sub wheel : lvalue {
+ my ($me) = @_;
+
+ $me->{wheel};
+}
+
+sub sid : lvalue {
+ my ($me) = @_;
+
+ $me->{sid};
+}
+
+sub put {
+ my ($me, $msg) = @_;
+
+ $me->{wheel}->put($msg);
+}
+
+sub post {
+ my $me = shift;
+
+ $poe_kernel->post($me->{sid}, @_);
+}
+
+
+1;
+
Modified: trunk/main/server/lib/Haver/Server/Object/User.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object/User.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/Object/User.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -23,8 +23,7 @@
use Haver::Preprocessor;
use Haver::Server::Object;
use Haver::Server::Object::Index;
-use Haver::Server::Globals qw( $Config );
-use base qw( Haver::Server::Object Haver::Server::Object::Index );
+use base qw( Haver::Server::Object );
our $VERSION = 0.05;
Modified: trunk/main/server/lib/Haver/Server/Object.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Object.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/Object.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -18,17 +18,16 @@
package Haver::Server::Object;
use strict;
use warnings;
+use Haver::Preprocessor;
use Carp;
use Fatal qw(:void open close opendir closedir);
use Haver::Base;
-use Haver::Preprocessor;
-
-use YAML (); # Load, Dump
+use Storable (); # nstore, retrieve.
use File::Basename (); # fileparse
use File::Spec;
-use Scalar::Util (); # weaken
use File::Path ();
+
# Subclass Haver::Savable
use base 'Haver::Savable';
@@ -57,6 +56,9 @@
attrib => 'pl',
);
+
+our $IdPattern ||= qr/[a-z][a-z0-9_'.-]+/;
+
our %Types = (
# '' => 'public',
'+' => 'broadcast',
@@ -92,9 +94,15 @@
$me->SUPER::initialize();
- $me->{_fields} = {};
- $me->{_flags} = {};
+ $me->{_fields} = {};
+ $me->{_flags} = {};
$me->{id} ||= $ID++;
+
+ my @ns = @{ (delete $me->{namespaces}) || [] };
+
+ foreach my $ns (@ns) {
+ $me->{".$ns"} = {};
+ }
return $me;
}
@@ -102,13 +110,9 @@
## Accessor methods.
sub id {
- my ($me, $val) = @_;
+ my ($me) = @_;
- if (@_ == 2) {
- return $me->{id} = $val;
- } else {
- return $me->{id};
- }
+ return $me->{id};
}
sub filename {
@@ -118,11 +122,21 @@
sub directory {
my ($me) = @_;
- my ($vol, $dir) = File::Spec->splitpath($me->filename);
- return $vol.$dir;
+ return File::Spec->catdir($StorageDir, $me->namespace);
}
+
+sub saved_ids {
+ my ($me) = @_;
+ my $dir = $me->directory;
+ my $dh;
+ opendir $dh, $dir or return ();
+ my @dirs = readdir $dh;
+ closedir $dh;
+ return wantarray ? @dirs : [EMAIL PROTECTED];
+}
+
## Flag methods
sub get_flags {
my ($me, $key) = @_;
@@ -238,6 +252,16 @@
return \%data;
}
+sub _init_data {
+ my ($me) = @_;
+
+ $me->{_fields} = (delete $me->{'-default'}{fields}) || {};
+ $me->{_flags} = (delete $me->{'-default'}{flags}) || {};
+ delete $me->{'-default'};
+
+ 1;
+}
+
sub _load_data {
my ($me, $data) = @_;
@@ -247,8 +271,8 @@
ASSERT: $data->{Class} eq ref($me);
use warnings;
- $me->{_fields} = delete $data->{fields};
- $me->{_flags} = delete $data->{flags};
+ %{$me->{_fields}} = (%{$me->{_fields}}, %{delete $data->{fields}});
+ %{$me->{_flags}} = (%{$me->{_flags}}, %{delete $data->{flags}});
1;
}
@@ -266,6 +290,113 @@
return $me->namespace . '/' . $me->id;
}
+
+sub write_file {
+ my ($me, $file, $data) = @_;
+ Storable::nstore($data, $file);
+}
+
+sub read_file {
+ my ($me, $file) = @_;
+ Storable::retrieve($file);
+}
+
+
+
+
+sub has_namespace {
+ my ($me, $ns) = @_;
+ return exists $me->{".$ns"};
+}
+
+sub is_valid_id {
+ my ($this, $uid) = @_;
+
+ if (defined $uid && $uid =~ /^$IdPattern$/) {
+ return 1;
+ } else {
+ return 0;
+ }
+}
+
+sub namespaces {
+ my ($me) = @_;
+ my @ns = ();
+
+ @ns = grep(s/^\.//, keys %{ $me });
+
+ return wantarray ? @ns : [EMAIL PROTECTED];
+}
+
+sub add {
+ my ($me, $object) = @_;
+ my $id = $object->id;
+ my $ns = $object->namespace;
+
+ if (not($me->contains($ns, $id)) && $me->can_contain($object)) {
+ $me->{".$ns"}{$id} = $object;
+ $me->{".$ns"}{$id}
+ } else {
+ return undef;
+ }
+}
+
+sub fetch {
+ my ($me, $ns, $id) = @_;
+ if (@_ != 3) {
+ croak "fetch must be called with exactly three arguments!";
+ }
+
+ return $me->{".$ns"}{$id} if $me->contains($ns, $id);
+}
+
+sub contains {
+ my ($me, $ns, $id) = @_;
+ if (@_ != 3) {
+ croak "contains must be called with exactly three arguments!";
+ }
+
+ delete $me->{".$ns"}{$id} unless defined $me->{".$ns"}{$id};
+ return exists $me->{".$ns"}{$id};
+}
+
+sub remove {
+ my $me = shift;
+ my ($ns, $id);
+
+ if (@_ == 1 && ref $_[0]) {
+ my $o = $_[0];
+ $ns = $o->namespace;
+ $id = $o->id;
+ } elsif (@_ == 2) {
+ ($ns, $id) = @_;
+ } else {
+ die "Wrong number of arguments.";
+ }
+ delete $me->{".$ns"}{$id};
+}
+
+sub list_ids {
+ my ($me, $ns) = @_;
+ my $h = $me->{".$ns"};
+
+ wantarray ? keys %$h : [ keys %$h ];
+}
+sub list_vals {
+ my ($me, $ns) = @_;
+ my $h = $me->{".$ns"};
+
+ wantarray ? values %$h : [ values %$h ];
+}
+sub can_contain {
+ # Can contain anything, really.
+ 1;
+}
+
+
+
+
+
1;
=head1 NAME
Added: trunk/main/server/lib/Haver/Server/POE/Broadcaster.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Broadcaster.pm 2004-06-27
20:57:14 UTC (rev 263)
+++ trunk/main/server/lib/Haver/Server/POE/Broadcaster.pm 2004-06-28
02:37:38 UTC (rev 264)
@@ -0,0 +1,71 @@
+# vim: set ft=perl ts=4 sw=4:
+# Haver::Server::POE::Broadcaster - description
+#
+# Copyright (C) 2004 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
+package Haver::Server::POE::Broadcaster;
+use strict;
+use warnings;
+use POE;
+
+our $VERSION = 0.01;
+use Haver::Preprocessor;
+use Haver::Server::Registry qw( $Registry );
+
+use constant CHUNK => 10;
+
+sub create {
+ my ($this) = @_;
+
+ POE::Session->create(
+ package_states => [
+ $this => [qw(
+ _start
+ _stop
+ send
+ )],
+ ],
+ );
+}
+
+sub _start {
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+
+ $kernel->alias_set('Broadcaster');
+}
+
+sub send {
+ my ($kernel, $heap, $target, $msg) = @_[KERNEL, HEAP, ARG0, ARG1];
+ # ASSERT: ref($target) eq 'ARRAY' and ref($msg) eq 'ARRAY';
+ my $n = @$target;
+ my $end = $n > CHUNK ? CHUNK : $n;
+ my @targ = splice(@$target, 0, $end);
+
+ foreach my $t (@targ) {
+ my $u = ref $t ? $t : $Registry->fetch('user', $t);
+ eval { $u->wheel->put($msg) };
+ warn $@ if $@;
+ }
+
+ if (@$target) {
+ $kernel->yield('send', $target, $msg);
+ }
+}
+
+sub _stop { }
+
+1;
+
Modified: trunk/main/server/lib/Haver/Server/POE/Commands.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/POE/Commands.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -28,7 +28,9 @@
use Haver::Preprocessor;
use Digest::SHA1 qw(sha1_base64);
use Haver::Util::Misc ();
+use Haver::Server::Registry qw( $Registry );
+
our $VERSION = 0.02;
our $RELOAD = 1;
our @Commands = qw(
@@ -37,11 +39,12 @@
PONG
AUTH
AUTH:PASS
- IN TO THIS
+ IN TO
MSG JOIN PART QUIT
USERS
);
+
sub _mkcmd {
my $func = $_;
$func =~ s/:/_/g;
@@ -59,6 +62,7 @@
return \%cmds;
}
+
sub do_unknown_cmd {
my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
@@ -85,8 +89,8 @@
} else {
my $user = new Haver::Server::Object::User(
id => $uid,
- sid => $_[SESSION]->ID,
wheel => $heap->{socket},
+ sid => $_[SESSION]->ID,
);
$user->set(
mode => $mode,
@@ -210,19 +214,19 @@
'IN', $heap->{scope}{cid},
'MSG', $heap->{uid}, @$args,
);
- $kernel->post('Registry', 'broadcast', $users, [EMAIL
PROTECTED]);
+ $kernel->post('Broadcaster', 'send', $users, [EMAIL PROTECTED]);
} elsif ($heap->{scope}{uid}) {
if (not ref $heap->{scope}{uid}) {
my $user = $Registry->fetch('user',
$heap->{scope}{uid});
- $user->send(['MSG', $heap->{uid}, @$args]);
+ $user->put(['MSG', $heap->{uid}, @$args]);
} else {
my @msg = ( 'MSG', $heap->{uid}, @$args );
- $kernel->post('Registry', 'broadcast',
$heap->{scope}{uid}, [EMAIL PROTECTED]);
+ $kernel->post('Broadcaster', 'send',
$heap->{scope}{uid}, [EMAIL PROTECTED]);
}
} else {
return unless check_perm_access($heap->{user}, 'global msg');
my $users = $Registry->list_ids('user');
- $kernel->post('Registry', 'broadcast', $users, ['MSG',
$heap->{uid}, @$args]);
+ $kernel->post('Broadcaster', 'send', $users, ['MSG',
$heap->{uid}, @$args]);
}
}
@@ -242,7 +246,7 @@
$chan->add($user);
$user->add($chan);
my $uids = $chan->list_ids('user');
- $kernel->post('Registry', 'broadcast', $uids,
+ $kernel->post('Broadcaster', 'send', $uids,
['IN', $cid, 'JOIN', $heap->{uid}],
);
} else {
@@ -261,7 +265,7 @@
if ($user->contains('channel', $cid)) {
my $chan = $Registry->fetch('channel', $cid);
my $uids = $chan->list_ids('user');
- $kernel->post('Registry', 'broadcast', $uids, ['IN', $cid,
'PART', $uid]);
+ $kernel->post('Broadcaster', 'send', $uids, ['IN', $cid,
'PART', $uid]);
$chan->remove($user);
$user->remove($chan);
} else {
@@ -287,6 +291,7 @@
$kernel->yield('shutdown', 'ACTIVE', @$args);
}
+my $PingTime = 60;
#> PONG($time)
sub cmd_PONG {
my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
@@ -295,7 +300,7 @@
if ($time eq $heap->{ping_time}) {
$kernel->alarm_remove($heap->{ping});
$heap->{ping} = $kernel->alarm_set('send_ping',
- time + $Config->{Server}{PingTime} +
int(rand(5)));
+ time + $PingTime + int(rand(5)));
$heap->{ping_time} = undef;
} else {
$kernel->yield('bye', 'BAD PING');
Modified: trunk/main/server/lib/Haver/Server/POE/Connection.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-06-27
20:57:14 UTC (rev 263)
+++ trunk/main/server/lib/Haver/Server/POE/Connection.pm 2004-06-28
02:37:38 UTC (rev 264)
@@ -1,4 +1,4 @@
-# Haver::Server::Connection,
+# Haver::Server::POE::Connection,
# this creates a session, which represents the user...
#
# Copyright (C) 2003 Dylan William Hardison.
@@ -18,7 +18,7 @@
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
# TODO, write POD. Soon.
-package Haver::Server::Connection;
+package Haver::Server::POE::Connection;
use strict;
use Carp qw(croak confess carp cluck);
@@ -31,52 +31,50 @@
use Haver::Protocol;
use Haver::Server::POE::Commands;
+use Haver::Server::Registry qw( $Registry );
+use Scalar::Util ();
use Digest::SHA1 qw( sha1_base64 );
-
our $RELOAD = 1;
-
sub create {
- my ($class, @args) = @_;
- my $C = "Haver::Server::POE::Commands";
+ my ($class) = shift;
+ # ASSERT: (@_ == 1 and ref($_[0]) eq 'HASH') or ((@_ % 2) == 0);
+ my $opts = @_ == 1 ? $_[0] : { @_ };
+
POE::Session->create(
package_states => [
$class => {
# POE states
- '_start' => '_start',
- '_stop' => '_stop',
- '_default' => '_default',
+ _start => '_start',
+ _stop => '_stop',
+ _default => '_default',
# Wheel states
- 'socket_input' => 'socket_input',
- 'socket_error' => 'socket_error',
- 'socket_flush' => 'socket_flush',
+ socket_input => 'socket_input',
+ socket_error => 'socket_error',
+ socket_flush => 'socket_flush',
# Utility states
- 'want' => 'on_want',
- 'cleanup' => 'on_cleanup',
- 'shutdown' => 'on_shutdown',
+ want => 'on_want',
+ cleanup => 'on_cleanup',
+ 'shutdown' => 'on_shutdown',
'warn' => 'on_warn',
'die' => 'on_die',
'accept' => 'on_accept',
- 'auth' => 'on_auth',
- 'send_ping' => 'on_send_ping',
-# 'broadcast' => 'on_broadcast',
-
+ auth => 'on_auth',
+ unknown_cmd => 'on_unknown_cmd',
},
- $C => $C->commands,
],
- heap => {
- },
- args => [EMAIL PROTECTED],
+ heap => {},
+ args => [ $opts ],
);
}
sub _start {
- my ($heap, $session, $kernel, $socket, $address, $port ) =
- @_[ HEAP, SESSION, KERNEL, ARG0, ARG1, ARG2];
+ my ($heap, $session, $kernel, $opt) = @_[ HEAP, SESSION, KERNEL,
ARG0];
+ my ($address, $socket, $port) = ($opt->{address}, $opt->{sock},
$opt->{port});
$address = Socket::inet_ntoa($address);
$kernel->post('Logger', 'note', 'Socket Birth');
@@ -102,8 +100,6 @@
%$heap = (
timer => $timer,
- ping => undef,
- ping_time => undef,
socket => $sock,
shutdown => 0,
plonk => 0,
@@ -113,7 +109,7 @@
uid => undef,
);
- $sock->put(['HAVER', 3, "line=$Config->{Server}{LineLimit}"]);
+ $sock->put(['HAVER', 3, "line=2048"]);
$kernel->yield('want', 'IDENT',
address => $address,
port => $port,
@@ -168,12 +164,6 @@
return if $heap->{plonk};
return if $heap->{shutdown};
- if ($heap->{ping} && !$heap->{ping_time}) {
- $kernel->alarm_remove($heap->{ping});
- $heap->{ping} = $kernel->alarm_set(
- 'send_ping',
- time + $Config->{Server}{PingTime});
- }
my $want = 0;
my $cmd = shift @$args;
@@ -196,6 +186,7 @@
$kernel->yield('die', 'SPEEDY');
}
}
+
sub socket_flush {
my ($kernel, $heap) = @_[KERNEL, HEAP];
@@ -214,6 +205,12 @@
}
+sub on_unknown_cmd {
+ my ($kernel, $heap, $event, $args) = @_[KERNEL, HEAP, ARG0, ARG1];
+
+ $kernel->yield('warn', UCMD => [$event], $heap->{scope}{cid});
+}
+
sub on_shutdown {
my ($kernel, $heap, $session, @args) = @_[KERNEL, HEAP, SESSION, ARG0
.. $#_];
return if $heap->{shutdown};
@@ -244,6 +241,7 @@
my @args = $opts{args} ? @{$opts{args}} : ();
$heap->{socket}->put(['WANT', $want, @args]);
}
+
sub on_cleanup {
my ($kernel, $heap, @args) = @_[KERNEL, HEAP, ARG0 .. $#_];
@@ -263,13 +261,11 @@
foreach my $chan ($user->list_vals('channel')) {
$user->remove($chan);
$chan->remove($user);
- push(@users, $chan->list_vals('user'));
+ push(@users, $chan->list_ids('user'));
}
my %users = map { ($_ => $_) } @users;
my $msg = ['QUIT', $uid, @args];
- foreach my $u (values %users) {
- eval { $u->send($msg) };
- }
+ $kernel->post('Broadcaster', 'send', [ keys %users ],
$msg);
}
if ($user) {
($heap->{port}, $heap->{address}) = $user->get('.port',
'.address');
@@ -315,13 +311,8 @@
my ($kernel, $heap, $uid, $user) = @_[KERNEL, HEAP, ARG0, ARG1];
$kernel->alarm_remove(delete $heap->{timer});
- $heap->{ping} = $kernel->alarm_set(
- 'send_ping',
- time + $Config->{Server}{PingTime});
- $heap->{ping_time} = undef;
-
-
+
$Registry->add($user);
$heap->{user} = $user;
$heap->{uid} = $uid;
@@ -350,19 +341,4 @@
);
}
-sub on_send_ping {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
-
- my $time = time;
- $heap->{socket}->put(['PING', $time]);
-
- $heap->{ping} = $kernel->alarm_set(
- 'shutdown', time + $Config->{Server}{PingTime}, 'PING');
- $heap->{ping_time} = $time;
-
- $kernel->post('Logger', 'note', "Sending PING: $time");
-}
-
-
-
1;
Modified: trunk/main/server/lib/Haver/Server/POE/Listener.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE/Listener.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/POE/Listener.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -32,61 +32,106 @@
use Haver::Server::POE::Connection;
sub create {
- my ($class, %opts) = @_;
+ my $class = shift;
+ # ASSERT: (@_ == 1 and ref($_[0]) eq 'HASH') or ((@_ % 2) == 0);
+ my $opts = @_ == 1 ? $_[0] : { @_ };
+
POE::Session->create(
package_states =>
[
- $class => [
- '_start',
- '_stop',
- 'socket_birth',
- 'socket_fail',
- ]
+ $class => [qw(
+ _start
+ _stop
+ socket_birth
+ socket_fail
+ listen
+ shutdown
+ )],
],
- heap => {
- port => $opts{port},
- },
- args => [EMAIL PROTECTED],
+ heap => $opts,
);
}
sub _start {
my ($kernel, $heap) = @_[KERNEL, HEAP];
- my $port = $heap->{port};
- DEBUG: "Listener starts.";
+ # DEBUG(session): "Listener starts.";
+ $heap->{conn} = {};
+ $heap->{kids} = {};
+ $kernel->alias_set('Listener');
+
+ my $ifaces = $heap->{interfaces};
+ return unless $ifaces;
+
+ foreach my $i (@$ifaces) {
+ $kernel->yield('listen', $i->{host}, $i->{port});
+ }
+
+}
+
+sub _stop {
+ my ($kernel, $heap) = @_[KERNEL,HEAP];
+ delete $heap->{listener};
+ delete $heap->{session};
+ #DEBUG(session): "Listener stops.";
+}
+
+sub _child {
+ my ($kernel, $heap, $type, $kid) = @_[KERNEL, HEAP, ARG0, ARG1];
+
+ if ($type eq 'create' or $type eq 'gain') {
+ $heap->{kids}{$kid->ID} = 1;
+ } elsif ($type eq 'lose') {
+ delete $heap->{kids}{$kid->ID};
+ } else {
+ die "I don't know how I got here!\n";
+ }
+}
+
+sub listen {
+ my ($kernel, $heap, $host, $port) = @_[KERNEL, HEAP, ARG0, ARG1];
$kernel->post('Logger', 'note', "Listening on port $port.");
- $heap->{listener} = POE::Wheel::SocketFactory->new(
- #BindAddress => '127.0.0.1',
+ my $wheel = POE::Wheel::SocketFactory->new(
BindPort => $port,
Reuse => 1,
SuccessEvent => 'socket_birth',
FailureEvent => 'socket_fail',
);
- $kernel->alias_set('Listener');
+ $heap->{conn}{$wheel->ID} = {
+ wheel => $wheel,
+ host => $host,
+ port => $port,
+ };
}
-sub _stop {
- my ($kernel, $heap) = @_[KERNEL,HEAP];
- delete $heap->{listener};
- delete $heap->{session};
- DEBUG: "Listener stops.";
-}
+
+
sub socket_birth {
- my ($kernel, $socket, $address, $port) = @_[ KERNEL, ARG0, ARG1, ARG2 ];
+ my ($kernel, $heap, $socket, $address, $port) = @_[KERNEL, HEAP, ARG0,
ARG1, ARG2];
+ Haver::Server::POE::Connection->create(
+ sock => $socket,
+ address => $address,
+ port => $port,
+ );
+}
- create Haver::Server::POE::Connection ($socket, $address, $port);
-}
sub socket_fail {
my ($kernel, $heap, $operation, $errnum, $errstr, $wheel_id) =
@_[KERNEL, HEAP, ARG0..ARG3];
- die "Listener: '$operation' failed: $errstr";
+ delete $heap->{conn}{$wheel_id};
+ $kernel->post('Logger', 'error', "Operation '$operation' failed:
$errstr ($errnum)");
}
sub shutdown {
- $_[KERNEL]->alias_remove('Listener');
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+ $kernel->alias_remove('Listener');
+
+ foreach my $kid (keys %{ $heap->{kids} }) {
+ $kernel->post($kid, 'shutdown');
+ }
+ %$heap = ();
}
1;
Modified: trunk/main/server/lib/Haver/Server/POE.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/POE.pm 2004-06-27 20:57:14 UTC (rev
263)
+++ trunk/main/server/lib/Haver/Server/POE.pm 2004-06-28 02:37:38 UTC (rev
264)
@@ -25,72 +25,76 @@
use POE;
use Haver::Preprocessor;
-use Haver::Config (
- default => {
- IKC => {
- Host => 'localhost',
- Name => 'HaverServer',
- Port => 4040,
- },
- Logs => {},
- Server => {
- LineLimit => 2048,
- PingTime => 60,
- Port => 7070,
- },
- },
-);
+use Haver::Config;
use Haver::Server::POE::Listener;
+use Haver::Server::POE::Broadcaster;
use Haver::Server::Registry;
use Haver::Server::Object::Channel;
use Haver::Server::Object::User;
+use Haver::Server::Object::POE;
use Haver::Server::Object::Index;
-use Haver::Server::Remote;
-
use Haver::Util::Logger;
use Haver::Util::Reload;
+
our $VERSION = 0.06;
-my ($Config, $Registry);
+my %Default = (
+ logger => {
+ levels => {},
+ },
+ listener => {
+ interfaces => [
+ { port => 7071 },
+ ]
+ },
+ broadcaster => { },
+ path => {
+ storage => "./store",
+ },
+ channels => [qw(
+ main
+ lobby
+ attic
+ basement
+ kitchen
+ )],
+);
-
sub boot {
- my ($this, %opts) = @_;
- $|++;
+ my ($this, $file) = @_;
- ASSERT: $opts{confdir};
- ASSERT: $opts{datadir};
- DEBUG: "Booting ", __PACKAGE__;
-
- $Config = instance Haver::Config(
- file => "$opts{confdir}/config.yml"
+ # ASSERT: defined $file;
+ # DEBUG(session): "Booting ", __PACKAGE__;
+
+ my $cfg = new Haver::Config (
+ file => $file,
+ default => \%Default,
);
- $Registry = instance Haver::Server::Registry;
+ $cfg->save;
+ init Haver::Util::Reload;
+ my $reg = instance Haver::Server::Registry;
+
+ my @cids = (Haver::Server::Object::Channel->saved_ids, @{
$cfg->{channels} });
+ foreach my $cid (@cids) {
+ DEBUG: $cid;
+ my $chan = Haver::Server::Object::Channel->new(id => $cid);
+ $chan->load;
+ $reg->add($chan);
+ }
- if ($Config->{Feature}{IKC}) {
- require POE::Component::IKC::Server;
- import POE::Component::IKC::Server;
- create_ikc_server(
- ip => $Config->{IKC}{Host} || 'localhost',
- port => $Config->{IKC}{Port} || '4040',
- name => $Config->{IKC}{Name} || 'HaverServer',
- );
+ if ($cfg->{path}{storage}) {
+ $Haver::Server::Object::StorageDir = $cfg->{path}{storage};
}
-
- Haver::Reload->init;
- $Config->{Server}{PingTime} ||= 60;
- Haver::Server::Object->store_dir( "$opts{datadir}/store" );
-
-
- $this->create;
+ $this->create(cfg => $cfg);
}
sub create {
- my ($class) = @_;
+ my ($class, %opt) = @_;
+
POE::Session->create(
package_states => [
$class => [
@@ -101,49 +105,38 @@
'shutdown',
]
],
- heap => {},
+ heap => {
+ cfg => $opt{cfg}
+ },
);
}
sub _start {
my ($kernel, $heap) = @_[KERNEL, HEAP];
- my $port = $Config->{Server}{Port} || 7070;
- DEBUG: "Server starts.";
- create Haver::Util::Logger (
- levels => $Config->{Logs},
- );
- create Haver::Server::POE::Listener (
- port => $port
- );
+
+ # DEBUG(session): "Server starts.";
+ create Haver::Util::Logger $heap->{cfg}{logger};
+ create Haver::Server::POE::Listener $heap->{cfg}{listener};
+ create Haver::Server::POE::Broadcaster $heap->{cfg}{broadcaster};
+
+
$kernel->sig('INT' => 'intterrupt');
$kernel->sig('DIE' => 'die');
}
sub _stop {
- DEBUG: "Server stops.";
-
- my @chans;
- $Store->{Channels} = [EMAIL PROTECTED];
-
- foreach my $chan ($Registry->list_vals('channel')) {
- if ($chan->has('_perm')) {
- push(@chans, $chan->id);
- $chan->save;
- }
- }
-
- $Store->save;
- $Config->save;
+ # DEBUG(session): "Server stops.";
}
sub die {
- print "Got DIE\n";
+ # DEBUG(session): "Got die!";
}
sub interrupt {
print "Got INT\n";
+ return 0;
}
sub shutdown {
}
Modified: trunk/main/server/lib/Haver/Server/Registry.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Registry.pm 2004-06-27 20:57:14 UTC
(rev 263)
+++ trunk/main/server/lib/Haver/Server/Registry.pm 2004-06-28 02:37:38 UTC
(rev 264)
@@ -22,12 +22,33 @@
use Haver::Preprocessor;
use Haver::Server::Object::Index;
-use base qw( Haver::Server::Object Haver::Server::Object::Index );
+use base qw( Haver::Server::Object Haver::Server::Object::Index Exporter );
use POE;
+use Carp;
our $VERSION = 0.04;
our $RELOAD = 1;
+our $Registry;
+our @EXPORT_OK = qw( $Registry );
+sub instance {
+ my $class = shift;
+
+ # don't warn about redefining a function.
+ do {
+ no warnings;
+ *instance = \&self;
+ };
+
+ return $Registry = $class->SUPER::new(@_);
+}
+
+sub self { $Registry }
+
+sub new {
+ croak "Can't call new on ", __PACKAGE__;
+}
+
sub namespace {
'registry',
}
