# ============================================================================
#  DBPrinter
#
#  Intercepts output to tie()'ed filehandle and writes it to Oracle
#  UTL_FILE.FILE_TYPE filehandle.  Allows perl output to be redirected
#  from one server to another over a DB link.  Max length per write (line)
#  is 2000 chars.
#
#  Jeremy Hickerson, 4/13/2006
# ============================================================================

package DBPrinter;

use strict;

use DBI;

# ============================================================================
#                           Package level vars
# ============================================================================
my (%glb_prepared_sql, $sth_pls_write_DBfh, $DBH, $DB_fh, $Filedir, $Filename,

    $DB_linkname);

# Constants
my $SQL_CHAR             = 1;
my $SQL_NUMERIC          = 2;
my $SQL_DECIMAL          = 3;
my $SQL_INTEGER          = 4;
my $SQL_SMALLINT         = 5;
my $SQL_FLOAT            = 6;
my $SQL_REAL             = 7;
my $SQL_DOUBLE           = 8;
my $SQL_DATE             = 9;
my $SQL_TIME            = 10;
my $SQL_TIMESTAMP       = 11;
my $SQL_VARCHAR         = 12;
my $SQL_LONGVARCHAR     = -1;
my $SQL_BINARY          = -2;
my $SQL_VARBINARY       = -3;
my $SQL_LONGVARBINARY   = -4;
my $SQL_BIGINT          = -5;
my $SQL_TINYINT         = -6;
my $SQL_BIT             = -7;
my $SQL_WCHAR           = -8;
my $SQL_WVARCHAR        = -9;
my $SQL_WLONGVARCHAR   = -10;


# ============================================================================
#                             Constructor
# ============================================================================
sub new {

    my ($class, $self);

    ($class, $DBH, $Filedir, $Filename, $DB_linkname) = @_;


    if ($DB_linkname) { $DB_linkname = "\@$DB_linkname" }

    else { $DB_linkname = "" }

    open_DBfh();


    $self = { };

    bless($self, $class);

    return $self;
}


# ============================================================================
#                              Methods
# ============================================================================
sub print {

    my ($class, $data) = @_;


    # from Oracle's utl_file package:
    #
    # FILE_TYPE - File handle
    # 
    # TYPE file_type IS RECORD (id BINARY_INTEGER);
    # we can populate/save id field of outfile with a bind var


    # for performance we will only prepare repeated sql once
    if (exists $glb_prepared_sql{"sth_pls_write_DBfh"} ) {
	    $sth_pls_write_DBfh = $glb_prepared_sql{"sth_pls_write_DBfh"};
    }
    else {

	    $sth_pls_write_DBfh = $DBH->prepare( qq{

	    DECLARE
	        outfile          sys.UTL_FILE.FILE_TYPE$DB_linkname;

	    BEGIN

	        outfile.id := :DB_fh;

	        sys.utl_file.put$DB_linkname(outfile, :data);

	    END; } );

	    $sth_pls_write_DBfh->bind_param_inout(":DB_fh", \$DB_fh, $SQL_BINARY);

	    $glb_prepared_sql{"sth_pls_write_DBfh"} = $sth_pls_write_DBfh;
    }


    $sth_pls_write_DBfh->bind_param_inout(":data", \$data, $SQL_VARCHAR);

    $sth_pls_write_DBfh->execute();

}


sub open_DBfh {


    my $sth_pls_open_DBfh = $DBH->prepare( qq{

	DECLARE

	    outfile              sys.UTL_FILE.FILE_TYPE$DB_linkname;
	    MAX_LINESIZE         integer := 2000;

	BEGIN

	    outfile := sys.utl_file.fopen$DB_linkname(:Filedir, :Filename, 'w', MAX_LINESIZE);

	    :DB_fh  := outfile.id;

	END; } );

	$sth_pls_open_DBfh->bind_param_inout(":DB_fh",    \$DB_fh,    $SQL_BINARY);
	$sth_pls_open_DBfh->bind_param_inout(":Filename", \$Filename, $SQL_VARCHAR);
	$sth_pls_open_DBfh->bind_param_inout(":Filedir",  \$Filedir,  $SQL_VARCHAR);

	$sth_pls_open_DBfh->execute();

}


sub close_DBfh {

    my $sth_pls_close_DBfh = $DBH->prepare( qq{

	DECLARE
	    outfile              sys.UTL_FILE.FILE_TYPE$DB_linkname;

	BEGIN

	    outfile.id := :DB_fh;

	    sys.utl_file.fclose$DB_linkname(outfile);

	END; } );

    $sth_pls_close_DBfh->bind_param_inout(":DB_fh",    \$DB_fh,    $SQL_BINARY);

    $sth_pls_close_DBfh->execute();

}


# ============================================================================
#                                 Destructor
# ============================================================================

sub DESTROY {

    %glb_prepared_sql = ();

    close_DBfh();

}

1;