1     #!/usr/bin/perl -Tw
2     $|++;
3     use strict;
4     use CGI qw(:standard escapeHTML);
5     use HTTP::Daemon;
6     use HTTP::Status;
7     use URI::Find;
8     
9     ## config
10    my $PORT = 42001;           # at what port
11    my $TIMEOUT = 90;           # number of quiet seconds before abort
12    my $CHAT_TIME_MAX = 300;    # how long to keep old scrollback
13    my $CHAT_COUNT_MAX = 12;    # how many messages max
14    my $NAME_MAX = 30;          # how long can a name be
15    my $MESS_MAX = 120;         # how long can a message be
16    ## end config
17    
18    my ($HOST) = $ENV{SERVER_NAME} =~ /(.*)/s; # untaint
19    
20    my $d = do {
21      local($^W) = 0;
22      new HTTP::Daemon (LocalAddr => $HOST, LocalPort => $PORT,
        Reuse => 1)
23    };
24    my $url = "http://$HOST:$PORT";
25    
26    print header;
27    # durn - no shortcuts for this!  what was lincoln thinkin'? :)
28    print &lt;&lt;END;
29    &lt;html>&lt;head>&lt;title>Chat with us!&lt;/title>&lt;/head>
30    &lt;frameset rows="75%,25%">
31    &lt;frame src="$url/read10" name=read>&lt;frame src="$url/write"
      name=write>
32    &lt;/frameset>&lt;/html>
33    END
34      
35    exit 0 unless defined $d;   # do we need to become the server?
36    
37    defined(my $pid = fork) or die "Cannot fork: $!";
38    exit 0 if $pid;             # I am the parent
39    close(STDOUT);
40    
41    my @CHAT;
42    {
43      alarm($TIMEOUT);              # (re-)set the deadman timer
44      my $c = $d->accept or redo;   # $c is a connection
45      my $r = $c->get_request;      # $r is a request
46      close $c, redo unless $r;     # not sure why I need this
47    
48      (my $code = $r->url->epath) =~ s{^/}{};
49      $c->send_basic_header;
50      $CGI::Q = new CGI $r->content;
51    
52      print $c header;              # start_html is inside switch
53      if (my ($secs) = $code =~ /read(\d+)/) {
54        print $c start_html(-head => ["&lt;meta http-equiv=refresh
         content=$secs>"]);
55        
56        print $c h1("Chat responses"), "Change update to";
57        print $c " ",a({-href => "$url/read$_"}, $_) for qw(1 2 5 10 15 30               60);
58        print $c " seconds", br;
59    
60        shift @CHAT while @CHAT > $CHAT_COUNT_MAX or
61          @CHAT and $CHAT[0][0] &lt; time - $CHAT_TIME_MAX;
62        print $c table( {-border => 0, -cellspacing => 0, -cellpadding
           => 2 },
63     map { Tr(td([substr(localtime($_->[0]),11,8).' from '.
64     fix($_->[1]).':', fix($_->[2],1) ]))} @CHAT);
65    
66      } elsif ($code =~ /write/) {
67        if (defined(my $name = param('name'))
68            and defined(my $message = param('message'))) { 
              # we have input!
69          tr/\x00-\x1f//d for $name, $message; # remove nasties
70          $name = substr($name, 0, $NAME_MAX) if length $name >
              $NAME_MAX;
71          $message = substr($message, 0, $MESS_MAX) if length $message
              > $MESS_MAX;
72          push @CHAT, [time, $name, $message] if length $name and
              length $message;
73        }
74    
75        print $c start_html, h1("Chat write");
76        print $c start_form(-action => "$url/write");
77        print $c textfield("name","[I must change my name]",
            $NAME_MAX),
78          submit("says:"), textfield("message", "", $MESS_MAX,
             $MESS_MAX, 1);
79        print $c end_form;
80      }
81    
82      print $c end_html;
83    
84      close $c;
85      redo;
86    }
87    
88    sub fix {    # HTML escape, plus find URIs if $_[1]
89      local $_ = shift; return escapeHTML($_) unless shift;
90      # use \001 as "shift out", "shift in", presume data doesn't have
          \001
91      find_uris($_, sub {my ($uri, $text) = @_;
92                         qq{\1&lt;a href="\1$uri\1 "
           target=_blank>\1$text\1&lt;/a>\1} });
93      s/\G(.*?)(?:\001(.*?)\001)?/escapeHTML($1).(defined $2 ? $2 :
          "")/eig;
94      $_;
95    }