Beefy Boxes and Bandwidth Generously Provided by pair Networks Cowboy Neal with Hat
more useful options
 
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
  • Outside of code tags, you may need to use entities for some characters:
            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 contemplating the Monastery: (7)
    As of 2014-04-20 13:44 GMT
    Sections?
    Information?
    Find Nodes?
    Leftovers?
      Voting Booth?

      April first is:







      Results (485 votes), past polls