Beefy Boxes and Bandwidth Generously Provided by pair Networks
We don't bite newbies here... much

WebChat in under 100 lines of Perl

by merlyn (Sage)
on Sep 05, 2000 at 08:06 UTC ( #31083=sourcecode: print w/replies, xml ) Need Help??
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>
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

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{^/}{};
  $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
    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 > $
      push @CHAT, [time, $name, $message] if length $name and length $

    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, 
    print $c end_form;

  print $c end_html;

  close $c;

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
  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
Replies are listed 'Best First'.
RE: WebChat in under 100 lines of Perl
by bastard (Hermit) on Sep 08, 2000 at 08:11 UTC
    Neat script. I have one small enhancement. It will enable the use of the enter key to submit the just-typed message. (It's only an added convenience.)
    Unfortunatley javascript would be needed to refocus the cursor after the submission. (like google does)

    Replace this section of code:

    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;
    With this section of code:
    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), s +ubmit("Change Name"); print $c end_form; print $c start_form(-action => "$url/write"); print $c hidden("name","[I must change my name]", $NAME_MAX), subm +it("says:"), textfield("message", "", $MESS_MAX, $MESS_MAX, 1); print $c end_form;
    And it still falls under 100 lines (just not as much).
RE: WebChat in under 100 lines of Perl
by Anonymous Monk on Sep 21, 2000 at 10:27 UTC
    How about
    print $c start_html (-onload => 'document.forms[0].elements["message"].focus()'), h1("Chat write");
    This will save the users from clicking into the text filed, they can type the messages staright away.

    Edit kudra, 2001-11-09 Replaced pre with code

Re: WebChat in under 100 lines of Perl
by brandybuck31 (Novice) on Sep 21, 2004 at 14:50 UTC
    Do you know why I would be getting this message when trying to run this on a Solaris 8 system with Perl 5.8.5 (although I get the same error with Perl 5.6.1): Can't locate object method "epath" via package "URI::http" at line 48 I installed LWP, URI-Find, and URI, and running perl -MCPAN -e 'install "URI::http"' says that it is up to date. Thanks.
Log In?

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://31083]
[LanX]: AnomalousMonk: yeah the asteroid but not the god, right?
[jedikaiti]: :-)
[AnomalousMonk]: LanX: Of course the asteroid! There is/are no god(s).
erix suddenly wants to hear My Sweet Lord once more

How do I use this? | Other CB clients
Other Users?
Others having an uproarious good time at the Monastery: (17)
As of 2017-11-22 17:17 GMT
Find Nodes?
    Voting Booth?
    In order to be able to say "I know Perl", you must have:

    Results (327 votes). Check out past polls.