#################### main pod documentation begin ###################

=head1 NAME

  ZymonicMP - Zymonic mod_perl Handler module

=head1 SYNOPSIS

TODO

=head1 DESCRIPTION

TODO

=head1 INSTALLATION

1. When using ZymonicMP it's extremely important to make sure
MaxClients is less than max number of connections allowed by
Apache.

=head1 USAGE

=head1 BUGS

None we're aware of...

=head1 SUPPORT

As in the license, Zymonic is provided without warranty or support
unless purchased separately, however... If you email 
zymonic-support@zednax.com your issue will   be noted and may 
receive a response.

For security issues, please contact zymonic-security@zednax.com and
someone will respond within 8 working hours.


=head1 AUTHOR

    Alex Masidlover et al.
    CPAN ID: MODAUTHOR
    Zednax Limited
    alex.masidlover@zednax.com
    http://www.zednax.com

=head1 COPYRIGHT

This program is free software licensed under the...

	Zymonic Public License 1.0

The full text of the license can be found in the
LICENSE file included with this module.

Other licenses may be acceptable if including
parts of Zymonic in larger projects, please
contact Zednax for details. 


=head1 SEE ALSO

perl(1).

=cut

#################### main pod documentation end ###################

package Zymonic::MP;
use Zymonic::ModPerl;

use strict;
use warnings;

use Zymonic;
use Zymonic::Session;
use Zymonic::Config;
use Zymonic::DB;
use Zymonic::Auth;
use Zymonic::Locking;
use Zymonic::Messaging;
use Zymonic::Utils qw(clean debug rethrow_exception deep_replace_card_numbers death_handler close_debugs);

use Data::Dumper;
use XML::Simple;

BEGIN
{
    use Exporter ();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION = '0.01';
    @ISA     = qw(Exporter);

    #Give a hoot don't pollute, do not export more than needed by default
    @EXPORT      = qw();
    @EXPORT_OK   = qw();
    %EXPORT_TAGS = ();
}

#################### subroutine header begin ####################

=head2 inner_handler

 Usage     : ZymonicMP::inner_handler
 Purpose   : Is a mod_perl response handler for Zymonic. The 
 'inner' version does the work and can be wrapped in an eval
 for exception handling purposes.
 Returns   : a suitable response for mod_perl.
 Argument  : a mod_perl reference
 Throws    : nothing
 Comment   : TODO

See Also   : 

=cut

#################### subroutine header end ####################

sub inner_handler : method
{
    my ( $class, $r ) = @_;
    my $fh;

    # Clear the globals
    $Zymonic::session                             = '';
    $Zymonic::system                              = '';
    $Zymonic::messaging                           = '';
    $Zymonic::Utils::debug_function_nesting_level = 0;
    @Zymonic::Utils::debug_function_times         = ();

    # something within the decryptor clears down the ENV which causes error on loading CGI::Apache2::Wrapper
    # see SR 11222 for more details on this, seems to be only on solaris
    # for now explicitly set the variables
    $Zymonic::ENV{MOD_PERL}             = 2;
    $Zymonic::ENV{MOD_PERL_API_VERSION} = 2;

    # Config Vars
    my $saxon = 0;

    # XML out
    my $xmlout;

    # Global objects
    my $db;
    my $auth;

    # Clear @HISTORY first...
    Zymonic::Utils::clear_history();

    my $protocol = ( ( defined( $Zymonic::ENV{HTTPS} ) and $Zymonic::ENV{HTTPS} eq 'on' ) ? 'https' : 'http' );

    # Clean path
    $ENV{PATH} = "/bin:/sbin:/usr/bin:/usr/sbin:/usr/local/sbin:/bin:/usr/bin:/sbin:/usr/sbin";

    # set binmode for STDOUT and STDERR to handle unicode
    binmode STDOUT, ':utf8';
    binmode STDERR, ':utf8';

    # setup the field factory
    $Zymonic::field_factory = Zymonic::FieldFactory->new();

    # enable cache for table includes and relationship permissions
    $Zymonic::object_cache = { 'Zymonic::TableInclude' => {}, 'Zymonic::RelationshipPermissions' => {}, };

    # reset tabindex for this request
    $Zymonic::tabindex = 0;

    # Create a session object
    $Zymonic::session = Zymonic::Session->new(
        parent          => $class,
        cgi             => Zymonic::ModPerl::CGI->new($r),
        r               => $r,
        ip_address      => clean( $Zymonic::ENV{REMOTE_ADDR} ),
        x_forwarded_for => clean( $Zymonic::ENV{HTTP_X_FORWARDED_FOR} ) || '',
        protocol        => $protocol
    );

    unless ( $Zymonic::session->https() eq 'true' )
    {
        my $url = $Zymonic::session->{cgi}->url( -path_info => 1, -query => 1 );
        $url =~ s/http/https/ unless substr( $url, 0, 5 ) eq "https";
        $r->print( $Zymonic::session->redirect($url) );
        debug( "Redirecting URL: " . $url );
        return Apache2::Const::REDIRECT;
    }
    debug( "URL not needing to be redirected: " . $Zymonic::session->{cgi}->url( -path_info => 1, -query => 1 ) );

    # Problem with creating session, normally caused by a request with invalid xml
    if ( @{ $Zymonic::session->{ZMESSAGE} } )
    {
        my $xmlhash = { session_errors => $Zymonic::session->{ZMESSAGE}, };
        my $output_response = $Zymonic::session->convert_for_output($xmlhash);

        # Produce response for client instead of generic system error, $output_response
        # will typically contain a brief summary of the problem and the error log reference
        $r->print( $Zymonic::session->header() );
        $r->print($output_response);

        $Zymonic::session->DESTROY;
        $Zymonic::session = '';
    }
    else
    {
        # Load the config - use the requested system config, or the system config for the server
        # or the first system found in the config directory.
        $Zymonic::system = $Zymonic::session->system_name( clean( $r->hostname, "-_" ), "/etc/zymonic" );

        # Create a DB object for this instance

        debug("Zymonic starting... system: $Zymonic::system");
        if ( ref( $Zymonic::ZCONFIG{$Zymonic::system} ) =~ /Config/ )
        {
            $Zymonic::ZCONFIG{$Zymonic::system}->load_system_definition();
            $Zymonic::ZCONFIG{$Zymonic::system}->load();
        }
        else
        {
            $Zymonic::ZCONFIG{$Zymonic::system} = Zymonic::Config->new(
                parent      => $class,
                system_name => $Zymonic::system,
                config_dir  => "/etc/zymonic",
            );
        }

        # Check for no display mode
        my $no_display_attributes = $Zymonic::session->no_display_attributes;

        my $redirect_url   = '';
        my $file_retrieval = undef;

        # Make the database connection (Config already has a connection
        # but we can't use that as its global to all the instances and in
        # a multi-threaded environment its not possible to rule out a
        # future set-up where one instance may get another's last_insert_id).
        $db = Zymonic::DB->new( parent => $class, config => $Zymonic::ZCONFIG{$Zymonic::system} );

        $Zymonic::session->{DB} = $db;

        $auth = Zymonic::Auth->new(
            parent      => $class,
            config      => $Zymonic::ZCONFIG{$Zymonic::system},
            session     => $Zymonic::session,
            DB          => $db,
            user        => '',
            credentials => '',
            logged_in   => '',
            ip_address  => $Zymonic::session->{ip_address}
        );

        $db->{auth} = $auth;

        # Initialise the session fully
        $Zymonic::session->initialise_session(
            {
                config => $Zymonic::ZCONFIG{$Zymonic::system},
                auth   => $auth,
                DB     => $db
            }
        );

        # setup locks
        $Zymonic::locking =
          Zymonic::Locking->new( config => $Zymonic::ZCONFIG{$Zymonic::system}, auth => $auth, DB => $db, );

        # setup messaging
        $Zymonic::messaging =
          Zymonic::Messaging->new( config => $Zymonic::ZCONFIG{$Zymonic::system}, auth => $auth, DB => $db, );
        debug("Messaging set-up finished");

        # check if servside xslt is required
        $saxon = $Zymonic::session->server_side_xslt();

        # build documentation if needed
        if ( $Zymonic::session->build_documentation )
        {
            eval {
                $Zymonic::ZCONFIG{$Zymonic::system}->build_documentation($auth);
                1;
            } or do
            {

                # don't let any exceptions here bring the system down
                # debug it but ignore it
                my $exception = $@;
                if ($exception)
                {
                    if ( ref($exception) and $exception->isa('Zymonic::Exception') )
                    {
                        debug_exception($exception);
                    }
                    else
                    {
                        debug( 'Unknown Exception (or a die): ' . Dumper($exception) );
                    }
                }
            };
        }

        eval {
            local $SIG{__DIE__} = sub { death_handler( $_[0] ); };
            $xmlout = $Zymonic::session->view_control($no_display_attributes);
            if ( $Zymonic::session->dev_flag eq 'force_error' )
            {
                $xmlout->{error} = [] unless ref( $xmlout->{error} );
                push( @{ $xmlout->{error} }, { message => { content => "Forced error" } } );
            }
            1;
        }
          or do
        {
            my $exception = $@;
            if (
                    $exception
                and ref($exception)
                and (  $exception->isa('Zymonic::Exception::State::Redirect')
                    or $exception->isa('Zymonic::Exception::Redirect') )
              )
            {
                $redirect_url = $exception->redirect_url;
            }
            elsif ( $exception and ref($exception) and $exception->isa('Zymonic::Exception::FileIO::Retrieval') )
            {
                $file_retrieval = {
                    file              => $exception->file(),
                    file_name         => $exception->file_name(),
                    content_type      => $exception->content_type(),
                    not_as_attachment => $exception->not_as_attachment() || '',
                };
            }
            elsif ( $exception
                and ref($exception)
                and $exception->isa('Zymonic::Exception::RequestTracker::AbortedRequest') )
            {
                # don't error for aborted requests, just stop and return
                $xmlout =
                  { session_errors => { content => $Zymonic::ZCONFIG{$Zymonic::system}->ll('Request was aborted!') } };
            }
            else
            {
                rethrow_exception($exception);
            }
        };

        # check if serverside xslt flag was forced
        # doing this again rather than moving the above to lessen impact
        $saxon = $Zymonic::session->server_side_xslt() if $Zymonic::session->{force_server_side_xslt};

        # check for custom xsl
        my $zz_xsl = $Zymonic::session->clean_param( 'ZZxsl', '/\\-._' );
        my $xsl = $zz_xsl || $Zymonic::session->xsl();
        my $xsl_with_path = $Zymonic::ZCONFIG{$Zymonic::system}->{htmlroot};
        unless ($xsl)
        {
            if ( ref( $xmlout->{currentpage} ) && $xmlout->{currentpage}->{xsl} )
            {
                $xsl = $xmlout->{currentpage}->{xsl};
            }
            elsif ( $Zymonic::ZCONFIG{$Zymonic::system} )
            {
                $xsl = $Zymonic::ZCONFIG{$Zymonic::system}->xslt;

            }
        }

        my $language = $Zymonic::session->language;

        if (  -f $Zymonic::ZCONFIG{$Zymonic::system}->{htmlroot} . "/"
            . $language->{lang_code} . "-"
            . $language->{subset} . "/"
            . $xsl )
        {
            $xsl = "/" . $language->{lang_code} . "-" . $language->{subset} . "/" . $xsl;
        }

        if ($redirect_url)
        {
            $r->print( $Zymonic::session->header );
            $r->print( $Zymonic::session->redirect($redirect_url) );
        }
        elsif ($file_retrieval)
        {
            $Zymonic::session->send_retrieved_file(
                $file_retrieval->{file},      $file_retrieval->{content_type},
                $file_retrieval->{file_name}, $file_retrieval->{not_as_attachment},
            );

            $r->print( $Zymonic::session->header() );

            # read file in using read to pass through the data directly
            # read in (up to) 64k chunks and write straight out
            open FILE, "<", $file_retrieval->{file}
              or Zymonic::Exception::FileIO::Read->throw( filename => $file_retrieval->{file} );
            binmode FILE;
            binmode STDOUT;
            my $buffer;
            while ( read( FILE, $buffer, 65536 ) ) { $r->print($buffer); }
            Zymonic::Exception::FileIO::Read->throw(
                filename => $file_retrieval->{file},
                error    => "Problem copying: $!"
            ) if $!;
            close FILE;

        }
        else
        {

            # Output the response in the correct format
            my $output_type = $Zymonic::session->output_type($xmlout) || '';
            my $output_response = $Zymonic::session->convert_for_output($xmlout);

            if (   $Zymonic::ZCONFIG{$Zymonic::system}->{debug_io_xml}
                && $Zymonic::ZCONFIG{$Zymonic::system}->{debug_io_xml} eq 'true' )
            {
                debug( "Outgoing Response: " . deep_replace_card_numbers($output_response), 'true' );
            }

            # if no ZZxsl and param to suppress XSL or API mode, then don't output XSL info
            if ( !$zz_xsl
                && ( $Zymonic::session->clean_param("notransform") or $no_display_attributes ) )
            {
                $r->print( $Zymonic::session->header );
                $r->print($output_response);
            }
            elsif ( !$saxon )
            {
                $r->print( $Zymonic::session->header );
                $r->print( "<?xml-stylesheet href=\"" . $xsl . "\" type=\"text/xsl\"?>\n" ) if $output_type eq 'xml';
                $r->print($output_response);
            }
            else
            {
                open( XT, ">:encoding(UTF-8)", "/tmp/xml.$$" );
                print XT $output_response;
                close(XT);

                debug("Server Side XSLT: /usr/local/bin/saxon /tmp/xml.$$ $xsl_with_path/$xsl");
                $r->print( $Zymonic::session->header( type => 'text/html' ) );
                `/usr/local/bin/saxon /tmp/xml.$$ $xsl_with_path/$xsl >/tmp/html.$$`;
                open( HT, "<:encoding(UTF-8)", "/tmp/html.$$" );
                $r->print($_) while (<HT>);
                close(HT);
                `rm /tmp/html.$$`;
            }
        }

        if ( defined $fh )
        {
            close($fh);
        }

        $Zymonic::session->{DB}->close_db_connection();
        $Zymonic::session->DESTROY;

        #   use Zymonic::MemoryUse;
        #
        #   no strict 'refs';
        #
        #   my $mem_use = Zymonic::MemoryUse->new();
        #   $mem_use->stash_size('Zymonic');
        #   $mem_use->results_csv("/tmp/memory_$$." . time() . ".csv", 2);

        # Clear the globals
        $Zymonic::session = '';
        $Zymonic::system  = '';
        close_debugs();
        return ( !$redirect_url ) ? Apache2::Const::OK : Apache2::Const::HTTP_MOVED_TEMPORARILY;
    }
}

#################### subroutine header begin ####################

=head2 handler

 Usage     : ZymonicMP::handler
 Purpose   : Is a mod_perl response handler for Zymonic.
 Returns   : a suitable response for mod_perl.
 Argument  : a mod_perl reference
 Throws    : nothing
 Comment   : TODO

See Also   : 

=cut

#################### subroutine header end ####################

sub handler : method
{
    return Zymonic::ModPerl::handler(@_);
}

#################### subroutine header begin ####################

=head2 post_config

 Usage     : post_config()
 Purpose   : Does post_config routines before apache children fork,
 specifically creating an MM segment.
 Returns   : a suitable response for mod_perl.
 Argument  : nothing
 Throws    : nothing
 Comment   : TODO

See Also   : 

=cut

#################### subroutine header end ####################

sub post_config : method
{
    my $class = shift;

    Zymonic::ModPerl::post_config();
}

#################### subroutine header begin ####################

=head2 child_exit

 Usage     : child_exit()
 Purpose   : Called when apache child process exists, allowing cleanup
 of resources to be done
 Returns   : a suitable response for mod_perl.
 Argument  : nothing
 Throws    : nothing
 Comment   : TODO

See Also   : 
start
=cut

#################### subroutine header end ####################

sub child_exit : method
{
    my $child_pool = shift;
    my $s          = shift;

    # issues with DESTROY cleanup not being triggered in places where it is necessary
    # explicitly call it here to ensure cleanup is done
    map { $_->DESTROY('force'); } values %Zymonic::ZCONFIG;

    # clear all global var, this should then trigger DESTROY functions
    # which will do all the cleanup
    $Zymonic::session          = undef;
    $Zymonic::system           = undef;
    $Zymonic::messaging        = undef;
    $Zymonic::locking          = undef;
    $Zymonic::field_factory    = undef;
    %Zymonic::object_cache     = {};
    %Zymonic::ZCONFIG          = {};
    %Zymonic::SystemDefinition = {};

    return Apache2::Const::OK;
}

1;