http://qs321.pair.com?node_id=31083
Category: CGI Programming
Author/Contact Info Randal L. Schwartz - merlyn
Description: I was challenged by the fellow columnists of WebTechniques Magazine to write a nice decent WebChat in under 100 lines of Perl. I did it with 95. It works without JavaScript or Java, in all browsers that support frames and client-pull (meta refresh). Oh, and it even detects any URL-like strings in the messages, and auto links them to their target. In 95 lines. Yes.

This code is a review draft from a forthcoming WebTechniques Perl column and is provided for review purposes only. Further copying and redistribution is not permitted. Sorry, but that's the rules about the code I do for hire. (Clarification: You can download this and put it on your site to use it for "evaluation purposes", but you cannot redistribute the source out of context. Once the magazine releases the code, in about three months, you can download it from my official site and do with it what you want. I'm sorry for not being clearer about this, and sorry for being more restrictive than most open source stuff, but this is "work for hire", and I have to be careful.)

 
#!/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;
  $_;
}

Back to Code Catacombs