Beefy Boxes and Bandwidth Generously Provided by pair Networks
The stupid question is the question not asked
 
PerlMonks  

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

Comment on WebChat in under 100 lines of Perl
Download Code
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)

    Howto:
    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).
(duplicate of 33452) RE: WebChat in under 100 lines of Perl
by NodeReaper (Curate) on Sep 21, 2000 at 10:26 UTC

    Reason: (tfrayner) Duplicate node submitted with appropriate code tags. This node is redundant.

    For more information on this node visit: this

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.
    /Alex

    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 webchat.pl 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.

Back to Code Catacombs

Log In?
Username:
Password:

What's my password?
Create A New User
Node Status?
node history
Node Type: sourcecode [id://31083]
help
Chatterbox?
and the web crawler heard nothing...

How do I use this? | Other CB clients
Other Users?
Others avoiding work at the Monastery: (20)
As of 2014-07-24 16:13 GMT
Sections?
Information?
Find Nodes?
Leftovers?
    Voting Booth?

    My favorite superfluous repetitious redundant duplicative phrase is:









    Results (162 votes), past polls