Beefy Boxes and Bandwidth Generously Provided by pair Networks
Think about Loose Coupling
 
PerlMonks  

Comment on

( #3333=superdoc: print w/ replies, xml ) Need Help??
#!/usr/bin/perl # The Veachian Internet Relay Chat Daemon - Coded by Jahn Veach/Veachi +an64 - V64@V64.net - http://www.v64.net/ # This code is in the public domain. It is provided as is. You may use + it for any purpose you want. # The author is not responsible for any damages caused by this program +. use strict; use warnings; use IO::Select; use IO::Socket; use Socket; # TODO: Modularize code. # No subroutines fiddle around with globals (too much) # Constants ($local{} and the like) in sprintfs. # Some initialization: ###################################################################### +######### # We're just gonna get this out of the way right now. # These define all the server numerics and string formats. # # Note: Numeric 462 was originally ERR_ALREADYREGISTRED (not REGISTERE +D). # Why this legacy typo has stayed in for so long is beyond me. # I'm taking it out. ###################################################################### +######### my $RPL_WELCOME = 001; my $RPL_YOURHOST = 002; my $RPL_CREATED = 003; my $RPL_LUSERCLIENT = 251; my $RPL_LUSEROP = 252; my $RPL_LUSERUNKNOWN = 253; my $RPL_LUSERCHANNELS = 254; my $RPL_LUSERME = 255; my $RPL_LOCALUSERS = 265; my $RPL_GLOBALUSERS = 266; my $RPL_WHOISUSER = 311; my $RPL_WHOISSERVER = 312; my $RPL_ENDOFWHOIS = 318; my $RPL_MOTD = 372; my $RPL_MOTDSTART = 375; my $RPL_ENDOFMOTD = 376; my $ERR_NOSUCHNICK = 401; my $ERR_NOTEXTTOSEND = 412; my $ERR_UNKNOWNCOMMAND = 421; my $ERR_NOMOTD = 422; my $ERR_NONICKNAMEGIVEN = 431; my $ERR_ERRONEUSNICKNAME = 432; my $ERR_NICKNAMEINUSE = 433; my $ERR_NOTREGISTERED = 451; my $ERR_NEEDMOREPARAMS = 461; my $ERR_ALREADYREGISTERED = 462; my %numstr; $numstr{$RPL_WELCOME} = ':Welcome to the %s IRC Network %s!%s@%s'; $numstr{$RPL_YOURHOST} = ':Your host is %s, running version %s'; $numstr{$RPL_CREATED} = ':This server was created %s'; $numstr{$RPL_LUSERCLIENT} = ':There are %s users and %s invisible on % +s servers'; $numstr{$RPL_LUSEROP} = '%s :operator(s) online'; $numstr{$RPL_LUSERUNKNOWN} = '0 :unknown connection(s)'; $numstr{$RPL_LUSERCHANNELS} = '%s :channels formed'; $numstr{$RPL_LUSERME} = ':I have %s clients and %s servers'; $numstr{$RPL_LOCALUSERS} = ':Current Local Users: %s Max: %s'; $numstr{$RPL_GLOBALUSERS} = ':Current Global Users: %s Max: %s'; $numstr{$RPL_WHOISUSER} = '%s %s %s * %s'; $numstr{$RPL_WHOISSERVER} = '%s %s :%s'; $numstr{$RPL_ENDOFWHOIS} = '%s :End of /WHOIS list.'; $numstr{$RPL_MOTD} = ':- %s'; $numstr{$RPL_MOTDSTART} = ':- %s Message of the Day -'; $numstr{$RPL_ENDOFMOTD} = ':End of /MOTD command.'; $numstr{$ERR_NOSUCHNICK} = '%s :No such nick'; $numstr{$ERR_NOTEXTTOSEND} = ':No text to send'; $numstr{$ERR_UNKNOWNCOMMAND} = '%s :Unknown command or command not yet + implemented'; $numstr{$ERR_NOMOTD} = ':MOTD File is missing'; $numstr{$ERR_NONICKNAMEGIVEN} = ':No nickname given'; $numstr{$ERR_ERRONEUSNICKNAME} = '%s :Erroneus Nickname: %s'; $numstr{$ERR_NICKNAMEINUSE} = '%s :Nickname is already in use.'; $numstr{$ERR_NOTREGISTERED} = '%s :Register first'; $numstr{$ERR_NEEDMOREPARAMS} = '%s :Not enough parameters'; $numstr{$ERR_ALREADYREGISTERED} = ':You may not reregister'; my %commhash; $commhash{user} = \&serv_user; $commhash{nick} = \&serv_nick; $commhash{privmsg} = \&serv_privmsg; $commhash{whois} = \&serv_whois; $commhash{lusers} = \&serv_lusers; $commhash{motd} = \&serv_motd; $commhash{notice} = \&serv_privmsg; $commhash{online} = \&serv_online; ###################################################################### +######### my @clients_to_connect; # Array containing a list of filehandles that +just connected. my %users; # Hash containing filehandles as keys, references to hashe +s as values. Hashes contain user info. my %local; # Hash containing all local info for the server. Ex. $loca +l{users} # Will be replaced to be read from a config file later. $local{version} = 'Veachian-0.23'; $local{network} = 'V64net'; $local{server} = 'irc.V64.net'; $local{server_desc} = 'The Veachian IRCd - Written entirely in the Per +l programming language.'; $local{start_date} = get_date(); $local{motd_file} = 'vircd.motd'; $local{port} = 4242; $local{read_size} = 1_048_576; my $debug = 0; $local{users} = 0; $local{record_users} = 0; $local{invisible_users} = 0; $local{non_invisible_users} = 0; $local{servers} = 1; $local{operators} = 0; $local{channels} = 0; print "Starting $local{version}......"; $local{listen} = IO::Socket::INET->new( LocalPort => $local{port}, Listen => 10, Proto => 'tcp', Reuse => 1 ) or die "Unable to creating listening socket: $!\n"; $local{reader} = IO::Select->new(); $local{reader}->add($local{listen}); $local{sender} = IO::Select->new(); $local{sender}->add($local{listen}); print "Server running.\n"; while (1) { my @queues = IO::Select->select($local{reader}, $local{sender}, un +def, 0.1); my @clients_to_disconnect; # Array containing a list of filehandle +s that have disconnected. foreach my $fh (@{ $queues[1] }) { my $write = syswrite($fh, $users{$fh}->{recv_buf}); if ($users{$fh}->{nick} && $debug) { print "Sending to $users{ +$fh}->{hostname} ($users{$fh}->{nick}): $users{$fh}->{recv_buf}\n" } elsif ($debug) { print "Sending to $users{$fh}->{hostname}: $u +sers{$fh}->{recv_buf}\n" } if ($write) { $users{$fh}->{recv_buf} = ''; $local{sender}->remove($fh); } else { warn "Error sending data to $users{$fh}->{nick}: $!\nDa +ta saved.\n" } } foreach my $fh (@{ $queues[0] }) { if ($fh != $local{listen}) { my $sent_buf; my $read = sysread($fh, $sent_buf, $local{read_size}); if ($read) { my @bufs = split(/\n/, $sent_buf); foreach my $args (@bufs) { process_command($fh, $args); if ($users{$fh}->{nick} && $debug) { print "Receiv +ed from $users{$fh}->{hostname} ($users{$fh}->{nick}): $args\n" } elsif ($debug) { print "Received from $users{$fh}- +>{hostname}: $args\n" } } } else { push @clients_to_disconnect, $fh } # If data can't be read, the client either disconnected or + there was an error. Either way, get rid of their data. } else { my $fh = $local{listen}->accept; $users{$fh} = {}; $local{reader}->add($fh); send_user_msg_serv($fh, 'NOTICE AUTH :*** Looking up your +hostname...'); if (look_up_host($fh)) { send_user_msg_serv($fh, "NOTICE A +UTH :*** Hostname found: $users{$fh}->{hostname}") } else { send_user_msg_serv($fh, "NOTICE AUTH :*** Hostname +not resolved. Using IP instead: ($users{$fh}->{hostname})") } $users{$fh}->{connected} = 0; } } connect_new_clients() if $clients_to_co +nnect[0]; # Don't call if there's nothing there. disconnect_dead_clients(\@clients_to_disconnect) if $clients_to_di +sconnect[0]; # Ditto. } ###################################################################### +##### # Subroutines to handle logging on and logging off: ###################################################################### +##### # Does DNS and reverse DNS to find socket's full and real host. sub look_up_host { my ($fh) = @_; my $other_end = getpeername($fh); my $iaddr = (unpack_sockaddr_in($other_end))[1]; my $actual_ip = inet_ntoa($iaddr); my $claimed_hostname = gethostbyaddr($iaddr, AF_INET); my $name_lookup = (gethostbyname($claimed_hostname))[0]; if ($name_lookup) { $users{$fh}->{hostname} = $name_lookup; 1; } else { $users{$fh}->{hostname} = $actual_ip; return; } } # Occurs after NICK and USER are received and user is registered. This + would use a variable created in the # while loop like @clients_to_disconnect, but it's used by serv_nick() + and serv_user(), so no go until # a workaround is thought up. sub connect_new_clients { # Increase user count based on the number of waiting clients. $local{users} += @clients_to_connect; $local{non_invisible_users} += @clients_to_connect; $local{record_users} = $local{users} > $local{record_users +} ? $local{users} : $local{record_users}; foreach my $fh (@clients_to_connect) { print "Client connected: $users{$fh}->{hostname} ($users{$fh}- +>{nick})\n"; $users{$fh}->{connected} = 1; send_user_msg_num($fh, $RPL_WELCOME, $local{network}, $users{$ +fh}->{nick}, $users{$fh}->{username}, $users{$fh}->{hostname}); send_user_msg_num($fh, $RPL_YOURHOST, $local{server}, $local{v +ersion}); send_user_msg_num($fh, $RPL_CREATED, $local{start_date}); serv_lusers($fh); serv_motd($fh); } undef @clients_to_connect; } # Used to disconnect and clear the data of any clients that have disco +nnected. sub disconnect_dead_clients { my ($clients_to_disconnect) = @_; # Decrease the user counts based on the number of disconnected cli +ents here. $local{users} -= @$clients_to_disconnect; $local{non_invisible_users} -= @$clients_to_disconnect; foreach my $fh (@$clients_to_disconnect) { print "Client disconnected: $users{$fh}->{hostname} ($users{$f +h}->{nick})\n"; my $write = syswrite($fh, $users{$fh}->{recv_buf}); if ($users{$fh}->{nick} && $debug) { print "Sending to $users{ +$fh}->{hostname} ($users{$fh}->{nick}): $users{$fh}->{recv_buf}\n" } elsif ($debug) { print "Sending to $users{$fh}->{hostname}: $u +sers{$fh}->{recv_buf}\n" } if (!$write) { warn "Could not flush $users{$fh}->{nick}'s dat +a.\n" } $local{reader}->remove($fh); $local{sender}->remove($fh); my $nick = $users{$fh}->{nick}; if ($nick) { delete $users{lc $nick} } delete $users{$fh}; $fh->close; # Oddly enough, if I do this any sooner, it screws + up. } } ###################################################################### +##### # To prevent confusion on the subroutines that accept multi-word argum +ents: # my ($fh, $output) = @_ works because even though the output may be # multiple words, it is passed as one argument in a double-quoted stri +ng. # # Subroutines to send data: ###################################################################### +##### # Sends data prefixed with the user's full address. Used for messages. sub send_user_msg_addr { my ($fh, $output) = @_; my $message = ":$users{$fh}->{nick}!$users{$fh}->{username}\@$user +s{$fh}->{hostname} "; $message .= "$output\n"; $users{$fh}->{recv_buf} .= $message; $local{sender}->add($fh); } # Sends data prefixed with the server name. Used for data that doesn't + have a numeric, like server notices. sub send_user_msg_serv { my ($fh, $output) = @_; my $message = ":$local{server} "; $message .= "$output\n"; $users{$fh}->{recv_buf} .= $message; $local{sender}->add($fh); } # Send exactly what we're given. Used for all other messages. sub send_user_msg_raw { my ($fh, $output) = @_; my $message .= "$output\n"; $users{$fh}->{recv_buf} .= $message; $local{sender}->add($fh); } # Sends data prefixed with the server name and the supplied numeric. U +sed for server numerics. sub send_user_msg_num { my ($fh, $numeric, @args) = @_; my $message; if ($users{$fh}->{connected}) { $message = ":$local{server} $numer +ic $users{$fh}->{nick} " } else { $message = ":$local{server} $numeric * " } $message .= sprintf "$numstr{$numeric}", @args; $message .= "\n"; $users{$fh}->{recv_buf} .= $message; $local{sender}->add($fh); } ###################################################################### +##### # Subroutines to handle incoming commands: ###################################################################### +##### # Used to get a command and redirect it to the proper subroutine to ha +ndle the command. # Also returns an error for unknown commands. sub process_command { my ($fh, $args) = @_; my $command = (split / /, $args)[0]; $command = lc $command; # That's to catch anyone trying to send any other commands when th +ey're not registered. if (!$users{$fh}->{connected} && ($command ne 'nick' && $command n +e 'user')) { send_user_msg_num($fh, $ERR_NOTREGISTERED, $command); re +turn; } if (exists $commhash{$command}) { $commhash{$command}->($fh, $args +) } else { send_user_msg_num($fh, $ERR_UNKNOWNCOMMAND, $command) } } # Handles the user command. If NICK has already been issued, logs on. sub serv_user { my ($fh, $args) = @_; my @user_info = split / /, $args; if (!$users{$fh}->{connected}) { if (@user_info < 5) { send_user_msg_num($fh, $ERR_NEEDMOREPARA +MS, 'USER'); return; } $users{$fh}->{username} = "~$user_info[1]"; for (4..$#user_info) { if ($_ ne $#user_info) { $users{$fh}->{realname} .= "$user +_info[$_] " } else { $users{$fh}->{realname} .= $user_info[$_] } } if ($users{$fh}->{nick_done}) { delete $users{$fh}->{nick_done}; push @clients_to_connect, $fh; } else { $users{$fh}->{user_done} = 1 } } else { send_user_msg_num($fh, $ERR_ALREADYREGISTERED) } } # Handles the nick command. If NICK has already been issued, logs on. # Also handles nick changes. sub serv_nick { my ($fh, $args) = @_; my $nick = (split / /, $args)[1]; if (!$nick) { send_user_msg_num($fh, $ERR_NONICKNAMEGIVEN); return +; } $nick =~ s/^\://; $nick = substr($nick, 0, 30); if ($users{$fh}->{connected}) { if ($nick eq $users{$fh}->{nick}) { return } # a-z A-Z 0-9 ^ _ - ` \ [ ] { } | are the valid characters. Ni +ck can't start with a digit or a -. elsif (($nick =~ /^[0-9]/) || ($nick =~ /[^a-zA-Z0-9\^_\-\`\\\ +[\]\{\}\|]/) || ($nick =~ /^\-/)) { send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, $nick, 'Ille +gal characters'); } elsif ($nick =~ /^NickServ$/i) { send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, 'NickServ', +'No password stealing. Thanks.'); } elsif ($users{lc $nick}) { my $nick_in_use = $users{lc $nick}; send_user_msg_num($fh, $ERR_NICKNAMEINUSE, $users{$nick_in +_use}->{nick}); } else { # We have to send_user_msg_addr first so that the nick mes +sage comes out with the proper address: send_user_msg_addr($fh, "NICK :$nick"); my $old_nick = $users{$fh}->{nick}; delete $users{lc $old_nick}; $users{lc $nick} = $fh; $users{$fh}->{nick} = $nick; } } else { if (($nick =~ /^[0-9]/) || ($nick =~ /[^a-zA-Z0-9\^_\-\`\\\[\] +\{\}\|]/) || ($nick =~ /^\-/)) { send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, $nick, 'Ille +gal characters'); } elsif ($nick =~ /^NickServ$/i) { send_user_msg_num($fh, $ERR_ERRONEUSNICKNAME, 'NickServ', +'No password stealing. Thanks.'); } elsif ($users{lc $nick}) { my $nick_in_use = $users{lc $nick}; send_user_msg_num($fh, $ERR_NICKNAMEINUSE, $users{$nick_in +_use}->{nick}); } else { $users{$fh}->{nick} = $nick; $users{lc $nick} = $fh; if ($users{$fh}->{user_done}) { delete $users{$fh}->{user_done}; push @clients_to_connect, $fh; } else { $users{$fh}->{nick_done} = 1 } } } } # Sends off NOTICEs and PRIVMSGs. sub serv_privmsg { my ($fh, $args) = @_; my ($nick, $message_text) = (split / /, $args)[1, 2]; if (!$message_text) { send_user_msg_num($fh, $ERR_NOTEXTTOSEND); r +eturn; } if ($users{lc $nick}) { my $receiving_fh = $users{lc $nick}; my $message = ":$users{$fh}->{nick}!$users{$fh}->{username}\@$ +users{$fh}->{hostname} $args"; send_user_msg_raw($receiving_fh, $message); } else { send_user_msg_num($fh, $ERR_NOSUCHNICK, $nick) } } # Returns whois data about a nick. sub serv_whois { my ($fh, $args) = @_; my $nick = (split / /, $args)[1]; if (!$nick) { send_user_msg_num($fh, $ERR_NONICKNAMEGIVEN); return +; } if ($users{lc $nick}) { my $fh_of_whoised_nick = $users{lc $nick}; send_user_msg_num($fh, $RPL_WHOISUSER, $users{$fh_of_whoised_n +ick}->{nick}, $users{$fh_of_whoised_nick}->{username}, $users{$fh_of_ +whoised_nick}->{hostname}, $users{$fh_of_whoised_nick}->{realname}); send_user_msg_num($fh, $RPL_WHOISSERVER, $users{$fh_of_whoised +_nick}->{nick}, $local{server}, $local{server_desc}); send_user_msg_num($fh, $RPL_ENDOFWHOIS, $users{$fh_of_whoised_ +nick}->{nick}); } else { send_user_msg_num($fh, $ERR_NOSUCHNICK, $nick); send_user_msg_num($fh, $RPL_ENDOFWHOIS, $nick); } } # Returns server connection data. sub serv_lusers { my ($fh) = @_; send_user_msg_num($fh, $RPL_LUSERCLIENT, $local{non_invisible_user +s}, $local{invisible_users}, $local{servers}); send_user_msg_num($fh, $RPL_LUSEROP, $local{operators}); send_user_msg_num($fh, $RPL_LUSERUNKNOWN); send_user_msg_num($fh, $RPL_LUSERCHANNELS, $local{channels}); send_user_msg_num($fh, $RPL_LUSERME, $local{users}, $local{servers +}); send_user_msg_num($fh, $RPL_LOCALUSERS, $local{users}, $local{reco +rd_users}); send_user_msg_num($fh, $RPL_GLOBALUSERS, $local{users}, $local{rec +ord_users}); } # Returns the message of the day. sub serv_motd { my ($fh) = @_; if (open MOTD, $local{motd_file}) { send_user_msg_num($fh, $RPL_MOTDSTART, $local{server}); while (<MOTD>) { send_user_msg_num($fh, $RPL_MOTD, $_) } close MOTD; send_user_msg_num($fh, $RPL_ENDOFMOTD); } else { send_user_msg_num($fh, $ERR_NOMOTD); warn "MOTD could not be opened: $!\n"; } } sub serv_online { # %fhs is gone. How's this work now? my ($fh) = @_; #send_user_msg_serv($fh, "NOTICE :Current online nicks ($local{use +rs} total): "); #foreach my $fhs (values %fhs) { send_user_msg_serv($fh, "NOTICE : +$users{$fhs}->{nick}") } send_user_msg_serv($fh, "NOTICE :Broken, fix later."); } ###################################################################### +##### # Other subroutines: ###################################################################### +##### # Supply a date to show when the server was started. sub get_date { my @args = split / /, localtime $^T; "@args[0, 1, 2, 4] at $args[3] CST"; }

In reply to The Veachian IRC Daemon by Veachian64

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post; it's "PerlMonks-approved HTML":



  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.
  • Log In?
    Username:
    Password:

    What's my password?
    Create A New User
    Chatterbox?
    and the web crawler heard nothing...

    How do I use this? | Other CB clients
    Other Users?
    Others browsing the Monastery: (4)
    As of 2015-07-06 04:58 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      The top three priorities of my open tasks are (in descending order of likelihood to be worked on) ...









      Results (70 votes), past polls