#!/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 cra +sh ) 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 "unkno +wn chanter: # $socket->fileno\n"; } last MAIN if $quit or -e '.QUIT'; # exit main loop if necessa +ry... } } } # (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 f +ound 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}, j +oin(' ', sort keys %{$_->{$_->{private}?'allow':'ban'}})), "\n" if de +fined 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, $ms +gbuf) = /^([^\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 $nam +e 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}}), $_->{msgbu +f}), "\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 s +tring # is an abbreviation and returns it's associated value, or undef if no +t 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 co +ntain 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->se +tup_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->{writ +able} = 0; $self->{handler} = sub { $self->check_password($name, $success_h +andler, $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_hand +ler() : $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->{w +ritable} = 0; $self->{handler} = sub { $self->check_password($name, $succes +s_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 n +ew account $accounts{$name} = undef; # make sure no one else tries to crea +te this account $self->write(BOLD, "Create new user $name [Y/n]? ", RESET); $se +lf->{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: " . C +ONCEALED; $self->{socket}->syswrite($prompt, length $prompt); $self->{writ +able} = 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: " . CONCEALE +D; $self->{socket}->syswrite($prompt, length $prompt); $self->{writ +able} = 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->{wri +table} = 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") un +less 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} e +q $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 matc +h my @valid = qw/about await add goto help ignore invite list me m +sg ping password pray repeat reply quit unignore unawait who where/; ($self->{room}->{owner} eq $name or $name eq $superuser) and pus +h @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 @va +lid } # if a valid command was found, handle it # if no valid command was found but one was entered in, handle i +t 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 messa +ge 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 chan +troom 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 l +og in: $reset", join(' ', sort keys %{$self->{user}->{await}}), "\r\n +"); return }; /^goto$/ and do { defined(my $room = ::resolve($data, \%rooms)) or $self->write(BO +LD, 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, "Unle +ss you are the owner, you can only invite people to public chantrooms +.$reset\r\n"), return; defined (my $user = ::resolve($data, \%accounts)) or $self->writ +e(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.$res +et\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 $se +lf->write(RED, "$user->{name} has been banned from this chantroom.$re +set\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 recip +ient!$reset\r\n"), return; my $recipient; $msg eq '' and $self->write(GREEN, defined($recipient = ::resolv +e($to, \%accounts)) ? "If you send a message to $to, it will be deliv +ered 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 yo +u want to ping.$reset\r\n"), return; $self->dispatch($data, "$name>$reset [beep]\a"), return; return }; /^password$/ and push(@{$self->{nexthandlers}}, sub{$self->check_p +assword($name, sub {$self->get_new_password(sub{$self->{user}->{passw +ord}=$_[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(), r +eturn; my $msg = RESET . GREEN . "So long, $self->{user}->{name}, and t +hanks 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, RE +D, "No one has sent you a personal message yet, so I don't know who t +o reply to.$reset\r\n"), return; $data eq '' and $self->write(GREEN, "If you use the reply comman +d, your message will be delivered to $to.$reset\r\n"), return; exists $users{$to} or $self->write(BOLD, RED, "User $to is no lo +nger 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 l +og 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 ke +ys %{$self->{room}->{users}}), "\r\n"); ($data eq 'all' or $data eq '') and $self->write(GREEN, 'all cur +rent chanters: ', RESET, join(' ', sort keys %users), "\r\n"); grep(/^$data$/, ('room','all','')) or $self->write(GREEN, "curre +nt chanters matching $data: $reset", join(' ', sort grep /^$data/, ke +ys %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} chantr +oom, owned by $self->{room}->{owner}.$reset\r\n"), return; defined(my $user = ::resolve($data, \%accounts)) or $self->writ +e(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} chant +room, 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 cr +eate an allow list for private chantrooms.$reset\r\n"), return; $data eq '' or $self->list( $room->{allow}, $data, sub{defin +ed($_[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 th +e $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 b +an/unban users from public chantrooms.$reset\r\n"), return; $data eq '' or $self->list( $room->{ban}, $data, sub{if (def +ined $_[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 t +he $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 de +leted.$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->w +rite(BOLD, RED, "User $data not found.$reset\r\n"), return; defined(my $conn = ::resolve($user->{name}, \%users)) or $se +lf->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 y +ourself out, stupid!$reset\r\n"), return; $conn->{room} eq $room or $self->write(BOLD, RED, "User $use +r->{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 roo +t 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"), retur +n; /^unallow$/ and do { $room->{private} or $self->write(BOLD, RED, "You can only cr +eate 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 $r +oom->{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 th +e $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 b +an/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} c +hantroom.$reset\r\n")} ); $self->write(GREEN, "These users are currently banned from t +he $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 f +orce?$reset\r\n"), return; defined (my $user = ::resolve($to, \%accounts)) or $self->wr +ite(BOLD, RED, "User $to not found.$reset\r\n"), return; defined (my $conn = ::resolve($user->{name}, \%users)) or $s +elf->write(BOLD, RED, "User $user->{name} not currently logged in.$re +set\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 anyt +hing, 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.$res +et\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_ad +d = 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->wr +ite(BOLD, RED, "User $_ not found.", RESET, "\r\n"), next; $account eq $self->{user} and $self->write(BOLD, RED, "You ca +n't do that to yourself. Sorry.", RESET, "\r\n"), next; my $connection = ::resolve($account->{name}, \%users); exists $list->{$account->{name}} or &$on_add($account, $conne +ction) 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->{n +ame} 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 ro +om 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 other +wise 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(B +OLD, 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 (unles +s $override is true) unless ($room->{owner} eq $name or $override) { if ($room->{private}) { exists $room->{allow}->{$name} or $self->write(BOLD, RED, "Th +e $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, "Sor +ry, 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.]", RESE +T); 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}?'priv +ate':'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.]", RESE +T); $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 s +ent 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 c +hantroom $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, i +n 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 wil +l clear the list. $w/ignore$b users$r block all messages from$b users$r (separate +d 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 (priva +te 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 alrea +dy logged in!) $w/yell$b msg$r send$b msg$r to everyone currently logged i +n 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 v +alues %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}: $ms +g$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->{nam +e}: $msg$reset\r\n"; } $self->write(BOLD, "to $recipient->{name}: $msg$reset\r\n") u +nless $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 $reci +pient 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 out +put buffer $self->{writable} ? ($self->{socket}->syswrite($buf, length $buf) o +r $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
In reply to Chant Chatroom Server by davisagli
| For: | Use: | ||
| & | & | ||
| < | < | ||
| > | > | ||
| [ | [ | ||
| ] | ] |