«11C» chat.pl «PDF», «POD»

#!/usr/bin/perl

use warnings;
use strict;

use constant {
  MAX_NICK_LENGTH => 20,
  MAX_MSG_LENGTH  => 200,
  KLASSE11TK_HOME => "http://m19s28.vlinux.de/iblech/klasse11/",
  STAMPFILE       => "/tmp/klasse11-relay.stamp",
  DELAY           => 8,
};

sub sendmsg($$);

use CGI;
use CGI::Carp "fatalsToBrowser";
use File::Touch;
my $q = CGI->new;

my $user = $q->param("username");
my $msg  = $q->param("message");

my $last = (stat STAMPFILE)[9] || 0;
if(
  defined $user and
  defined $msg  and
  length($user) <= MAX_NICK_LENGTH  and
  length($msg)  <= MAX_MSG_LENGTH   and
  $user =~ /^[\w@|\\\/^+\-*.,;:]+$/ and
  $msg  =~ /^[\x20-\xff]+$/         and
  time - $last > DELAY
) {
  sendmsg $user => $msg;
  touch STAMPFILE or die "touch(STAMPFILE) schlug fehl: $!\n";
}

my $redir = $q->param("redirect") || $q->referer || KLASSE11TK_HOME;

print $q->redirect($redir),
      $q->start_html("Moved"),
      $q->p("<a href=\"" . qh($redir) . "\">Hier geht&#39;s weiter...</a>"),
      $q->end_html;
exit;

sub sendmsg($$) {
  my ($user, $msg) = @_;

  open my $fh, "|-", "/home/heinz/heinzbot/relay",
		     "--fifo=/tmp/klasse11-relay.fifo",
		     "--log=/tmp/klasse11-relay.log" or
		       die "Konnte nicht relay starten: $!\n";

  print $fh "[[$user]] $msg\n";

  close $fh;
}

sub qh {
  my $str = shift;

  my %subst = (
    '&' => "&amp;",
    '<' => "&lt;",
    '>' => "&gt;",
    '"' => "&quot;",

    # http://www.w3.org/TR/xhtml1/#C_13
    # The named character reference &apos; (the apostrophe, U+0027) was
    # introduced in XML 1.0 but does not appear in HTML. Authors should therefore
    # use &#39; instead of &apos; to work as expected in HTML 4 user agents.
    "'" => "&#39;",
  );

  my $new = "";
  while(length $str) {
    my $char = substr $str, 0, 1, "";
    $new .= defined $subst{$char} ? $subst{$char} : $char;
  }

  return $new;
}