#!/usr/bin/perl -wT

require 5.005;
use strict;
use IO::Socket;
use IO::Select;

# IMPORTANT: You must change these settings before using Chant:
my $port = 4242;              # (may also be specifed on command line)
my $superuser = 'davisagli';  # what do you want YOUR username to be?
my $user_file = 'users';      # where should user info be stored?
my $room_file = 'rooms';      # where should room info be stored?

# attempt to get port # from command line
$port = scalar(@ARGV)>0 ? $ARGV[0] : $port;

die "You must modify some basic settings for Chant" if grep {!defined} ($port,$superuser,$user_file,$room_file);

$|++; # enable autoflush for logging messages to STDOUT

# create main socket
my $listener = IO::Socket::INET->new (
               Proto => 'tcp',
               LocalPort => $port,
               Listen => 3,        # number of sockets to queue
               Reuse => 1          # allow immediate restart after crash
             ) or die $!;
print "Chantserver started on port $port\r\n";

# create socket selection
my $select = IO::Select->new($listener);

my @chanters;     # chanter objects, keyed by fileno
my %accounts;     # all users, keyed by username
my %users;        # all connected users, by username
my %rooms;        # all rooms, by room name

# create root chantroom (the name may be changed)
my $root = Chantroom->new('root', $superuser);

# reserve some usernames
$accounts{all} = undef;
$accounts{room} = undef;

$SIG{'PIPE'} = 'IGNORE';

# load saved user and room data
load_rooms();
load_users();

# set up interrupt handler -- this will only work in unix systems.
# If you want to stop chant in Windows, use the /shutdown command
# or put a .QUIT file in chant's working directory.
my $quit = 0;
use sigtrap handler => sub {$quit++}, qw(normal-signals);

# the main loop:
MAIN: until ($quit or -e '.QUIT') {
   # loop while there are waiting connections:
   while(scalar (my @ready = $select->can_read(3))) {
      #loop through each waiting connection:
      for my $socket (@ready) {
         if($socket == $listener) {
            # if it's a new connection, set up a new Chanter:
            my $new_socket = $listener->accept;
            $select->add($new_socket);
            Chanter->new($new_socket);
         } else {
            # if there's input from an existing connection,
            # call the chanter's current input handler:
            my $chanter = $chanters[$socket->fileno];
            defined $chanter ? &{$chanter->{handler}}() : print "unknown chanter: # $socket->fileno\n";
         }
         last MAIN if $quit or -e '.QUIT'; # exit main loop if necessary...
      }
   }
}

# (this runs after the main loop has ended:)

# save rooms and users
save_rooms();
save_users();

# clean up
print "Chant shutdown completed successfully.\n";
unlink '.QUIT' if -e '.QUIT';

# ___end of main program___

sub load_rooms {
# loads room data from the $room_file
   -e $room_file or print("Room file $room_file not found.  A new one will be created.\n"), return;
   open ROOMS, $room_file or die "Error opening room file ($room_file)";
   while (<ROOMS>) {
      my ($name, $owner, $private, $ban_allow) = /^([^\r]*)\r([^\r]*)\r([^\r]*)\r([^\r]*)/;
      exists $rooms{$name} and print("Duplicate room entry for $name found and ignored at $room_file line $..\n"), next;
      my $room = {
         name      => $name,
         owner     => $owner,
         private   => $private,
         $private ? 'allow' : 'ban' => {map {$_,''}(split /\s+/, $ban_allow)}
      };
      $rooms{$name} = $room;
   }
   close ROOMS;
   print "Loaded rooms from $room_file.\n";
}

sub save_rooms {
# saves room data to $room_file
   open ROOMS, ">$room_file" or print("Error opening room file ($room_file).  Rooms not saved!!!\n"), return 0;
   for (values %rooms) {
      print ROOMS join("\r", $_->{name}, $_->{owner}, $_->{private}, join(' ', sort keys %{$_->{$_->{private}?'allow':'ban'}})), "\n" if defined and $_ ne $rooms{root};
   }
   print "Rooms saved to $room_file.\n";
}

sub load_users {
# loads user data from $user_file
   -e $user_file or print("User file $user_file not found.  A new one will be created.\n"), return;
   open USERS, $user_file or die "Error opening user file ($user_file)";
   while (<USERS>) {
      my ($name, $password, $room, $ignore, $awaiting, $awaitedby, $msgbuf) = /^([^\x00]*)\x00([^\x00]*)\x00([^\x00]*)\x00([^\x00]*)\x00([^\x00]*)\x00([^\x00]*)\x00([^\x00]*)\n$/;
      defined $name or next;
      exists $accounts{$name} and print("Duplicate user entry for $name found and ignored at $user_file line $..\n"), next;
      $msgbuf =~ s/\r\n|\r|\n/\r\n/g;
      my $user = {
         name      => $name,
         password  => $password,
         msgbuf    => $msgbuf,

         ignore    => {map {$_,undef}(split /\s+/, $ignore)},
         awaiting  => {map {$_,undef}(split /\s+/, $awaiting)},
         awaitedby => {map {$_,undef}(split /\s+/, $awaitedby)}
      };
      $user->{room} = ::resolve(exists $rooms{$room} ? $room : 'root', \%rooms);
      $accounts{$name} = $user;
   }
   close USERS;
   print "Loaded user accounts from $user_file.\n\n";
}

sub save_users {
# saves user data to $user_file
   open USERS, ">$user_file" or print("Error opening user file ($user_file).  Users not saved!!!\n"), return 0;
   for (values %accounts) {
      defined or next;
      $_->{msgbuf} =~ s/\r\n|\n/\r/g;
      print USERS join("\x00", $_->{name}, $_->{password}, $_->{room}->{name}, join(' ', sort keys %{$_->{ignore}}), join(' ', sort keys %{$_->{awaiting}}), join(' ', sort keys %{$_->{awaitedby}}), $_->{msgbuf}), "\n";
   }
   close USERS;
   print "Users saved to $user_file.\n";
}

sub resolve {
# given an input string and a hash, finds the hash key for which the string
# is an abbreviation and returns it's associated value, or undef if not found
   my ($input, $target) = @_;

   return $target->{$input} if exists $target->{$input};
   for (sort keys %$target) { return $target->{$_} if /^\Q$input/i }
   return undef;
}

{
package Chantroom;
use strict;

sub new {
   my($class, $name, $owner, $private) = @_;

   my $self = {
      'name'  => $name,
      'owner' => defined $owner ? $owner : undef,
      'users' => {},
      'private' => defined $private ? $private : 0,
      'ban'   => {},
      'allow' => {}
   };
   bless $self, $class;
   $rooms{$name} = $self;
   return $self;
}

} # end of package Chantroom

{
# this is the chanter object; one will be created for each connection
package Chanter;

use strict;
use Term::ANSIColor qw/:constants/;

sub new {
# starts setting up a new chanter
   my($class,$socket) = @_;

   # create new chanter object
   my $self = {
      'socket'   => $socket,

      'handler'  => undef,
      'nexthandlers' => [],
      'quithandlers' => [],

      'inbuf'    => '',
      'outbuf'   => '',
      'writable' => 1,

      'lastcmd'  => undef,
      'lastmsger'=> undef,
      'buflastmsger' => undef,

      'user'     => undef
   };
   bless $self,$class;
   $chanters[$socket->fileno] = $self;

   $self->log( '[', $self->{socket}->peerhost, '] connected');

   # send welcome message and prompt for username
   $self->welcome;
   $self->write(BOLD, 'Username: ', RESET);

   # set next connection handler to be the username-retriever
   $self->{handler} = sub { $self->get_username };

   return $self;
}

sub welcome {
# sends welcome/about message to a user
   my ($self) = @_;
   my ($bold, $reset) = (BOLD, RESET);

   my $welcome = <<END;
$bold
                  CCC  H   H    A    N   N  TTTTT
                 C     H   H   A A   NN  N    T
                C      HHHHH  AAAAA  N N N    T
                 C     H   H  A   A  N  NN    T
                  CCC  H   H  A   A  N   N    T
$reset
Welcome to the Chant chatroom server, written in 100% pure Perl.
Copyright 2001 David Glick; distributed under the terms of the GNU GPL.

Thanks to Brian Slesinsky for his excellent tutorial on which this is based:
http://hotwired.lycos.com/webmonkey/97/18/index2a.html

Enter ${bold}/help$reset for a list of commands.
Have fun chanting!

END
   $welcome =~ s:\r\n|\n|\r:\r\n:g;
   $self->write($welcome);
}

sub get_username {
# retrieves a valid username from the client
   my($self) = @_;

   # read in the username request
   defined(my $name = $self->read) or return;
   $name eq '' and $self->write(BOLD, "Username: ", RESET), return;

   # make sure it's alphanumberic
   ($name) = $name =~ /^(\w+)$/;
   defined $name or $self->write(BOLD, RED, "The username must only contain alphanumeric characters. Please pick another: ", RESET), return;

   # make sure we don't duplicate usernames
   exists $users{$name} and $self->write(BOLD, RED, "Username $name is already in use.  Please choose another name: ", RESET), return;

   $self->log("user: $name");

   # if this is an existing user, check their password
   # if it's a new user, set up their account
   exists $accounts{$name} ? $self->check_password($name,sub{$self->setup_user($name)}) : $self->create_account($name);
}

sub check_password {
# performs a password check on a user; calls $success_handler if they pass it,
# and calls $fail_handler or disconnects them if they don't
   my ($self, $name, $success_handler, $fail_handler, $step, $attempt) = @_;
   $step = 0 unless defined $step;

   SWITCH: {
   $step == 0 and do {
      # first step: prompt for the password
      my $prompt = RESET . BOLD . "Enter your password: " . CONCEALED;
      $self->{socket}->syswrite($prompt, length $prompt); $self->{writable} = 0;
      $self->{handler} = sub { $self->check_password($name, $success_handler, $fail_handler, 1) };
      return };
   $step == 1 and do {
      # second step: check the password
      defined(my $pw = $self->read) or return; # read in the password
      $attempt = 1 unless defined $attempt;

      # unless they entered the correct password:
      unless ($pw eq $accounts{$name}->{password}) {
         $self->log("$name failed password check");
         $self->write(BOLD, RED, "Incorrect password. ", RESET);

         # if they've failed 3 times, call $fail_handler or disconnect them
         delete $accounts{$name}, (defined $fail_handler ? &$fail_handler() : $self->leave), return if $attempt == 3;

         # prompt to have them enter it again
         my $prompt = RESET . BOLD . "Try again: " . CONCEALED;
         $self->{socket}->syswrite($prompt, length $prompt); $self->{writable} = 0;
         $self->{handler} = sub { $self->check_password($name, $success_handler, $fail_handler, 1, $attempt+1) };
         return;
      }

      # if they entered it correctly, call the success handler
      $self->log("$name succeeded password check");
      &$success_handler();
      return };
   }
}

sub create_account {
# creates a new account for $name
   my ($self, $name, $step, $password) = @_;
   $step = 0 unless defined $step;

   SWITCH: {
    $step == 0 and do {
       # step one: prompt to make sure they realize they're making a new account
       $accounts{$name} = undef; # make sure no one else tries to create this account
       $self->write(BOLD, "Create new user $name [Y/n]? ", RESET); $self->{writable} = 0;
       $self->{handler} = sub { $self->create_account($name, 1) };
       return };
    $step == 1 and do {
       #step two: if they want to continue, prompt them to enter a new password
       defined(my $confirm = $self->read) or return;
       $confirm eq '' and $confirm = 'y';
       $confirm = lc $confirm;
       $confirm =~ /^y$|^n$/ or $self->write(BOLD, RED, "Please enter y or n: ", RESET), $self->{writable} = 0, return;
       $self->leave, return if $confirm eq 'n';

       $self->get_new_password( sub{$self->create_account($name, 2, $_[0])} );
       return };
    $step == 2 and do {
       #step three: set up the account and call setup_user
       my $user = {
          name      => $name,
          password  => $password,
          msgbuf    => '',
          room      => $root,
          ignore    => {},
          awaiting  => {},
          awaitedby => {}
       };
       $accounts{$name} = $user;
       $self->log("new user: $name");

       $self->setup_user($name);

       return };
   }
}

sub get_new_password {
# retrieves a new password from a user, and passes it to $handler
   my ($self, $handler, $step, $password) = @_;
   $step = 0 unless defined $step;

   SWITCH: {
   $step == 0 and do {
      # step one: prompt for the password
      my $prompt = RESET . BOLD . "Please choose a new password: " . CONCEALED;
      $self->{socket}->syswrite($prompt, length $prompt); $self->{writable} = 0;
      $self->{handler} = sub { $self->get_new_password($handler, 1) };
      return };
   $step == 1 and do {
      # step 2: if they entered a password, have them confirm it
      defined(my $pw = $self->read) or return;

      $self->get_new_password($handler, 0), return if $pw eq '';

      my $prompt = RESET . BOLD . "Confirm your password: " . CONCEALED;
      $self->{socket}->syswrite($prompt, length $prompt); $self->{writable} = 0;
      $self->{handler} = sub { $self->get_new_password($handler,2,$pw) };
      return };
   $step == 2 and do {
      # step 3: make sure they match, and if so pass it to $handler
      defined(my $pw = $self->read) or return;

      unless ($pw eq $password) {
       my $prompt = RESET . BOLD . RED . "The passwords did not match.  Please choose a new password: " . CONCEALED;
       $self->{socket}->syswrite($prompt, length $prompt); $self->{writable} = 0;
       $self->{handler} = sub { $self->get_new_password($handler,1) };
       return;
      }

      &$handler($password);
      return };
   }
}

sub create_room {
# creates a new room, with this user as the owner
   my ($self, $name, $step) = @_;
   $step = 0 unless defined $step;

   SWITCH: {
   $step == 0 and do {
      # step one: prompt for public/private-ness
      $self->write(BOLD, "Do you want the $name chantroom to be public [Y/n]? ", RESET); $self->{writable} = 0;
      $self->{handler} = sub{$self->create_room($name, 1)};
      return };
   $step == 1 and do {
      # step two: retrieve the answer to the above, ...
      defined(my $private = $self->read) or return;

      $private eq '' and $private = 'y';
      $private = lc $private;
      $private =~ /^y$|^n$/ or $self->write(BOLD, RED, "Please enter y or n: ", RESET), $self->{writable} = 0, return;
      $private = ($private eq 'y') ^ 1;

      # ...set up the new room, and send this user there
      my $room = Chantroom->new($name,$self->{user}->{name},$private);
      $self->log("$self->{user}->{name} created $name chantroom");
      $self->goto_room($room);
      $self->{handler} = $self->next_handler;
      return };
   }
}

sub setup_user {
# finishes logging a user into Chant
   my ($self, $name) = @_;

   # store and log user name
   $self->{user} = $accounts{$name};
   $users{$name} = $self;

   # send welcome and stored messages
   $self->write(GREEN, "Welcome to Chant, $name!", RESET, "\r\n");
   $self->write(GREEN, "Here are your stored messages: ", RESET, "\r\n", $self->{user}->{msgbuf}) unless $self->{user}->{msgbuf} eq '';
   $self->{user}->{msgbuf} = '';

   # tell people on this user's awaitedby list that they have arrived
   for my $recipient (keys %{$self->{user}->{awaitedby}}) {
      defined (my $user = ::resolve($recipient, \%accounts)) or next;
      defined (my $conn = ::resolve($user->{name}, \%users)) or next;
      $conn->write(GREEN, "[$name just logged in.]", RESET, "\r\n") unless exists $user->{ignore}->{$name};
   }

   # send this user to the room they were in when they last logged out
   $self->goto_room($self->{user}->{room}) or ($self->{user}->{room} eq $root or $self->goto_room($root)) or ($self->leave, return);

   # tell controller to enter the main handler on subsequent calls
   $self->{handler} = sub { $self->chant };
}

sub chant {
# the main handler while chanting
   my($self) = @_;

   # retrieve a line from the client
   defined(my $line = $self->read) or return;
   return if $line =~ /^\s*$/;

   # handle commands
   $self->log("$self->{user}->{name}: $line");
   $self->resolve_cmd($line);

   # tell controller where to go next
   $self->next_handler;

   # store this command
   $self->{lastcmd} = $line;
}

sub next_handler {
# returns a reference to any queued input handlers, or to $self->chant()
   my ($self) = @_;

   if (defined (my $next = shift @{$self->{nexthandlers}})) { &$next() }
      else { $self->{handler} = sub{$self->chant} }
}

sub resolve_cmd {
# determines which command should be handled, and calls the handler
   my ($self, $line, $to) = @_;
   my $name = $self->{user}->{name};

   # if line starts with '/':
   if ($line =~ /^\/.*$/) {
      my ($cmd, $data) = $line =~ /^\/(\S*)\s*(.*)$/;

      # list of commands that can match -- in the order that they match
      my @valid = qw/about await add goto help ignore invite list me msg ping password pray repeat reply quit unignore unawait who where/;
      ($self->{room}->{owner} eq $name or $name eq $superuser) and push @valid, qw/allow ban delete kick private public unallow unban/;
      $name eq $superuser and push @valid, qw/eval force save shutdown su yell/;

      # figure out which commmand the input is an abbreviation for
      my $command;
      unless ($cmd eq '') { /^\Q$cmd/i and $command = $_, last for @valid }

      # if a valid command was found, handle it
      # if no valid command was found but one was entered in, handle it as the recipient of a /msg
      # if no command was entered (the line starts with / followed by whitespace), treat it as a /reply
      defined $command ? $self->cmd($command, $data, $to) : ($cmd ne '' ? $self->cmd('msg', "$cmd $data") : $self->cmd('reply', $data));
   } else {
      # if command line didn't start with '/', broadcast it as a message to everyone
      $self->dispatch( (defined $to?$to:''), "$self->{user}->{name}> ", RESET, $line);
   }
}

sub cmd {
# handles the various chat commands
   my ($self, $cmd, $data, $to) = @_;

   my $reset = RESET;
   my $name = $self->{user}->{name};
   my $room = $self->{room};
   my $owner = ($name eq $room->{owner});
   $cmd = lc $cmd;

   SWITCH: for ($cmd) {
    # commands for all users:
    /^about$/ and $self->welcome, return;
    /^add$/   and do {
      exists $rooms{$data} and $self->write(BOLD, RED, "The $data chantroom already exists.$reset\r\n"), return;
      push @{$self->{nexthandlers}}, sub {$self->create_room($data)};
      return };
    /^await$/ and do {
      $data eq '' or $self->list( $self->{user}->{await}, $data, sub{$_[0]->{awaitedby}->{$name} = undef} );
      $self->write(GREEN, "You will be notified whenever these users log in: $reset", join(' ', sort keys %{$self->{user}->{await}}), "\r\n");
      return };
    /^goto$/  and do {
      defined(my $room = ::resolve($data, \%rooms)) or $self->write(BOLD, RED, "The $data chantroom was not found.$reset\r\n"), return;
      $self->goto_room($room);
      return };
    /^help$/  and $self->help, return;
    /^ignore$/and do {
      $data eq '' or $self->list( $self->{user}->{ignore}, $data, sub{defined ($_[1]) and $_[1]->write(GREEN, "$name has decided to ignore you, and will not receive any of your messages.$reset\r\n")} );
      $self->write(GREEN, "You are currently ignoring these users: ", join(' ', sort keys %{$self->{user}->{ignore}}), "$reset\r\n");
      return };
    /^invite$/ and do {
      ($room->{private} and !$owner) and $self->write(BOLD, RED, "Unless you are the owner, you can only invite people to public chantrooms.$reset\r\n"), return;
      defined (my $user = ::resolve($data, \%accounts)) or $self->write(BOLD, RED, "User $data not found.$reset\r\n"), return;
      defined (my $conn = ::resolve($user->{name}, \%users)) or $self->write(BOLD, RED, "User $user->{name} is not currently logged in.$reset\r\n"), return;
      $conn->{room} eq $room and $self->write(BOLD, RED, "$user->{name} is already in this room.$reset\r\n"), return;
      $room->{private} or exists $room->{ban}->{$user->{name}} and $self->write(RED, "$user->{name} has been banned from this chantroom.$reset\r\n"), return;
      push @{$conn->{nexthandlers}}, sub{$conn->invite($room,$name)};
      $self->write(GREEN, "$user->{name} has been invited to join the $room->{name} chantroom.$reset\r\n");
      return };
    /^list$/  and $self->write(GREEN, 'available chantrooms: ', RESET, join(' ', map {$rooms{$_}->{private}?(exists $rooms{$_}->{allow}->{$name}?BOLD.BLUE.$_.RESET:$_):(exists $rooms{$_}->{ban}->{$name}?BOLD.RED.$_.RESET:BOLD.$_.RESET)} (sort keys %rooms)), "\r\n"), return;
    /^repeat$/  and do {
      defined $self->{lastcmd} or $self->write(BOLD, RED, "You haven't used any commands yet!$reset\r\n"), return;
      push @{$self->{nexthandlers}}, sub{ $self->write(BOLD, YELLOW, $self->{lastcmd}, RESET); $self->{handler} = sub{$self->chant} };
      $self->{inbuf} .= $self->{lastcmd};
      #$self->resolve_cmd( $self->{lastcmd} );
      return };
    /^me$/    and $self->dispatch((defined $to?$to:''), RESET, "$name $data"), return;
    /^msg$/   and do {
      my ($to, $msg) = $data =~ /^(\w+)\s*(.*)$/;
      defined $to or $self->write(BOLD, RED, "You must specify a recipient!$reset\r\n"), return;
      my $recipient;
      $msg eq '' and $self->write(GREEN, defined($recipient = ::resolve($to, \%accounts)) ? "If you send a message to $to, it will be delivered to $recipient->{name}." : "User $to not found.", "$reset\r\n"), return;
      $self->resolve_cmd( $msg, $to );
      return };
    /^ping$/  and do {
      $data eq '' and $self->write(BOLD, RED, "You must specify who you want to ping.$reset\r\n"), return;
      $self->dispatch($data, "$name>$reset [beep]\a"), return;
      return };
    /^password$/ and push(@{$self->{nexthandlers}}, sub{$self->check_password($name, sub {$self->get_new_password(sub{$self->{user}->{password}=$_[0];$self->write(GREEN, "Password successfully changed.$reset\r\n");$self->{handler}=$self->next_handler;})}, sub{$self->{handler} = $self->next_handler})}), return;
    /^pray$/  and $self->dispatch($room->{owner}, "Prayer from $room->{name}: $name>$reset $data"), return;
    /^quit$/  and do {
      my $next;
      defined ($next = shift @{$self->{quithandlers}}) and &$next(), return;
      my $msg = RESET . GREEN . "So long, $self->{user}->{name}, and thanks for all the fish!$reset\r\n";
      $self->{socket}->syswrite($msg, length $msg);
      $self->leave;
      return };
    /^reply$/ and do {
      defined(my $to = $self->{buflastmsger}) or $self->write(BOLD, RED, "No one has sent you a personal message yet, so I don't know who to reply to.$reset\r\n"), return;
      $data eq '' and $self->write(GREEN, "If you use the reply command, your message will be delivered to $to.$reset\r\n"), return;
      exists $users{$to} or $self->write(BOLD, RED, "User $to is no longer connected.$reset\r\n"), return;
      $self->resolve_cmd( $data, $to );
      return };
    /^unawait$/  and do {
      $self->unlist( $self->{user}->{await}, $data, sub{delete $_[0]->{awaitedby}->{$name}} );
      $self->write(GREEN, "You will be notified whenever these users log in: $reset", join(' ', sort keys %{$self->{user}->{await}}), "\r\n");
      return };
    /^unignore$/ and do {
      $self->unlist( $self->{user}->{ignore}, $data, sub{defined($_[1]) and $_[1]->write(GREEN, "$name has decided to stop ignoring you, so you may resume your onslaught of messages.$reset\r\n")} );
      $self->write(GREEN, "Here is your current ignore list: ", join(' ', sort keys %{$self->{user}->{ignore}}), "$reset\r\n");
      return };
    /^who$/   and do {
      ($data eq 'room' or $data eq '') and $self->write(GREEN, 'users in ', $self->{room}->{name}, ' chantroom: ', RESET, join(' ', sort keys %{$self->{room}->{users}}), "\r\n");
      ($data eq 'all' or $data eq '') and $self->write(GREEN, 'all current chanters: ', RESET, join(' ', sort keys %users), "\r\n");
      grep(/^$data$/, ('room','all','')) or $self->write(GREEN, "current chanters matching $data: $reset", join(' ', sort grep /^$data/, keys %users), "\r\n");
      return };
    /^where$/ and do {
       $data eq '' and $self->write(GREEN, "You are currently in the ", $room->{private}?'private':'public', " $self->{room}->{name} chantroom, owned by $self->{room}->{owner}.$reset\r\n"), return;
       defined(my $user = ::resolve($data, \%accounts)) or $self->write(BOLD, RED, "User $data not found.$reset\r\n"), return;
       defined(my $conn = ::resolve($user->{name}, \%users)) or $self->write(BOLD, RED, "$user->{name} is not currently logged in.$reset\r\n"), return;
       $self->write(GREEN, "$user->{name} is currently in the ", $conn->{room}->{private}?'private':'public', " $conn->{room}->{name} chantroom, owned by $conn->{room}->{owner}.$reset\r\n");
       return };

    # commands for the owner of each room:
    if ($owner or $name eq $superuser) {
       /^allow$/  and do {
          $room->{private} or $self->write(BOLD, RED, "You can only create an allow list for private chantrooms.$reset\r\n"), return;
          $data eq '' or $self->list( $room->{allow}, $data, sub{defined($_[1]) and $_[1]->write(GREEN, "You have been granted free access to the private $room->{name} chantroom.$reset\r\n")} );
          $self->write(GREEN, "These users are currently allowed in the $room->{name} chantroom: ", join(' ', sort keys %{$room->{allow}}), "$reset\r\n");
          return };
       /^ban$/    and do {
          $room->{private} and $self->write(BOLD, RED, "You can only ban/unban users from public chantrooms.$reset\r\n"), return;
          $data eq '' or $self->list( $room->{ban}, $data, sub{if (defined $_[1]){ $_[1]->write(GREEN, "You have been banned from the $room->{name} chantroom.$reset\r\n"); ($_[1]->goto_room(::resolve('root',\%rooms)) or $_[1]->leave) if $_[1]->{room} eq $room}} );
          $self->write(GREEN, "These users are currently banned from the $room->{name} chantroom: ", join(' ', sort keys %{$room->{ban}}), "$reset\r\n");
          return };
       /^delete$/ and do {
          $room->{name} eq 'root' and $self->write(BOLD, RED, "Cannot delete root chantroom!$reset\r\n"), return;
          $self->write(GREEN, "The $room->{name} chantroom has been deleted.$reset\r\n");
          $_->goto_room($root) or $_->leave for values %{$room->{users}};
          delete $rooms{$room->{name}};
          $self->log("$name deleted $room->{name} chantroom");
          return };
       /^kick$/    and do {
          defined(my $user = ::resolve($data, \%accounts)) or $self->write(BOLD, RED, "User $data not found.$reset\r\n"), return;
          defined(my $conn = ::resolve($user->{name}, \%users)) or $self->write(BOLD, RED, "User $user->{name} is not currently logged in.$reset\r\n"), return;
          $conn eq $self and $self->write(BOLD, RED, "You can't kick yourself out, stupid!$reset\r\n"), return;
          $conn->{room} eq $room or $self->write(BOLD, RED, "User $user->{name} is not currently in this room.$reset\r\n"), return;
          $conn->write(GREEN, "You have been kicked out of the $room->{name} chantroom.$reset\r\n");
          $conn->goto_room($root) or $conn->leave;
          return };
       /^private$/ and do {
          $room->{name} eq 'root' and $self->write(BOLD, RED, "The root chantroom must remain public.$reset\r\n"), return;
          $room->{private} = 1, $self->write(GREEN, "The $room->{name} chantroom is now private.$reset\r\n");
          return };
       /^public$/ and $room->{private} = 0, $self->write(GREEN, "The $room->{name} chantroom is now publicly accessible.$reset\r\n"), return;
       /^unallow$/ and do {
          $room->{private} or $self->write(BOLD, RED, "You can only create an allow list for private chantrooms.$reset\r\n"), return;
          $self->unlist( $room->{allow}, $data, sub{if (defined $_[1]){ $_[1]->write(GREEN, "You may no longer freely access the private $room->{name} chantroom.$reset\r\n"); ($_[1]->goto_room(::resolve('root',\%rooms)) or $_[1]->leave) if $_[1]->{room} eq $room}} );
          $self->write(GREEN, "These users are currently allowed in the $room->{name} chantroom: ", join(' ', sort keys %{$room->{allow}}), "$reset\r\n");
          return };
       /^unban$/   and do {
          $room->{private} and $self->write(BOLD, RED, "You can only ban/unban users from public chantrooms.$reset\r\n"), return;
          $self->unlist( $room->{ban}, $data, sub{defined($_[1]) and $_[1]->write(GREEN, "You are no longer banned from the $room->{name} chantroom.$reset\r\n")} );
          $self->write(GREEN, "These users are currently banned from the $room->{name} chantroom: ", join(' ', sort keys %{$room->{ban}}), "$reset\r\n");
          return };
    }

    # commands for the superuser -- that's you
    if ($name eq $superuser) {
       # MAJOR SECURITY RISK!!! Enable for debugging only:
       # /^eval$/ and eval $data, return;
       /^force$/ and do {
          my ($to, $msg) = $data =~ /^(\w+)\s*(.*)$/;
          defined $to or $self->write(BOLD, RED, "Who do you want to force?$reset\r\n"), return;
          defined (my $user = ::resolve($to, \%accounts)) or $self->write(BOLD, RED, "User $to not found.$reset\r\n"), return;
          defined (my $conn = ::resolve($user->{name}, \%users)) or $self->write(BOLD, RED, "User $user->{name} not currently logged in.$reset\r\n"), return;
          $msg eq '' and $self->write(GREEN, "If you try to force $to, $user->{name} will carry out the action.$reset\r\n"), return;
          $self->write(BOLD, RED, "You can't force yourself to do anything, at least not that way.$reset\r\n"), return;
          $self->write(GREEN, "$user->{name} has been forced to $msg.$reset\r\n");
          $conn->write(GREEN, "$name has forced you to $msg.$reset\r\n");
          $conn->resolve_cmd($msg);
          return };
       /^save$/ and do {
          ::save_rooms() && ::save_users() or $self->write(BOLD, RED, "Error saving data!$reset\r\n"), return;
          $self->write(GREEN, "Rooms and users saved successfully.$reset\r\n"); return;
          };
       /^shutdown$/ and $quit++, return;
       /^su$/ and do {
          defined (my $user = ::resolve($data, \%accounts)) or $self->write(BOLD, RED, "User $data not found.$reset\r\n"), return;
          defined (my $conn = ::resolve($user->{name}, \%users)) and $self->write(BOLD, RED, "$user->{name} is already logged in.$reset\r\n"), return;
          push @{$self->{quithandlers}}, sub {
             delete $users{$self->{user}->{name}};
             $self->{user} = $accounts{$name};
             $self->write(GREEN, "You have regained control of $name.$reset\r\n");
             };
          $self->setup_user($user->{name});
          $self->write(GREEN, "You now control $user->{name}.$reset\r\n"), return;
          return };
       /^yell$/ and $self->resolve_cmd($data, '*'), return;
    }
   }

   # theoretically you should never get here:
   $self->write(BOLD, RED, "Command $cmd not recognized.$reset\r\n");
}

sub list {
# adds a list of users to a hash-list
   my ($self, $list, $users, $on_add) = @_;
   my %to_add;

   (!defined $users or $users eq '') ? ($to_add{all} = undef) : %to_add = map {($_, undef)} (split /\s+/, $users);
   if (scalar keys %to_add) {
      %to_add = map {defined $accounts{$_} ? ($_ => undef) : ()} (keys %accounts), delete $to_add{$self->{user}->{name}} if exists $to_add{all};
      for (sort keys %to_add) {
         defined(my $account = ::resolve($_, \%accounts)) or $self->write(BOLD, RED, "User $_ not found.", RESET, "\r\n"), next;
         $account eq $self->{user} and $self->write(BOLD, RED, "You can't do that to yourself.  Sorry.", RESET, "\r\n"), next;
         my $connection = ::resolve($account->{name}, \%users);
         exists $list->{$account->{name}} or &$on_add($account, $connection) if defined $on_add;
         $list->{$account->{name}} = undef;
      }
   }
}

sub unlist {
# removes a list of users from a hash-list
   my ($self, $list, $users, $on_delete) = @_;
   my %to_delete;

   (!defined $users or $users eq '') ? ($to_delete{all} = undef) : %to_delete = map {($_, undef)} (split /\s+/, $users);
   if (scalar keys %to_delete) {
      %to_delete = %$list if exists $to_delete{all};
      for (keys %to_delete) {
         my $account = ::resolve($_, \%accounts) or $self->write(BOLD, RED, "User $_ not found.", RESET, "\r\n"), next;
         if (exists $list->{$account->{name}}) {
            my $connection = ::resolve($account->{name}, \%users);
            &$on_delete($account, $connection) if defined $on_delete;
            delete $list->{$account->{name}};
         }
      }
   }
}

sub invite {
# invites a user to enter a different chantroom
   my ($self, $room, $from, $step) = @_;
   $step = 0 unless defined $step;

   SWITCH: {
   $step == 0 and do {
      # step one: prompt them to enter the room
      $self->write(GREEN, "$from has invited you to join the $room->{name} chantroom.  Do you want to go there now [Y/n]? ", RESET);
      $self->{writable} = 0;
      $self->{handler} = sub{$self->invite($room,$from,1)};
      return };
   $step == 1 and do {
      # step two: handle the response to the above -- either go the room or don't
      defined(my $conf = $self->read) or return;

      $conf eq '' and $conf = 'y'; $conf = lc $conf;
      $conf =~ /^y$|^n$/ or $self->write(BOLD, RED, "Please enter y or n: ", RESET), return;

      my $from = ::resolve($from,\%users);
      if ($conf eq 'y') {
         defined $from and $from->write(GREEN, "$self->{user}->{name} has accepted your invitation to the $room->{name} chantroom.", RESET, "\r\n");
         $self->goto_room($room, 1);
      } else {
         defined $from and $from->write(GREEN, "$self->{user}->{name} has declined your invitation to the $room->{name} chantroom.", RESET, "\r\n");
      }
      $self->{handler} = $self->next_handler;
      return };
   }
}

sub goto_room {
# sends a user to a new chantroom; returns 1 if successful and 0 otherwise
   my ($self, $room, $override) = @_;
   my $name = $self->{user}->{name};
   $override = 0 unless defined $override;

   # make sure the user is not already in this room, and that the room exists
   defined $self->{room} and $self->{room} eq $room and $self->write(BOLD, RED, "You are already in the $room->{name} chantroom.", RESET, "\r\n"), return 0;
   exists $rooms{$room->{name}} or $self->write(BOLD, RED, "The $room->{name} chantroom no longer exists.", RESET, "\r\n"), return;

   # make sure the user has the privilege of entering this room (unless $override is true)
   unless ($room->{owner} eq $name or $override) {
      if ($room->{private}) {
         exists $room->{allow}->{$name} or $self->write(BOLD, RED, "The $room->{name} chantroom is private; you can not go there unless the owner allows or invites you.", RESET, "\r\n"), return 0;
      } else {
         exists $room->{ban}->{$name} and $self->write(BOLD, RED, "Sorry, you have been banned from the $room->{name} chantroom.", RESET, "\r\n"), return 0;
      }
   }

   # alert users in the old room to this user's departure
   if (defined $self->{room}) {
      $self->broadcast(GREEN, "[$name has left this chantroom.]", RESET);
      delete $self->{room}->{users}->{$name};
   }

   # send them to the new room
   $self->{room} = $self->{user}->{room} = $room;
   $room->{users}->{$name} = $self;
   $self->write(GREEN, "You have entered the ", $room->{private}?'private':'public', " $room->{name} chantroom, owned by $room->{owner}.\r\nThe following users are here: ", RESET, join(' ', sort keys %{$room->{users}}), "\r\n");
   $self->broadcast(GREEN, "[$name has entered this chantroom.]", RESET);
   $self->log("$name entered $room->{name} chantroom");
   return 1;
}

sub help {
# prints the happy little help message
   my ($self) = @_;

   my ($w, $b, $g, $r) = (BOLD, BOLD . BLUE, GREEN, RESET);
   my $help = <<END;
${w}Chant help:$r
$w-------------------------------------------------------------------------------$r
Commands and usernames may be shortened; Chant will try to guess what you mean.

${g}General commands:$r
${b}msg$r                  send$b msg$r to your chantroom
$w/me$b msg$r              emote$b msg$r to your chantroom
$w/msg$b user msg$r        send$b msg$r to$b user$r
$w/${b}user msg$r            same as $w/msg$b user$r if$b user$r isn't a valid command
$w/reply$b msg$r or $w/$b msg$r  send$b msg$r to the last person who sent you a $w/msg$r
$w/ping$b user$r           send a beep to$b user$r
$w/invite$b user$r         invite$b user$r to join your chantroom
$w/pray$b msg$r            send$b msg$r to the owner of your current chantroom

$w/about$r               print the welcome message
$w/help$r                print these help pages
$w/repeat$r              repeat your last command
$w/password$r            change your Chant password
$w/quit$r                end your connection to Chant
$w/who$r [${w}all$r|${w}room$r|${b}user$r] lists chanters logged in, in your room, or matching$b user$r
$w/where$b user$r          print the name of the chantroom$b user$r is currently in
$w/list$r                list all available chantrooms
$w/goto$b room$r           go to$b room$r
$w/add$b room$r            add a chantroom named room

Typing one of the $w/un...$r commands without specifying$b users$r will clear the list.
$w/ignore$b users$r        block all messages from$b users$r (separated by spaces)
$w/unignore$b users$r      stop ignoring$b users$r
$w/await$b users$r         alert you when$b users$r log on
$w/unawait$b users$r       remove$b users$r from the await list

${g}Commands for room owners:$r
$w/private$r or $w/public$r  make this room private or public
$w/delete$r              delete this room
$w/invite$b user$r         invite$b user$r to join this room
$w/kick$b user$r           kick$b user$r out of this room
$w/allow$b users$r         allow$b users$r to enter this private room anytime they please
$w/unallow$b users$r       remove$b users$r from the allow list (private rooms only)
$w/ban$b users$r           ban$b users$r from this room (public rooms only)
$w/unban$b users$r         remove$b users$r from the ban list (public rooms only)
END

   $help .= <<END if $self->{user}->{name} eq $superuser;

${g}Commands for the superuser:$r
$w/save$r                save the current rooms and users to disk
$w/shutdown$r            shutdown Chant
$w/eval$b cmd$r            eval$b cmd$r (you must specifically enable this!)
$w/force$b user cmd$r      force$b user$r to perform$b cmd$r
$w/su$b user$r             control$b user$r (only if they aren't already logged in!)
$w/yell$b msg$r            send$b msg$r to everyone currently logged in
END

   $help =~ s:\r\n|\n|\r:\r\n:g;
   #$self->write($help);
   $self->page($help);
}

sub dispatch {
# sends a message to $to, which may be either a username, or 'room', 'all', or ''
   my ($self, $to) = (shift, shift);
   my $msg = join '',@_;

   if ($to eq '*') {
      $self->write(BOLD, $msg, RESET, "\r\n");
      $_ ne $self and $_->write(BOLD, BLUE, $msg, RESET, "\r\n") for values %users;
   } elsif ($to eq '' or $to eq 'room' or $to eq 'all') {
      # send the message to everyone in the current room
      $self->write(BOLD, $msg, RESET, "\r\n");
      $self->broadcast(BOLD, BLUE, $msg, RESET);
   } else {
      # send the message to one other user

      my $reset = RESET;

      # find the recipient
      my $recipient = ::resolve($to, \%accounts) or $self->write(BOLD, RED, "User $to not found.$reset\r\n"), return;
      my $connection = ::resolve($recipient->{name}, \%users) or $self->write(BOLD, RED, "User $recipient->{name} not currently available.  Your message will be delivered the next time $recipient->{name} logs on.$reset\r\n");

      # send them the message unless they're ignoring this user
      unless (exists $recipient->{ignore}->{$self->{user}->{name}}) {
         if (defined $connection) {
            $connection->write(BOLD, BLUE, "to $recipient->{name}: $msg$reset\r\n");
            $connection->{lastmsger} = $self->{user}->{name};
         } else {
            # add it to their stored messages if they're offline
            $recipient->{msgbuf} .= BOLD . BLUE . "to $recipient->{name}: $msg$reset\r\n";
         }
         $self->write(BOLD, "to $recipient->{name}: $msg$reset\r\n") unless $recipient eq $self->{user};
      } else {
         $self->write(BOLD, RED, "$recipient->{name} is ignoring you. Your message will not be delivered.$reset\r\n");
      }
   }
}

sub flush_output {
# sends buffered output to the client
   my($self) = @_;
   my $buf = $self->{outbuf};
   $self->{outbuf} = '';
   $self->write($buf) unless $buf eq '';
}

sub broadcast {
# sends a message to the other chanters in this room
   my($self) = (shift);
   my $msg = join '',@_;

   for my $recipient (values %{$self->{room}->{users}}) {
      $recipient->write("$msg\r\n") unless not defined $recipient or (exists $recipient->{user}->{ignore}->{$self->{user}->{name}} or $recipient eq $self);
   }
}

sub read {
# reads in line parts from this socket, returning '' until the line is complete
   my($self) = @_;

   # turn on output buffering -- we don't want to send anything to the
   # client until they are done typing
   $self->{writable} = 0;
   $self->{buflastmsger} = $self->{lastmsger};

   # retrieve characters from the client
   $self->{socket}->sysread(my $buf, 80);
   $self->leave if $buf eq '';

   # standardize line endings
   $buf =~ s/\r\n|\r/\n/;

   # add to the input buffer
   $self->{inbuf} .= $buf;

   # if the user has completed a line...
   if ($self->{inbuf} =~ /\n/) {
      # retrieve the line from the input buffer
      ($buf, $self->{inbuf}) = $self->{inbuf} =~ /(.*)\n(.*)/s;

      # handle any backspace characters
      $buf =~ s/[^\010]\010// while $buf =~ /[^\010]\010/;
      $buf =~ s/\010//g;

      # turn off output buffering and flush output buffer
      $self->{writable} = 1;
      $self->flush_output;

      # return the line
      return $buf;

   } else {
      # if the line is not complete, don't return any of it yet
      return;
   }
}

sub page {
# sends a string to the user, one 24-line page at a time
   my ($self, $text, $in_progress) = @_;
   my ($maxcols, $maxlines) = (80, 24);
   my ($line, $col) = (1,0);
   my $in_escape = 0;
   $in_progress = 0 unless defined $in_progress;

   if ($in_progress) {
      defined(my $input = $self->read) or return;
      $input =~ /^q$/i and $self->next_handler, return;
   }

   my $i = -1; my $char; my $len = length $text;
   while (++$i < $len and defined($char = substr($text,$i,1))) {
      $line > $maxlines and last;
      $in_escape and ($char eq 'm' ? ($in_escape = 0, next) : next);
      $char eq "\x1b" and $in_escape = 1, next;
      $char eq "\n" and $line++, $col = 0, next;
      "\r\a" =~ /\Q$char/ and next;
      $col++; $col >= $maxcols and $line++, $col = 1, next;
   }
   my ($now, $later) = (substr($text,0,$i), substr($text,$i));

   $self->write($now);
   if (defined $later and $later !~ /^\s*$/) {
      $self->write(BOLD, 'Press enter to continue or enter q to quit...', RESET); $self->{writable} = 0;
      $in_progress or push @{$self->{nexthandlers}}, sub{$self->page($later, 1)};
   } else {
      $in_progress ? $self->next_handler : return;
   }
}

sub write {
# sends a message to the current user
   my $self = shift;
   my $buf = join '', @_;
   return if $buf eq '';

   # this is so the user's input will be yellow
   $buf = RESET . $buf . BOLD . YELLOW;

   # either send the message directly to the user or add it to the output buffer
   $self->{writable} ? ($self->{socket}->syswrite($buf, length $buf) or $self->leave) : ($self->{outbuf}.=$buf);
}

sub leave {
# deletes this user and cleans up
   my($self) = @_;
   my $name = '';

   if (defined $self->{user}) {
      $name = $self->{user}->{name};

      delete $users{$name};
      delete $self->{room}->{users}->{$name};

      $self->broadcast(GREEN, "[$name disconnected.]", RESET);
   }

   $self->log("$name [", $self->{socket}->peerhost, '] disconnected');

   undef $chanters[$self->{socket}->fileno];
   $select->remove($self->{socket});
   $self->{socket}->close;
}

sub log {
# logs a message to STDOUT
   my($self) = shift;
   my $msg = join '', @_;
   print $self->{socket}->fileno . ": $msg\n";
}

} # end of package Chanter