=head1 NAME

TPages - Tsort Page handler

=head1 DESCRIPTION

This package provides the page handling for the Tsort pages
on the web site

=cut

package TPages;

use 5.006;
use strict;
use warnings;

require Exporter;

our @ISA = qw(Exporter);

our %EXPORT_TAGS = ( 'all' => [ qw(
	
) ] );

our @EXPORT_OK = ( @{ $EXPORT_TAGS{'all'} } );

our @EXPORT = qw(
	
);
our $VERSION = '0.01';

my $attach_dir = "/var/www/attach/";
my $log_dir = "/var/log/apache2";
my $site = "";

use Apache2::Const qw(FORBIDDEN DECLINED OK M_GET M_POST
                      MODE_READBYTES SERVER_ERROR 
                      HTTP_LOCKED HTTP_UNAUTHORIZED);

use APR::Const    qw(SUCCESS BLOCK_READ);

use Apache2::RequestRec;
use Apache2::RequestIO;
use Apache2::ServerUtil;
use Apache2::Directive;
use Apache2::ServerRec;
use Apache2::URI;
use Apache2::Connection;
use Apache2::Filter;
use Apache2::SubProcess ();

use APR::Brigade;
use APR::Bucket;
use APR::Table;

use constant IOBUFSIZE => 8192;

use IO::File;
use Time::Local;

my %config;
my %query;

sub got_error
  {
    my($msg) = @_;
    Apache2::ServerRec->log_error($msg."\n");
    return "<span class=\"error_msg\">$msg</span>";
  }

sub unpack_var
  {
    my($r,$line) = @_;
    return undef if(!defined $line || $line eq "");

    if($line =~ m/^([\w\d_\-]+)(\s*=\s*|\s+)(\S.*)$/)
      {
        return($1,$3);
      }
    # Should give an error here really
    return(got_error("Cannot unpick config variable from \"$line\""));
  }

sub unpick_config
  {
    # In Apache2 the dir_config() method has been removed from 
    # the request and replaced with per_dir_config() which 
    # returns a class that has no documentation.

    # The documentation says that you can call dir_config() on
    # the Apache2::ServerUtil->server() object passing a key, 
    # but you can't.  If you pass no key you get a APR::Table object
    # which the documentation says is tied to a hash, but FIRSTKEY 
    # is not implemented so the keys() function won't work.  The 
    # documentation also claims that a do() method has been 
    # created to iterate over the keys, but it hasn't.

    # There is a Apache2::Directive method that returns the 
    # configuration information.  So we use that and do it the 
    # hard way
    my $r = shift;
    my %ret;
    my $tree = Apache2::Directive::conftree();
    my $hash = $tree->lookup('Location', $r->uri());
    my $vars = ${$hash}{PerlSetVar};
    if(ref($vars) eq "ARRAY")
      {
        foreach my $l (@{$vars})
          {
            next if(!defined $l || $l eq "");
            my($k1,$v1) = unpack_var($r,$l);
            $ret{$k1} = $v1
                     if(defined $v1);
          }
      }
    else
      {
        return () if(!defined $vars || $vars eq "");
        my($k,$v) = unpack_var($r,$vars);
        $ret{$k} = $v
                 if(defined $v);
      }
    return %ret;
  }

sub content 
  {
    # From http://perl.apache.org/docs/2.0/user/handlers/filters.html#All_in_One_Filter
    # There must be a better way but I don't know what it is

    my $r = shift;
  
    my $bb = APR::Brigade->new($r->pool, $r->connection->bucket_alloc);
  
    my $data = '';
    my $seen_eos = 0;
    do{
        $r->input_filters->get_brigade($bb, Apache2::Const::MODE_READBYTES,
                                         APR::Const::BLOCK_READ, IOBUFSIZE);
  
        for (my $b = $bb->first; $b; $b = $bb->next($b))
          {
            if ($b->is_eos)
              {
                $seen_eos++;
                last;
              }
  
            if ($b->read(my $buf))
              {
                $data .= $buf;
              }
  
            $b->remove; # optimization to reuse memory
          }
      } while (!$seen_eos);
  
    $bb->destroy;
  
    return $data;
  }

sub fill_query
  {
    # Extract any query args into the %query hash
    my $r = shift;

    # Clear out the current query vals
    %query = ();

    my $args = $r->args();
    if(defined $args)
      {
        # Extract parameters from the query
        my @q = split(/[\&]/,$args);
        while(@q)
          {
            my($var,$val) = split(/\=/,shift(@q));

            # Don't do any escape translation, we are just going to
            # send it on anyway

            if(defined $query{$var})
              {
                # Must have multiple values for a single param.  Angler 
                # uses this technique when creating [array] attributes

                # We shove such attributes into an array
                $query{$var} = [$query{$var}]
                               if(ref($query{$var}) ne "ARRAY");
                push @{$query{$var}},$val;
              }
            else
              {
                $query{$var} = $val;
              }
          }
      }
    return if($r->method_number() == M_GET);
    if($r->method_number() != M_POST)
      {
        Apache2::ServerRec->log_error("Handler cannot deal with ".
                            $r->method." (".$r->method_number().")");
        return;
      }

    # There are two types of request we could have, a 
    # set of var=val pairs or a multipart form
    # The first line tells us if this is a multipart form
    my $buffer = content($r);
    if($buffer =~ /^(\-{20,50}[0-9a-zA-Z]+)[\n\r]+/)
      {
        # This is a multipart form with a marker between each part
        my $marker = $1;
        $query{_multipart_marker} = $marker;

        while($buffer)
          {
            if($buffer =~ /$marker/)
              {
                my $chunk = $`;
                $buffer = $';

                $chunk =~ s/^\r\n//;
                next if($chunk eq "");
                my $attrib_name = "bad_spec";
    
                while($chunk)
                  {
                    if($chunk =~ s/^Content-Disposition\s*\:\s*form-data; name="([^\"]+)"; filename="([^\"]+)"[\n\r]+//i)
                      {
                        $attrib_name = $1;

                        $query{$1."_filename"} = $2;
                      }
                    elsif($chunk =~ s/^Content-Disposition\s*\:\s*form-data; name="([^\"]+)"[\n\r]+//i)
                      {
                        $attrib_name = $1;
                      }
                    elsif($chunk =~ s/^Content-Type\s*\:\s*(.*)[\n\r]+//)
                      {
                      }
                    elsif($chunk =~ s/^[\n\r]+//)
                      {
                        last;
                      }
                    else
                      {
                        last;
                      }
                  }
                # I think that the value has an extra CRLF on it
                $chunk =~ s/\r\n$//;
                $query{$attrib_name} = $chunk;
              }
            else
              {
                last;
              }
          }
      }
    else
      {
        # This is a set of var=val pairs, unpick it
        my @q = split(/[\&]/,$buffer);
        while(@q)
          {
            my($var,$val) = split(/\=/,shift(@q));
    
            # Don't do any escape translation, we are just going to
            # send it on anyway
    
            if(defined $query{$var})
              {
                # Must have multiple values for a single param.  Angler 
                # uses this technique when creating [array] attributes
    
                # We shove such attributes into an array
                $query{$var} = [$query{$var}]
                                   if(ref($query{$var}) ne "ARRAY");
                push @{$query{$var}},$val;
              }
            else
              {
                $query{$var} = $val;
              }
          }
      }
  }

sub fill_query_new
  {
    # The method described as upload doesnt work
  }

sub ip_banned
  {
    my($ip) = @_;
    # return 1 if($ip =~ m#^192.168.254.#i);
    return 1 if($ip =~ m#^91.207.61#i);
    return 1 if($ip =~ m#^66.67.59#i);
    return 1 if($ip =~ m#^68.53.138#i);
    return 1 if($ip =~ m#^68.89.75#i);
    return 1 if($ip =~ m#^91.122.6#i);
    return 1 if($ip =~ m#^89.110.16#i);
    return 1 if($ip =~ m#^24.17.196#i);
    return 1 if($ip =~ m#^180.150.131#i);
    return 1 if($ip =~ m#^123.243.77#i);
    return 1 if($ip =~ m#^189.127.190#i);
    return 1 if($ip =~ m#^190.2.14#i);
    return 1 if($ip =~ m#^193.173.148#i);
    return 1 if($ip =~ m#^79.160.18#i);
    return 1 if($ip =~ m#^178.150.51#i);
    return 1 if($ip =~ m#^91.197.146#i);
    return 1 if($ip =~ m#^94.102.51.196#i);
    return 1 if($ip =~ m#^77.92.233.198#i);
    return 1 if($ip =~ m#^94.100.25#i);
    return 1 if($ip =~ m#^85.141.190#i);
    return 1 if($ip =~ m#^85.141.181#i);
    return 1 if($ip =~ m#^31.192.105.38#i);
    return 1 if($ip =~ m#^89.149.242.189#i);
    return 1 if($ip =~ m#^91.201.67.12#i);

    return "";
  }

sub safari_form
  {
    my($r,$page_path,$extra) = @_;
    # Create special form for Safari Users
    my $set_site = "";
    $set_site = "<input type=\"hidden\" name=\"site\" value=\"$site\"/>"
                            if(defined $site && $site ne "");

        send_page("Contact Tsort",<<"EndForm");
<p>
The Safari and Android browsers for some reason do not correctly 
encode multipart forms unless you add an attachment 
(which is difficult if, for example, you are on an iPhone).
For that reason this special page will send a message to 
us without using a multipart form.  Usually it would be 
best to send us your email address so we can communicate 
directly rather than having to come here all the time.</p>
<form method="POST" action="/forms/contact.htm">
<table width="80%" align="center" class="contact_form">
  <tr><td width ="50%" class="contact_label">Subject:</td>
      <td width ="25%" class="contact_label">Email to Reply To:</td>
      <td width ="25%" class="contact_label">Attachment:</td></tr>
  <tr><td class="contact_val"><input type="text" size="40" name="subject"/></td>
      <td class="contact_val"><input type="text" name="email"/></td>
      <td class="contact_val">&nbsp;$set_site</tr>
  <tr><td colspan="3">
      <textarea name="body" rows="20" cols="70"></textarea></td></tr>
  <tr><td colspan="2">&nbsp;</td>
      <td><input type="submit" value="Send Message"/></td></tr>
</table>
EndForm
        return OK;
  }

sub contact_form
  {
    my($r,$page_path,$extra) = @_;

    my $this_ip = $r->connection()->remote_ip();

    # if the form has not yet been filled in we shouldn't be 
    # doing this test
    if("" && !defined $query{body})
      {
        send_page("Bad query structure",<<"EndForm");
<p>
This message seems to be missing essential components.
It looks like it was generated by a badly formed script,
 and has been rejected.
</p>
EndForm
        return OK;
      }
    if($query{body} =~ /(<|%3C)[\+\s]*a[\+\s]*href[\+\s]*(\=|%3d)/i)
      {
        send_page("Bad IP Address",<<"EndForm");
<p>
This message seems to contain spam, it has been 
rejected.
</p>
EndForm
        return OK;
      }
    if(ip_banned($this_ip) || 
            (defined $query{body} && $query{body} =~ /dildo/i) ||
            (defined $query{subject} && $query{subject} =~ /back\+to\+you/i) ||
            (defined $query{body} && $query{body} =~ /^\S{6}[\+\s]+%3Ca[\s\+]+href/i))
      {
        send_page("Bad IP Address",<<"EndForm");
<p>
This IP address has been used to attempt to send spam
using this mechanism.  Firstly this attempt failed and 
secondly this feature has been removed for this address.
</p>
EndForm
        return OK;
      }

    if(!defined $query{site} || $query{site} eq "")
      {
        $site = "";
      }
    else
      {
        $site = $query{site};
      }

    if(!defined $query{subject} && !defined $query{body})
      {
        # This has to be a enctype="multipart/form-data" form
        # for uploading stuff
        send_page("Contact Tsort",<<"EndForm");
<p>
Use this form to send messages to Tsort.  If you want a reply you have 
to fill out your email address.  If you are using a Safari browser (or 
the one on Android), 
or if the system keeps sending you back to this page you could 
try using <a href="/forms/safari_contact.htm">this alternate page</a>
to send us a message.</p>
<form method="POST" action="/forms/contact.htm" enctype="multipart/form-data">
<table width="80%" align="center" class="contact_form">
  <tr><td width ="50%" class="contact_label">Subject:</td>
      <td width ="25%" class="contact_label">Email to Reply To:</td>
      <td width ="25%" class="contact_label">Attachment:</td></tr>
  <tr><td class="contact_val"><input type="text" size="40" name="subject"/></td>
      <td class="contact_val"><input type="text" name="email"/></td>
      <td class="contact_val"><input type="file" name="attach"/></tr>
  <tr><td colspan="3">
      <textarea name="body" rows="20" cols="70"></textarea></td></tr> 
  <tr><td colspan="2">&nbsp;</td>
      <td><input type="submit" value="Send Message"/></td></tr>
</table>
EndForm
        return OK;
      }
    my $contents = "";
    if(!-d $attach_dir || !-w $attach_dir)
      {
        got_error("Cannot send message");
        $contents .= "Message directory misconfigured";
      }
    my $date = lc(get_date("short"));
    $date =~ s/\s/_/g;

    my $count = 1;
    while(-r $attach_dir.sprintf("msg-$date-%04d",$count))
      {
        $count++;
      }
    my $msg = sprintf("msg-$date-%04d",$count);
    my $atc = sprintf("atc-$date-%04d",$count);
    my $fh = IO::File->new(">${attach_dir}$msg");
    if(!defined $fh)
      {
        $contents .= "Cannot open $msg";
      }
    else
      {
        # Fix up the + chars that the non 
        # multipart form inserts
        foreach my $a ('subject','body','srcpage','srctitle',
                          'email','attach_filename')
          {
            next if(!defined $query{$a});
            $query{$a} = unenc_form_arg($query{$a});
          }

        print $fh "Subject: $query{subject}\n";
        print $fh "ReplyTo: $query{email}\n";
        print $fh "FromIP: $this_ip\n";
        print $fh "Site: $site\n"
                      if(defined $site && $site ne "");
        print $fh "Attachment File: $query{attach_filename}\n"
                      if(defined $query{attach_filename} && 
                            $query{attach_filename} ne "");
        print $fh "From Page: $query{srcpage}\n"
                      if(defined $query{srcpage});
        print $fh "From Page Title: $query{srctitle}\n"
                      if(defined $query{srctitle});
        print $fh "Body:\n\n";
        print $fh $query{body};
        $fh->close();
        if(defined $query{attach})
          {
            my $afh = IO::File->new(">${attach_dir}$atc");
            if(defined $afh)
              {
                print $afh $query{attach};
                $afh->close();
              }
          }
      }
    if($contents eq "")
      {
        my $return_ptr = "";
        if(defined $query{srcpage} && defined $query{srctitle})
          {
            $return_ptr = "<a href=\"$query{srcpage}\">Return to \&quot;$query{srctitle}\&quot;</a>";
          }
        send_page("Message Sent","<p>Message Sent, thank you $return_ptr</p>");
      }
    else
      {
        send_page("Message Failed",$contents);
      }
    return OK;
  }

sub unenc_form_arg
  {
    my($text) = @_;

    return undef 
        if(!defined $text);

    $text =~ s/(\S)\+(\S)/$1 $2/g;
    $text =~ s/(\S)\+(\S)/$1 $2/g;
    while($text =~ m/\%([a-f0-9][a-f0-9])/i)
      {
        my $in_hex = $1;
        my $in_ch = chr(hex($in_hex));
        $text =~ s/\%$in_hex/$in_ch/gi;
      }
    return $text;
  }

sub add_entry
  {
    # Insert a single entry from a building list
    my($hr,$key,$cols_ar,@vals) = @_;
    if(!defined $hr->{$key})
      {
        # Create an empty one to build on
        my @entry;
        for(my $i=0;$i<=$#{$cols_ar};$i+=2)
          {
            if($cols_ar->[$i+1] eq "++")
              {
                push @entry,0;
              }
            else
              {
                push @entry,"";;
              }
          }
        $hr->{$key} = \@entry;
      }
    for(my $i=0;$i<=$#{$cols_ar};$i+=2)
      {
        if($cols_ar->[$i+1] eq "++")
          {
            $hr->{$key}->[$i/2]++;
          }
        elsif($cols_ar->[$i+1] =~ /^k$/i)
          {
            $hr->{$key}->[$i/2] = $key;
          }
        elsif($cols_ar->[$i+1] =~ /^(\d+)$/)
          {
            $hr->{$key}->[$i/2] = $vals[$1];
          }
        elsif($cols_ar->[$i+1] =~ /^(\d+),$/)
          {
            my $src = $1;
            my %vals;
            foreach my $val (split(/\s*,\s*/,
                             $hr->{$key}->[$i/2]))
              {
                $vals{$val} = 1;
              }
            $vals{$vals[$src]} = 1;
            $hr->{$key}->[$i/2] = join(', ',sort keys %vals);
          }
        else 
          {
            # Don't know how to do this yet
            $hr->{$key}->[$i/2] .= "Cannot process ".$cols_ar->[$i+1];
          }
      }
  }

sub access_bydate
  {
    return access_log("bydate");
  }

sub access_bypage
  {
    return access_log("bypage");
  }

sub access_byip
  {
    return access_log("byip");
  }

sub access_byret
  {
    return access_log("byret");
  }

sub access_log
  {
    # Report on who has accessed the site
    my ($method) = @_;
    $method = "bydate" if(!defined $method);

    my $fh = IO::File->new("$log_dir/access.log");
    my $messages = "";
    if(!defined $fh)
      {
        send_page("Cannot open access report");
        return OK;
      }
    my @fields;
    my $flags = "ignore_local";
    if($method eq "bydate")
      {
        @fields =
          ("Date" => "k", "Count" => "++", "IP Address" => "0,",
           "Ret" => "5,", "Refer" => "7,",
          );
        $flags = "ignore_local";
      }
    elsif($method eq "byip")
      {
        @fields =
          ("IP" => "k", "Count" => "++", "Last Access" => "3",
          );
        $flags = "ignore_local";
      }
    elsif($method eq "bypage")
      {
        @fields =
          ("Page" => "k", "Count" => "++", "Last Access" => "3",
           "Ret" => "5,","Refer" => "7,");
      }
    elsif($method eq "byret")
      {
        @fields =
          ("Return Code" => "k", "Count" => "++", "Last Access" => "3",
           "Page" => "8,", "Proto" => "9,",
          );
      }
    my(%info);
    my %sort_val;
    my %timevals;
    while(my $line = <$fh>)
      {
        chomp($line);
        if($line =~ /^(\S+)\s+(\S+)\s+(\S+)\s+\[([^\]]+)\]\s+\"([^\"]+)\"\s+(\d+)\s+(\d+|\-)\s+\"([^\"]+)\"/)
          {
            my($ip,$dnk,$user,$date,
               $cmd,$ret,$bytes,$refer) = ($1,$2,$3,$4,$5,$6,$7,$8);
            my $post_method = "UNK";
            my $page = "UNK";
            my $proto = "UNK";
            if($cmd =~ /^(\S+)\s+(\S+)\s+(\S+)/)
              {
                ($post_method,$page,$proto) = ($1,$2,$3);
              }
            my $time = parse_date($date);
            my $time_str = define_period($time);
            next if($flags =~ /ignore_local/i && $ip =~ /^192\.168/);
            next if($ip =~ /\:\:/);
            my $key;
            if($method eq "bydate")
              {
                # Want to order elements by date
                my $time_ka = define_period($time);
                $key = $time_ka;
                $sort_val{$time_ka} = sprintf("%013d",2000000000-$time);
              }
            elsif($method eq "byip")
              {
                # Want to order elements by IP
                $key = $ip;
                $sort_val{$ip} = sprintf("%03d%03d%03d%03d",
                                         split(/\.+/,$ip));
              }
            elsif($method eq "bypage")
              {
                # Want to order elements by page
                $key = $page;
                $sort_val{$page} = $page;
              }
            elsif($method eq "byret")
              {
                # Want to order elements by return code
                $key = $ret;
                $sort_val{$ret} = sprintf("%05d",$ret);
              }
            else
              {
                $messages .= "Unknown method $method";
                last;
              }
            add_entry(\%info,$key,\@fields,$ip,$dnk,$user,$time_str,
                                          $post_method,$ret,$bytes,$refer,
                                          $page,$proto);
          }
        else
          {
            $messages .= "<p>Cannot parse line \&quot;<tt>".
                         "$line</tt>\&quot;</p>\n";
          }
      }
    $fh->close();
    my $contents = <<"StartPage";
<p>
This shows the most recent access counts. $messages</p>
<form method="POST" action="/admin/access.htm">
</form>
<table class="admin">
  <tr>
StartPage
    for(my $i=0;$i<=$#fields;$i+=2)
      {
        $contents .= "    <td class=\"admin_header\">$fields[$i]</td>\n";
      }
    $contents .= "  </tr>\n";
    foreach my $k (sort {$sort_val{$a} cmp $sort_val{$b}} keys %info)
      {
        my @vals = @{$info{$k}};
        $contents .= "<tr>";
        foreach my $v (@vals)
          {
            $contents .= "<td class=\"admin_cell\">$v</td>\n";
          }
        $contents .= "</tr>";
      }
    $contents .= <<"EndPage";
</table>
EndPage
    send_page("Access",$contents);
    return OK;
  }

sub define_period
  {
    my($time) = @_;
    my($sec,$min,$hour,$dom,$mon,$year) = gmtime($time);
    if(time - $time < 24*60*60)
      {
        # In the last 24 hours, use the full time
        return report_date($year,$mon,$dom,$hour,$min);
      }
    elsif(time - $time < (40*24*60*60))
      {
        # In the last month, use the day
        return report_date($year,$mon,$dom);
      }
    return report_date($year,$mon);
  }

sub report_date
  {
    my($year,$mon,$dom,$hour,$min) = @_;
    my @mon =
      (
        'Jan', 'Feb', 'Mar', 'Apr', 'May', 'Jun',
        'Jul', 'Aug', 'Sep', 'Oct', 'Nov', 'Dec',
      );
    $year += 1900 if($year < 200);
    return $mon[$mon]." ".$year
                       if(!defined $dom);
    return $dom." ".$mon[$mon]." ".$year
                       if(!defined $hour);
    return sprintf("%2d %s %4d %02d:%02d",$dom,$mon[$mon],$year,$hour,$min);
  }
 
sub parse_date
  {
    my($from_str) = @_;
    my %mon = (
        jan => 0, feb => 1, mar => 2, apr => 3, may => 4, jun => 5,
        jul => 6, aug => 7, sep => 8, oct => 9, nov => 10, dec => 11,
      );
    if($from_str =~ m#^(\d+)/(\w+)/(\d+)\:(\d+)\:(\d+)#)
      {
        my($dom,$mon,$year,$hour,$min) = ($1,$2,$3,$4,$5);
        if(defined $mon{lc($mon)})
          {
            my $time = timegm(0,$min,$hour,$dom,$mon{lc($mon)},$year);
            return $time;
          }
        return "Unknown month $mon";
      }
    return "Cant parse |$from_str|";
  }

sub angler_control
  {
    # Tell the angler user that the whole process needs 
    # restarting
    my $flag_name = "/tmp/do-restart-".get_date();
    open(OUT,">$flag_name");
    print OUT "Request";
    close(OUT);
    chmod(0777,$flag_name);

    send_page("Angler Done","<p>Done</p>");
    return OK;
  }

sub report_passed
  {
    # Report the paramters we were passed
    my $content = "";
    foreach my $key (keys %query)
      {
        $content .= "<p>Query: $key = $query{$key}</p>\n";
      }
    foreach my $key (keys %config)
      {
        $content .= "<p>Config: $key = $config{$key}</p>\n";
      }
    send_page("Vals",$content);
    return OK;
  }

my %pages =
  (
    "/forms/contact.htm" => 
      {
        name => "Contact Tsort",
        fun => \&contact_form,
        audience => "all",
      },
    "/forms/safari_contact.htm" =>
      {
        name => "Safari Contact Tsort",
        fun => \&safari_form,
        audience => "all",
      },
    "/admin/params.htm" =>
      {
        name => "Test Page",
        fun => \&report_passed,
        audience => "all",
      },
    "/admin/access.htm" =>
      {
        name => "Access Log",
        fun => \&access_bydate,
        audience => "all",
      },
    "/admin/access_bydate.htm" =>
      {
        name => "Access Log",
        fun => \&access_bydate,
        audience => "all",
      },
    "/admin/access_byip.htm" =>
      {
        name => "Access Log",
        fun => \&access_byip,
        audience => "all",
      },
    "/admin/access_byret.htm" =>
      {
        name => "Access Log",
        fun => \&access_byret,
        audience => "all",
      },
    "/admin/access_bypage.htm" =>
      {
        name => "Access Log",
        fun => \&access_bypage,
        audience => "all",
      },
    "/admin/angler.htm" =>
      {
        name => "Angler Control",
        fun => \&angler_control,
        audience => "all",
      },
  );

sub get_date
  {
    my($len) = @_;

    my($s,$mi,$h,$d,$mo,$y,$wd) = gmtime(time);
    my @mon = ('Jan','Feb','Mar','Apr','May','Jun',
         'Jul','Aug','Sep','Oct','Nov','Dec');
    $y += 1900 if($y < 1900);
    return sprintf("%2d %s %04d %02d:%02d",$d,
                   $mon[$mo],$y,$h,$mi)
              if(!defined $len || $len eq "long");
    return sprintf("%2d %s %04d",$d,$mon[$mo],$y);
  }

sub send_page
  {
    my($title,$contents) = @_;

    my $date = get_date();

    my $root_path = "/";

    if(defined $site && $site eq "dm4ep")
      {
        print <<"EndHeader";
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html>
  <head>
    <title>$title</title>
    <meta name="Last_mod" content="$date"/>
    <meta name="Author" content="Tsort"/>
    <meta name="generator" content="$0"/>
    <link rel="icon" href="${root_path}favicon.ico" type="image/x-icon"/>
    <link rel="shortcut icon" href="${root_path}favicon.ico" type="image/x-icon"/>
    <style type="text/css">
      \@import url(${root_path}dm4ep.css);
    </style>
  </head>
  <body class="intro_page">
  <h1>$title</h1>
$contents
<p class="footer">&copy; 2007-2009, Steve Hawtin el al.</p>
</td></tr></table>
  </body>
</html>
EndHeader
      }
    else
      {
    print <<"EndHeader";
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.1//EN" "http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd">
<html>
  <head>
    <title>$title</title>
    <meta name="Last_mod" content="$date"/>
    <meta name="Author" content="Tsort"/>
    <meta name="generator" content="$0"/>
    <link rel="icon" href="${root_path}favicon.ico" type="image/x-icon"/>
    <link rel="shortcut icon" href="${root_path}favicon.ico" type="image/x-icon"/>
    <style type="text/css">
      \@import url(${root_path}tsort.css);
    </style>
  </head>
  <body class="music_page">
<table class="layout">
<tr><td class="menu">
  <table class="music_menu">
    <tr><td class="logo"><a 
            href="http://tsort.info/"><img 
            src="${root_path}tsort-std011.gif" class="logo"/></a></td></tr>
    <tr class="item"><td class="music_item"><a href="${root_path}music/index.htm">Music</a></td></tr>
    <tr class="item"><td class="software_item"><a href="${root_path}software/index.htm">Computing</a></td></tr>
    <tr class="item"><td class="family_item"><a href="${root_path}iabok/index.htm">Info Arch</a></td></tr>
  </table>
                     </td>
    <td class="main">
  <h1>$title</h1>
$contents
<p class="footer">&copy; 2007-20013, Steve Hawtin el al.</p>
</td></tr></table>
  </body>
</html>
EndHeader
      }
  }

sub handler
  {
    my $r = shift;

    $r->content_type('text/html');
    return OK if($r->header_only());

    my %config = unpick_config($r);
    # First we have to populate the %query hash
    fill_query($r);

    my $this_path = $r->uri();
    my $rel_path = $this_path;

    foreach my $pat (keys(%pages))
      {
        
        my($page_base,$page_part);

        if(!defined $pat || $pat eq "")
          {
            got_error("Badly defined page name in \%pages");
            next;
          }
        if($rel_path =~ /^($pat)(.*)$/)
          {
            $page_base = $1;
            $page_part = $2;
          }
        else
          {
            next;
          }

        return &{$pages{$pat}->{fun}}($r,$page_base,$page_part);
      }

    # Drop down to here if we can't identify the interactive page
    # we actually want
    send_page("Unknown Page",<<"EndContents");
<p>
The page you selected does not exist.  If you think this is an 
error in the website please send us a <a href="/forms/contact.htm">message</a>
telling us how you got here.
</p>
EndContents
    return OK;
  }

1;
__END__
=head1 AUTHOR

Steve Hawtin

=head1 SEE ALSO

L<perl>.

=cut