#!/usr/bin/perl
# -----------------------------------------------------------------------------
# TWC
# Treuwert-Computer GmbH
# Schloßbergring 9
# 79098 Freiburg
#
# Author: Klaus Reger <K.Reger@twc.de>
#
# -----------------------------------------------------------------------------
# Program-Data
# -----------------------------------------------------------------------------
# Project  :
# System   :
# Program  :
# Module   : $RCSfile: Base.pm,v $
# Version  : $Revision: 1.7 $
# Date     : $Date: 2002/02/25 10:42:12 $
# State    : $State: Exp $
#
# Description:
#   This module handles all the things of WWWdb, which have
#   to do with HTML
#
# Change-log (See at end of this file)
#
# --- Known Bugs -------------
# please look at the BUGS-File
# --- TODO -------------------
# please look at the TODO-File
# ----------------------------------------------------------------------------

package Base;
use vars qw(%hAttribs);

use Data::Dumper;
use Locale::PGetText;           # internationalisation

=head1 NAME

WWWdb::Base - Base-Class for all WWWdb-Objects

=head1 SYNOPSIS

 use WWWdb::Base;

=cut

if(exists $ENV{MOD_PERL})
{
   no strict;
}
else
{
   use strict;
}


# provides automatic access to all attributes
use vars qw($AUTOLOAD);

$Base::SIG{'__DIE__'}  = \&main::MyDie;


{
   %hAttribs =
   (
    DebugLvl      => ["i", "public", "rw", 0],
   );
}



sub Base::_getSuperClasses($cClassPI)
{
   my $cSelf    = shift;
   my $cClassPI = shift;

   my @lResult = $cClassPI;
   my $cISA;

   no strict "refs";
   my @lISA = @{"${cClassPI}::ISA"};
   use strict "refs";

   foreach $cISA (@lISA)
   {
      push @lResult, $cSelf->_getSuperClasses($cISA);
   }


   return @lResult;
}


sub Base::AUTOLOAD ($)
{
    my $cSelfPI    = shift;

    my $cAttr      = $AUTOLOAD;
    my $cBaseClass = ref($cSelfPI) || $cSelfPI;

    my $cMethod;
    my $cSuperPackage;
    my $cSuperProc;
    my $cDataType;
    my $cAttType;
    my $cReadWrite;
    my $cDefault;
    my @lClass;
    my $cClass;


    # get all base-classes
    @lClass = $cSelfPI->_getSuperClasses($cBaseClass);

    # walk through all classes
    foreach my $cClass (@lClass)
    {

       # settable attributes of this class
       no strict "refs";
       my %hAtt = %{"${cClass}::hAttribs"};
       use strict "refs";

       # Remove path
       $cAttr =~ s/.*:://;

       # ignore this
       return
           if $cAttr eq "DESTROY";

       # read the attribute
       if($cAttr =~ /^get(.*)$/)
       {
          $cMethod = $1;

          # Params for setting a value?
          die sprintf("Method '%s' is only for reading data " .
                      "from class %s!\n",
                      $cAttr,
                      $cBaseClass)
              if @_;
       }
       elsif($cAttr =~ /^set(.*)$/)
       {
          $cMethod = $1;

          # Params for setting a value?
          die sprintf("Method '%s' is for setting data in " .
                      "class %s, but no value is given!\n",
                      $cAttr,
                      $cBaseClass)
              if !@_;
       }
       else
       {
          die sprintf ("Unknown access to attribute '%s' of class '%s'!\n",
                       $cAttr,
                       $cBaseClass);
       }


       # look for all defined Attributes
       if ($hAtt{$cMethod})
       {

          # example: ["i", "public",  "rw", 1],
          ($cDataType, $cAttType, $cReadWrite, $cDefault) =
              @{$hAtt{$cMethod}};

          $cSuperPackage = (caller())[0];
          $cSuperProc    = (caller(1))[3];

          # when called from _init use of private methods is ok
          $cReadWrite .= "w"
              if($cSuperProc eq "${cSuperPackage}::_init");

          # check for private attributes
          if($cAttType eq "private" || $cAttType eq "protected")
          {


             if (($cClass ne $cSuperPackage) &&
                 ($cSuperProc ne "${cSuperPackage}::_init"))
             {
                die sprintf("Hey!!! Method '%s' is private in class %s!\n",
                            $cMethod,
                            $cBaseClass);
             }
          }

          # Params for setting a value?
          if (@_)
          {

             die sprintf("Method '%s' is read-only in class '%s'!\n",
                         $cMethod,
                         $cBaseClass)
                 unless $cReadWrite =~ /w/;

             $cSelfPI->{$cMethod} = shift;

             # This generates a subroutine for reading that attribute
             # Isn't that extremely cool?

             no strict "refs";
             *{$AUTOLOAD} = sub
             {
                my $cMet = $cMethod;

                # printf STDERR sprintf("ANON (Class %s) set%s(%s)\n",
                #                       $_[0], $cMet, $_[1]);
                if (defined($_[1]))
                {
                   $_[0]->{$cMet} = $_[1];

                   return $_[1];
                }

                # Params for setting a value?
                die sprintf("A: Method 'set%s' is for setting data in " .
                            "class %s, but no value is given!\n",
                            $cMet,
                            ref($_[0]));
             };
             use strict "refs";
          }
          else
          {
             my $cMet = $cMethod;

             # Creating a subroutine for setting the attribute
             no strict "refs";
             *{$AUTOLOAD} = sub {
                # printf STDERR sprintf("ANON (Class %s) get%s returns '%s'\n",
                #                       $_[0], $cMet, $_[0]->{$cMet});

                # Params for setting a value?
                die sprintf("A: Method '%s' is only for reading data " .
                            "from class %s!\n",
                            $cMet,
                            ref($_[0]))
                    if defined $_[1];

                return $_[0]->{$cMet};
             };
             use strict "refs";


          }

          return $cSelfPI->{$cMethod};
       }
    }

    die sprintf("Method '%s' is not defined in class '%s'!\n",
                $cMethod,
                $cBaseClass);
}


sub Base::new ($@)
{
    my $cPkgPI    = shift;
    my %hParamsPI = (@_);

    my $oSelf;
    my %hSelf;
    my @lClass;
    my $cClass;

    $cClass = ref($cPkgPI) || $cPkgPI;
    $oSelf = bless \%hSelf, $cClass;

    @lClass = $oSelf->_getSuperClasses($cClass);

    foreach my $cClass (@lClass)
    {

       # settable attributes of this class
       no strict "refs";
       my %hAtt = %{"${cClass}::hAttribs"};
       use strict "refs";

       # This object was cloned
       if(ref($cPkgPI))
       {
          # FIXME: currently not implemented
          # maybe clone the object with DataDumper

          my $cGetAtt = "get" . $_;
          my $cValue;
          my $cName;

          # copy all the attributes
          while (($cName, $cValue) = each %hAtt)
          {
             $hSelf{$_} = $cPkgPI->$cGetAtt()
                 unless defined($hParamsPI{$_});
          }
       }


       # Set the default-values
       foreach (keys %hAtt)
       {

          $oSelf->{"$_"} = $hAtt{$_}[3];
       }

       $oSelf->_init($cClass, %hParamsPI);
    }


    return $oSelf;
}

sub Base::_init($$@)
{
    my $oSelfPI    = shift;
    my $cInitClass = shift;
    my %hParamsPI  = (@_);

    my $cClass;

    $cClass = ref($oSelfPI) || $oSelfPI;

    # Assign the parameters
    no strict "refs";
    foreach my $cParamName (keys %{"${cInitClass}::hAttribs"})
    {

       my $cSetAtt = "set" . $cParamName;

       # Set attribute, if passed by parameter
       if (defined $hParamsPI{$cParamName} &&
           $hParamsPI{$cParamName} ne "")
       {
          if(ref($hParamsPI{$cParamName}) eq "ARRAY")
          {
             $oSelfPI->$cSetAtt($hParamsPI{$cParamName});
          }
          else
          {
             $oSelfPI->$cSetAtt($hParamsPI{$cParamName});
          }
       }
    }
    use strict "refs";
}


sub Base::Dump ()
{
    my $cSelf = shift;

    $Data::Dumper::Indent = 1;         # mild pretty print

    print STDERR Data::Dumper::Dumper($cSelf);
}


sub Base::i18n ($$)
{
    my $cSelf    = shift;
    my $cMessage = shift;

    my $cResult;

    $cResult = gettext($cMessage);

    $cResult =~ s/FIXME //;

    return $cResult;
}



sub Base::UnTaint($;$)
{
   my $cUnTaintExpr  = shift;
   my $cUnTaintRegex = shift || "^(.*)\$";

   if ($cUnTaintExpr =~ $cUnTaintRegex)
   {
      # now untainted
      return $1;
   }
   else
   {
      return $cUnTaintExpr;
   }
}



sub Base::ShowAttributes ()
{
    my $cSelf = shift;
    my $cName;
    my $cType;
    my $cReadWrite;
    my $cHtmlInternal;
    my @lClass;
    my $cClass;
    my $cDataType;
    my $cAttType;
    my $cDefault;


    $cSelf = ref($cSelf)
	if(ref($cSelf));

    format STDERR_TOP =
---------------------------------------------------------------
 List of the Attributes of Class @<<<<<<<<<<<<<<<<<<<<<<<<<<<<
			       $cSelf
--------------------------------------------+------+-----+-----
 Name                                       | Type | R/W | P/I
--------------------------------------------+------+-----+-----
.

    format STDERR =
 @<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<< | @<<< | @<< | @<<
 $_, $cDataType, $cReadWrite, $cAttType
.

    # Start a new page
    select STDERR;
    $- = 0;

    # get all base-classes
    @lClass = $cSelf->_getSuperClasses($cSelf);

    # walk through all classes
    foreach my $cClass (@lClass)
    {

       # settable attributes of this class
       no strict "refs";
       my %hAtt = %{"${cClass}::hAttribs"};
       use strict "refs";

       foreach (sort keys %hAtt)
       {

          # example: ["i", "public",  "rw", 1],
          ($cDataType, $cAttType, $cReadWrite, $cDefault) =
              @{$hAtt{$_}};

          write STDERR;

       }

   print STDERR
       "--------------------------------------------+------+-----+-----\n"
           if %hAtt;

   select STDOUT;
    }
}

1;

