#!/usr/bin/perl
# -----------------------------------------------------------------------------
# TWC
# Treuwert-Computer GmbH
# Schloßbergring 9
# 79098 Freiburg
#
# -----------------------------------------------------------------------------
# Program-Data
# -----------------------------------------------------------------------------
# Project  :
# System   :
# Program  :
# Modul    : $RCSfile: WWWdb_TransUri.pm,v $
# Version  : $Revision: 1.2 $
# Date     : $Date: 2003/04/11 14:09:43 $
# State    : $State: Exp $
#
# Description:
#   This module maps adresses of the form
#   http://myhost/wwwdb/<Database>/<config-file>[;params]
#   to the real call of WWWDb
#
# -----------------------------------------------------------------------------
# $Log: WWWdb_TransUri.pm,v $
# Revision 1.2  2003/04/11 14:09:43  k_reger
# - Default translation section corrected
#
# Revision 1.1  2002/02/28 08:42:37  k_reger
# - Moved from .. and renamed
#
# Revision 1.10  2000/11/15 12:06:08  k_reger
# - domain will be checked too
#
# Revision 1.9  2000/11/03 11:38:28  k_reger
# - detect browser-defined language
#
#
#
# --- FIX ----- FIX ----- FIX -----FIX ----- FIX ----- FIX -------------------

package Apache::WWWdb_TransUri;

use strict;
use Apache::Constants qw(:common);

# --- This Routine gets linked into the Apache-Server -----------------------
sub handler
{
   my $hReqObj = shift;

   my $cOrigUri = $hReqObj->uri;

   my $cAcceptLang;
   my $cApplication;
   my $cDatabase;
   my $cDocRoot;
   my $cJunk;
   my $cLang;
   my $cNewUri = undef;
   my $cParam;
   my $cSessionId;
   my $cWWWdb;
   my @lRest;

   my %hWWWdb = ();

   open DEBUG, ">/tmp/WWWdb_TransUri.log";
   printf DEBUG ("OrigUri: " . $cOrigUri . "\n");

   if(-r "/etc/WWWdb_TransUri.rc")
   {
      open TRANS_URI, "</etc/WWWdb_TransUri.rc"
          or return DECLINED;

      printf DEBUG ("Will use file: " .
                    "/etc/WWWdb_TransUri.rc\n");

      while(<TRANS_URI>)
      {
         chomp;

         if(/^(\S+)\s*=\s*(\S+)$/)
         {
            $hWWWdb{$1} = $2;

            printf DEBUG ("Found entry: $1 => $2\n");

         }
      }

      close TRANS_URI;
   }
   else
   {
      printf DEBUG ("No File, using defaults\n");

      $hWWWdb{"NULL"}                  = "WWWdb/0000000000000000/WWWdb/WWWdb:Index";
      $hWWWdb{".*,wwwdb/i,en.*"}       = "WWWdb/0000000000000000/WWWdb/WWWdb:Index";
      $hWWWdb{".*,wwwdb/i,de.*"}       = "WWWdb/0000000000000001/WWWdb/WWWdb:Index";
      $hWWWdb{".*,wwwdb_devel/i,en.*"} = "WWWdb_devel/0000000000000000/WWWdb/WWWdb:Index";
      $hWWWdb{".*,wwwdb_devel/i,de.*"} = "WWWdb_devel/0000000000000001/WWWdb/WWWdb:Index";
   }

   ($cJunk, $cWWWdb, @lRest) = split '/', $cOrigUri;

   # set WWWdb-domain to "NULL" if none is given
   if($cWWWdb =~ /^[0-9a-h]{16}$/)
   {
      unshift @lRest, $cWWWdb;
      $cWWWdb = "NULL";
   }

   # map domain to base-dir
   $cAcceptLang = $hReqObj->header_in("Accept-language");
   printf DEBUG ("ContLang = $cAcceptLang\n");
   printf DEBUG ("Server   = " . $hReqObj->get_server_name() . "\n");

   # en is the default, when no lang is specified in the browser
   foreach $cLang (split ", ", ($cAcceptLang . ",en"))
   {
      printf DEBUG ("Lang = $cLang\n");

      foreach (keys %hWWWdb)
      {
         my $cDomain;
         my $cWWWdbDomain;
         my $bCaseIndependent = 0;
         my $cLangRegex;

         printf DEBUG ("Scan $_\n");

         if(/^(\S+?),(\S+?)(\/i)?(,(\S+))?$/)
         {

            $cDomain          = $1;
            $cWWWdbDomain     = $2;
            $bCaseIndependent = ($3? 1: 0);
            $cLangRegex       = $5;

            printf DEBUG ("Domain:$1, WWWdbDomain:$2, CaseInd:$bCaseIndependent, LangRegex:$5\n");

            next
                unless ($hReqObj->get_server_name() =~ /^$cDomain$/);

            if(($bCaseIndependent?
                lc($cWWWdb) eq lc($cWWWdbDomain):
                $cWWWdb eq $cWWWdbDomain))
            {
               printf DEBUG ("Domain ok, Lang = $cLang\n");

               if(($cLangRegex && ($cLang =~ $cLangRegex)) ||
                  (!$cLangRegex))
               {
                  printf DEBUG ("Language matching!\n");

                  my @lDefaults = split "/", $hWWWdb{$_};

                  $hReqObj->subprocess_env('WWWDB_DOMAIN' => $cWWWdbDomain);

                  $cWWWdb  = $lDefaults[0];
                  $cNewUri = "/cgi-bin/" . $lDefaults[0] . ".cgi";

                  $cSessionId   = $lDefaults[1];
                  $cDatabase    = $lDefaults[2];
                  $cApplication = $lDefaults[3];

                  last;
               }
            }
         }
      }
      last
          if $cNewUri;

   }

   return DECLINED
       unless $cNewUri;

   # Look, if we have a session-id
   if ($lRest[0] =~ /^[0-9a-h]{16}$/)
   {
      $cSessionId = shift @lRest;
   }
   else
   {

      return DECLINED
          if @lRest;

      $cSessionId = "0" x 16
          unless $cSessionId;
   }

   $hReqObj->subprocess_env('WWWDB_SESSION_ID' => $cSessionId);

   $cDatabase    = ((@lRest)?
                    shift @lRest:
                    $cDatabase or 'Default');
   $cApplication = ((@lRest)?
                    shift @lRest:
                    $cApplication or 'WWWdb/Index');
   $cParam       = "";

   # Generate a directory-path
   $cApplication =~ s.:./.g;
   $cDocRoot = ($hReqObj->document_root() . "/" . $cWWWdb);

   $hReqObj->subprocess_env('WWWDB_BASE_PATH' => $cDocRoot);
   $hReqObj->subprocess_env('WWWDB_DATABASE'  => $cDatabase);

   if ($cApplication =~ /([^;]*)(;(.*))/)
   {
      $cApplication = $1;
      $cParam       = $3;
   }

   $hReqObj->subprocess_env('WWWDB_CONFIG_FILE' => $cApplication);
   $hReqObj->subprocess_env('WWWDB_PARAMS'      => $cParam);

   printf DEBUG ("WWWDB_BASE_PATH=>$cDocRoot WWWDB_DATABASE=>$cDatabase\nWWWDB_CONFIG_FILE=>$cApplication WWWDB_PARAMS=>$cParam\n");

   # here we have anything else (graphics, etc.)
   if (@lRest)
   {
        $cNewUri = join  ("/",
                          $cDocRoot,
                          @lRest);
   }

   printf DEBUG ("SessionId=$cSessionId Database=$cDatabase Appl=$cApplication\n");


   # check the cache file
   unless ($hReqObj->header_in("Pragma"))
   {
      my $cCacheFileName = join ("/",
                                 ($cWWWdb,
                                  "tmp/cache",
                                  $cDatabase,
                                  $cSessionId,
                                  $cApplication,
                                  "-$cParam-0.html"));

      $cCacheFileName =~ s/[!\"\\;=&,\']/_/g;

      printf DEBUG ("CacheFile (rel): " . $cCacheFileName . "\n");
      printf DEBUG ("CacheFile (abs): " . $hReqObj->document_root() . "/" .
                    $cCacheFileName . "\n");

      # do we have a cached-file without cgi-params?
      if (-f $hReqObj->document_root() . "/" . $cCacheFileName)
      {

         $cNewUri =  "/" . $cCacheFileName;

         # $hReqObj->content_type("text/html");
         # $hReqObj->send_http_header;

         open CACHE, "<" . $hReqObj->document_root() . "/" . $cCacheFileName;

         while (<CACHE>)
         {
            $hReqObj->print($_);
         }

         close CACHE;

         return DONE;
      }

   }

   $hReqObj->uri($cNewUri);

   printf DEBUG ("NewUri: " . $cNewUri . "\n");
   close DEBUG;

   return DECLINED;
}

1;

__END__