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;
$_;
}
|
RE: WebChat in under 100 lines of Perl
by bastard (Hermit) on Sep 08, 2000 at 08:11 UTC
|
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). | [reply] [Watch: Dir/Any] [d/l] [select] |
RE: WebChat in under 100 lines of Perl
by Anonymous Monk on Sep 21, 2000 at 10:27 UTC
|
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
| [reply] [Watch: Dir/Any] [d/l] |
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. | [reply] [Watch: Dir/Any] |
|
|