Net::CyanChat::Server - Perl interface for running a CyanChat server.

  use Net::CyanChat::Server;

  our $cho = new Net::CyanChat::Server (
          host  => 'localhost',
          port  => 1812,
          debug => 1,
  );

  # Start the server.
  $cho->connect();

  # Loop.
  $cho->start();

  Welcome to Net::CyanChat::Server v. <VERSION>

  There are only a few simple rules:
       1. Be respectful to other users.
       2. Keep the dialog "G" rated.
       3. And HAVE FUN!

  Termination of use can happen without warning!

  50|password

  - Cleaned up the documentation a bit.

  - Messages can contain pipes in them now.
  - Removed the "staff protocol" number; replaced it with "staff password"
  - Changed the socket end-of-lines to CrLf instead of just Lf.

  - Initial release.

  - Add support for built in profanity filters and bans.
  - Add IP encryption algorythm similar to Cyan's.
  - Display user's ISP as their home Age, rather than their IP address.

    Net::CyanChat - Perl interface to CyanChat.
    Copyright (C) 2007  Casey Kirsle

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    (at your option) any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

package Net::CyanChat::Server;

#------------------------------------------------------------------------------#
# Net::CyanChat - Perl interface for connecting to Cyan Worlds' chat room.     #
#------------------------------------------------------------------------------#
# POD documentation is at the very end of this source code.                    #
#------------------------------------------------------------------------------#

use strict;
use warnings;
use IO::Socket;
use IO::Select;

our $VERSION = '0.03';

sub new {
	my $proto = shift;
	my $class = ref($proto) || $proto;

	my $self = {
		host       => 'localhost',
		port       => 1812,
		password   => undef, # Staff password for command 50
		sock       => undef,
		select     => undef,
		welcome    => [
			"Welcome to Net::CyanChat::Server v. $VERSION",
			"",
			"There are only a few simple rules:",
			"    1. Be respectful to other users.",
			"    2. Keep the dialog \"G\" rated.",
			"    3. And HAVE FUN!",
			"",
			"Termination of use can happen without warning!",
		],
		conn       => {},
		who        => {},
		@_,
	};

	bless ($self,$class);
	return $self;
}

sub version {
	my ($self) = @_;
	return $VERSION;
}

sub debug {
	my ($self,$msg) = @_;

	return unless $self->{debug} == 1;
	print "Net::CyanChat::debug // $msg\n";
}

sub connect {
	my ($self) = @_;

	# Create the socket.
	$self->{sock} = IO::Socket::INET->new (
		LocalAddr => $self->{host},
		LocalPort => $self->{port},
		Listen    => 1,
		Reuse     => 1,
	) or die "Socket error: $!";

	# Create a select object.
	$self->{select} = IO::Select->new ($self->{sock});
	return 1;
}

sub start {
	my ($self) = @_;
	while (1) {
		$self->do_one_loop();
	}
	return undef;
}

sub reply {
	my ($self,$socket,$msg) = @_;

	# Send the message.
	print "S: $msg\n";
	eval {
		$socket->send ("$msg\x0d\x0a") or do {
			# He's been disconnected.
			my $id = $socket->fileno;
			if ($self->{conn}->{$id}->{login}) {
				# Remove him.
				my $user = $self->{conn}->{$id}->{username};
				delete $self->{who}->{$user};
				delete $self->{conn}->{$id};

				# Broadcast it.
				$self->broadcast ("31|$user|^3<mistakenly used an unsafe Linking Book without a maintainer's suit *ZZZZZWHAP*>");
				$self->sendWhoList();
			}

			$self->{select}->remove ($socket);
			$socket->close();
		}
	};

	if ($@) {
		warn "<$@>";
		$self->{select}->remove ($socket);
	}
}

sub do_one_loop {
	my ($self) = @_;

	# Look for events.
	my @ready = $self->{select}->can_read(.1);
	return unless(@ready);

	# Go through each event.
	foreach my $socket (@ready) {
		# If the listening socket is ready, accept a new connection.
		if ($socket == $self->{sock}) {
			my $new = $self->{sock}->accept();
			$self->{select}->add ($new);
			print $new->fileno . ": connected\n";

			# Setup data for this connection.
			my $nid = $new->fileno;
			$self->{conn}->{$nid} = {
				level    => 0,
				announce => 0,
				nickname => undef,
				username => undef,
				login    => 0,
			};

			# Send a 35.
			my @memlist = ();
			foreach my $member (keys %{$self->{who}}) {
				my $addr = $self->{who}->{$member};
				push (@memlist,"$member,$addr");
			}
			my $mems = join ('|', @memlist);
			$self->reply ($new,"35|$mems");
		}
		else {
			# Get their ID.
			my $id = $socket->fileno;

			# Read their request.
			my $line = '';
			$socket->recv ($line, 2048);
			chomp $line;
			$line =~ s/\r//ig;
			$line =~ s/\n//ig;

			# Skip if this line is blank.
			next if $line eq "";

			# Go through the events.
			my ($cmd,@args) = split(/\|/, $line);

			print "C $id: $line\n";

			if ($cmd == 10) {
				# 10 = Sending their name.
				if ($self->{conn}->{$id}->{announce}) {
					my $nick = join ("|",@args);
					if (!defined $nick) {
						# No nick defined.
						$self->reply ($socket,"21|3ChatServer|^1No nickname was defined!");
					}
					else {
						# Format their username.
						my $user = join ("", $self->{conn}->{$id}->{level}, $nick);

						# Valid nick?
						if (length $nick <= 20 && $nick !~ /\|/) {
							# See if the nick isn't already logged on.
							if (exists $self->{who}->{$user}) {
								$self->reply ($socket,"21|3ChatServer|^1The nickname is already in use.");
							}
							else {
								# Setting another name?
								if (length $self->{conn}->{$id}->{username} > 0) {
									# Remove the old.
									my $old = $self->{conn}->{$id}->{username};
									delete $self->{who}->{$old};
								}

								# Make up their join message.
								my $join = "somewhere on the internet Age";

								# Staff?
								if ($self->{conn}->{$id}->{level} == 1) {
									$join = "Cyan Worlds, Inc.";
								}

								# Join them.
								$self->{who}->{$user} = $socket->peerhost;
								$self->{conn}->{$id}->{username} = $user;
								$self->{conn}->{$id}->{nickname} = $nick;
								$self->{conn}->{$id}->{login} = 1;
								$self->reply ($socket,"11"); # 11 = name accepted
								$self->broadcast ("31|$user|^2<links in from $join>");

								# Update the Who List.
								$self->sendWhoList();
							}
						}
						else {
							# Invalid nick.
							$self->reply ($socket,"10"); # 10 = name invalid
						}
					}
				}
			}
			elsif ($cmd == 15) {
				# 15 = Remove their name (sign out).
				if ($self->{conn}->{$id}->{login}) {
					# Exit them.
					my $nick = $self->{conn}->{$id}->{username};
					$self->{conn}->{$id}->{username} = undef;
					$self->{conn}->{$id}->{nickname} = undef;
					$self->{conn}->{$id}->{login} = 0;
					delete $self->{who}->{$nick};
					$self->broadcast ("31|$nick|^3<links safely back to their home Age>");
					$self->sendWhoList();
				}
			}
			elsif ($cmd == 20) {
				# 20 = send private message.
				if ($self->{conn}->{$id}->{login}) {
					my $to = shift @args;
					my $msg = join ("|",@args);

					if ($to && $msg) {
						# Send to this user's socket.
						my $recipient = $self->getSocket ($to);
						$self->reply ($recipient,"21|$to|$msg");
					}
				}
			}
			elsif ($cmd == 30) {
				# 30 = send public message.
				if ($self->{conn}->{$id}->{login}) {
					my $msg = join ("|",@args);
					$self->broadcast ("31|$self->{conn}->{$id}->{username}|$msg");
				}
			}
			elsif ($cmd == 40) {
				# 40 = client ready.
				my $proto = join ("|",@args);
				$proto = 0 unless length $proto > 0;

				# Client is ready now.
				$self->{conn}->{$id}->{announce} = 1;
				my @welcome = reverse (@{$self->{welcome}});
				foreach my $send (@welcome) {
					$self->reply ($socket,"40|1$send");
				}
			}
			elsif ($cmd == 50) {
				# 50 = Staff password.
				my $pass = join ("|",@args);

				if (defined $self->{password} && $pass eq $self->{password}) {
					# This is a staff member.
					print "Make $id a Staff Connection\n";
					$self->{conn}->{$id}->{level} = 1;
				}
			}
			elsif ($cmd == 60) {
				# 60 = Promote other users
				my ($user,$newlevel) = @args;

				# Only admin users can use this option.
				if ($self->{conn}->{$id}->{level} == 1) {
					# See that the user they mentioned exists.
					my $targetid = -1;
					my $oldwho = '';
					foreach my $con (keys %{$self->{conn}}) {
						next unless exists $self->{conn}->{$con}->{nickname};
						if ($self->{conn}->{$con}->{nickname} eq $user) {
							$oldwho = $self->{conn}->{$con}->{username};
							$targetid = $con;
						}
					}

					if ($targetid >= 0) {
						# They do. Promote them.
						my $newwho = join ("",$newlevel,$user);
						$self->{conn}->{$targetid}->{level} = $newlevel;
						$self->{conn}->{$targetid}->{username} = $newwho;
						$self->{who}->{$newwho} = delete $self->{who}->{$oldwho};
						print "Promote $user ($targetid) to $newlevel\n";
						use Data::Dumper;
						print Dumper($self);

						# Send the Who List.
						$self->sendWhoList();
					}
					else {
						$self->reply ($socket,"21|3ChatClient|^1User not found.");
					}
				}
				else {
					$self->reply ($socket,"21|3ChatClient|^Permission denied.");
				}
			}
			elsif ($cmd == 70) {
				# 70 = ignore user
				my $target = join ("|",@args);
				if (length $target > 0) {
					# Send mutual ignore to this user's client.
					my $recipient = $self->getSocket ($target);
					$self->reply ($recipient,"70|$self->{conn}->{$id}->{username}");
				}
			}
			else {
				# Unknown command.
				if ($self->{conn}->{$id}->{login}) {
					$self->reply ($socket,"21|3ChatClient|^1Command not implemented.");
				}
			}
		}
	}
}

sub setWelcome {
	my ($self,@msgs) = @_;

	# Keep these messages.
	return unless @msgs;

	$self->{welcome} = [ @msgs ];

	return 1;
}

sub setPassword {
	my ($self,$pass) = @_;

	# Save the password.
	if (defined $pass) {
		if (length $pass > 0) {
			$self->{password} = $pass;
		}
		else {
			$self->{password} = undef;
		}
	}

	return $self->{password};
}

sub url {
	my ($self) = @_;

	return join (':', $self->{host}, $self->{port});
}

sub sendWhoList {
	my ($self) = @_;

	# Get the Who List.
	my @memlist = ();
	foreach my $member (keys %{$self->{who}}) {
		my $addr = $self->{who}->{$member};
		push (@memlist,"$member,$addr");
	}
	my $list = join ('|', @memlist);

	# Send the Who List to all connections.
	foreach my $socket ($self->{select}->handles) {
		next if ($socket == $self->{sock});

		# Send the 35.
		$self->reply ($socket,"35|$list");
	}

	return 1;
}

sub getSocket {
	my ($self,$handle) = @_;

	# Find this handle's socket.
	foreach my $socket ($self->{select}->handles) {
		my $id = $socket->fileno;
		if (exists $self->{conn}->{$id}->{username}) {
			if ($handle eq $self->{conn}->{$id}->{username}) {
				return $socket;
			}
		}
	}

	return undef;
}

sub broadcast {
	my ($self,$data) = @_;

	# Find this handle's socket.
	foreach my $socket ($self->{select}->handles) {
		my $id = $socket->fileno;
		if ($self->{conn}->{$id}->{login}) {
			# Send it.
			$self->reply ($socket,$data);
		}
	}
}

1;
__END__