Author: dylan
Date: 2005-06-19 03:36:52 -0400 (Sun, 19 Jun 2005)
New Revision: 772
Added:
trunk/main/core/lib/Haver/Factory.pm
trunk/main/core/lib/Haver/Logger.pm
trunk/main/core/lib/Haver/Session.pm
trunk/main/core/lib/Haver/Util.pm
trunk/main/core/lib/Haver/Wheel.pm
trunk/main/core/lib/Haver/Wheel/
trunk/main/core/lib/Haver/Wheel/Loader.pm
trunk/main/core/t/003_wheel.t
trunk/main/core/t/004_loader.t
trunk/main/core/t/005_wheel_run.t
trunk/main/core/t/006_factory.t
trunk/main/server/lib/Haver/Server/Wheel.pm
trunk/main/server/lib/Haver/Server/Wheel/
trunk/main/server/lib/Haver/Server/Wheel/Login.pm
trunk/main/server/lib/Haver/Server/Wheel/Main.pm
Removed:
trunk/main/core/lib/Haver/Base/
trunk/main/core/lib/POE/
trunk/main/server/lib/Haver/Server/Registry.pm
trunk/misc/poe-wheel-square/lib/POE/Wheel/Square.pm
trunk/misc/poe-wheel-square/lib/POE/Wheel/Square/Loader.pm
trunk/misc/poe-wheel-square/t/001_wheel.t
trunk/misc/poe-wheel-square/t/002_loader.t
trunk/misc/poe-wheel-square/t/003_run.t
Modified:
trunk/
trunk/main/core/lib/Haver/Base.pm
trunk/main/core/lib/Haver/Config.pm
trunk/main/core/t/002_protocol.t
trunk/main/server/bin/haverd.pl
trunk/main/server/lib/Haver/Server/Avatar.pm
trunk/main/server/lib/Haver/Server/Entity.pm
trunk/main/server/lib/Haver/Server/Entity/Channel.pm
trunk/main/server/lib/Haver/Server/Entity/Lobby.pm
trunk/main/server/lib/Haver/Server/Entity/Service.pm
trunk/main/server/lib/Haver/Server/Entity/User.pm
trunk/main/server/lib/Haver/Server/Listener.pm
trunk/main/server/lib/Haver/Server/Talker.pm
Log:
[EMAIL PROTECTED]: dylan | 2005-06-18 16:42:24 -0400
commiting this so I can rename it.
[EMAIL PROTECTED]: dylan | 2005-06-18 16:43:31 -0400
major class reorganization.
[EMAIL PROTECTED]: dylan | 2005-06-18 16:45:10 -0400
added tests for Haver::Wheel.
[EMAIL PROTECTED]: dylan | 2005-06-19 02:26:12 -0400
lots of test cases for haver-core.
New generic factory class with caching. Much nicer than singletons.
Also no longer using Spiffy source filtering.
[EMAIL PROTECTED]: dylan | 2005-06-19 03:36:15 -0400
Okay, now it works with Haver::Wheels.
Property changes on: trunk
___________________________________________________________________
Name: svk:merge
- 1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/havercurs-objc:43050
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk:11166
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk-merge-10131:11178
27e50396-46e3-0310-8b22-ae223a1f35ce:/local:212
e9404bb1-7af0-0310-a7ff-e22194cd388b:/haver/local:1074
edfcd8bd-4ce7-0310-a97e-bb1efd40edf3:/local:238
+ 1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/havercurs-objc:43050
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk:11166
1f59643a-e6e5-0310-bc24-f7d4c744f460:/haver/local/trunk-merge-10131:11178
27e50396-46e3-0310-8b22-ae223a1f35ce:/local:212
e9404bb1-7af0-0310-a7ff-e22194cd388b:/haver/local:1099
edfcd8bd-4ce7-0310-a97e-bb1efd40edf3:/local:238
Modified: trunk/main/core/lib/Haver/Base.pm
===================================================================
--- trunk/main/core/lib/Haver/Base.pm 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/lib/Haver/Base.pm 2005-06-19 07:36:52 UTC (rev 772)
@@ -7,7 +7,10 @@
our @EXPORT_BASE = qw( DEBUG field croak carp confess );
-{
+field 'factory';
+
+
+BEGIN {
no warnings;
sub field(@) {
use warnings;
Modified: trunk/main/core/lib/Haver/Config.pm
===================================================================
--- trunk/main/core/lib/Haver/Config.pm 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/lib/Haver/Config.pm 2005-06-19 07:36:52 UTC (rev 772)
@@ -1,7 +1,9 @@
# vim: set ts=4 sw=4 expandtab si ai sta tw=100:
# This module is copyrighted, see end of file for details.
package Haver::Config;
-use Haver::Base '-Base';
+use strict;
+use warnings;
+use Haver::Base -base;
use Scalar::Util 'reftype';
use YAML ();
@@ -13,6 +15,7 @@
sub initialize {
+ my $self = shift;
my $file = $self->{file};
my $config = -e $file ? YAML::LoadFile($file) : {};
$self->{config} = merge_hash($config, $self->{default} || {});
@@ -30,6 +33,7 @@
}
sub save {
+ my $self = shift;
YAML::DumpFile($self->{file}, $self->{config});
}
@@ -79,7 +83,7 @@
return [EMAIL PROTECTED], @$right];
}
-
+1;
__END__
=head1 NAME
Added: trunk/main/core/lib/Haver/Factory.pm
===================================================================
--- trunk/main/core/lib/Haver/Factory.pm 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/main/core/lib/Haver/Factory.pm 2005-06-19 07:36:52 UTC (rev
772)
@@ -0,0 +1,44 @@
+# vim: set ts=4 sw=4 expandtab si ai sta tw=104:
+# This module is copyrighted, see end of file for details.
+package Haver::Factory;
+use strict;
+use warnings;
+use Haver::Base -base;
+our $VERSION = 0.01;
+
+field classes => { };
+field _cache => { };
+
+sub make {
+ my $self = shift;
+ my $name = shift;
+ my $class = $self->class($name);
+ my $object = $class->new(@_);
+
+ if ($object->can('factory')) {
+ $object->factory($self);
+ }
+
+ return $object;
+}
+
+sub cache {
+ my $self = shift;
+ my $name = shift;
+ my $class = $self->class($name);
+
+ return $self->{_cache}{$name} || ($self->{_cache}{$name} =
$class->new(@_));
+}
+
+sub class {
+ my ($self, $name) = @_;
+ $self->{classes}{$name};
+}
+
+sub register_class {
+ my ($self, $name, $class) = @_;
+ $self->{classes}{$name} = $class;
+}
+
+
+1;
Added: trunk/main/core/lib/Haver/Logger.pm
===================================================================
--- trunk/main/core/lib/Haver/Logger.pm 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/lib/Haver/Logger.pm 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,26 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Logger;
+use strict;
+use warnings;
+use Carp;
+use Exporter;
+use base 'Exporter';
+
+our $VERSION = 0.02;
+our @EXPORT_OK = qw( Log );
+
+sub Log (@) {
+ if (@_ == 1) {
+ #$POE::Kernel::poe_kernel->post('Logger', 'debug', @_);
+ print "[debug] ", @_, "\n";
+ } elsif (@_ > 1) {
+ #$POE::Kernel::poe_kernel->post('Logger', @_);
+ my $s = shift;
+ print "[$s] ", @_, "\n";
+ } else {
+ croak 'Log() must be called with >= 1 arguments';
+ }
+}
+
+1;
Added: trunk/main/core/lib/Haver/Session.pm
===================================================================
--- trunk/main/core/lib/Haver/Session.pm 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/main/core/lib/Haver/Session.pm 2005-06-19 07:36:52 UTC (rev
772)
@@ -0,0 +1,44 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Session;
+use strict;
+use warnings;
+
+use Haver::Base -base;
+use Haver::Logger 'Log';
+use POE::Session;
+
+our $VERSION = 0.08;
+our @EXPORT_BASE = qw(
+ SESSION OBJECT
+ KERNEL HEAP STATE
+ SENDER CALLER_FILE
+ CALLER_LINE ARG0
+ ARG1 ARG2 ARG3
+ ARG4 ARG5 ARG6
+ ARG7 ARG8 ARG9
+ Log
+);
+
+
+sub import (@) {
+ if (grep /^-(Base|selfless)$/, @_) {
+ croak "Haver::Base::Session subclasses may not use -Base or
-selfless!";
+ }
+ my $package = caller();
+ shift->SUPER::import(-package => $package, @_);
+}
+
+sub create () {
+ my $this = shift;
+ my $what = ref $this ? 'object' : 'package';
+
+ create POE::Session (
+ "${what}_states" => [
+ $this => $this->states,
+ ],
+ args => [ { @_ } ],
+ )
+}
+
+1;
Added: trunk/main/core/lib/Haver/Util.pm
===================================================================
--- trunk/main/core/lib/Haver/Util.pm 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/lib/Haver/Util.pm 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,88 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Util;
+use strict;
+use warnings;
+
+use base 'Exporter';
+
+our $VERSION = 0.02;
+our @EXPORT = ();
+our @EXPORT_OK = qw( is_valid_name is_reserved_name );
+our %EXPORT_TAGS = (
+ name => [qw( is_valid_name is_reserved_name )],
+);
+
+our $NamePattern = qr/^&?[a-z][a-z0-9_.'@-]+$/i;
+
+sub is_valid_name {
+ my $name = shift;
+ $name =~ $NamePattern;
+}
+
+sub is_reserved_name {
+ my $name = shift;
+ $name =~ /^&/ or $name =~ /@/;
+}
+
+
+1;
+__END__
+=head1 NAME
+
+Haver::Util - description
+
+=head1 SYNOPSIS
+
+ use Haver::Util;
+ # Small code example.
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 EXPORTS
+
+This module optionally exports the following functions.
+
+=head2 is_valid_name($name)
+
+Returns true if $name is considered a valid haver name, false otherwise.
+
+=head2 is_reserved_name($name)
+
+Returns true if $name is only available for services and other privledged
entities.
+
+=head1 EXPORT GROUPS
+
+=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
+
Added: trunk/main/core/lib/Haver/Wheel/Loader.pm
===================================================================
--- trunk/main/core/lib/Haver/Wheel/Loader.pm 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/main/core/lib/Haver/Wheel/Loader.pm 2005-06-19 07:36:52 UTC (rev
772)
@@ -0,0 +1,145 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Wheel::Loader;
+use strict;
+use warnings;
+use Carp;
+
+our $VERSION = '0.04';
+
+sub new {
+ my $class = shift;
+ my $self = {
+ wheels => {},
+ };
+ bless $self, $class;
+}
+
+sub load_wheel {
+ my ($self, $class, @args) = @_;
+
+ if (exists $self->{wheels}{$class}) {
+ croak "Plugin $class already loaded!";
+ }
+
+ my $object = $class->new(@args);
+ $object->load;
+ $self->{wheels}{$class} = $object;
+}
+
+sub unload_wheel {
+ my ($self, $class) = @_;
+ my $object = delete $self->{wheels}{$class};
+ $object->unload;
+}
+
+sub wheels {
+ my $self = shift;
+ keys %{ $self->{wheels} };
+}
+
+sub unload_all_wheels {
+ my ($self) = @_;
+ map { $self->unload($_) } $self->wheels
+}
+
+sub fetch_wheel {
+ my ($self, $class) = @_;
+
+ if (exists $self->{wheels}{$class}) {
+ $self->{wheels}{$class};
+ } else {
+ undef;
+ }
+}
+
+
+1;
+__END__
+=head1 NAME
+
+Haver::Wheel::Loader - description
+
+=head1 SYNOPSIS
+
+ use Haver::Wheel::Loader;
+ use MyPlugin;
+
+ # ... In some POE state ...
+ my $loader = Haver::Wheel::Loader;
+ $loader->load_wheel('MyPlugin', 'some', 'args');
+ $_[HEAP]{loader} = $loader;
+
+=head1 DESCRIPTION
+
+This object maintains a list of wheel objects which have states loaded into a
session.
+
+FIXME: Write a better description.
+
+=head1 METHODS
+
+This class implements the following methods:
+
+=head2 new(Z<>)
+
+This returns a new Haver::Wheel::Loader object.
+
+=head2 load_wheel($class, @args)
+
+Creates a new object of class $class, passing @args to its new() class method.
+The newly created object will have its load() method called, which should load
states into the
+currently active L<POE::Session>.
+
+For details on defining wheels, see L<POE::Session::Plugin>.
+
+=head2 unload_wheel($class)
+
+Call unload() on the object associated with $class,
+and then destroy the said object.
+
+=head2 wheels(Z<>)
+
+Returns a list of the currently loaded class names.
+
+=head2 fetch_wheel($class)
+
+Returns the wheel object of type $class.
+Returns undef if $class was never loaded.
+
+=head2 unload_all_wheels(Z<>)
+
+Unload all currently loaded wheels.
+
+This is called when the wheel loader is DESTROY()'d, so you never really need
to call it.
+
+=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/>, L<POE>, L<POE::Session>, L<POE::NFA>.
+
+=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
+
Added: trunk/main/core/lib/Haver/Wheel.pm
===================================================================
--- trunk/main/core/lib/Haver/Wheel.pm 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/lib/Haver/Wheel.pm 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,243 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Wheel;
+use strict;
+use warnings;
+
+use Haver::Base -base;
+use POE::Session;
+use POE::Wheel;
+
+our $VERSION = 0.08;
+our @EXPORT_BASE = qw(
+ SESSION OBJECT
+ KERNEL HEAP STATE
+ SENDER CALLER_FILE
+ CALLER_LINE ARG0
+ ARG1 ARG2 ARG3
+ ARG4 ARG5 ARG6
+ ARG7 ARG8 ARG9
+);
+
+const kernel => $POE::Kernel::poe_kernel;
+field package => 1;
+
+sub new {
+ my $class = shift;
+ my $self = {
+ # I only prefix these with underscores because I am paranoid of
+ # subclasses clobbering them. :)
+ _provided_states => [],
+ _defined_states => { },
+ _id => POE::Wheel::allocate_wheel_id(),
+ };
+ bless $self, $class;
+ $self->provide("load_$self->{_id}", 'on_load');
+ $self->provide("unload_$self->{_id}", 'on_unload');
+ $self->setup(@_);
+ return $self;
+}
+
+sub setup { }
+
+# POE state called when we load.
+sub on_load {
+
+}
+
+# POE state called when we unload.
+sub on_unload {
+
+}
+
+sub provide {
+ my ($self, $state, $method) = @_;
+ croak "state name undefined!" unless defined $state;
+ push @{ $self->{_provided_states} }, [ $state, $method ];
+}
+
+sub provided_states {
+ my $self = shift;
+ @{ $self->{_provided_states} };
+}
+
+sub defined_states {
+ my $self = shift;
+ keys %{ $self->{_defined_states} };
+}
+
+
+sub invoke {
+ my $self = shift;
+ my $act = shift;
+ my $kernel = $self->kernel;
+ my $session = $kernel->get_active_session();
+ my $class = ref $self;
+ $kernel->call($session, join('_', $act, $self->ID));
+}
+
+sub ID { shift->{_id} }
+
+# Load all provided states.
+sub load {
+ my $self = shift;
+ map {
+ $self->define(@$_)
+ } $self->provided_states;
+ $self->invoke('load');
+}
+
+# Unload all *defined* states.
+sub unload {
+ my $self = shift;
+ $self->invoke('unload');
+ map {
+ $self->undefine($_)
+ } $self->defined_states;
+}
+
+sub define {
+ my ($self, $state, $method) = @_;
+ my $kernel = $self->kernel;
+ $method ||= $state;
+
+ croak "State $state defined; can't redefine"
+ if exists $self->{_defined_states}{$state};
+ $self->{_defined_states}{$state} = $method;
+ $kernel->state($state,
+ $self->{package} ? ref $self : $self,
+ $method
+ );
+}
+
+sub undefine {
+ my ($self, $state) = @_;
+
+ croak "State $state not defined; can't undefine"
+ unless exists $self->{_defined_states}{$state};
+ delete $self->{_defined_states}{$state};
+ $self->kernel->state($state);
+}
+
+
+sub DESTROY {
+ my $self = shift;
+ POE::Wheel::free_wheel_id($self->ID);
+}
+
+1;
+__END__
+=head1 NAME
+
+Haver::Wheel - Base class for modules that extend POE::Session at runtime.
+
+=head1 SYNOPSIS
+
+ package MyPlugin;
+ use POE;
+ use base 'Haver::Wheel';
+
+ sub setup {
+ my $self = shift;
+ $self->provide('foo', 'on_foo');
+ }
+
+ sub on_foo {
+ my ($kernel, $heap, $self) = @_[KERNEL, HEAP, OBJECT];
+ # ...
+ }
+
+=head1 DESCRIPTION
+
+This module allows the loading and unloading of object states into a running
L<POE::Session>.
+
+Plugins are not unlike a L<POE::Wheel>, except instead of producing events,
they respond to them.
+
+This behavior is similar to that of L<POE::NFA>, except it is added to
existing L<POE::Session>
+sessions.
+
+=head1 METHODS
+
+This class implements the following methods:
+
+=head2 new(@args)
+
+This returns a new wheel object.
+Its arguments (@args) are passed to setup()
+
+=head2 setup(Z<>)
+
+B<Do not call this method>. It is called by new().
+
+Subclasses should overload this method and use it call provide()
+to specify which states they define in the current session.
+
+=head2 ID(Z<>)
+
+This returns the unique wheel id of the square wheel.
+
+=head2 define($state [, $method ])
+
+Bind $state in the currently active session to the method $method of $self.
+If $method is omitted, it defaults to the same name as $state.
+
+=head2 undefine($state)
+
+Remove the binding of $state in the current session, if and only if it was
previously
+defined by our $self.
+
+=head2 provide($state [, $method ])
+
+This is like a delayed define(). It will only occurs when load() is called.
+
+=head2 load(Z<>)
+
+Load all C<provide>'d states.
+
+=head2 unload(Z<>)
+
+This undefines (with undefine()) all states that were defined with define()
+or provided() and subsequently loaded with load().
+
+=head2 on_load
+
+This is method is called as a POE state when the plugin is loaded.
+$_[KERNEL], $_[SESSION], etc, should all be correct.
+
+=head2 on_unload
+
+This is method is called as a POE state when the plugin is unloaded.
+$_[KERNEL], $_[SESSION], etc, should all be correct.
+
+=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/>, L<Haver::Wheel::Loader>,
+L<POE>, L<POE::Session>, L<POE::NFA>.
+
+=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/main/core/t/002_protocol.t
===================================================================
--- trunk/main/core/t/002_protocol.t 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/t/002_protocol.t 2005-06-19 07:36:52 UTC (rev 772)
@@ -7,9 +7,8 @@
# change 'tests => 1' to 'tests => last_test_to_print';
-use Test::More tests => 6;
+use Test::More tests => 5;
BEGIN {
- use_ok('Haver');
use_ok('Haver::Protocol', qw(:event :crlf :escape));
};
Added: trunk/main/core/t/003_wheel.t
===================================================================
--- trunk/main/core/t/003_wheel.t 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/t/003_wheel.t 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,25 @@
+#!/usr/bin/perl
+# vim: set ft=perl:
+use strict;
+use Test::More tests => 4;
+
+my $class = 'Haver::Wheel';
+use_ok($class);
+can_ok($class, 'new');
+
+my $plugin = $class->new;
+
+isa_ok($plugin, $class);
+can_ok($plugin,
+ qw(
+ provide
+ load
+ unload
+ define
+ undefine
+ provided_states
+ defined_states
+ setup
+ kernel
+ )
+);
Added: trunk/main/core/t/004_loader.t
===================================================================
--- trunk/main/core/t/004_loader.t 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/t/004_loader.t 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,20 @@
+#!/usr/bin/perl
+# vim: set ft=perl:
+use strict;
+use Test::More tests => 4;
+
+my $class = 'Haver::Wheel::Loader';
+require_ok($class);
+can_ok($class, 'new');
+
+my $loader = $class->new;
+isa_ok($loader, $class);
+can_ok($loader,
+ qw(
+ load_wheel
+ unload_wheel
+ wheels
+ fetch_wheel
+ unload_all_wheels
+ )
+);
Added: trunk/main/core/t/005_wheel_run.t
===================================================================
--- trunk/main/core/t/005_wheel_run.t 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/t/005_wheel_run.t 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,95 @@
+#!/usr/bin/perl
+# vim: set ft=perl:
+use strict;
+use Test::More tests => 7;
+use POE;
+use Haver::Wheel;
+use Haver::Wheel::Loader;
+
+BEGIN {
+ package MyWheel;
+ use POE;
+ use base 'Haver::Wheel';
+
+ sub setup {
+ my $self = shift;
+ $self->provide('foo', 'on_foo');
+ $self->provide('bar', 'on_bar');
+ $self->provide('baz', 'on_baz');
+ }
+
+ sub on_load {
+ my $self = $_[OBJECT];
+ $self->{load} = 1;
+ }
+
+ sub on_unload {
+ my $self = $_[OBJECT];
+ $self->{unload} = 1;
+ }
+ sub on_foo {
+ my $self = $_[OBJECT];
+ $self->{foo}++;
+ }
+
+ sub on_bar {
+ my $self = $_[OBJECT];
+ $self->{bar}++;
+ }
+
+ sub on_baz {
+ my $self = $_[OBJECT];
+ $self->{baz}++;
+ if ($self->{baz} == 1) {
+ $_[KERNEL]->yield('bye');
+ }
+ }
+}
+
+POE::Session->create(
+ inline_states => {
+ _start => \&on_start,
+ _stop => \&on_stop,
+ bye => \&on_bye,
+ },
+);
+
+POE::Kernel->run;
+
+sub on_start {
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+ my $loader = new Haver::Wheel::Loader;
+ $loader->load_wheel('MyWheel');
+ $heap->{loader} = $loader;
+
+ diag "Starting session";
+ foreach my $state (qw( foo bar baz )) {
+ $kernel->yield($state) for 1 .. 3;
+ }
+}
+
+sub on_stop {
+ diag "Stopping session";
+}
+
+sub on_bye {
+ my ($kernel, $heap) = @_[KERNEL, HEAP];
+ my $loader = $heap->{loader};
+ my $p = $loader->fetch_wheel('MyWheel');
+
+ diag "Saying goodbye";
+ is($p->{foo}, 3, "Called foo 3 times");
+ is($p->{bar}, 3, "Called bar 3 times");
+ is($p->{baz}, 3, "Called baz 3 times");
+
+ diag "Calling foo again";
+ $kernel->call($_[SESSION], 'foo');
+ is($p->{foo}, 4, "foo is now 4");
+
+ diag "Unloading MyWheel";
+ $loader->unload_wheel('MyWheel');
+ $kernel->call($_[SESSION], 'foo');
+ isnt($p->{foo}, 5, "foo is not 5");
+ ok($p->{load}, "on_load was called.");
+ ok($p->{unload}, "on_unload was called.");
+}
Added: trunk/main/core/t/006_factory.t
===================================================================
--- trunk/main/core/t/006_factory.t 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/core/t/006_factory.t 2005-06-19 07:36:52 UTC (rev 772)
@@ -0,0 +1,30 @@
+#!/usr/bin/perl
+# vim: set ft=perl:
+
+#########################
+
+# change 'tests => 1' to 'tests => last_test_to_print';
+
+use Test::More tests => 6;
+BEGIN {
+ use_ok('Haver::Factory');
+ use_ok('Haver::Config');
+};
+
+can_ok('Haver::Factory', 'new', 'make', 'cache', 'register_class');
+
+my $fac = new Haver::Factory (
+ classes => {
+ config => 'Haver::Config'
+ },
+);
+
+ok($fac, 'testing new()');
+
+my $config = $fac->make('config', file => 'foobar');
+ok($config->file eq 'foobar', "testing make()");
+
+my $c1 = $fac->cache('config', file => 'foobar');
+my $c2 = $fac->cache('config', file => 'foobar');
+
+ok($c1 == $c2, "testing cache() for sameness");
Modified: trunk/main/server/bin/haverd.pl
===================================================================
--- trunk/main/server/bin/haverd.pl 2005-06-17 01:11:39 UTC (rev 771)
+++ trunk/main/server/bin/haverd.pl 2005-06-19 07:36:52 UTC (rev 772)
@@ -18,12 +18,30 @@
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
use strict;
use warnings;
+use lib qw( lib ../core/lib );
+use Haver::Server::Entity::User;
+use Haver::Server::Entity::Channel;
+use Haver::Server::Entity::Lobby;
+use Haver::Factory;
use Haver::Server::Listener;
+
+
use POE;
-create Haver::Server::Listener;
+my $factory = new Haver::Factory (
+ classes => {
+ user => 'Haver::Server::Entity::User',
+ channel => 'Haver::Server::Entity::Channel',
+ lobby => 'Haver::Server::Entity::Lobby',
+ config => 'Haver::Config',
+ },
+);
+create Haver::Server::Listener (
+ factory => $factory,
+);
+
POE::Session->create(
inline_states => {
_start => sub {
Modified: trunk/main/server/lib/Haver/Server/Avatar.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Avatar.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Avatar.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,17 +1,19 @@
# vim: set ts=4 sw=4 noexpandtab si ai sta tw=104:
# This module is copyrighted, see end of file for details.
package Haver::Server::Avatar;
-use Haver::Base -Base;
+use strict;
+use warnings;
+use Haver::Base -base;
-our $VERSION = 0.07;
+our $VERSION = 0.08;
-field -weak => 'wheel';
+field -weak => 'wheel';
field _access => {};
sub put {
- my $msg = shift;
+ my ($self, $msg) = @_;
if (my $w = $self->wheel) {
$w->put($msg);
@@ -22,26 +24,22 @@
}
sub grant {
- my ($where, $what, $level) = @_;
+ my ($self, $where, $what, $level) = @_;
$self->{_access}{$where}{$what} = $level || 1;
}
sub revoke {
- my ($where, $what) = @_;
+ my ($self, $where, $what) = @_;
return undef if not exists $self->{_access}{$where};
return delete $self->{_access}{$where}{$what};
}
sub may {
- my ($where, $what) = @_;
+ my ($self, $where, $what) = @_;
return undef unless exists $self->{_access}{$where};
return undef unless exists $self->{_access}{$where}{$what};
return $self->{_access}{$where}{$what};
}
-
-sub compare {
- my ($where, $what)
-}
Modified: trunk/main/server/lib/Haver/Server/Entity/Channel.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Entity/Channel.pm 2005-06-17
01:11:39 UTC (rev 771)
+++ trunk/main/server/lib/Haver/Server/Entity/Channel.pm 2005-06-19
07:36:52 UTC (rev 772)
@@ -1,20 +1,22 @@
# vim: set ts=4 sw=4 expandtab si ai sta tw=104:
# This module is copyrighted, see end of file for details.
package Haver::Server::Entity::Channel;
-use Haver::Server::Entity qw( -Base );
+use strict;
+use warnings;
+use Haver::Server::Entity -base;
-our $VERSION = 0.20;
+our $VERSION = 0.22;
const namespace => 'channel';
field _contents => {};
sub can_contain {
- my $object = shift;
+ my ($self, $object) = @_;
$object->namespace eq 'user';
}
sub put {
- my ($msg) = @_;
+ my ($self, $msg) = @_;
foreach my $user ($self->contents('user')) {
$user->put($msg);
@@ -22,7 +24,7 @@
}
sub add {
- my ($object) = @_;
+ my ($self, $object) = @_;
my $ns = $object->namespace;
my $name = lc $object->name;
@@ -34,7 +36,7 @@
}
sub fetch {
- my ($ns, $name) = @_;
+ my ($self, $ns, $name) = @_;
$name = lc $name;
return undef unless exists $self->{_contents}{$ns};
@@ -43,7 +45,7 @@
}
sub remove {
- my ($ns, $name) = @_;
+ my ($self, $ns, $name) = @_;
$name = lc $name;
return undef unless exists $self->{_contents}{$ns};
@@ -52,7 +54,7 @@
}
sub contents {
- my ($ns) = @_;
+ my ($self, $ns) = @_;
my @values = ();
if (exists $self->{_contents}{$ns}) {
@@ -63,9 +65,10 @@
}
sub contains {
- my ($ns, $name) = @_;
+ my ($self, $ns, $name) = @_;
return undef unless exists $self->{_contents}{$ns};
return exists $self->{_contents}{$ns}{lc $name};
}
+1;
Modified: trunk/main/server/lib/Haver/Server/Entity/Lobby.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Entity/Lobby.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Entity/Lobby.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,22 +1,21 @@
# vim: set ts=4 sw=4 expandtab si ai sta tw=104:
# This module is copyrighted, see end of file for details.
package Haver::Server::Entity::Lobby;
-use Haver::Server::Entity::Channel -Base;
+use strict;
+use warnings;
+use Haver::Server::Entity::Channel -base;
-our $VERSION = 0.20;
-our $Self;
+our $VERSION = 0.22;
-const name => '&lobby';
-const lobby => new Haver::Server::Entity::Lobby;
+const name => '&lobby';
-
sub can_contain {
- my $object = shift;
+ my ($self, $object) = @_;
$self != $object;
}
sub fetch {
- my ($ns, $name) = @_;
+ my ($self, $ns, $name) = @_;
if ($ns eq 'channel' and $name eq '&lobby') {
return $self;
@@ -26,7 +25,7 @@
}
sub contains {
- my ($ns, $name) = @_;
+ my ($self, $ns, $name) = @_;
if ($ns eq 'channel' and $name eq '&lobby') {
return 1;
@@ -35,3 +34,4 @@
}
}
+1;
Modified: trunk/main/server/lib/Haver/Server/Entity/Service.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Entity/Service.pm 2005-06-17
01:11:39 UTC (rev 771)
+++ trunk/main/server/lib/Haver/Server/Entity/Service.pm 2005-06-19
07:36:52 UTC (rev 772)
@@ -1,7 +1,12 @@
# vim: set ts=4 sw=4 expandtab si ai sta tw=100:
# This module is copyrighted, see end of file for details.
package Haver::Server::Entity::Service;
-use Haver::Server::Entity qw( -Base );
-use Haver::Server::Avatar qw( -mixin );
+use strict;
+use warnings;
+use Haver::Server::Entity -base;
+use Haver::Server::Avatar -mixin;
const namespace => 'service';
+
+
+1;
Modified: trunk/main/server/lib/Haver/Server/Entity/User.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Entity/User.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Entity/User.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,8 +1,10 @@
# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
# This module is copyrighted, see end of file for details.
package Haver::Server::Entity::User;
-use Haver::Server::Entity qw( -Base );
-use Haver::Server::Avatar qw( -mixin );
+use strict;
+use warnings;
+use Haver::Server::Entity -base;
+use Haver::Server::Avatar -mixin;
const namespace => 'user';
field _channels => {};
@@ -10,13 +12,13 @@
sub join {
- my ($chan) = @_;
+ my ($self, $chan) = @_;
$chan->add($self);
$self->add_channel($chan->name);
}
sub part {
- my ($chan) = @_;
+ my ($self, $chan) = @_;
$chan->remove($self->namespace, $self->name);
$self->remove_channel($chan->name);
}
Modified: trunk/main/server/lib/Haver/Server/Entity.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Entity.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Entity.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,10 +1,29 @@
# vim: set ts=4 sw=4 expandtab si ai sta tw=104:
# This module is copyrighted, see end of file for details.
package Haver::Server::Entity;
-use Haver::Base '-Base';
+use strict;
+use warnings;
+use Haver::Base -base;
+use Haver::Util;
-field name => '&undef';
+field _name => '&undef';
field attr => {};
stub 'namespace';
+stub 'put';
+sub name {
+ my $self = shift;
+ if (@_ == 0) {
+ return $self->_name;
+ } else {
+ my $name = shift;
+ if (Haver::Util::is_valid_name($name)) {
+ return $self->_name($name);
+ } else {
+ croak "Can't set name to invalid value of $name!";
+ }
+ }
+}
+
+1;
Modified: trunk/main/server/lib/Haver/Server/Listener.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Listener.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Listener.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -2,22 +2,24 @@
use strict;
use warnings;
-use Haver::Base::Session -base;
+use Haver::Session -base;
use Haver::Server::Talker;
use POE::Wheel::SocketFactory;
-our $VERSION = '0.02';
+our $VERSION = 0.03;
our $Alias = 'Listener';
-states qw(
- _start
- _stop
- _child
- socket_birth
- socket_fail
- listen
- shutdown
-);
+sub states {
+ return [qw(
+ _start
+ _stop
+ _child
+ socket_birth
+ socket_fail
+ listen
+ shutdown
+ )];
+}
sub _start {
@@ -25,8 +27,8 @@
$heap->{wheels} = {};
$heap->{children} = {};
+ $heap->{factory} = $opt->{factory};
$kernel->alias_set($Alias);
-
Log("$Alias starts.");
}
@@ -75,6 +77,7 @@
address => Socket::inet_ntoa($address),
port => $port,
sockinfo => $heap->{info}{$wid},
+ factory => $heap->{factory},
);
}
Deleted: trunk/main/server/lib/Haver/Server/Registry.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Registry.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Registry.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,72 +0,0 @@
-# Haver::Server::Registry - Index for users, channels, etc.
-#
-# Copyright (C) 2003 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::Registry;
-use strict;
-#use warnings;
-
-use Haver::Preprocessor;
-use 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 @EXPORT_OK = qw( $Registry );
-our $Registry;
-
-sub instance {
- my $class = shift;
-
- # don't warn about redefining a function.
- {
- no warnings;
- *old_instance = \&instance;
- *instance = \&self;
- }
-
- return $Registry = $class->SUPER::new(@_);
-}
-
-sub self { $Registry }
-
-sub new {
- croak "Can't call new on ", __PACKAGE__;
-}
-
-sub namespace {
- 'registry',
-}
-
-sub id {
- 'registry',
-}
-
-sub filename {
- my ($me) = @_;
- return File::Spec->catfile($Haver::Server::Object::StorageDir,
$me->namespace);
-}
-
-sub can_contain {
- my ($me, $obj) = @_;
-
- !$obj->isa(__PACKAGE__);
-}
-
-1;
Modified: trunk/main/server/lib/Haver/Server/Talker.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Talker.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Talker.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,42 +1,29 @@
package Haver::Server::Talker;
-use Haver::Base::Session -base;
-use Haver::Base::Session -XXX, -dumper;
use strict;
use warnings;
-use Haver::Server;
-use Haver::Server::Entity::Lobby;
-use Haver::Server::Entity::User;
+use Haver::Session -base;
use Haver::Protocol::Filter;
+use Haver::Wheel::Loader;
+use Haver::Server;
+use Haver::Server::Wheel::Login;
+use Haver::Server::Wheel::Main;
+
use POE::Wheel::ReadWrite;
use POE::Driver::SysRW;
our $VERSION = '0.08';
-our $Lobby = lobby Haver::Server::Entity::Lobby;
-my $NamePattern = qr/&?[a-z][a-z0-9_.'@-]+/i;
-
-sub valid_name {
- my $name = shift;
- return $name =~ $NamePattern;
+sub states {
+ return [qw(
+ _start _stop _default
+ input error flush
+ shutdown fail
+ )];
}
-sub reserved_name {
- for (shift) {
- return (/&/ or /\@/);
- }
-}
-
-states qw(
- _start _stop _default
- input error flush
- shutdown fail
-
- msg_HAVER
-);
-
sub _start {
my ($heap, $session, $kernel, $opt) = @_[ HEAP, SESSION, KERNEL,
ARG0];
my ($address, $socket, $port) = ($opt->{address}, delete $opt->{sock},
$opt->{port});
@@ -55,7 +42,10 @@
%$heap = (
%$opt,
client => $client,
+ lobby => $opt->{factory}->cache('lobby'),
+ loader => new Haver::Wheel::Loader,
);
+ $heap->{loader}->load_wheel('Haver::Server::Wheel::Login');
}
@@ -74,6 +64,8 @@
if (not $heap->{version}) {
Log('warning', "Client issued unknown command ($cmd)
before HAVER.");
Log('warning', 'Probably a search engine...');
+ $heap->{error} = 1;
+ $heap->{client} = undef;
$kernel->yield('shutdown');
} else {
Log('warning', "Client isseud unknown command $cmd");
@@ -127,6 +119,7 @@
sub shutdown {
my ($kernel, $heap, $session, @why) = @_[KERNEL, HEAP, SESSION, ARG0,
ARG1];
+ my $lobby = $heap->{lobby};
if ($heap->{shutdown}) {
Log('critical', 'Race condition: shutdown called more than
once!');
@@ -139,7 +132,7 @@
my $user = delete $heap->{user};
my %seen;
foreach my $name ($user->channels) {
- my $chan = $Lobby->fetch('channel', $name);
+ my $chan = $lobby->fetch('channel', $name);
$user->part($chan);
foreach my $u ($chan->contents('user')) {
unless ($seen{ $u->name }++) {
@@ -153,7 +146,7 @@
}
if (my $user = $heap->{user}) {
- $Lobby->remove($user->namespace, $user->name);
+ $lobby->remove($user->namespace, $user->name);
}
$kernel->alarm_remove_all();
}
@@ -167,168 +160,6 @@
}
}
-sub msg_HAVER {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($version) = @$args;
- Log('notice', 'Client is ' . $version);
- $heap->{client}->put(
- ['HAVER', $heap->{sockinfo}{host},
"Haver::Server/$Haver::Server::VERSION"]);
- $heap->{version} = $version;
-
- $kernel->state('msg_IDENT', __PACKAGE__);
- $kernel->state('msg_HAVER');
-}
-sub msg_IDENT {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name) = @$args;
- my $ns = 'user';
-
- if ($Lobby->contains($ns, $name)) {
- $kernel->yield('fail', "exists.$ns", $name);
- } elsif (not valid_name($name)) {
- $kernel->yield('fail', "invalid.$ns", $name);
- } elsif ($ns eq 'user' and reserved_name($name)) {
- $kernel->yield('fail', "reserved.$ns", $name);
- } else {
- my $user = new Haver::Server::Entity::User (
- name => $name,
- wheel => $heap->{client}, # weak reference!
- );
- $Lobby->add($user);
- $heap->{user} = $user;
- $heap->{client}->put(['HELLO', $name]);
- $kernel->state('msg_IDENT');
- foreach (qw( TO BYE IN JOIN PART OPEN )) {
- $kernel->state("msg_$_", __PACKAGE__);
- }
- }
-}
-
-sub msg_TO {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name, $type) = (shift @$args, shift @$args);
- my $user = $heap->{user};
- my $targ = $Lobby->fetch('user', $name);
-
-
- unless (valid_name($name)) {
- $kernel->yield('fail', "invalid.name", $name);
- return;
- }
- unless ($targ) {
- $kernel->yield('fail', 'unknown.user');
- return;
- }
- unless (defined $type) {
- $kernel->yield('fail', 'missing.type');
- return;
- }
-
-
- $targ->put(['FROM', $user->name, $type, @$args]);
-}
-
-sub msg_IN {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name, $type) = (shift @$args, shift @$args);
- my $user = $heap->{user};
- my $chan = $Lobby->fetch('channel', $name);
-
-
- unless (valid_name($name)) {
- $kernel->yield('fail', "invalid.name", $name);
- return;
- }
- unless ($chan) {
- $kernel->yield('fail', 'unknown.channel');
- return;
- }
- unless (defined $type) {
- $kernel->yield('fail', 'missing.type');
- return;
- }
-
- $chan->put(['IN', $chan->name, $user->name, $type, @$args]);
-}
-
-sub msg_JOIN {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name) = @$args;
- my $user = $heap->{user};
- my $chan = $Lobby->fetch('channel', $name);
-
- unless (valid_name($name)) {
- $kernel->yield('fail', "invalid.name", $name);
- return;
- }
- unless ($chan) {
- $kernel->yield('fail', 'unknown.channel');
- return;
- }
- if ($chan->contains('user', $user->name)) {
- $kernel->yield('fail', 'moron');
- return;
- }
-
- $user->join($chan);
- $chan->put(['JOIN', $chan->name, $user->name]);
-}
-
-sub msg_OPEN {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name) = @$args;
-
- unless (valid_name($name)) {
- $kernel->yield('fail', "invalid.name", $name);
- return;
- }
- if ($Lobby->contains('channel', $name)) {
- $kernel->yield('fail', 'exists.channel');
- return;
- }
-
- $Lobby->add(
- new Haver::Server::Entity::Channel (
- name => $name
- )
- );
- $heap->{client}->put(['OPEN', $name]);
- $kernel->yield('msg_JOIN', [$name]);
-
-}
-
-sub msg_PART {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- my ($name) = @$args;
- my $user = $heap->{user};
- my $chan = $Lobby->fetch('channel', $name);
-
- unless (valid_name($name)) {
- $kernel->yield('fail', 'invalid.name', $name);
- return;
- }
- unless ($chan) {
- $kernel->yield('fail', 'unknown.channel');
- return;
- }
- unless ($chan->contains('user', $user->name)) {
- $kernel->yield('fail', 'moron');
- return;
- }
-
- $chan->put(['PART', $chan->name, $user->name]);
- $user->part($chan);
-}
-
-
-
-sub msg_BYE {
- my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
- $kernel->yield('shutdown', 'bye', $args->[0]);
-}
-
-
-
1;
Added: trunk/main/server/lib/Haver/Server/Wheel/Login.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Wheel/Login.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Wheel/Login.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -0,0 +1,115 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Server::Wheel::Login;
+use strict;
+use warnings;
+
+use Haver::Server::Wheel -base;
+use Haver::Util qw( :name );
+
+our $VERSION = 0.02;
+
+sub setup {
+ my $self = shift;
+ $self->msg('HAVER');
+}
+
+sub msg_HAVER {
+ my ($self, $kernel, $heap, $args) = @_[OBJECT, KERNEL, HEAP, ARG0];
+ my ($version) = @$args;
+
+ Log('notice', 'Client is ' . $version);
+ $heap->{client}->put(
+ ['HAVER', $heap->{sockinfo}{host},
"Haver::Server/$Haver::Server::VERSION"]);
+ $heap->{version} = $version;
+ $self->define('msg_IDENT', 'msg_IDENT');
+}
+
+sub msg_IDENT {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my ($name) = @$args;
+ my $lobby = $_[HEAP]{lobby};
+ my $ns = 'user';
+
+ if ($lobby->contains($ns, $name)) {
+ $kernel->yield('fail', "exists.$ns", $name);
+ } elsif (not is_valid_name($name)) {
+ $kernel->yield('fail', "invalid.$ns", $name);
+ } elsif ($ns eq 'user' and is_reserved_name($name)) {
+ $kernel->yield('fail', "reserved.$ns", $name);
+ } else {
+ my $user = $heap->{factory}->make($ns,
+ name => $name,
+ wheel => $heap->{client}, # weak reference!
+ );
+ $lobby->add($user);
+ $heap->{user} = $user;
+ $heap->{client}->put(['HELLO', $name]);
+ $heap->{loader}->unload_wheel(__PACKAGE__);
+ $heap->{loader}->load_wheel('Haver::Server::Wheel::Main');
+ }
+}
+
+
+1;
+__END__
+=head1 NAME
+
+Haver::Server::Wheel::Login - description
+
+=head1 SYNOPSIS
+
+ use Haver::Server::Wheel::Login;
+ # Small code example.
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 INHERITENCE
+
+Haver::Server::Wheel::Login 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
+
Added: trunk/main/server/lib/Haver/Server/Wheel/Main.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Wheel/Main.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/main/server/lib/Haver/Server/Wheel/Main.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -0,0 +1,211 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Server::Wheel::Main;
+use strict;
+use warnings;
+
+use Haver::Server::Wheel -base;
+use Haver::Util 'is_valid_name';
+
+sub setup {
+ my $self = shift;
+ $self->msg('TO');
+ $self->msg('IN');
+ $self->msg('JOIN');
+ $self->msg('OPEN');
+ $self->msg('PART');
+ $self->msg('BYE');
+}
+
+sub msg_JOIN {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $lobby = $heap->{lobby};
+ my ($name) = @$args;
+ my $user = $heap->{user};
+ my $chan = $lobby->fetch('channel', $name);
+
+ unless (is_valid_name($name)) {
+ $kernel->yield('fail', "invalid.name", $name);
+ return;
+ }
+ unless ($chan) {
+ $kernel->yield('fail', 'unknown.channel');
+ return;
+ }
+ if ($chan->contains('user', $user->name)) {
+ $kernel->yield('fail', 'moron');
+ return;
+ }
+
+ $user->join($chan);
+ $chan->put(['JOIN', $chan->name, $user->name]);
+}
+
+sub msg_OPEN {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $lobby = $heap->{lobby};
+ my ($name) = @$args;
+
+ unless (is_valid_name($name)) {
+ $kernel->yield('fail', "invalid.name", $name);
+ return;
+ }
+ if ($lobby->contains('channel', $name)) {
+ $kernel->yield('fail', 'exists.channel');
+ return;
+ }
+
+ $lobby->add(
+ $heap->{factory}->make('channel',
+ name => $name
+ )
+ );
+ $heap->{client}->put(['OPEN', $name]);
+ $kernel->yield('msg_JOIN', [$name]);
+
+}
+
+sub msg_PART {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $lobby = $heap->{lobby};
+ my ($name) = @$args;
+ my $user = $heap->{user};
+ my $chan = $lobby->fetch('channel', $name);
+
+ unless (is_valid_name($name)) {
+ $kernel->yield('fail', 'invalid.name', $name);
+ return;
+ }
+ unless ($chan) {
+ $kernel->yield('fail', 'unknown.channel');
+ return;
+ }
+ unless ($chan->contains('user', $user->name)) {
+ $kernel->yield('fail', 'moron');
+ return;
+ }
+
+ $chan->put(['PART', $chan->name, $user->name]);
+ $user->part($chan);
+}
+
+
+sub msg_TO {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $lobby = $heap->{lobby};
+ my ($name, $type) = (shift @$args, shift @$args);
+ my $user = $heap->{user};
+ my $targ = $lobby->fetch('user', $name);
+
+
+ unless (is_valid_name($name)) {
+ $kernel->yield('fail', "invalid.name", $name);
+ return;
+ }
+ unless ($targ) {
+ $kernel->yield('fail', 'unknown.user');
+ return;
+ }
+ unless (defined $type) {
+ $kernel->yield('fail', 'missing.type');
+ return;
+ }
+
+
+ $targ->put(['FROM', $user->name, $type, @$args]);
+}
+
+sub msg_IN {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ my $lobby = $heap->{lobby};
+ my ($name, $type) = (shift @$args, shift @$args);
+ my $user = $heap->{user};
+ my $chan = $lobby->fetch('channel', $name);
+
+
+ unless (is_valid_name($name)) {
+ $kernel->yield('fail', "invalid.name", $name);
+ return;
+ }
+ unless ($chan) {
+ $kernel->yield('fail', 'unknown.channel');
+ return;
+ }
+ unless (defined $type) {
+ $kernel->yield('fail', 'missing.type');
+ return;
+ }
+
+ $chan->put(['IN', $chan->name, $user->name, $type, @$args]);
+}
+
+sub msg_BYE {
+ my ($kernel, $heap, $args) = @_[KERNEL, HEAP, ARG0];
+ $kernel->yield('shutdown', 'bye', $args->[0]);
+}
+
+
+
+
+1;
+__END__
+=head1 NAME
+
+Haver::Server::Wheel::Message - description
+
+=head1 SYNOPSIS
+
+ use Haver::Server::Wheel::Message;
+ # Small code example.
+
+=head1 DESCRIPTION
+
+FIXME
+
+=head1 INHERITENCE
+
+Haver::Server::Wheel::Message 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
+
Added: trunk/main/server/lib/Haver/Server/Wheel.pm
===================================================================
--- trunk/main/server/lib/Haver/Server/Wheel.pm 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/main/server/lib/Haver/Server/Wheel.pm 2005-06-19 07:36:52 UTC (rev
772)
@@ -0,0 +1,18 @@
+# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
+# This module is copyrighted, see end of file for details.
+package Haver::Server::Wheel;
+use strict;
+use warnings;
+use Haver::Wheel -base;
+use Haver::Logger 'Log';
+
+our $VERSION = 0.04;
+our @EXPORT_BASE = 'Log';
+
+sub msg {
+ my ($self, $word) = @_;
+ $self->provide("msg_$word", "msg_$word");
+}
+
+
+1;
Deleted: trunk/misc/poe-wheel-square/lib/POE/Wheel/Square/Loader.pm
===================================================================
--- trunk/misc/poe-wheel-square/lib/POE/Wheel/Square/Loader.pm 2005-06-17
01:11:39 UTC (rev 771)
+++ trunk/misc/poe-wheel-square/lib/POE/Wheel/Square/Loader.pm 2005-06-19
07:36:52 UTC (rev 772)
@@ -1,145 +0,0 @@
-# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
-# This module is copyrighted, see end of file for details.
-package POE::Wheel::Square::Loader;
-use strict;
-use warnings;
-use Carp;
-
-our $VERSION = '0.04';
-
-sub new {
- my $class = shift;
- my $self = {
- wheels => {},
- };
- bless $self, $class;
-}
-
-sub load_wheel {
- my ($self, $class, @args) = @_;
-
- if (exists $self->{wheels}{$class}) {
- croak "Plugin $class already loaded!";
- }
-
- my $object = $class->new(@args);
- $object->load;
- $self->{wheels}{$class} = $object;
-}
-
-sub unload_wheel {
- my ($self, $class) = @_;
- my $object = delete $self->{wheels}{$class};
- $object->unload;
-}
-
-sub wheels {
- my $self = shift;
- keys %{ $self->{wheels} };
-}
-
-sub unload_all_wheels {
- my ($self) = @_;
- map { $self->unload($_) } $self->wheels
-}
-
-sub fetch_wheel {
- my ($self, $class) = @_;
-
- if (exists $self->{wheels}{$class}) {
- $self->{wheels}{$class};
- } else {
- undef;
- }
-}
-
-
-1;
-__END__
-=head1 NAME
-
-POE::Wheel::Square::Loader - description
-
-=head1 SYNOPSIS
-
- use POE::Wheel::Square::Loader;
- use MyPlugin;
-
- # ... In some POE state ...
- my $loader = POE::Wheel::Square::Loader;
- $loader->load_wheel('MyPlugin', 'some', 'args');
- $_[HEAP]{loader} = $loader;
-
-=head1 DESCRIPTION
-
-This object maintains a list of wheel objects which have states loaded into a
session.
-
-FIXME: Write a better description.
-
-=head1 METHODS
-
-This class implements the following methods:
-
-=head2 new(Z<>)
-
-This returns a new POE::Wheel::Square::Loader object.
-
-=head2 load_wheel($class, @args)
-
-Creates a new object of class $class, passing @args to its new() class method.
-The newly created object will have its load() method called, which should load
states into the
-currently active L<POE::Session>.
-
-For details on defining wheels, see L<POE::Session::Plugin>.
-
-=head2 unload_wheel($class)
-
-Call unload() on the object associated with $class,
-and then destroy the said object.
-
-=head2 wheels(Z<>)
-
-Returns a list of the currently loaded class names.
-
-=head2 fetch_wheel($class)
-
-Returns the wheel object of type $class.
-Returns undef if $class was never loaded.
-
-=head2 unload_all_wheels(Z<>)
-
-Unload all currently loaded wheels.
-
-This is called when the wheel loader is DESTROY()'d, so you never really need
to call it.
-
-=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/>, L<POE>, L<POE::Session>, L<POE::NFA>.
-
-=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
-
Deleted: trunk/misc/poe-wheel-square/lib/POE/Wheel/Square.pm
===================================================================
--- trunk/misc/poe-wheel-square/lib/POE/Wheel/Square.pm 2005-06-17 01:11:39 UTC
(rev 771)
+++ trunk/misc/poe-wheel-square/lib/POE/Wheel/Square.pm 2005-06-19 07:36:52 UTC
(rev 772)
@@ -1,234 +0,0 @@
-# vim: set ts=4 sw=4 noexpandtab si ai sta tw=100:
-# This module is copyrighted, see end of file for details.
-package POE::Wheel::Square;
-use strict;
-use warnings;
-use Carp;
-use POE::Wheel;
-our $VERSION = '0.06';
-our $Kernel = $POE::Kernel::poe_kernel;
-
-sub new {
- my $class = shift;
- my $self = {
- # I only prefix these with underscores because I am paranoid of
- # subclasses clobbering them. :)
- _provided_states => [],
- _defined_states => { },
- _id => POE::Wheel::allocate_wheel_id(),
- };
- bless $self, $class;
- $self->provide("load_$self->{_id}", 'on_load');
- $self->provide("unload_$self->{_id}", 'on_unload');
- $self->setup(@_);
- return $self;
-}
-
-sub setup { }
-
-# POE state called when we load.
-sub on_load {
-
-}
-
-# POE state called when we unload.
-sub on_unload {
-
-}
-
-
-# This method is not really public. :)
-sub kernel {
- my ($self, $kernel) = @_;
- $Kernel = $kernel;
-}
-
-sub provide {
- my ($self, $state, $method) = @_;
- push @{ $self->{_provided_states} }, [ $state, $method ];
-}
-
-sub provided_states {
- my $self = shift;
- @{ $self->{_provided_states} };
-}
-
-sub defined_states {
- my $self = shift;
- keys %{ $self->{_defined_states} };
-}
-
-
-sub invoke {
- my $self = shift;
- my $act = shift;
- my $session = $Kernel->get_active_session();
- my $class = ref $self;
- $Kernel->call($session, join('_', $act, $self->ID));
-}
-
-sub ID { shift->{_id} }
-
-# Load all provided states.
-sub load {
- my $self = shift;
- map {
- $self->define(@$_)
- } $self->provided_states;
- $self->invoke('load');
-}
-
-# Unload all *defined* states.
-sub unload {
- my $self = shift;
- $self->invoke('unload');
- map {
- $self->undefine($_)
- } $self->defined_states;
-}
-
-sub define {
- my ($self, $state, $method) = @_;
- $method ||= $state;
-
- croak "State $state defined; can't redefine"
- if exists $self->{_defined_states}{$state};
- $self->{_defined_states}{$state} = $method;
- $Kernel->state($state,
- $self->{package} ? ref $self : $self,
- $method
- );
-}
-
-sub undefine {
- my ($self, $state) = @_;
-
- croak "State $state not defined; can't undefine"
- unless exists $self->{_defined_states}{$state};
- delete $self->{_defined_states}{$state};
- $Kernel->state($state);
-}
-
-
-sub DESTROY {
- my $self = shift;
- POE::Wheel::free_wheel_id($self->ID);
-}
-
-1;
-
-__END__
-=head1 NAME
-
-POE::Wheel::Square - Base class for modules that extend POE::Session at
runtime.
-
-=head1 SYNOPSIS
-
- package MyPlugin;
- use POE;
- use base 'POE::Wheel::Square';
-
- sub setup {
- my $self = shift;
- $self->provide('foo', 'on_foo');
- }
-
- sub on_foo {
- my ($kernel, $heap, $self) = @_[KERNEL, HEAP, OBJECT];
- # ...
- }
-
-=head1 DESCRIPTION
-
-This module allows the loading and unloading of object states into a running
L<POE::Session>.
-
-Plugins are not unlike a L<POE::Wheel>, except instead of producing events,
they respond to them.
-
-This behavior is similar to that of L<POE::NFA>, except it is added to
existing L<POE::Session>
-sessions.
-
-=head1 METHODS
-
-This class implements the following methods:
-
-=head2 new(@args)
-
-This returns a new wheel object.
-Its arguments (@args) are passed to setup()
-
-=head2 setup(Z<>)
-
-B<Do not call this method>. It is called by new().
-
-Subclasses should overload this method and use it call provide()
-to specify which states they define in the current session.
-
-=head2 ID(Z<>)
-
-This returns the unique wheel id of the square wheel.
-
-=head2 define($state [, $method ])
-
-Bind $state in the currently active session to the method $method of $self.
-If $method is omitted, it defaults to the same name as $state.
-
-=head2 undefine($state)
-
-Remove the binding of $state in the current session, if and only if it was
previously
-defined by our $self.
-
-=head2 provide($state [, $method ])
-
-This is like a delayed define(). It will only occurs when load() is called.
-
-=head2 load(Z<>)
-
-Load all C<provide>'d states.
-
-=head2 unload(Z<>)
-
-This undefines (with undefine()) all states that were defined with define()
-or provided() and subsequently loaded with load().
-
-=head2 on_load
-
-This is method is called as a POE state when the plugin is loaded.
-$_[KERNEL], $_[SESSION], etc, should all be correct.
-
-=head2 on_unload
-
-This is method is called as a POE state when the plugin is unloaded.
-$_[KERNEL], $_[SESSION], etc, should all be correct.
-
-=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/>, L<POE::Wheel::Square::Loader>,
-L<POE>, L<POE::Session>, L<POE::NFA>.
-
-=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
-
Deleted: trunk/misc/poe-wheel-square/t/001_wheel.t
===================================================================
--- trunk/misc/poe-wheel-square/t/001_wheel.t 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/misc/poe-wheel-square/t/001_wheel.t 2005-06-19 07:36:52 UTC (rev
772)
@@ -1,25 +0,0 @@
-#!/usr/bin/perl
-# vim: set ft=perl:
-use strict;
-use Test::More tests => 4;
-
-my $class = 'POE::Wheel::Square';
-use_ok($class);
-can_ok($class, 'new');
-
-my $plugin = $class->new;
-
-isa_ok($plugin, $class);
-can_ok($plugin,
- qw(
- provide
- load
- unload
- define
- undefine
- provided_states
- defined_states
- setup
- kernel
- )
-);
Deleted: trunk/misc/poe-wheel-square/t/002_loader.t
===================================================================
--- trunk/misc/poe-wheel-square/t/002_loader.t 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/misc/poe-wheel-square/t/002_loader.t 2005-06-19 07:36:52 UTC (rev
772)
@@ -1,20 +0,0 @@
-#!/usr/bin/perl
-# vim: set ft=perl:
-use strict;
-use Test::More tests => 4;
-
-my $class = 'POE::Wheel::Square::Loader';
-require_ok($class);
-can_ok($class, 'new');
-
-my $loader = $class->new;
-isa_ok($loader, $class);
-can_ok($loader,
- qw(
- load_wheel
- unload_wheel
- wheels
- fetch_wheel
- unload_all_wheels
- )
-);
Deleted: trunk/misc/poe-wheel-square/t/003_run.t
===================================================================
--- trunk/misc/poe-wheel-square/t/003_run.t 2005-06-17 01:11:39 UTC (rev
771)
+++ trunk/misc/poe-wheel-square/t/003_run.t 2005-06-19 07:36:52 UTC (rev
772)
@@ -1,95 +0,0 @@
-#!/usr/bin/perl
-# vim: set ft=perl:
-use strict;
-use Test::More tests => 7;
-use POE;
-use POE::Wheel::Square;
-use POE::Wheel::Square::Loader;
-
-BEGIN {
- package MyWheel;
- use POE;
- use base 'POE::Wheel::Square';
-
- sub setup {
- my $self = shift;
- $self->provide('foo', 'on_foo');
- $self->provide('bar', 'on_bar');
- $self->provide('baz', 'on_baz');
- }
-
- sub on_load {
- my $self = $_[OBJECT];
- $self->{load} = 1;
- }
-
- sub on_unload {
- my $self = $_[OBJECT];
- $self->{unload} = 1;
- }
- sub on_foo {
- my $self = $_[OBJECT];
- $self->{foo}++;
- }
-
- sub on_bar {
- my $self = $_[OBJECT];
- $self->{bar}++;
- }
-
- sub on_baz {
- my $self = $_[OBJECT];
- $self->{baz}++;
- if ($self->{baz} == 1) {
- $_[KERNEL]->yield('bye');
- }
- }
-}
-
-POE::Session->create(
- inline_states => {
- _start => \&on_start,
- _stop => \&on_stop,
- bye => \&on_bye,
- },
-);
-
-POE::Kernel->run;
-
-sub on_start {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- my $loader = new POE::Wheel::Square::Loader;
- $loader->load_wheel('MyWheel');
- $heap->{loader} = $loader;
-
- diag "Starting session";
- foreach my $state (qw( foo bar baz )) {
- $kernel->yield($state) for 1 .. 3;
- }
-}
-
-sub on_stop {
- diag "Stopping session";
-}
-
-sub on_bye {
- my ($kernel, $heap) = @_[KERNEL, HEAP];
- my $loader = $heap->{loader};
- my $p = $loader->fetch_wheel('MyWheel');
-
- diag "Saying goodbye";
- is($p->{foo}, 3, "Called foo 3 times");
- is($p->{bar}, 3, "Called bar 3 times");
- is($p->{baz}, 3, "Called baz 3 times");
-
- diag "Calling foo again";
- $kernel->call($_[SESSION], 'foo');
- is($p->{foo}, 4, "foo is now 4");
-
- diag "Unloading MyWheel";
- $loader->unload_wheel('MyWheel');
- $kernel->call($_[SESSION], 'foo');
- isnt($p->{foo}, 5, "foo is not 5");
- ok($p->{load}, "on_load was called.");
- ok($p->{unload}, "on_unload was called.");
-}
