Subversion Repositories DevTools

########################################################################

# COPYRIGHT - VIX IP PTY LTD ("VIX"). ALL RIGHTS RESERVED.

#

# Module name   : DBI.pm

# Module type   : Makefile system

# Compiler(s)   : n/a

# Environment(s): jats

#

# Description   : This package has been created to simplify the migration

#                 of the deployments scripts that use an DBI:ODBC interface

#                 to Release Manager, to a JDBC interface.

#

#                 The package provides suffient methods to trick the existing

#                 code into working. No More. No less.

#

#......................................................................#

require 5.006_001;

use strict;

use warnings;

#use Data::Dumper;

use Cwd;

use IPC::Open2;

package DBI;

our $VERSION = '2.0.1';

use Exporter;

our @EXPORT = qw();

our @EXPORT_OK = (@EXPORT, qw());

our %EXPORT_TAGS = qw( );

our $verbose = $ENV{'GBE_DBI_VERBOSE'} || 0;

our $errstr = "No Error";

my  $appname = 'ReleaseManagerSelect.jar';

my $full_app;

#-------------------------------------------------------------------------------

# Function        : connect

#

# Description     : Connect to the SQL server

#

# Inputs          : $db                     - Database Name

#                   $user                   - User Name

#                   $passwd                 - PassWord

#

# Returns         : New connection

#                   undef if the required Java utility cannot be found

#

sub connect

{

    my $obclass = shift;

    my $class = ref($obclass) || $obclass;

    bless my $self = {

        DB          => $_[0],

        USER        => $_[1],

        PASSWORD    => $_[2],

        ATTRREF     => $_[3],

        ERROR       => 0,

        ECOUNT      => 0,

        FH_READ     => undef,

        FH_WRITE    => undef,

        PID         => 0,

    } => ( $class );

    if ( $self->{ATTRREF}->{verbose} )

    {

        $verbose = $self->{ATTRREF}->{verbose};

    }

    #

    #   Need to locate the path to the Java applet

    #   This can be in th "CLASSPATH", but that simply forces the problem of

    #   locating the utility into the configuration world

    #

    #   Look in Perls @INC list, as we expect to find the program within one of

    #   thePerl Libraries.

    #

    unless ( $full_app )

    {

        foreach my $dir ( @INC )

        {

            my $apppath = "$dir/$appname";

            next unless ( -f $apppath );

            $full_app = $apppath;

            last;

        }

        if ( ! $full_app )

        {

            $errstr = "Cannot find $appname in @INC path";

            return;

        }

    }

    $errstr = "OK";

    #

    #   Initiate the external application server

    #   This is slow and will only done once

    #

    #   Start up the Java based Oracle interface script

    #   Create it with both a read and a write handle as we will be pushing

    #   requests at it and pulling data from it.

    #

    #   Monitor the status of the server waiting for an indication that the

    #   connection is open, or that the connection link has terminated.

    #

    #

    my @cmd;

    push @cmd, "java";                      # Use form that will not invoke a shell

    push @cmd, "-jar";

    push @cmd, $full_app;

    push @cmd, $self->{DB};

    push @cmd, $self->{USER};

    push @cmd, $self->{PASSWORD};

    print "[DBI] Command: @cmd\n" if $verbose;

    $self->{PID} = IPC::Open2::open2($self->{FH_READ}, $self->{FH_WRITE}, @cmd );

    $self->{ERROR} = 1;

    $errstr = "Failed to start server app";

    if ( $self->{PID} )

    {

        #

        #   Extract status and any error information

        #

        my $fh = $self->{FH_READ};

        while ( <$fh> )

        {

            $_ =~ s~\s+$~~;

            print "[DBI] Connect: $_\n" if $verbose;

            if ( m/^ConnectionOpened:/ )

            {

                $self->{ERROR} = 0;

                $errstr = "OK";

                last;

            }

            if ( m/^Error:(.*?)\s*$/ )

            {

                $errstr = $1;

            }

            if ( m/^Status:ConnectionClosed$/ )

            {

                $self->{PID} = 0;

            }

        }

    }

    #

    #   Return class iff the connection has been established

    #

    return $self->{ERROR} ? undef : ($self);

}

#-------------------------------------------------------------------------------

# Function        : errstr

#

# Description     : Return the last open error

#

# Inputs          : None

#

# Returns         : String

#

sub errstr

{

    return $errstr;

}

#-------------------------------------------------------------------------------

# Function        : prepare

#

# Description     : Prepare an SQL statement for processing

#

# Inputs          : $self

#                   $statement

#

# Returns         : Reference to a class

#                   undefined on error

#

sub prepare

{

    my $self = shift;

    my $statement = shift;

    #

    #   Remove new-lines from the statement

    #   Must not send new-lines to the application - they don't make it

    #

    $statement =~ s~\n~ ~g;

    #

    #   Remove leading and trailing whitespace

    #

    $statement =~ s~^\s*~~;

    $statement =~ s~\s*$~~;

    print "[DBI] Prepare: $statement\n" if $verbose;

    #

    #   Create a new object to represent the SQL statement being prepared

    #

    my $class = "DBI_Prepare";

    bless my $new_self = {

        CONNECTION => $self,

        STATEMENT => $statement,

        ROWS_READ   => 0,

        ROWS        => 0,

        FH          => undef,

        ERRSTR      => 'OK',

    } => ( $class );

    $self->{ECOUNT}++;

    return $new_self;

}

#-------------------------------------------------------------------------------

# Function        : disconnect

#

# Description     : Close the connection

#

# Inputs          : None

#

# Returns         : Nothing

#

sub disconnect

{

    my $self = shift;

    print "[DBI] Disconnect\n" if $verbose;

    if ( $self->{PID} )

    {

        #

        #   Send out a zero-length query

        #   This will cause the helper application to close the connection

        #

        my $fhw = $self->{FH_WRITE};

        print $fhw "\n\n\n";

        #

        #   Now read in data until the pipe breaks

        #

        my $fhr = $self->{FH_READ};

        while ( <$fhr> )

        {

            chomp;

            print "[DBI] Disconnect: $_\n" if $verbose;

        }

        close( $self->{FH_READ} );

        close( $self->{FH_WRITE} );

        $self->{FH_READ} = undef;

        $self->{FH_WRITE} = undef;

        #

        #   Kill the server task.

        #   It will hang around forever if we don't do this

        #

#        kill 9, $self->{PID};

        $self->{PID} = 0;

    }

    return 1;

}

#-------------------------------------------------------------------------------

# Function        : DESTROY

#

# Description     : Called when the object is destroyed

#

# Inputs          :

#

# Returns         :

#

sub DESTROY

{

    my $self = shift;

    $self->disconnect();

    $self->dumpSelf() if $verbose > 1;

    print "[DBI] Connection destroyed\n" if $verbose;

}

#==============================================================================

#   dumpSelf, debugging member to dump selfs hash

#==============================================================================

sub dumpSelf

{

    use Data::Dumper;

    my $self = shift;

    print Data::Dumper->Dump([$self], [ref($self)]);

}   # dumpSelf

#-------------------------------------------------------------------------------

#

#   A new package to encapulate the actual SQL operations

#

package DBI_Prepare;

#-------------------------------------------------------------------------------

# Function        : execute

#

# Description     : Execute the SQL statement

#

# Inputs          : A list of substitution arguments

#                   These will be repalced within the SELECT statement;

#

# Returns         : True: Execution was good

#

sub execute

{

    my $self = shift;

    my @args = @_;

    my @rows;

    my $statement = $self->{STATEMENT};

    #

    #   The users query may contain '?' characters

    #   These are replaced with arguments passed in to the 'execute'

    #

    if ( @args )

    {

        foreach my $arg ( @args )

        {

            $statement =~ s~\?~'$arg'~;

        }

    }

    #

    #   Write the select statement to the helper server task on the writer pipe

    #   The server will execute the task on our behalf and return the results

    #   on our reader handle

    #

    $self->{ERRSTR} = 'None';

    my $fhw = $self->{CONNECTION}{FH_WRITE};

    print $fhw "$statement\n";

    #

    #   Extract ALL the data from the link

    #   This will allow for nested calls

    #

    #   Assume that we have an error, until we see the start of data marker

    #

    $self->{ERROR} = 1;

    my $fhr = $self->{CONNECTION}{FH_READ};

    while ( <$fhr> )

    {

        chomp;

        if ( m/Data:(.*)/ )

        {

            push @rows, $1;

            print "[DBI] Execute: $_\n" if $verbose > 2;

        }

        else

        {

            print "[DBI] Execute: $_\n" if $verbose;

        }

        if ( m/^DataStart:/ )

        {

            $self->{ERROR} = 0;

        }

        if ( m/^DataEnd:/ )

        {

            last;

        }

        if ( m/^Warning:(.*?)\s*$/ )

        {

            $self->{ERROR} = 1;

            $self->{ERRSTR} = $1;

        }

    }

    $self->{ROWS} = \@rows;

    return ! $self->{ERROR};

}

#-------------------------------------------------------------------------------

# Function        : errstr

#

# Description     : Return the last execute error

#

# Inputs          : None

#

# Returns         : String

#

sub errstr

{

    my $self = shift;

    return $self->{ERRSTR};

}

#-------------------------------------------------------------------------------

# Function        : rows

#

# Description     : Return the number of rows extracted in the query

#

# Inputs          : None

#

# Returns         : -1, because we don't know

#

sub rows

{

    my $self = shift;

    my $row_count = 1 + $#{$self->{ROWS}};

    print "[DBI] Rows: $row_count\n" if $verbose > 1;

    return $row_count;

}

#-------------------------------------------------------------------------------

# Function        : fetchrow_array

#

# Description     : Return the next row of data

#

# Inputs          : None

#

# Returns         : The next row of data

#                   undef on end of data

#

sub fetchrow_array

{

    my $self = shift;

    my $rowref = $self->{ROWS};

    my $data = shift @$rowref;

    return () unless ( $data );

    $data =~ s~\s+$~~;

    my @row;

    foreach my $item ( split (',', $data ) )

    {

        push @row, pack( 'H*', $item);

    }

    print "[DBI] RawData: ". join(',', @row)."\n" if $verbose > 1;

#   print "[DBI] RawData: ". join(',', @row)."\n";

    $self->{ROWS_READ}++;

    return @row;

}

#-------------------------------------------------------------------------------

# Function        : finish

#

# Description     : Finish the 'execute'

#

# Inputs          : None

#

# Returns         : Nothing

#

sub finish

{

    my $self = shift;

}

#-------------------------------------------------------------------------------

# Function        : DESTROY

#

# Description     : Called when the object is destroyed

#

# Inputs          :

#

# Returns         :

#

sub DESTROY

{

    my $self = shift;

    $self->dumpSelf() if $verbose > 1;

    print "[DBI] Query destroyed\n" if $verbose;

}

#==============================================================================

#   dumpSelf, debugging member to dump selfs hash

#==============================================================================

sub dumpSelf

{

    use Data::Dumper;

    my $self = shift;

    print Data::Dumper->Dump([$self], [ref($self)]);

}   # dumpSelf

1;