File Coverage

blib/lib/DBD/MVS_FTPSQL.pm

Criterion	Covered	Total	%
statement	20	262	7.6
branch	1	132	0.7
condition	0	24	0.0
subroutine	7	33	21.2
pod	0	1	0.0
total	28	452	6.1

# DBD::MVS_FTPSQL - DBD driver to query IBM DB2 mainframe databases through an FTP server.
#
# Copyright (c) 2007 Clemente Biondo
#
# You may distribute under the terms of either the GNU General Public
# License or the Artistic License, as specified in the Perl README file.

use warnings;
use strict;
#require 5.004;
require DBI;
use Net::FTP;
use IO::File;
use Carp qw(croak);

package DBD::MVS_FTPSQL;
our $VERSION = '0.38.14';

our $drh = undef; # Driver handle. Every thread has one (see CLONE method)

# Driver handle constructor
sub driver {
  return $drh if $drh; # If already created, return it
  my ($class, $attr) = @_;
  $class .= "::dr";

  return DBI::_new_drh($class, {
    'Name'        => 'MVS_FTPSQL',
    'Version'     => $VERSION,
    'Attribution' => 'DBD::MVS_FTPSQL by Clemente Biondo '.
                     ''
  });
}

#Ensure that two different ithreads don't' share the same driver object
sub CLONE {undef $drh;}

#End of DBD::MVS_FTPSQL
package DBD::MVS_FTPSQL::dr;

$DBD::MVS_FTPSQL::dr::imp_data_size = 0;

# Database handle constructor.
# Some database specific verifications, default settings and the like can
# go here.
sub connect {
  my ($drh, $dr_dsn, $username, $password, $attr) = @_;
  my $driver_prefix = "mvs_ftpsql_";

  #The dr_dsn string is in "ODBC" format name1=value1;...;nameN=valueN
  foreach my $var ( split /;/, $dr_dsn ) {
      my ($attr_name, $attr_value) = split '=', $var, 2;
      return $drh->set_err(1, "Can't parse DSN part '$var'")
          unless defined $attr_value;

      # add driver prefix to attribute name if it doesn't have it already
      $attr_name = $driver_prefix.$attr_name
          unless $attr_name =~ /^$driver_prefix/o;

      # Store attribute into %$attr, replacing any existing value.
      # The DBI will STORE() these into $dbh after we've connected
      $attr->{$attr_name} = $attr_value;
  }


  return $drh->set_err(1, "Error in the dns string: you must specify the ".
                          "mainframe hostname.")
           unless defined ($attr->{mvs_ftpsql_hostname});

  # Get the attributes we'll use to connect.
  # We use delete here because these no need to STORE them
  my $host    = delete $attr->{mvs_ftpsql_hostname};
  my $port    = delete $attr->{mvs_ftpsql_port}     || 21;
  my $timeout = delete $attr->{mvs_ftpsql_timeout}  || 120;
  my $remote_directory = delete $attr->{mvs_ftpsql_remote_directory}  || '';

  #Additional default attributes
  $attr->{mvs_ftpsql_remote_prefix} = 'FSQL'
    unless $attr->{mvs_ftpsql_remote_prefix};

  $attr->{mvs_ftpsql_ssid} = ''
    unless $attr->{mvs_ftpsql_ssid};
  my $debug = 0;
  my $conn =  Net::FTP->new(            $host
                            ,Port    => $port
                            ,Debug   => $debug
                            ,Timeout => $timeout
                            ,Passive => 1 )
 or return $drh->set_err(1,"Cannot establish an ftp connection to host ".
              "$host at port $port. Error received: $!");

  return $drh->set_err(1,"Login failed. Error received: ". $conn->message)
    unless ($conn->login($username,$password));

  unless ($remote_directory eq '') {
  	$remote_directory =~ s/^([^\/])/\/\/$1/;
  	return $drh->set_err(1,"Remote directory not accepted. Error received: ".
  	  $conn->message) unless ($conn->cwd($remote_directory));
  }

  my ($outer, $dbh) = DBI::_new_dbh($drh, { Name => $dr_dsn });
  #$dbh->STORE('Active', 1 );

  $dbh->{mvs_ftpsql_connection} = $conn;
  return $outer;
}

sub data_sources {return undef;}

sub disconnect_all {}

#End of DBD::MVS_FTPSQL::dr

package DBD::MVS_FTPSQL::db;

$DBD::MVS_FTPSQL::db::imp_data_size = 0;

#Todo:
# primary_key
# foreign_key_info

# The get_info function was automatically generated by
# DBI::DBD::Metadata::write_getinfo_pm v1.05.
sub get_info {
  my($dbh, $info_type) = @_;
  require DBD::MVS_FTPSQL::GetInfo;
  my $v = $DBD::MVS_FTPSQL::GetInfo::info{int($info_type)};
  $v = $v->($dbh) if ref $v eq 'CODE';
  return $v;
}

# The type_info_all function was automatically generated by
# DBI::DBD::Metadata::write_typeinfo_pm v1.05.
sub type_info_all {
  my ($dbh) = @_;
  require DBD::MVS_FTPSQL::TypeInfo;
  return [ @$DBD::MVS_FTPSQL::TypeInfo::type_info_all ];
}

#Note: blanks must become undef
sub column_info {
  my $dbh     = shift;
  my $catalog = shift; #not applicable so not used at all
  my $schema  = shift;
  my $table   = shift;
  my $column  = shift;
  my @where = ();

  foreach ( [\$schema,'TBCREATOR'],  [\$table,'TBNAME'],  [\$column,'NAME']) {
    if (defined(${$_->[0]}) && ${$_->[0]} ne '') {
      my $op = index(${$_->[0]},'%') < 0  ? '=' : 'LIKE';
      push(@where,$_->[1]." $op '".${$_->[0]}."'");
    }
  }

  my $where = (($#where >= 0) ?  'WHERE ' : '') . join (' AND ',@where);
  my $sth = $dbh->prepare(<
  select
     ''                      as TABLE_CAT
    ,TBCREATOR               as TABLE_SCHEM
    ,TBNAME                  as TABLE_NAME
    ,NAME                    as COLUMN_NAME
    ,''                      as DATA_TYPE
    ,COLTYPE                 as TYPE_NAME
    ,LENGTH                  as COLUMN_SIZE
    ,''                      as BUFFER_LENGTH
    ,LENGTH - SCALE          as DECIMAL_DIGITS
    ,''                      as NUM_PREC_RADIX
    ,case NULLS when 'N' then
     '0' else '1' end        as NULLABLE
    ,REMARKS                 as REMARKS
    ,DEFAULTVALUE            as COLUMN_DEF
    ,''                      as SQL_DATA_TYPE
    ,''                      as SQL_DATETIME_SUB
    ,''                      as CHAR_OCTET_LENGTH
    ,COLNO                   as ORDINAL_POSITION
    ,case NULLS when 'N' then
     'NO' else 'YES' end     as IS_NULLABLE
  from sysibm.syscolumns
  $where
  order by TBCREATOR,TBNAME,NAME,COLNO
  with ur
EOSQL
  $sth->execute() || Carp::croak ("Execute operation failed:$!");
  return $sth;
}

#Note: blanks must become undef
sub table_info {
  my $dbh     = shift;
  my $catalog = shift; #not applicable so not used at all
  my $schema  = shift;
  my $table   = shift;
  my $type    = shift;

  my %type2flag = (
    'ALIAS'                    => 'A'
   ,'GLOBAL TEMPORARY'         => 'G'
   ,'SYSTEM TABLE'             => 'T'
   ,'TABLE'                    => 'T'
   ,'VIEW'                     => 'V'
   ,'AUXILIARY TABLE'          => 'X'
   ,'MATERIALIZED QUERY TABLE' => 'M'
  );

  my $flag_table = $type2flag{$type};
  $flag_table    = '' unless(defined($type2flag{$type}));

  my @where = ();

  foreach ( [\$schema,'CREATOR'],  [\$table,'NAME'],  [\$flag_table,'TYPE']) {
    if (defined(${$_->[0]}) && ${$_->[0]} ne '') {
      my $op = index(${$_->[0]},'%') < 0  ? '=' : 'LIKE';
      push(@where,$_->[1]." $op '".${$_->[0]}."'");
    }
  }

  my $where = (($#where >= 0) ?  'WHERE ' : '') . join (' AND ',@where);

  #There is no need of escaping because only the first sql instruction can be
  #executed and this driver alllows only selects.
  # create a "blank" statement handle
  my $sth = $dbh->prepare(<
SELECT
  ''   AS TABLE_CAT
 ,NAME as TABLE_NAME
 ,CREATOR as TABLE_SCHEM
 ,case when type = 'A'                         then 'ALIAS'
       when type = 'G'                         then 'GLOBAL TEMPORARY'
       when type = 'T' and name like 'SYS'     then 'SYSTEM TABLE'
       when type = 'T' and name not like 'SYS' then 'TABLE'
       when type = 'V'                         then 'VIEW'
       when type = 'X'                         then 'AUXILIARY TABLE'
       when type = 'M'                         then 'MATERIALIZED QUERY TABLE'
       else 'UNKNOWN' END AS TABLE_TYPE
 ,REMARKS
FROM SYSIBM.SYSTABLES
$where
WITH UR
EOSQL
  $sth->execute() || Carp::croak ("Execute operation failed:$!");
  return $sth;
}

sub ping {
  my $dbh = shift;
   if ($dbh->FETCH('Active')) {
     my $warnmsg = "";
     {
       local $SIG{__WARN__} = sub {$warnmsg=shift;};
     	$dbh->{mvs_ftpsql_connection}->quot('noop');
     }
     $dbh->disconnect() unless $warnmsg eq "";
     #Todo: warnmsg needs to be returned to the user?
  }
  return $dbh->FETCH('Active');
}

sub prepare {
    my ($dbh, $statement, @attribs) = @_;
    return $drh->set_err(1, 'Statement preparation failed: '.
      'There is no active database connection.')
      unless $dbh->FETCH('Active');
    return $drh->set_err(1, 'Statement preparation failed: '.
                 'The sql statement is empty.') unless length($statement);

    # workaround for a peculiarity of the ftp server: if CR/LF is present
    # the preceding character will be removed (the string will be chopped)
    $statement =~ s/\r|\n/ /g;
    # create a 'blank' sth
    my ($outer, $sth) = DBI::_new_sth($dbh, {
    	 Statement     => $statement
    	});

    # Todo: improve the placeholder management
    $sth->STORE('NUM_OF_PARAMS', ($statement =~ tr/?//));
    $sth->{mvs_ftpsql_params} = [];

    return $outer;
}

sub commit {
  my ($dbh) = @_;
  if ($dbh->FETCH('Warn')) {
      warn("Commit ineffective while AutoCommit is on");
  }
  0;
}

sub rollback {
  my ($dbh) = @_;
  if ($dbh->FETCH('Warn')) {
      warn("Rollback ineffective while AutoCommit is on");
  }
  0;
}

sub STORE {
  my ($dbh, $attr, $val) = @_;
  if ($attr eq 'AutoCommit') {
    if (!$val) { die "Can't disable AutoCommit"; }
    return 1;
  }
  if ($attr eq 'ChopBlanks') {
    if (!$val) { die "Can't set ChopBlanks to false"; }
    return 1;
  }
  if ($attr eq 'Active') {
    die "Can't change the read-only connection status attribute 'Active'";
    return 1;
  }
  if ($attr =~ m/^mvs_ftpsql_/) {
    $dbh->{$attr} = $val;
    return 1;
  }
  $dbh->SUPER::STORE($attr, $val);
}

sub FETCH {
    my ($dbh, $attr) = @_;
    if ($attr eq 'AutoCommit') { return 1; }
    if ($attr eq 'ChopBlanks') { return 1; }
    if ($attr eq 'Active') {
         return    defined($dbh->{mvs_ftpsql_connection})
                && defined($dbh->{mvs_ftpsql_connection}->connected());
    }
    if ($attr =~ m/^mvs_ftpsql_/) {
        return $dbh->{$attr};
    }

#  defined($conn->connected());

    $dbh->SUPER::FETCH($attr);
}

sub disconnect () {
  my $dbh = shift;
  $dbh->{mvs_ftpsql_connection}->quit() if $dbh->FETCH('Active');
  #$dbh->STORE('Active',0);
  return 1;
}

sub DESTROY ($) {
  my $dbh = shift;
  #Take care of DBI handle 0x....... cleared whilst still active error.
  $dbh->disconnect();
}

#End of DBD::MVS_FTPSQL::db

package DBD::MVS_FTPSQL::st;

$DBD::MVS_FTPSQL::st::imp_data_size = 0;

#Attributes Implemented
#NUM_OF_FIELDS (integer, read-only)
#NAME (array-ref, read-only)
#NAME_lc (array-ref, read-only)
#NAME_uc (array-ref, read-only)
#NAME_hash (hash-ref, read-only)
#NAME_lc_hash (hash-ref, read-only)
#NAME_uc_hash (hash-ref, read-only)
#Statement (string, read-only)
#Database (dbh, read-only)
#Attributes not Implemented (todo)
#TYPE (array-ref, read-only)
#PRECISION (array-ref, read-only)
#SCALE (array-ref, read-only)
#NULLABLE (array-ref, read-only)
#CursorName (string, read-only)
#ParamValues (hash ref, read-only)
#ParamArrays (hash ref, read-only)
#ParamTypes (hash ref, read-only)
#RowsInCache (integer, read-only)

sub STORE {
  my ($sth, $attr, $val) = @_;
    if ($attr =~ m/^mvs_ftpsql_/) {
        $sth->{$attr} = $val;
        return 1;
    }
    $sth->SUPER::STORE($attr, $val);
}

sub FETCH {
    my ($sth, $attr) = @_;
    if ($attr =~ m/^mvs_ftpsql_/) {
        return $sth->{$attr};
    }
    $sth->SUPER::FETCH($attr);
}

#Taken (like other pieces of code) from DBI guide
sub bind_param {
  my ($sth, $pNum, $val, $attr) = @_;
  my $type = (ref $attr) ? $attr->{TYPE} : $attr;
  if ($type) {
      my $dbh = $sth->{Database};
      #mhm seems a bug in the manual?
      #$val = $dbh->quote($sth, $type);
      $val = $dbh->quote($val, $type);
  }
  my $params = $sth->{mvs_ftpsql_params};
  $params->[$pNum-1] = $val;
  1;
}

sub execute {
  my ($sth, @bind_values) = @_;

  # start of by finishing any previous execution if still active
  $sth->finish if $sth->FETCH('Active');
  my $params = (@bind_values) ?
      \@bind_values : $sth->{mvs_ftpsql_params};

  my $numParam = $sth->FETCH('NUM_OF_PARAMS');
  return $sth->set_err(1, "Wrong number of parameters")
      if @$params != $numParam;

  my $statement = $sth->{'Statement'};

  #Todo: the bind mechanism needs to be improved
  for (my $i = 0;  $i < $numParam;  $i++) {
      $statement =~ s/\?/$params->[$i]/;
  }

  #very dirty error handling technique, but eval {} if(@$) seems to clutter
  #(maybe my mistake) with $drh->set_err (todo: dig into the problem)
  my ($error_code,$error_message,$error_state) = (1,"",0);
  my $dbh = $sth->{Database};
  my $fh = mvs_ftpsql_execute(
     $dbh->{'mvs_ftpsql_connection'}
    ,$dbh->{'mvs_ftpsql_ssid'}
    ,$dbh->{'mvs_ftpsql_remote_prefix'}
    ,$statement
    ,\$error_message
    ,\$error_state
    ,\$error_code
  ) or return $sth->set_err($error_code, $error_message,$error_state);

  # Notice that this driver processes only SELECT statement (a protocol
  # limitation imposed by design), so $fh is ever a file handle to the
  # output of a query.
  #print while(<$fh>);exit;
  my $header = <$fh>;

  #\x00 was placed as a workaround for a strange behaviour with some tables
  $header =~ s/\x00| |\r|\n//g;
  my @header = split(/\t/,$header);
  #print $header[0];exit;
  unless (exists($sth->{'NAME'})) {
    $sth->STORE('NUM_OF_FIELDS' => $#header +1);
    $sth->{'NAME'}              = \@header;
  }

  $sth->{'mvs_ftpsql_data'} = $fh;

  #Row counting
  my $rowcount = 0;
  my $pos = $fh->getpos();
  $rowcount++ while(<$fh>);
  $fh->setpos($pos);
  $sth->{'mvs_ftpsql_rows'} = $rowcount;

  $sth->{Active} = 1;
  return ($rowcount ? $rowcount : '0E0');
}

sub fetchrow_arrayref {
  my ($sth) = @_;
  my $fh = $sth->{mvs_ftpsql_data};
  unless ($fh) {
      $sth->STORE(Active => 0);
      return undef;
  }
  my $tmp = <$fh>;
  unless ($tmp) {
      $sth->STORE(Active => 0);
      return undef;
  }

  #Text fields are right padded, numbers are left padded.
  #The field is at least long as his label.
  #This is the reason we can't disable ChopBlanks
  $tmp =~ s/\r|\n//g;
  $tmp =~ s/ +\t/\t/g;
  $tmp =~ s/ +$//g;

  my @fields = split(/\t/,$tmp,-1);
  if (($sth->FETCH('NUM_OF_FIELDS')) < ($#fields+1) ) {
    $fh->close();
    $sth->SUPER::finish();
    #Todo: give more info in the pod and propose as solution
    #TRANSLATE (A, ' ', x'05') (lo horizontal tab (HT) \x09 in EBCDIC diventa \x05)
    Carp::croak (
      "Fetch failed: Horizontal tab found. One or more character columns in the resultset ".
      "contain tabs characters ('\\x09').\nAlthough not an error, due to ".
      "limitations imposed by the ftp/sql feature this driver can't ".
      "manage those values.\nSee the documentation to learn how to work ".
      "around this issue."
    );
  }
  return $sth->_set_fbav(\@fields);
}

*fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref

sub rows { shift->{mvs_ftpsql_rows}; }

sub DESTROY {
  my $sth = shift;
  $sth->finish if $sth->FETCH('Active');
}

sub finish {
  my $sth = shift;
  $sth->{mvs_ftpsql_data}->close();
  $sth->SUPER::finish();
}

sub mvs_ftpsql_execute {
  my $ftp_conn                   = shift;
  my $db2subsys                  = shift;
  my $remote_sql_filename_prefix = shift;
  my $sql                        = shift;
  my $error_message              = shift;
  my $error_state                = shift;
  my $error_code                 = shift;
  my $qlen = length($sql);

  #datasets allocated with RETPD > 0 can't be deleted
  $ftp_conn->quot("site FILE=SEQ LR=$qlen BLOCKSI=$qlen REC=F RET=0");

  #Query upload
  my $fh = IO::File->new_tmpfile()
    or Carp::croak("Cannot create temporary storage for the sql statement:$!");
  $fh->seek(0,0) || Carp::croak ("Seek operation failed:$!");
  print $fh $sql;
  $fh->flush() || Carp::croak ("Flush operation failed:$!");
  $fh->seek(0,0) || Carp::croak ("Seek operation failed:$!");
  $ftp_conn->put_unique($fh,$remote_sql_filename_prefix.'0001');

  #Workaround:the current implementation of Net::FTP::put_unique do not
  #returns the filename. The error lie in the regexp at line 72 of
  #Net/FTP/dataconn.pm
  my $filename = $1
    if $ftp_conn->message() =~
      /($remote_sql_filename_prefix\d{4}) \(unique name\)/
        or Carp::croak ("Cannot determine the remote sql filename.");
  $ftp_conn->quot ('SITE NOTRAIL FILE=SQL DB2='.$db2subsys.' SPR LR=32000 REC=F '.
                   'SQLC=N BLOCKSI=32000');
  $fh->truncate(0) || Carp::croak ("Truncate operation failed:$!");
  #Error handling
  #"551 Transfer aborted: SQL PREPARE/DESCRIBE failure" -> sql syntax error
  #"551 Transfer aborted: SQL not available.  Attempt to open plan EZAFTPMQ"
  #"554 Transfer aborted: unsupported SQL statement" -> only selects
  #"551 Transfer aborted: attempt to connect to DB2  failed" -> subsystem error
  #MVS was unable to locate a DB2 subsystem with the specified name

  my $warnmsg = "";
  my $transfer_msg="";
  {
    local $SIG{__WARN__} = sub {$warnmsg=shift;};
    $ftp_conn->get ($filename,$fh);
    $transfer_msg = $ftp_conn->message();
  }
  $ftp_conn->quot ('SITE FILETYPE=SEQ');
  $ftp_conn->delete($filename);
  if ($transfer_msg =~ /Transfer aborted: SQL PREPARE\/DESCRIBE failure/) {
    $fh->flush()   || Carp::croak ("Flush operation failed:$!");
    $fh->seek(0,0) ||Carp::croak ("Seek operation failed:$!");

    $$error_message = "The SQL statement is invalid:\n". do {local $/; <$fh>} ."\n";

    #Workaround for a problem with filehandles and set_err
    #Forces a copy of the content of the file.
    #Without the following line the content of the error message is not reported.
    $$error_message = sprintf ('%s',$$error_message);
    $$error_state = $1 if ($$error_message =~ /SQLSTATE\s+=\s+(\d+)/);
    $$error_code  = $1 if ($$error_message =~ /SQLCODE\s+=\s+([\-0-9]+)/);

    #print "$$error_state";
    #exit;

  } elsif($transfer_msg =~ /Transfer aborted: (.*)/) {
  	$$error_message = $1;
  	$$error_code = '-30080';
  	$$error_state = '08001'
  } elsif ($warnmsg ne "") {
  	$$error_message = $warnmsg;
  	$$error_code = '-30080';
  	$$error_state = '08001'
  } else {
    $fh->seek(0,0) || Carp::croak ("Seek operation failed:$!");
    return $fh;
  }
  $fh->flush()   || Carp::croak ("Flush operation failed:$!");
  $fh->close();
  undef ($fh);
  return undef;
}

#End of DBD::MVS_FTPSQL::st

1;

__END__