debug results from the CPAN

Acme-MUDLike
view release on metacpan or search on metacpan
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"> &lt;-- nickname<br>
                    <input type="password" name="admin" value="$admin_tmp"> &lt;-- 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 }
( run in 1.269 second using v1.01-cache-2.11-cpan-39bf76dae61 )