#!/usr/bin/perl -wT

$safeperl = 0;

$scripturl = 'psychopath.pl';

$datafile = 'psychopathdata';
$datadir = '/home/ganesh/psychopath';

$donefile = 'done.thtml';
$newentryfile = 'newentry.thtml';
$errorfile = 'error.thtml';
$viewfile = 'view.thtml';

@entries = ('name','email','text', 'road');

$notify = 'psychopath@lists.urchin.earth.li';
# $notify = 'ganesh@earth.li';
$short_notify = 'psychopath-short@lists.urchin.earth.li';

$admin = 'ganesh@earth.li';
$from = 'Marston Psychopath Status Update <psychopath@urchin.earth.li>';

# --- For non-safeperl --- #

use Carp;

sub sort_numeric { sort {$a <=> $b} @_ }

$ENV{'PATH'} = '';

sub mail {
    croak 'Usage: mail($recipient, $subject, $contents)' unless @_ == 3;
    my ($recipient, $subject, $contents) = @_;
    croak 'Undefined recipient' unless defined $recipient;
    croak 'Undefined subject' unless defined $subject;
    croak 'Undefined contents' unless defined $contents;
    local(*MAILHANDLE);
    # Sanity checks
    return 0 unless length($recipient) < 256
        && $recipient =~ /^[A-Za-z0-9][A-Za-z0-9.@%:$&_+=~-]+$/
        && length($subject) <= 256;
    # Mild attempt to avoid people sending local email by mistake
    return 0 if $recipient !~ /@/;
    $subject =~ tr/\n\r\f//d;
    my $pid = open(MAILHANDLE, "|-");
    return 0 unless defined($pid);
    if (!$pid) {
        # child
        # Avoid calling "exit" on failure since it no longer does a real
        # exit and instead returns to perl in the child with a "Callback
        # called exit" error message followed by double flushing of
        # input buffers
        exec("/usr/bin/mail", "-s $subject",
                              '-a', "From: $from", $recipient)
            or exec("/bin/false") or die "panic: can't even exec /bin/false\n";
    }
    # parent
    print MAILHANDLE $contents;
    close MAILHANDLE;
    return !($? >> 8);
}



# --- Hopefully you shouldn't need to change anything below this line --- #

$datainput = $datadir.'/'.$datafile;
$dataoutput = $safeperl ? $datafile : $datainput;

print "Content-type: text/html\n\n";

sub linksub {
  ($var,$string,$queryhash,$form)=@_;
  if($form) {
    $formstart='<FORM ACTION="'.$scripturl.'" METHOD="post">';
    foreach $key (keys %$queryhash) {
      $formstart.='<INPUT TYPE="hidden" NAME="'.$key.'" VALUE="'
	.$$queryhash{$key}.'">';
    }
    $formstart.=authfields();
    $formstart.='<INPUT TYPE="submit" VALUE="';
    $formend='"></FORM>';
    $$var=~s/\<A[\w\s]*$string[\w\s]*\>(.*?)\<\/A\>/$formstart$1$formend/sig;
  } else {
    $query="";
    foreach $key (keys %$queryhash) {
      $query.="$key=$$queryhash{$key}&";
    }
    chop $query;
    $query=~s/&/&amp;/g;
    $$var=~s/\<A([\w\s]*)$string([\w\s]*)\>/<A$1HREF=\"$scripturl?$query$2\">/sig;
  }
}

sub formsub {
  ($var,$string,$replace)=@_;
  $$var=~s/\<FORM(.*?)$string(.*?)\>/<FORM$1$replace$2>/sig;
}

sub slurp {
  my ($filename)=@_;
  open FILE,"<$datadir/$filename"
    or cgierror("Couldn't open $filename");
  my $data="";
  while(<FILE>) {
    $data.=$_;
  }
  close FILE;
  linksub(\$data,"NEWENTRY",{"mode" => "newentry"},0);
  linksub(\$data,"VIEW",{"mode" => "view"},0);
  formsub(\$data,"ACTIONSELF",'ACTION="'.$scripturl.'"');
  return $data;
}

$handlingerror=0;

sub cgierror {
  my ($error)=@_;
  if($handlingerror) {
    print "<HTML><HEAD><TITLE>Fatal error!</TITLE></HEAD>\n";
    print "<BODY><H1>";
    print $error;
    print "</H1><BR>";
    print "Please email <a href=\"mailto:$admin\">$admin</a> "
      ."explaining how you got this error";
    print "</BODY></HTML>\n";
  }
  $handlingerror=1;
  
  $errordata=slurp($errorfile);

  $errordata=~s/\$errmsg/$error/ig;

  print $errordata;

  exit;
}

sub escape {
  my $data=shift;
  $data=~s/&/&amp;/g;
  $data=~s/</&lt;/g;
  $data=~s/>/&gt;/g;
  # not sure if these improve the look or not, on balance probably not
  # $data=~s/\n/<BR>/g;
  # $data=~s/\\n/<BR>/g;
  return $data;
}

sub optimise_shortlength {
  my ($name, $msg, $min_name_length, $max_shortmsg_length) = @_;
  my ($name_trimmed, $msg_trimmed);
  my $name_sep = ' --';
  my $ellipsis = '...';
  $msg =~ s/\n/ /g;
  my $overflow_length = length($name) + length($name_sep) + length($msg) - $max_shortmsg_length;
  if ($overflow_length <= 0) {
    $name_trimmed = $name;
    $msg_trimmed = $msg;
  } elsif ($overflow_length < (length($name) - $min_name_length)) {
    $name_trimmed = substr($name, 0, $overflow_length);
    $msg_trimmed = $msg
  } else {
    $name_trimmed = substr($name, 0, $min_name_length);
    $msg_trimmed = substr($msg, 0, $max_shortmsg_length - length($name_trimmed) - length($name_sep) - length($ellipsis)) . $ellipsis;
  }
  my $shortmsg = $msg_trimmed . $name_sep . $name_trimmed;
  return $shortmsg;
}

if(uc($ENV{'REQUEST_METHOD'}) eq "GET") {
   $input=$ENV{'QUERY_STRING'};
} elsif(uc($ENV{'REQUEST_METHOD'}) eq "POST") {
   read(STDIN,$input,$ENV{'CONTENT_LENGTH'});
}

@kvpairs = split (/&/, $input);

foreach $kvpair (@kvpairs) {
  ($key,$value) = split (/=/, $kvpair);
  $value =~ tr /+/ /;
  $value =~ s/%([\dA-Fa-f][\dA-Fa-f])/pack ("C", hex ($1))/eg;
  $kvpairs{$key} = $value;
}

defined($kvpairs{'mode'}) or $kvpairs{'mode'}='view';

if($kvpairs{'mode'} eq 'add') {
  
  foreach $entry (@entries) {
    defined($kvpairs{$entry}) or cgierror("You need a $entry parameter");
  }

  $kvpairs{'road'} = lc($kvpairs{'road'});
  $kvpairs{'road'} =~ s/\s//g;

  $kvpairs{'road'} eq 'motorway' or cgierror("You got the road wrong");

  $remote="$ENV{'REMOTE_ADDR'} ($ENV{'REMOTE_HOST'})";

  mail($notify,"Psychopath update",
       "Author: $kvpairs{'name'} ($kvpairs{'email'}) from $remote\n".
       "Information: \n$kvpairs{'text'}\n");

  my $shortmsg = optimise_shortlength($kvpairs{'name'}, $kvpairs{'text'}, 12, 140);
  mail($short_notify, $shortmsg, $shortmsg);

  open DATA, ">>$dataoutput"
    or cgierror("Couldn't open submissions file for writing");

  print DATA time;
  print DATA "\n";

  foreach $entry (@entries) {
    $kvpairs{$entry}=~s/\n/\\n/g;
    chomp($kvpairs{$entry});
    print DATA $entry.'='.$kvpairs{$entry}."\n";
  }

  print DATA "remote=$remote\n";
  print DATA "--\n";

  close DATA;
  
  print slurp($donefile);

} elsif($kvpairs{"mode"} eq "view") {

  $template=slurp($viewfile);

  open DATAI,"$datainput"
    or cgierror("Couldn't open data file for reading");

  until(eof DATAI) {
    $time=<DATAI>;
    chomp $time;

    my $lastkey;

    do {
      $input=<DATAI>;
      # handle continuation lines which seem to appear with a literal \n
      if ($input =~ /^\\n(.*)$/) { $data{$time}->{$lastkey}.="\n$1"; }
      if ($input=~/^(\w+)=(.*)$/) { $data{$time}->{$1}=$2; $lastkey=$1; }
    } while($input!~/^--$/);
  }

  close DATAI;

  $page=defined($kvpairs{"page"}) ? $kvpairs{"page"} : 1;

  ($max)=
    ($template=~/\<REPEAT MAX=(\d+)\>/i)
      or cgierror("Need MAX specifier in REPEAT tag in template file");

  $startnum=$max*($page-1);
  $endnum=$max*($page)-1;
  
  $maxnum=(scalar keys %data)-1;

  $endnum>$maxnum and $endnum=$maxnum;

  if($startnum==0) {
    $template=~s/\<IFNEXT\>.*?\<\/IFNEXT\>//sig;
  } else {
    $template=~s/\<IFNEXT\>(.*?)\<\/IFNEXT\>/$1/sig;      
    linksub(\$template,"NEXT",
	    {"mode" => $kvpairs{"mode"},
	     "page" => $page-1},
	    0);
  }

  if($endnum==$maxnum) {
    $template=~s/\<IFPREV\>.*?\<\/IFPREV\>//sig;
  } else {
    $template=~s/\<IFPREV\>(.*?)\<\/IFPREV\>/$1/sig;
    linksub(\$template,"PREV",
	    {"mode" => $kvpairs{"mode"},
	     "page" => $page+1},
	    0);
  }

  ($pre,$repeat,$post)=
    ($template=~/^(.*)\<REPEAT MAX=\d+\>(.*)\<\/REPEAT\>(.*)$/si)
      or cgierror("Bad template file format");


  print $pre;

  foreach $time ((reverse (sort_numeric (keys %data)))[$startnum..$endnum]) {
    ($min,$hour,$day,$mon,$year,$wday) = (localtime($time))[1,2,3,4,5,6];
    @months = ("January","February","March","April","May","June",
	       "July","August","September","October","November","December");
    @days = ('Sunday','Monday','Tuesday','Wednesday','Thursday',
	     'Friday','Saturday');

    $datestr="$days[$wday] $day $months[$mon] ".($year+1900)
      ." ".($hour<10 ? "0$hour" : $hour).":"
      .($min<10 ? "0$min" : $min)."\n";
    $out=$repeat;

  $data{$time}->{'email'}=~/([\d\w\._\-\+\%]+@[\d\w\._\-\+\%]+)/ 
    or $data{$time}->{'email'}='';
    
    foreach $entry (@entries,'remote') {
      $out=~s/\$$entry/escape($data{$time}->{$entry})/ieg;
    }
    $out=~s/\$date/$datestr/ig;

    print $out;
  }
		 
  print $post;
		 
} elsif($kvpairs{"mode"} eq "newentry") {
  print slurp($newentryfile);
} else {
  cgierror("Unknown mode!");
}
