comment on

#!/usr/bin/perl -Tw
# copyright (c) 2000 by Randal L. Schwartz for WebTechniques Magazine
# this draft provided for review purposes only
$|++;
use strict;
use CGI qw(:standard escapeHTML);
use HTTP::Daemon;
use HTTP::Status;
use URI::Find;

## config
my $PORT = 42001;               # at what port
my $TIMEOUT = 90;               # number of quiet seconds before abort
my $CHAT_TIME_MAX = 300;        # how long to keep old scrollback
my $CHAT_COUNT_MAX = 12;        # how many messages max
my $NAME_MAX = 30;              # how long can a name be
my $MESS_MAX = 120;             # how long can a message be
## end config

my ($HOST) = $ENV{SERVER_NAME} =~ /(.*)/s; # untaint

my $d = do {
  local($^W) = 0;
  new HTTP::Daemon (LocalAddr => $HOST, LocalPort => $PORT, Reuse => 1
+)
};
my $url = "http://$HOST:$PORT";

print header;
# durn - no shortcuts for this!  what was lincoln thinkin'? :)
print <<END;
<html><head><title>Chat with us!</title></head>
<frameset rows="75%,25%">
<frame src="$url/read10" name=read><frame src="$url/write" name=write>
</frameset></html>
END
  
exit 0 unless defined $d;       # do we need to become the server?

defined(my $pid = fork) or die "Cannot fork: $!";
exit 0 if $pid;                 # I am the parent
close(STDOUT);

my @CHAT;
{
  alarm($TIMEOUT);              # (re-)set the deadman timer
  my $c = $d->accept or redo;   # $c is a connection
  my $r = $c->get_request;      # $r is a request
  close $c, redo unless $r;     # not sure why I need this

  (my $code = $r->url->epath) =~ s{^/}{};
  $c->send_basic_header;
  $CGI::Q = new CGI $r->content;

  print $c header;              # start_html is inside switch
  if (my ($secs) = $code =~ /read(\d+)/) {
    print $c start_html(-head => ["<meta http-equiv=refresh content=$s
+ecs>"]);
    
    print $c h1("Chat responses"), "Change update to";
    print $c " ",a({-href => "$url/read$_"}, $_) for qw(1 2 5 10 15 30
+ 60);
    print $c " seconds", br;

    shift @CHAT while @CHAT > $CHAT_COUNT_MAX or
      @CHAT and $CHAT[0][0] < time - $CHAT_TIME_MAX;
    print $c table( {-border => 0, -cellspacing => 0, -cellpadding => 
+2 },
                    map { Tr(td([substr(localtime($_->[0]),11,8).' fro
+m '.
                                 fix($_->[1]).':', fix($_->[2],1) ]))}
+ @CHAT);

  } elsif ($code =~ /write/) {
    if (defined(my $name = param('name'))
        and defined(my $message = param('message'))) { # we have input
+!
      tr/\x00-\x1f//d for $name, $message; # remove nasties
      $name = substr($name, 0, $NAME_MAX) if length $name > $NAME_MAX;
      $message = substr($message, 0, $MESS_MAX) if length $message > $
+MESS_MAX;
      push @CHAT, [time, $name, $message] if length $name and length $
+message;
    }

    print $c start_html, h1("Chat write");
    print $c start_form(-action => "$url/write");
    print $c textfield("name","[I must change my name]", $NAME_MAX),
      submit("says:"), textfield("message", "", $MESS_MAX, $MESS_MAX, 
+1);
    print $c end_form;
  }

  print $c end_html;

  close $c;
  redo;
}

sub fix {                       # HTML escape, plus find URIs if $_[1]
  local $_ = shift; return escapeHTML($_) unless shift;
  # use \001 as "shift out", "shift in", presume data doesn't have \00
+1
  find_uris($_, sub {my ($uri, $text) = @_;
                     qq{\1<a href="\1$uri\1" target=_blank>\1$text\1</
+a>\1} });
  s/\G(.*?)(?:\001(.*?)\001)?/escapeHTML($1).(defined $2 ? $2 : "")/ei
+g;
  $_;
}
[download]

In reply to WebChat in under 100 lines of Perl by merlyn

Are you posting in the right place? Check out Where do I post X? to know for sure.
Posts may use any of the Perl Monks Approved HTML tags. Currently these include the following:
<code> <a> <b> <big> <blockquote> <br /> <dd> <dl> <dt> <em> <font> <h1> <h2> <h3> <h4> <h5> <h6> <hr /> <i> <li> <nbsp> <ol> <p> <small> <strike> <strong> <sub> <sup> <table> <td> <th> <tr> <tt> <u> <ul>
Snippets of code should be wrapped in <code> tags not <pre> tags. In fact, <pre> tags should generally be avoided. If they must be used, extreme care should be taken to ensure that their contents do not have long lines (<70 chars), in order to prevent horizontal scrolling (and possible janitor intervention).
Want more info? How to link or How to display code and escape characters are good places to start.


go ahead... be a heretic
	PerlMonks