Genezzo::Contrib::Clustered::ModPerlWrap - Mod Perl wrappers for Genezzo

    StartPage();
    Connect("/dev/raw");
    ProcessStmt("insert into t1 values (10, 'test10')");
    ProcessStmt("insert into t1 values (11, 'test11')");
    Commit();
    FinishPage();

    StartPage();
    Connect("/dev/raw");
    ProcessStmt("select * from t1");
    FinishPage();

    Copyright (C) 2005 by Eric Rollins.  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

#!/usr/bin/perl
#
# ModPerlWrap.pm
# Eric Rollins 2005
#
use strict;
use warnings;

package Genezzo::Contrib::Clustered::ModPerlWrap;

use File::Path;
use File::Spec;
use Data::Dumper;
use Genezzo::GenDBI;
use Genezzo::Contrib::Clustered;
use Genezzo::Contrib::Clustered::GLock::GLock;
use POSIX;

require Exporter;
our @ISA = ("Exporter");

our @EXPORT = qw(PrintForm StartPage ProcessStmt Rollback Commit 
		 Connect FinishPage);

our $dbh;
our $query_num = 0;
our $dbi_gzerr;

sub entry {
    my $sigset = POSIX::SigSet->new(POSIX::SIGUSR2);
    my $old_sigset = POSIX::SigSet->new;
    POSIX::sigprocmask(POSIX::SIG_BLOCK, $sigset, $old_sigset)
		     or die "Error blocking SIGUSR2: $!\n";
}

sub normal_exit {
    my $sigset = POSIX::SigSet->new(POSIX::SIGUSR2);
    my $old_sigset = POSIX::SigSet->new;
    POSIX::sigprocmask(POSIX::SIG_UNBLOCK, $sigset, $old_sigset)
		     or die "Error unblocking SIGUSR2: $!\n";

    # Apache remaps this to ModPerl::Util::exit()
    exit();
}

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

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

    my $sev = "UNKNOWN";
    
    if (exists($args{severity}))
    {
	$sev = uc($args{severity});
    
	$sev = 'WARNING'
	    if ($sev =~ m/warn/i);

	# don't print 'INFO' 
	if ($args{severity} =~ m/info/i)
	{
	    return;
	}
    }

    # log error
    print STDERR "ERROR $sev", __PACKAGE__, ": ",  $args{msg};

    print "<error>\n";
    print "  <error-severity>";
    print $sev;
    print "</error-severity>\n";
    print "  <error-message>";
    print __PACKAGE__, ": ",  $args{msg};
    print "</error-message>\n";
    print "</error>\n";
};

sub return_error
{
    my ($where) = @_;

    print "  <error-location>", $where, "</error-location>\n";
    print "</results>\n";
    normal_exit();
};

sub sig_handler {
    if(Genezzo::Contrib::Clustered::GLock::GLock::ast_poll()){
	# message print may not be signal-safe.
	print STDERR "\n$$ Exiting immediately due to lock request\n";
	CORE::exit();
    }
}

BEGIN {
}

sub Connect {
    my ($gnz_home) = @_;

    # also covered in StartPage()
    entry();

    if(defined($dbh)){
	return;  # already connected
    }

    # Perl "safe" signals prevent signals from being recd during Apache 
    # event loop.
    #$SIG{USR2} = \&sig_handler;
    my $sigActionObj  =POSIX::SigAction->new(\&sig_handler);
    $sigActionObj->flags(&POSIX::SA_RESTART);
    POSIX::sigaction(POSIX::SIGUSR2,$sigActionObj)                     
	or die "Error setting SIGUSR2 handler: $!\n";

    Genezzo::Contrib::Clustered::GLock::GLock::set_notify();

    $query_num = 1;  # already incr from zero in StartPage()

    $dbh = Genezzo::GenDBI->connect($gnz_home, 
				    "NOUSER", 
				    "NOPASSWORD",
				    {GZERR => $dbi_gzerr,
				     PrintError => 0,
				     RaiseError => 0});

    if(defined($dbh)){
	$dbh->do("startup"); # start the database

	my $ret = $dbh->do("rollback");  # Grab shared locks.

	if(!defined($ret)){
	    return_error("rollback");
	}
    }
}

use CGI qw(:standard escapeHTML);

# This routine is not protected against interruption.
sub PrintForm {
    print header();
    print start_html("Genezzo");
    print "  <h2>Enter Genezzo SQL Statement:</h2>\n";
    print "  <form>\n";
    print "    <textarea rows=\"5\" cols=\"60\" name=\"query\"></textarea>\n";
    print "    <p>\n";
    print "    <input type=\"submit\"/>\n";
    print "  </form>\n";
    print end_html();
}

sub StartPage {
    entry();
    print "Content-type: text/xml\n\n";
    print '<?xml version="1.0" encoding="iso-8859-1"?>';
    print "\n";
    print "<results>\n"; 
    print "<query_num>$query_num</query_num>\n";   # to debug mod_perl reuse
    print "<os_pid>$$</os_pid>\n";
    $query_num++;
}

# For queries prints results as XML.
sub ProcessStmt {
    my ($stmt) = @_;

    if(!defined($dbh)){
	return_error("connect");
    }

    my $sth = $dbh->prepare($stmt);

    if(!defined($sth)){
	return_error("prepare");
    }

    my $ret = $sth->execute();

    if(!defined($ret)){
	$dbh->do("rollback"); 
	return_error("execute");
    }

    my $numFields = $sth->{NUM_OF_FIELDS};

    if(!defined($numFields)){
	return;
    }

    while (1)
    {
	my @ggg = $sth->fetchrow_array();

	last
	    unless (scalar(@ggg));

	print "   <row>\n";
 
	my $i;

	for($i = 0; $i < $numFields; $i++){
	    print "      <", $sth->{NAME}->[$i], ">";
	    print $ggg[$i];
	    print "</", $sth->{NAME}->[$i], ">";
	    print "\n";
	}

	print "   </row>\n";
    }

    # Can fatal errors occur during fetch, requiring rollback?
}

sub Rollback {
    my $ret = $dbh->do("rollback");
    
    if(!defined($ret)){
	return_error("rollback");
    }
}

sub Commit {
    my $ret = $dbh->do("commit");
    
    if(!defined($ret)){
	return_error("commit");
    }
}

sub FinishPage {    
    print "</results>\n";
    normal_exit();
}

1;

__END__