#!/usr/bin/perl
#
# $Header: /Users/claude/fuzz/lib/Genezzo/Havok/RCS/SysHook.pm,v 7.14 2007/11/20 07:41:42 claude Exp claude $
#
# copyright (c) 2005-2007 Jeffrey I Cohen, all rights reserved, worldwide
#
#
package Genezzo::Havok::SysHook;
use Genezzo::Util;
use Genezzo::Dict;

use strict;
use warnings;
use warnings::register;

use Carp;

our $VERSION;

our $Got_Hooks;       # set to 1 after all hooks get loaded
our %SysHookOriginal; # save original value of all hooks for posterity
our %ReqObjList;      # Object-Oriented Require
our %ReqObjMethod;    # Object-Oriented Meth

our $MAKEDEPS;

BEGIN {
    $VERSION = do { my @r = (q$Revision: 7.14 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; # must be all one line, for MakeMaker

    $Got_Hooks = 0;

    my $pak1  = __PACKAGE__;
    $MAKEDEPS = {
        'NAME'     => $pak1,
        'ABSTRACT' => ' ',
        'AUTHOR'   => 'Jeffrey I Cohen (jcohen@cpan.org)',
        'LICENSE'  => 'gpl',
        'VERSION'  =>  $VERSION,
#        'UPDATED'  => Genezzo::Dict::time_iso8601()
        }; # end makedeps

    $MAKEDEPS->{'PREREQ_HAVOK'} = {
        'Genezzo::Havok' => '0.0',
        'Genezzo::Havok::Utils' => '0.0', # for userfunctions
    };

    # DML is an array, not a hash

    my $now = 
    do { my @r = (q$Date: 2007/11/20 07:41:42 $ =~ m|Date:(\s+)(\d+)/(\d+)/(\d+)(\s+)(\d+):(\d+):(\d+)|); sprintf ("%04d-%02d-%02dT%02d:%02d:%02d", $r[1],$r[2],$r[3],$r[5],$r[6],$r[7]); };

    my $dml =
        [
#         "i havok 4 $pak1 SYSTEM $now 0 $VERSION"
         ];

    my %tabdefs = 
        ('sys_hook' =>  {
            create_table =>  
                'xid=n pkg=c hook=c replace=c xtype=c xname=c args=c owner=c creationdate=c version=c',
                dml => $dml
            }
         );
    $MAKEDEPS->{'TABLEDEFS'} = \%tabdefs;

    my @sql_funcs = qw(
                       add_sys_hook
                       );

    my @ins1;
    my $ccnt = 1;
    for my $pfunc (@sql_funcs)
    {
        my %attr = (module => $pak1, 
                    function => "sql_func_" . $pfunc,
                    creationdate => $now,
                    argstyle => 'HASH',
                    sqlname => $pfunc);

        my @attr_list;
        while ( my ($kk, $vv) = each (%attr))
        {
            push @attr_list, '\'' . $kk . '=' . $vv . '\'';
        }

        my $bigstr = "select add_user_function(" . join(", ", @attr_list) .
            ") from dual";
        push @ins1, $bigstr;
        $ccnt++;
    }

    # add help for all functions
    push @ins1, "select add_help(\'$pak1\') from dual";

    # register havok module

    push @ins1, "select register_havok_package(" .
        "\'modname=" . $pak1 .  "\', ".
        "\'creationdate=" . $now .  "\', ".
        "\'version=" . $VERSION .  "\'".
        ") from dual";

    # XXX XXX: NOTE: check is for install, which is after create_table/dml

    $MAKEDEPS->{'DML'} = [
                          { check => [
                                      "select * from user_functions where xname = \'$pak1\'"                                      
],
                            install => \@ins1 }
                          ];

#    print Data::Dumper->Dump([$MAKEDEPS]);
}

our $GZERR = sub {
    my %args = (@_);

    return 
        unless (exists($args{msg}));

    if (exists($args{self}))
    {
        my $self = $args{self};
        if (defined($self) && exists($self->{GZERR}))
        {
            my $err_cb = $self->{GZERR};
            return &$err_cb(%args);
        }
    }

    carp $args{msg}
        if warnings::enabled();
    
};

sub MakeYML
{
    use Genezzo::Havok;

    my $makedp = $MAKEDEPS;

#    $makedp->{'UPDATED'}  = Genezzo::Dict::time_iso8601();

    return Genezzo::Havok::MakeYML($makedp);
}

# XXX XXX: Note: This method and the associated SQL script are
# deprecated, since all the work is done in HavokUse
sub MakeSQL
{
    my $bigSQL; 
    ($bigSQL = <<EOF_SQL) =~ s/^\#//gm;
#REM Copyright (c) 2005, 2006, 2007 Jeffrey I Cohen.  All rights reserved.
#REM
#REM 
#select HavokUse('Genezzo::Havok::SysHook') from dual;
#
#REM HAVOK_EXAMPLE
#i sys_hook 1 Genezzo::Dict dicthook1 Howdy_Hook require Genezzo::Havok::Examples Howdy SYSTEM TODAY 0
#i sys_hook 2 Genezzo::Dict dicthook1 Ciao_Hook  require Genezzo::Havok::Examples Ciao SYSTEM TODAY 0
#
#
#
#commit
#shutdown
#startup
EOF_SQL
    my $now = Genezzo::Dict::time_iso8601();
    $bigSQL =~ s/TODAY/$now/gm;
    $bigSQL =~ s/HAVOK_VERSION/$VERSION/gm;
    $bigSQL = "REM Generated by " . __PACKAGE__ . " version " .
        $VERSION . " on $now\nREM\n" . $bigSQL;

    return $bigSQL;
}

sub getpod
{
    my $bigHelp;
    ($bigHelp = <<'EOF_HELP') =~ s/^\#//gm;
#=head1 System_Hooks
#
#=head2  add_sys_hook : add_sys_hook(pkg=...,hook=...,module=...,function=...)
#
#To create a system hook for dicthook1 in Genezzo::Dict using the 
#function "Howdy" in Genezzo::Havok::Examples just use:
#  select add_sys_hook(
#             'pkg=Genezzo::Dict',
#             'hook=dicthook1',
#             'replace=Howdy_Hook',
#             'module=Genezzo::Havok::Examples',
#             'function=Howdy') from dual;
#
#More sophisticated functions may need to define the sys_hook
#table columns as specified in L<Genezzo::Havok::SysHook>. 
#Use the help command:
#
#  select add_sys_hook('help') from dual;
#
#to list the valid parameters
#
#
#
EOF_HELP

    my $msg = $bigHelp;

    return $msg;

} # end getpod


sub _build_sql_for_sys_hook
{
    my %required = (
                    xid => "no xid!",
                    pkg => "no package!",
                    hook => "no hook!",
                    replace => "no replace!",
                    xname => "no xname!",
                    args => "no args!"
                    );

    my $now = Genezzo::Dict::time_iso8601();

    my %optional = (
                    xtype => "require",
                    creationdate => $now,
                    owner => "SYSTEM",
                    version => 0
                    );
    my %args = (
                %optional,
		@_);

    # synonyms
    $args{xname} = $args{module} if (exists($args{module}));
    $args{args}  = $args{function} if (exists($args{function}));
    $args{pkg}  = $args{package} if (exists($args{package}));

    return undef
        unless (Validate(\%args, \%required));

    my $pattern = "\'%s\', " x 9;
    $pattern .= "\'%s\' ";

    my $bigstr = "insert into sys_hook values (" .
        sprintf($pattern,
                $args{xid},
                $args{pkg},
                $args{hook},
                $args{replace},
                $args{xtype},
                $args{xname},
                $args{args},

                $args{owner},
                $args{creationdate},
                $args{version});

    $bigstr .= ")";

    return $bigstr;
}

sub sql_func_add_sys_hook
{
    my %args= @_;

    my $dict = $args{dict};
    my $dbh  = $args{dbh};
    my $fn_args = $args{function_args};
    
#    print Data::Dumper->Dump($fn_args);

    my $now = Genezzo::Dict::time_iso8601();

    # list the optional values
    my %nargs = (
                 xtype => "require",
                 creationdate => $now,
                 owner => "SYSTEM",
                 version => 0,

                 dict => $dict
                 );

    my $do_help = 0;

    $do_help = 1 unless (scalar(@{$fn_args}));
    
    my $valid = 
        'xid|pkg|hook|replace|xtype|xname|args|owner|creationdate|version';

    $valid .= '|module|function|package'; # additional synonyms

    for my $argi (@{$fn_args})
    {
        # separate key=val pairs into hash args

        my @foo;
        @foo = ($argi =~ m/^(\s*\w+\s*\=\s*)(.*)(\s*)$/)
            if ($argi =~ m/\w+\s*\=/);


        if ($argi =~ m/^\s*($valid)\s*\=/i)
        {
            my $nargtype = $foo[0];
            # remove the spaces and equals ("=");
            $nargtype =~ s/\s//g;
            $nargtype =~ s/\=//g;

            $nargtype = 'xname' if ($nargtype =~ m/^module/i);
            $nargtype = 'args' if ($nargtype =~ m/^function/i);
            $nargtype = 'pkg' if ($nargtype =~ m/^package/i);

            $nargs{lc($nargtype)} = $foo[1];
        }
        else
        {
            if (scalar(@{$fn_args}) == 1)
            {
                if ($argi =~ m/^help$/i)
                {
                    $do_help = 1;
                    last;
                }
            } # end if 1 arg
        }
    } # end for

    if ($do_help)
    {
        my $outi = "Valid arguments are:\n    ";

        $outi .= join(" ",split(/\|/, $valid)) . "\n";

        my $bigexample;
        ($bigexample = <<EOF_EXAMPLE) =~ s/^\#//gm;
#
#To create a system hook for dicthook1 in Genezzo::Dict using the 
#function "Howdy" in Genezzo::Havok::Examples just use:
#  select add_sys_hook(
#             'pkg=Genezzo::Dict',
#             'hook=dicthook1',
#             'replace=Howdy_Hook',
#             'module=Genezzo::Havok::Examples',
#             'function=Howdy') from dual;
EOF_EXAMPLE

        $outi .= $bigexample;
        
        return $outi;
    }

    unless (exists($nargs{xid}))
    {
        my $hashi  = $dict->DictTableGetTable (tname => "sys_hook") ;
        my $tv = tied(%{$hashi});

        $nargs{xid} = $dict->DictGetNextVal(tname => "sys_hook",
                                            col   => "xid",
                                            tieval => $tv);

    }

    my $bigstr = _build_sql_for_sys_hook(%nargs);

    return 0 unless(defined($bigstr));

    my $sth =
        $dbh->prepare($bigstr);
    
    return 0
        unless ($sth);


    # insert the function definition in the user_function table
    return 0
        unless ($sth->execute());

    # load the hook
    return Genezzo::Havok::SysHook::LoadSysHook(%nargs);

}

sub LoadSysHook
{
    my %optional;

    my %required = (
                    xid          => "no xid!",
                    xtype        => "no xtype!",
                    xname        => "no xname!",
                    owner        => "no owner!",
                    creationdate => "no creationdate!",
                    args         => "no args!",

                    pkg          => "no pkg!",
                    hook         => "no hook!",
                    replace      => "no replace!",

                    dict         => "no dictionary!"
                    );

    my %args = (%optional,
                @_);

    return 0
        unless (Validate(\%args, \%required));

    my $xid    = $args{xid};
    my $xtype  = $args{xtype};
    my $xname  = $args{xname};
    my $owner  = $args{owner};
    my $dat    = $args{creationdate};
    my $xargs  = $args{args};

    my $xpkg   = $args{pkg};
    my $hook   = $args{hook};
    my $repl   = $args{replace};

    my $dict   = $args{dict};

    my $stat = 1;

    my $save_previous_hook;

    # block 1
    {
        my $mainf = $xpkg . "::"  . $hook;

        my @varlist; # list of variables to hold previous value of coderef

        if (defined($repl)
            && length($repl))
        {
                
            # build name of variable to hold previous value of
            # hook coderef
            
            $repl = $xname . "::" . $repl; # scope for require package
            push @varlist, $repl;
        }

        # have we seen this hook before?
        unless (exists($SysHookOriginal{"$mainf"}))
        {

            # create a placeholder, even for non-existant
            # functions.  Then we know to "undef" them if we
            # re-initialize...
            
            $SysHookOriginal{"$mainf"} = undef;

            # save the original value for a hook variable if necessary
            my $orig_var = 'SysHookOriginal{"'. $mainf . '"}';
            push @varlist, $orig_var;
        }

        if (scalar(@varlist))
        {
            # we have a hook that needs saving...
            $save_previous_hook = "";

            # save to modules "replace" var and SysHookOriginal 
            # if necessary
            for my $varname (@varlist)
            {
                $save_previous_hook .= '$' . $varname . ' = \&' . $mainf .
                    ' if defined(&' . $mainf . ');';
            }
            greet $save_previous_hook;

        }
        else
        {
            # do nothing
            $save_previous_hook = undef;
        }

    } # end block 1

    if ($xtype =~ m/^(oo_require|require)$/i)
    {
        my $req_str = "require $xname";

        eval "$save_previous_hook"
            if (defined($save_previous_hook));
            
        greet $req_str;

        unless (eval $req_str)
        {
            my %earg = (#self => $self,
                        msg => "no such package - $xname - for table sys_hook, row $xid");

            &$GZERR(%earg)
                if (defined($GZERR));

#                next;
            return 0;
        }

        # check if package has GZERR function, and redefine it to use
        # our version (since our version might get redefined to point
        # to parent routine).
        
        my $gz_err_var = $xname . "::GZERR";
        my $use_gzerr;
        
        my $s1 = "\$use_gzerr = defined(\$$gz_err_var);";
        eval "$s1";
        greet $s1, $use_gzerr;

        # XXX XXX: check for existance of "args" function...

        no strict 'refs';
        no warnings 'redefine';

        my @inargs;

        if ($xargs =~ m/\s/)
        {
            @inargs = split(/\s/, $xargs);
        }
        else
        {
            push @inargs, $xargs;
        }

        if ($xtype =~ m/^(oo_require)$/i)
        {
            # Object-Oriented Require
            unless (exists($ReqObjList{"$xname"}))
            {
                whisper "init object for package $xname";
                
                my $obj;
                my $initstr = '$obj = ' . $xname ;
                $initstr   .= "->" . 'SysHookInit($dict)';
                whisper "$initstr";
                eval " $initstr " ;
                if ($@)
                {
                    my %earg = (#self => $self,
                                msg => "$@\nbad pkg init : $initstr");
                    
                    &$GZERR(%earg)
                        if (defined($GZERR));

                    $stat = 0;
                }

                # create an entry even if the init fails
                $ReqObjList{"$xname"} = $obj;                        
            }
                
        }

        my $obj1;

        for my $fname (@inargs)
        {
            # Note: add functions to specified namespace...

            my $mainf = $xpkg . "::"  . $hook;
            my $packf =  $xname . "::" . $fname;

            my $func = "sub " . $mainf ;
            if (($xtype =~ m/^(oo_require)$/i) &&
                exists($ReqObjList{"$xname"}) &&
                defined($ReqObjList{"$xname"}))
            {
                $obj1 = $ReqObjList{"$xname"};
                #$ReqObjMethod{$packf} = sub { $obj1->$packf(@_) };
                #$func .= '{ return $ReqObjMethod{' . $packf . '}->(@_); }';
#                    $func .= '{ my $mref = sub { $obj1->$packf(@_) };';
#                    $func .= ' return $mref->(@_); }';

                # lots of work to avoid 'Variable "$mref" may be
                # unavailable...'

                $func .= '{ my $mref = ' .
                    'sub { $Genezzo::Havok::SysHook::ReqObjList{"' 
                    . $xname .'"}->' . $packf . '(@_) };';
                $func .= ' return $mref->(@_); }';

#                    $mref = sub { $obj1->$packf(@_) };
#                    $func .= '{ return $mref->(@_); }';
            }
            else
            {
                $func .= "{ return " . $packf . '(@_); }';
            }            

            whisper $func;

#            eval {$func } ;
            eval " $func " ;
            if ($@)
            {
                my %earg = (#self => $self,
                            msg => "$@\nbad function : $func");

                &$GZERR(%earg)
                    if (defined($GZERR));

                $stat = 0;
            }

        }

            
    } # end  if $xtype =~ (oo_require|require)
    elsif ($xtype =~ m/^function$/i)
    {
        my $doublecolon = "::";


        # XXX XXX: what about hook name? what should it mean?

        unless ($xname =~ m/$doublecolon/)
        {
            # Note: add functions to  namespace...
            
            $xname = $xpkg . "::" . $xname;
        }

        my $func = "sub " . $xname . " " . $xargs;
            
#            whisper $func;

#            eval {$func } ;
        eval " $func " ;
        if ($@)
        {
            my %earg = (#self => $self,
                        msg => "$@\nbad function : $func");
            
            &$GZERR(%earg)
                if (defined($GZERR));
            $stat = 0;
        }
    } # end if xtpe =~ function
    else
    {
        my %earg = (#self => $self,
                    msg => "unknown user extension - $xtype");

        &$GZERR(%earg)
            if (defined($GZERR));

        $stat = 0;
    }

    return $stat;

} # end loadsyshook

sub HavokInit
{
#    whoami;
    my %optional = (phase => "init");
    my %required = (dict  => "no dictionary!",
                    flag  => "no flag"
                    );

    my %args = (%optional,
		@_);
#		
    my @stat;

    push @stat, 0, $args{flag};
#    whoami (%args);

    return @stat
        unless (Validate(\%args, \%required));

    if ($Got_Hooks)
    {

        # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX 
        # don't load hooks twice to avoid circular links!!  Is it
        # sufficient to call the first entry for each hook and reset
        # the hook to its "replace" var, i.e for dicthook1, set
        # dicthook1 = &Howdy_Hook ? Or use SysHookOriginal hash?
        # XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX XXX 
        $stat[0] = 1; # ok!
        return @stat;
    }

    my $dict   = $args{dict};
    my $phase  = $args{phase};

    return @stat
        unless ($dict->DictTableExists(tname => "sys_hook",
                                       silent_notexists => 1));

    my $hashi  = $dict->DictTableGetTable (tname => "sys_hook") ;

    return @stat # no User Extensions
        unless (defined ($hashi));

    my $tv = tied(%{$hashi});

    while ( my ($kk, $vv) = each ( %{$hashi}))
    {
        my $getcol = $dict->_get_col_hash("sys_hook");  
        my $xid    = $vv->[$getcol->{xid}];
        my $xtype  = $vv->[$getcol->{xtype}];
        my $xname  = $vv->[$getcol->{xname}];
        my $owner  = $vv->[$getcol->{owner}];
        my $dat    = $vv->[$getcol->{creationdate}];
        my $xargs  = $vv->[$getcol->{args}];

        my $xpkg   = $vv->[$getcol->{pkg}];
        my $hook   = $vv->[$getcol->{hook}];
        my $repl   = $vv->[$getcol->{replace}];
            
#        greet $vv;
        
        my $lstat =
            LoadSysHook(
                        xid          => $xid,
                        xtype        => $xtype,
                        xname        => $xname,
                        owner        => $owner,
                        creationdate => $dat,
                        args         => $xargs,

                        pkg          => $xpkg,
                        hook         => $hook,
                        replace      => $repl,

                        dict         => $dict
                        );

    } # end while

    $Got_Hooks = 1;

    greet %SysHookOriginal;

    $stat[0] = 1; # ok!
    return @stat;
}

sub HavokCleanup
{
#    whoami;
    return HavokInit(@_, phase => "cleanup");
}


END { }       # module clean-up code here (global destructor)

## YOUR CODE GOES HERE

1;  # don't forget to return a true value from the file

__END__
# Below is stub documentation for your module. You better edit it!

=head1 NAME

Genezzo::Havok::SysHook - load the SysHook table

=head1 SYNOPSIS

 # don't say "use Genezzo::Havok::SysHook".  Update the
 # dictionary havok table:

select HavokUse('Genezzo::Havok::SysHook') from dual;


=head1 DESCRIPTION

Basic Havok module - load the SysHook table

create table sys_hook (
    xid   number,
    pkg   char,
    hook  char,
    replace  char,
    xtype char,
    xname char,
    args  char,
    owner char, 
    creationdate char,
    version char
    );

=over 4

=item xid - a unique id number
  
=item pkg - name of package for this hook

=item hook - name of hook function

=item replace - unique name for previous hook coderef.  
If blank or null, just replace existing hook, 
otherwise is variable name for
previous version of the hook, and may get called from new hook

=item  xtype - the string "require" or "function"

=item xname - if xtype = "require", then xname is a package name, like
"Text::Soundex".  if xtype = "function", xname is a function name.  A
function name may be qualified with a package.


=item args - if xtype = "require", an (optional) blank-separated list
of functions to import to the default Genezzo namespace.  if xtype =
"function", supply an actual function body in curly braces.

=item owner - owner of the package or function

=item creationdate - date row was created

=back

=head2 Example:

insert into sys_hook values (1, 'Genezzo::Dict', 'dicthook1', 'Howdy_Hook',
'require', 'Genezzo::Havok::Examples',  
'Howdy', 'SYSTEM', '2004-09-21T12:12');

The row causes SysHook to "require Genezzo::Havok::Examples", and
calls the "Howdy" function from the hook function "dicthook1" in the
package Genezzo::Dict.  The previous coderef for the function "dicthook1"
(if it exists) is assigned to $Genezzo::Havok::Examples::Howdy_Hook. 
The Howdy function can call &$Howdy_Hook() to activate the original
"dicthook1" function.


=head1 ARGUMENTS

=head1 FUNCTIONS

=over 4

=back

=head1 RISKS 

Replacing system functions in an operational database has
approximately the same level of risk exposure as running with the
bulls at Pamplona with your pants around your ankles.  Which is to
say, "somewhat foolhardy".  

=head2 EXPORT

=over 4


=back


=head1 LIMITATIONS

=head1 TODO

=over 4

=item should be able to dynamically create hook vars, versus using
existing "our" vars.

=item should we do something smart on dictionary shutdown, like unload hooks?  Or have a clever way to re-init and reload a hook?

=back

=head1 AUTHOR

Jeffrey I. Cohen, jcohen@genezzo.com

=head1 SEE ALSO

L<perl(1)>.

Copyright (c) 2005-2007 Jeffrey I Cohen.  All rights reserved.

    This program is free software; you can redistribute it and/or modify
    it under the terms of the GNU General Public License as published by
    the Free Software Foundation; either version 2 of the License, or
    any later version.

    This program is distributed in the hope that it will be useful,
    but WITHOUT ANY WARRANTY; without even the implied warranty of
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
    GNU General Public License for more details.

    You should have received a copy of the GNU General Public License
    along with this program; if not, write to the Free Software
    Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA

Address bug reports and comments to: jcohen@genezzo.com

For more information, please visit the Genezzo homepage 
at L<http://www.genezzo.com>

=cut