Acme-MUDLike
view release on metacpan or search on metacpan
lib/Acme/MUDLike.pm view on Meta::CPAN
# into the object returned by thingie->whatever
#
# * /list (like look, but with stringified object references)
#
# * /mark <n> ... or... /mark <stringified obj ref>
#
# * messages still in duplicate when the same player logs in twice; make room's tell_object operate uniquely.
#
# * messages in triplicate because each player has three routines and is inserted into the floor three times. oops.
#
# * build the ajax.chat.js into source. -- okay, test.
#
# * eval, call
#
# * inventory's insert() method should set the insertee's environment to itself. that way, all objects have an environment.
#
# * Commands need to do $floor->tell_object or $self->tell_object rather than output directly.
#
# * Put @messages into the room ($floor). Get the chat action out of the main loop. Dispatch all
# actions. Maybe.
#
our $password; # Acme::State friendly
our $floor; # holds all other objects
our $players; # holds all players; kind of like $floor except in the future, inactive players might get removed from the floor, or there might be multiple rooms
my $continuity;
my $got_message; # diddled to wake the chat event watchers
$SIG{PIPE} = 'IGNORE';
sub new {
my $package = shift;
my %args = @_;
die "We've already got one" if $continuity;
$password = delete $args{password} if exists $args{password};
$password ||= join('', map { $_->[int rand scalar @$_] } (['a'..'z', 'A'..'Z', '0'..'9']) x 8),
my $staticp = sub {
# warn "staticp: url->path: ``@{[ $_[0]->url->path ]}''";
return 0 if $_[0]->url->path =~ m/\.js$/;
# warn "staticp: dynamic js handling override not engaged";
return $_[0]->url->path =~ m/\.(jpg|jpeg|gif|png|css|ico|js)$/
};
$continuity = $args{continuity} || Continuity->new(
staticp => sub { $staticp->(@_); },
callback => sub { login(@_) },
path_session => 1,
port => 2000,
%args,
);
print "Admin:\n", $continuity->adapter->daemon->url, '?admin=', $password, '&nick=', (getpwuid $<)[0], "\n";
$floor ||= Acme::MUDLike::room->new();
$players ||= Acme::MUDLike::inventory->new();
bless { }, $package;
}
sub loop { my $self = shift; $continuity->loop(@_); }
sub header {
qq{
<html><head>
<script src="/jquery.js" type="text/javascript"></script>
<script src="/chat.js" type="text/javascript"></script>
</head><body>
};
}
sub footer { qq{</body></html>\n}; }
sub login {
my $request = shift;
#
# per-user variables
#
my $player;
# STDERR->print("debug: " . $request->request->url->path . "\n"); # XXX
# STDERR->print("debug: " . $request->request->as_string . "\n"); # XXX
$SIG{PIPE} = 'IGNORE'; # XXX not helping at all. grr.
#
# static files
#
if($request->request->url->path eq '/chat.js') {
# warn "handling chat.js XXX: ". $request->request->url->path;
$request->print(Acme::MUDLike::data->chat_js());
return;
} elsif($request->request->url->path eq '/jquery.js') {
# warn "handling jquery.js XXX: ". $request->request->url->path;
$request->print(Acme::MUDLike::data->jquery());
return;
}
#
# login
#
while(1) {
my $nick_tmp = $request->param('nick');
my $admin_tmp = $request->param('admin');
if(defined($nick_tmp) and defined($admin_tmp) and $nick_tmp =~ m/^[a-z]{2,20}$/i and $admin_tmp eq $password) {
my $nick = $nick_tmp;
$player = $players->named($nick) || $players->insert(Acme::MUDLike::player->new(name => $nick), );
$player->request = $request;
# @_ = ($player, $request,); goto &{Acme::MUDLike::player->can('command')};
$player->command($request); # doesn't return
}
# warn "trying login again XXX";
$nick_tmp ||= ''; $admin_tmp ||= '';
$nick_tmp =~ s/[^a-z]//gi; $admin_tmp =~ s/[^a-z0-9]//gi;
$request->print(
header, # $msg,
qq{
<form method="post" action="/">
<input type="text" name="nick" value="$nick_tmp"> <-- nickname<br>
<input type="password" name="admin" value="$admin_tmp"> <-- admin password<br>
<input type="submit" value="Enter"><br>
</form>
},
footer,
);
$request->next();
}
}
#
# object
#
package Acme::MUDLike::object;
sub new { my $package = shift; bless { @_ }, $package; }
sub name :lvalue { $_[0]->{name} }
sub environment :lvalue { $_[0]->{environment} }
sub use { }
sub player { 0 }
sub desc { }
sub tell_object { }
sub get { 1 } # may be picked up
sub id { 0 }
#
# inventory
#
package Acme::MUDLike::inventory;
sub new {
# subclass this to build little container classes or create instances of it directly
my $package = shift; bless [ ], $package;
}
sub delete {
my $self = shift;
my $name = shift;
for my $i (0..$#$self) {
return splice @$self, $i, 1, () if $self->[$i]->id($name);
}
}
sub insert {
my $self = shift;
my $ob = shift;
UNIVERSAL::isa($ob, 'Acme::MUDLike::object') or Carp::confess('lit: ' . $ob . ' ref: ' . ref($ob));
push @$self, $ob;
$ob->environment = $self;
$ob;
}
sub named {
my $self = shift;
my $name = shift;
for my $i (@$self) {
return $i if $i->id($name);
}
}
sub apply {
my $self = shift;
my $func = shift;
my @args = @_;
my @ret;
for my $i (@$self) {
if(ref($func) eq 'CODE') {
push @ret, $func->($i, @args);
} else {
push @ret, $i->can($func)->($i, @args);
}
}
return @ret;
}
sub contents {
my $self = shift;
return @$self;
}
#
# room
#
package Acme::MUDLike::room;
push our @ISA, 'Acme::MUDLike::inventory';
sub tell_object {
my $self = shift;
my $message = shift;
# rather than buffering messages, room objects recurse and distribute the message to everyone and everything in it
# $self->apply('tell_object', $message);
my %already_told;
$self->apply(sub { return if $already_told{$_[0]}++; $_[0]->tell_object($message); }, );
}
#
# players
#
package Acme::MUDLike::players;
push our @ISA, 'Acme::MUDLike::inventory'; # use base 'Acme::MUDLike::inventory';
#
# player
#
package Acme::MUDLike::player;
push our @ISA, 'Acme::MUDLike::object';
sub player { 1 }
sub new {
my $pack = shift;
bless {
inventory => Acme::MUDLike::inventory->new,
messages => [ ],
@_,
}, $pack;
}
sub request :lvalue { $_[0]->{request} }
sub id { $_[0]->{name} eq $_[1] or $_[0] eq $_[1] }
sub name { $_[0]->{name} }
sub password { $_[0]->{password} }
sub x :lvalue { $_[0]->{x} }
sub y :lvalue { $_[0]->{y} }
sub xy { $_[0]->{x}, $_[0]->{y} }
sub get { 0; } # can't be picked up
sub inventory { $_[0]->{inventory} }
sub evalcode :lvalue { $_[0]->{evalcode } }
sub current_item :lvalue { $_[0]->{current_item} }
sub tell_object {
my $self = shift;
my $msg = shift;
push @{$self->{messages}}, $msg;
shift @{$self->{messages}} if @{$self->{messages}} > 100;
$got_message = 1; # XXX wish this didn't happen for each player but only once after all players got their message
}
sub get_html_messages {
my $self = shift;
return join "<br>\n", map { s{<}{\<}gs; s{\n}{<br>\n}g; $_ } $self->get_messages;
}
sub get_messages {
my $self = shift;
my @ret;
# this is written out long because I keep changing it around
for my $i (1..20) {
exists $self->{messages}->[-$i] or last;
my $msg = $self->{messages}->[-$i];
push @ret, $msg;
}
return reverse @ret;
}
sub header () { Acme::MUDLike::header() }
sub footer () { Acme::MUDLike::footer() }
sub command {
my $self = shift;
my $request = shift;
# this is called by login() immediately after verifying credientials
if($request->request->url->path =~ m/pushstream/) {
# warn "pushstream path_session handling XXX";
my $w = Coro::Event->var(var => \$got_message, poll => 'w');
while(1) {
$w->next;
# warn "got_message diddled XXX";
# on submitting the form without a JS background post, the poll HTTP connection gets broken
$SIG{PIPE} = 'IGNORE';
( run in 2.242 seconds using v1.01-cache-2.11-cpan-6aa56a78535 )