#!/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

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!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • 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, details, 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, summary, 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.