#!/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: Plugin.pm,v $
# Version  : $Revision: 1.10 $
# Date     : $Date: 2002/02/28 15:27:04 $
# State    : $State: Exp $
#
# Description:
#   This module handles all the things of WWWdb, which have
#   to do with Plugins
#
# Change-log (See at end of this file)
#
# --- Known Bugs -------------
# please look at the BUGS-File
# --- TODO -------------------
# please look at the TODO-File
# ----------------------------------------------------------------------------

=head1 NAME

WWWdb::Plugin - Plugins for WWWdb

=head1 SYNOPSIS

 use WWWdb::Plugin;

 $oPlugin   = Plugin->new($cName,
                          ["HasPrePost" => $bHasPrePost,]
                          ["HasMy"      => $bHasMy]);

 $cResult   = $oPlugin->Call(@lParams);

 $bResult   = $oPlugin->IsDefined($cType);

 $cName     = $oPlugin->getName();

=cut

# The POD text continues at the end of the file.



use WWWdb::Base;


# --------------------------------------------------------------------
# Plugin
# --------------------------------------------------------------------
package Plugin;
use vars qw(%hMethods
            %hAttribs
            %hDefinedSubsMGL
            %hRegisteredPluginsMGL
            %hRequiredSourcesMGL);

use English;
use strict;


@Plugin::ISA = qw(Base);

{

   my %hDefinedSubsMGL;
   my %hRegisteredPluginsMGL;
   my %hRequiredSourcesMGL;

   %hAttribs =
       (
        Name        => ["c", "public",     "r", undef],
        HasPrePost  => ["b", "protected",  "r", 0],
        HasMy       => ["b", "protected",  "r", 0],
        IsDefined   => ["h", "private",    "r", undef],
        );
}


# --- constructor ---------------------------------------------------
sub Plugin::new()
{
   my ($cPkgPI)      = shift;
   my $cNamePI       = shift;

   my $cClass   = ref($cPkgPI) || $cPkgPI;

   my $hSelf   = $cClass->SUPER::new(@_);

   bless ($hSelf, $cClass);

   # The name is a must!
   die "$cClass: needs a name!\n"
       unless $cNamePI;

   $hRegisteredPluginsMGL{$cNamePI} = $hSelf;

   &_Init_SymTableCache()
       unless (defined %hDefinedSubsMGL);

   $hSelf->{"Name"} = $cNamePI;

   foreach ("Pre", "Post", "My", "Default")
   {
      $hSelf->{"IsDefined"}->{"$_"} = 0;
   }

   if ($hSelf->{"HasPrePost"})
   {
      foreach ("Pre", "Post")
      {
         $hSelf->{"IsDefined"}->{"$_"} =
             $hSelf->_CheckIfProcDefined("$_" . "$cNamePI");
      }

   }

   if ($hSelf->{"HasMy"})
   {

      $hSelf->{"IsDefined"}->{"My"} =
          $hSelf->_CheckIfProcDefined("My". $cNamePI);
   }

   $hSelf->{"IsDefined"}->{"Default"} =
          $hSelf->_CheckIfProcDefined($cNamePI);

   $hSelf->Dump();              # FIXME

   return $hSelf;
}




# --- Call a Plugin -------------------------------------------------
sub Plugin::Call(@)
{

   my $hSelfPI   = shift;

   my $cResult = "";

   if($hSelfPI->{"HasPrePost"} &&
      $hSelfPI->{"IsDefined"}->{"Pre"})
   {
      $cResult .= $hSelfPI->_Eval("Pre", @_);
   }

   if($hSelfPI->{"HasMy"} &&
      $hSelfPI->{"IsDefined"}->{"My"})
   {
      $cResult .= $hSelfPI->_Eval("My", @_);
   }
   else
   {
      if($hSelfPI->{"IsDefined"}->{"Default"})
      {
         $cResult .= $hSelfPI->_Eval("", @_);
      }
      else
      {
         $cResult .= "@_";
      }
   }

   if($hSelfPI->{"HasPrePost"} &&
      $hSelfPI->{"IsDefined"}{"Post"})
   {
      $cResult .= $hSelfPI->_Eval("Post", @_);
   }

   return $cResult;
}


sub Plugin::IsDefined($)
{
   my $hSelfPI   = shift;
   my $cTypePI   = shift;

   my $cResult = undef;

   if(defined $hSelfPI->{"IsDefined"}->{$cTypePI})
   {
      $cResult = $hSelfPI->{"IsDefined"}->{$cTypePI};
   }

   return $cResult;
}

# --- "Plug in" a Plugin ------------------------------------------------
sub Plugin::Require($$)
{
   my $cPackagePI    = shift;
   my $cPerlSourcePI = Base::UnTaint(shift);

   my $cPerlSourceCode = "package $cPackagePI;\n\n";

   return
       if defined($hRequiredSourcesMGL{"$cPerlSourcePI"});

   $hRequiredSourcesMGL{"$cPerlSourcePI"} = $cPackagePI;

   if (-f $cPerlSourcePI)
   {
      if (-r $cPerlSourcePI)
      {
         open PERL_SOURCE, "<$cPerlSourcePI" or
             die "Can't open $cPerlSourcePI";

         foreach (<PERL_SOURCE>)
         {
            $cPerlSourceCode .= Base::UnTaint($_) . "\n";
         }

         # $cPerlSourceCode .= join "", <PERL_SOURCE>;
         close PERL_SOURCE;

         unless (eval $cPerlSourceCode)
         {
            die ("The following Plugin ($cPerlSourcePI) failed!\n\n" .
                 "<PRE>" . $cPerlSourceCode . "</PRE>" .
                 "with the following errors:" . "<BR>" .
                 "$@");
         }
      }
      else
      {
         die(sprintf(i18n("Sorry, but the plugin-source %s ".
                          "is not readable!"),
                     br() x 2 .
                     (big(b($cPerlSourcePI))) .
                     br() x 2));
      }
   }
   else
   {
      die(sprintf(i18n("Sorry, but the plugin-source %s ".
                       "does not exist!"),
                  br() x 2 .
                  (big(b($cPerlSourcePI))) .
                  br() x 2));

   }

   &_Init_SymTableCache($cPackagePI);
}



# --- internal evaluation-method ----------------------------------------
sub _Eval($@)
{
   my $hSelfPI     = shift;
   my $cPrefixPI   = shift;

   my $cResult = "";

   my $cArgumentList = "";
   my @lArgumentList = @_;
   my $cPerlCall;


   if (@lArgumentList)
   {
      foreach (@lArgumentList)
      {

         # mask 's
         s/\'/\\\'/g;

         $_ = "'" . $_ . "'"
             unless(ref $_);
      }

      $cArgumentList = join ", ", @lArgumentList;
   }

   $cPerlCall = sprintf ("&main::%s%s (%s)",
                         $cPrefixPI,
                         $hSelfPI->{"Name"},
                         $cArgumentList);
   print STDERR "Plugin::_Eval: $cPerlCall\n";

   $cResult = eval Base::UnTaint("$cPerlCall");


   return $cResult;
}


sub _CheckIfProcDefined($)
{
   my $hSelfPI     = shift;
   my $cProcNamePI = shift;

   my $bResult = 0;

   $bResult = defined($hDefinedSubsMGL{$cProcNamePI});

   return $bResult;
}


sub _Init_SymTableCache (;$)
{
   my $cPackageNamePI = shift || "main";
   my $cVarName;
   my $pGlobValue;
#   my $tStash;
#   my %tStash;

   local (*tAlias);

   no strict;

   *tStash = *{"${cPackageNamePI}::"};

   # for a explanation of this subroutine see the book
   # "Advanced Perl Programming" from O'Reilly
   # Chapter 6: Modules, Access to the Symbol-table

   # Lookup the symbol-table
   while (($cVarName, $pGlobValue) = each %tStash)
   {
      next
          if ($cVarName =~ /^SYS.*/ or
              $cVarName =~ /^__.*/);

      *tAlias = $pGlobValue;

      # Procedure defined?
      if (defined (&tAlias))
      {
         if($cPackageNamePI ne "main")
         {
            $cVarName = $cPackageNamePI . "::" . $cVarName;
         }

         $hDefinedSubsMGL{$cVarName} = 1;
         # print STDERR "Plugin::_Init_SymTableCache $cVarName defined\n";
      }
   }
   use strict;

   return;
}



sub _UndefAllPlugins()
{
   my $cPluginNames;

   foreach $cPluginNames (keys %hRegisteredPluginsMGL)
   {

      foreach (keys %{$hRegisteredPluginsMGL{"$cPluginNames"}->{"IsDefined"}})
      {
         next
             if $_ eq "Default";

         if($hRegisteredPluginsMGL{"$cPluginNames"}->{"IsDefined"}->{$_})
         {
            eval "undef (&$_$cPluginNames)";
#            print STDERR  "Plugin::_UndefAllPlugins: undef &main::" .
#              $_ . $cPluginNames . "\n";
         }
      }

      undef $hRegisteredPluginsMGL{"$cPluginNames"};
      delete $hRegisteredPluginsMGL{"$cPluginNames"};

   }

   undef %hDefinedSubsMGL;
   undef %hRegisteredPluginsMGL;

}


1;


__END__


=head1 DESCRIPTION

=head1 The Plugin class

Plugins are one of the base-technology, which makes WWWdb so flexible.
It allows the user, to plug in his own modules I<before>, I<after>
and/or I<instead> of the system-routine.

An example demonstrates, how this works. Lets assume we have a
subroutine named I<Plugin>. If we want to add functionality, I<before>
this routine is called we need a own plugin called I<PrePlugin>. For
additional functionality I<after> the call of the Routine we have to
define a routine called I<PostPlugin>.

But what, if we want to replace the default plugin completely? Ok,
then we must define the subroutine I<MyPlugin>. If it is defined, this
subroutine instead of the original I<Plugin> is called.

=head2 Note

=over 4

Currently the plugins are expected in the main:: name-space.

=back

=head2 Class Methods

=over 4

=item B<new>

 $oPlugin   = Plugin->new($cName,
                          ["HasPrePost" => $bHasPrePost,]
                          ["HasMy"      => $bHasMy]);

With this method, a new plugin can be allocated. The I<Name>-Parameter
contains the base-name of the subroutines. The I<HasPrePost> and
I<HasMy>-parameters control, what types of plugins are searched, the
defaults are I<0>.

=item B<Call>

 $cResult   = $oPlugin->Call(@lParams);

Calls the plugins, depending on the Has...-flags given at creation
time and the availability of the subroutines. The results of the
subroutines are concatenated and will be returned. The given parameters
were evaluated and passed to the plugin-routines.

=item B<IsDefined>

 $bResult   = $oPlugin->IsDefined($cType);

Checks for this plugin, if a subroutine for one of the specified types
 I<Pre>,
 I<Post>,
 I<My> or
 I<Default>
is defined. If it is, I<1> is returned; I<0> if not.
For any other types I<undef> will be given back.

=back

=head2 Class Attributes

=over 4

=item B<Name>

 $cName = $oPlugin->getName();

The base-name of this Plugin. (Read-only)

=item B<HasPrePost>

 $bHasPrePost = $oPlugin->getHasPrePost();

True, when this Plugin could have a Pre- or Post-Plugin. (Read-only,
private)

=item B<HasMy>

 $bHasMy = $oPlugin->getHasMy();

True, when this Plugin could be replaced by a My-Plugin. (Read-only,
private)

=back
