dbSession.pm

package dbSession;
# -*- perl -*-
use strict;
use MIME::Base64;
use POSIX;

=head1 NAME

dbSession - a DBI wrapper with various db helpers and utils

=cut

=head1 SYNOPSIS

  use dbSession;

  #constructors:

  my $ds = dbSession->new($db_locator [, $authfile]);
  my $ds = dbSession->new([$server[:$port], $user, $pass, $server_type]);  

  #direct connection:
  my $ds = dbSession->postgres($server, $user, $password, $db);
  my $ds = dbSession->oracle($server, $user, $password, $db);
  my $ds = dbSession->sybase($server, $user, $password, $db);
  my $ds = dbSession->mysql($serverhost, $user, $password, $db);

  # methods:
  my $dbh  = $ds->dbh(); # get DBI's database handle
  my $res  = $ds->do($sql); #non-query SQL execution
  my $sth  = $ds->prep($sql);    #prepare SQL for execution
  my $sth  = $ds->prepare($sql); # ditto
  my $sth  = $ds->exec($sql, ...); #prepare and execute an SQL
  my $sth  = $ds->exec($sth, ...); #execute a previously prepared $sth
  my $aref = $ds->fetch($sth); #fetches next row as an array ref  
  my $aref = $ds->fetch(); # fetches next row for the most recent $sth 
                           # (generated by the last prep() or exec())
  my @rowvalues  = $db->getval($sql); #returns a single row (the first)
  my $fieldvalue = $db->getval($sql); #in scalar context returns the first field
  

=head1 DESCRIPTION

A wrapper module for DBI, with various helper subroutines

=cut

use Exporter;
use DBI;
our ($VERSION, @ISA, @EXPORT);
@ISA = qw(Exporter);
@EXPORT = qw( initLog restoreSTD resumeLog flog
 db_perm scrypt sdecrypt db_srvtype db_login db_logout db_lastlogin
 onErrExit trim cur_status ask_pass ask_cpass getDate
 sql_do sql_exec sql_prepare sth_exec sth_fetch sth_afetch 
 sql_get_value sql_get_values sql_get_all syb_dboalias
 confirm nice_int nice_intm sql_quote sql_dquote
 print_sql print_sql_fetch sql_to_file ErrExit
 fmt_fasta print_fasta sql2fasta sql2fasta_CLR fetch2fasta
 sub sql_cmdfile sql_execlist batchsql_to_file 
 syb_getIndexes syb_putIndexes);

#-- package variables (static):
#-- these will be overriden by the [Default] section of ~/.db_pass 
#   or the authentication file, or whatever extra info the user 
#   provides in the locator string
# if no .db_pass or other authentication file/data is given,
# these defaults MUST BE edited apropriately for local compliance 
# before installing the module
# Example, for sybase:
#  our $DBDEF_SRV_TYPE='sybase';
#  our $DBDEF_SERVER = $ENV{'DSQUERY'} || 'SYBEST';
#  our $DBDEF_USER='access';
#  our $DBDEF_PASS='access';

our $DBDEF_SRV_TYPE='mysql';
our $DBDEF_SERVER = 'localhost';
# this is the host name, and it may include ":<port#>"
our $DBDEF_USER='access';
our $DBDEF_PASS='access';

our $dbExitSub=\&dbErrExit;
our $dbLastError='';

our $DEF_FASTA_LINELEN=60;

#--procedural interface helpers:

our %dbhs; # dbh -> [valid, server[:port], user, pass, initdb, servertype]
our $db_last_dbh;

our ($file_log, $stdout_log, $stderr_log);
local *__OLDERR;
local *__OLDSTD;

#-- we could test for CGI environment e.g.:
# unless ($ENV{HTTP_ACCEPT} || $ENV{HTTP_HOST}) { ... }
#-- to avoid ~/.db_pass parsing and instead just use the DBDEF_* values above

return 1;

=head1 GLOBAL (non-OO) SUBROUTINES

----------------------------------------------------------------

=cut

=head2 initLog(<logfilename> [, <STDOUT_redirect_file>, <STDERR_redirect_file>])

 Initializes the logging system. Subsequent flog() calls will write
 into <logfilename> Beware that <logfilename>, if exists, is deleted
 and then created again at each initLog() call.
 
 May optionally redirect STDOUT and/or STDERR to the provided log
 file(s)

=cut

sub initLog {
 ($file_log, $stdout_log, $stderr_log) = @_;
 return unless ($file_log);
 unlink($file_log);
 #also saves STDOUT, STDERR;
 open(__OLDOUT, ">&STDOUT") if $stdout_log;
 open(__OLDERR, ">&STDERR") if $stderr_log;

 if ($stdout_log) {
    open(STDOUT, ">$stdout_log") 
       || &$dbExitSub("Cannot redirect STDOUT to file $stdout_log");
    }
 if ($stderr_log) {
    if ($stderr_log eq $stdout_log) {
        open(STDERR, ">&STDOUT");
        }
     else {   
       open(STDERR, ">$stderr_log") 
         || &$dbExitSub("Cannot redirect STDERR to file $stderr_log");
       }
    }
}


=head2 restoreSTD( )

 Restores the STDERR and STDOUT if they were previously redirected by initLog() 
 
=cut


sub restoreSTD {
 return unless ($file_log);
 close STDERR if ($stderr_log);
 close STDOUT if ($stdout_log);
 open(STDOUT, ">&__OLDOUT");
 open(STDERR, ">&__OLDERR");
}

sub resumeLog {
 if ($stdout_log) {
    open(STDOUT, ">>$stdout_log") 
       || &$dbExitSub("Cannot redirect STDOUT to file $stdout_log");
    }
 if ($stderr_log) {
    if ($stderr_log eq $stdout_log) {
        open(STDERR, ">&STDOUT");
        }
     else {   
       open(STDERR, ">>$stderr_log") 
         || &$dbExitSub("Cannot redirect STDERR to file $stderr_log");
       }
    }
}


=head2 flog(<text>..)

 The given text lines are written to STDERR and to the log file if such
 was established by initLog()

=cut

sub flog {
 if ($file_log) {
   local *LOG_FILE;
   open(LOG_FILE, ">>$file_log");
    print LOG_FILE join("\n",@_)."\n";
    print __OLDERR join("\n",@_)."\n";
    #print STDERR join("\n",@_)."\n";
   close LOG_FILE;
  }
else {
  print STDERR join("\n",@_)."\n";
  }
}

sub db_askpass {
   my ($server, $srvtype, $user, $db)=@_;
   $user=$ENV{'USER'} unless $user;
   $user=$ENV{'USERNAME'} unless $user;
   $server=$DBDEF_SERVER unless $server;
   $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
   # script instructed to ask for password always
   my $pass=&ask_pass("Enter password for user '$user' on server '$server',\n  database $db");
   return ($server, $user, $pass, $db, $srvtype);
   }

=head2 db_perm(<db> [,<auth_file>] [, 'ASK'])
 
  returns: (server_name, user, pass, db, server_type, server_port)
  
  (if server_port is returned non-zero, then server_name is actually a hostname and 
   server_port is optional)

  if no <auth_file> is specified, ~/.db_pass is read.
  
  Parses <auth_file> looking for server and user authentication data
  necessary for initiating a connection to the database $db,  (using
  the current Unix user as the username, unless :<user> is included in
  $db)

  $db parameter can also have a more complex locator format:
  
     <dbschema>[@<server>[/<server_type>]][:<user>]
     
    ..where <server_type> can be 'postgres', 'oracle', 'sybase' or 'mysql'. 
    None of <server>,<user>,<server_type> are necessary except to avoid 
    ambiguity when multiple servers with the same name (but different DBMS)
    exist in <auth_file>

  If a server name is not found for the current <dbname>, the [Default]
  section  is looked-up in <auth_file>; if that section is missing,
  hardcoded defaults are used instead.
  
  If the 3rd parameter of this function is the string 'ASK', db_perm will 
  stop and ask for the specified user's password interactively.
  
  The <auth_file> contains the encrypted passwords just for very basic 
  visual protection (use dbpass utility to update the passwords; see 
  the subroutines scrypt and sdecrypt in this module)


 ----------------------------------------
 [Default]
 server_type=oracle
 server=BIOCOMPD

 [BIOCOMPD]
 db1, db2, db3, ...

 [MYSERVER/oracle@orclhost.dfci.harvard.edu:3139]
 db1_1, db1_2, db1_3, ...

 [MYSERVER/mysql@tools.dfci.harvard.edu]
 db1_1, db1_2, db1_3, ...

 [MYSQLSRV/mysql@mysqlhost:port]
 db2_1, db2_2, db2_3, ...

 [Authentication]
 BIOCOMPD:username/encpassword
 MYSERVER/oracle:username/encpassword
 MYSERVER/mysql:username/encpassword
 MYSQLSRV:username/encpassword
 -----------------------------------------

The server name can be optionally followed by '/<srv_type>' 
and/or '@<host>' (optionally ':<port>'), otherwise Default values 
are assumed.

 If server names are uniquely assigned and the DBD driver has a mechanism
of resolving the host name based on the server name (e.g. like Oracle does by
using environment variables like TNS_ADMIN, TWO_TASK, etc.), a ~/db_pass file
can be as simple as this:
 ---------------------------------
 [Default] 
 server_type=oracle

 [BIOCOMPD] 
 db1, db2, db3...

 [Authentication] 
 BIOCOMPD:username:encpassword
 ------------------------------------
 
IMPORTANT: the [Authentication] section MUST be the last section in the
file, while [Default] section MUST be the first (to speed up parsing).

=cut

sub db_perm {
 my ($dblocator, $authfile, $flag)=@_;
 $authfile='' unless defined($authfile);
 $flag=$authfile if $authfile =~ '/\bASK\b/i' && !defined($flag);
 my $db_err="Error at db_perm('$dblocator', '$authfile'):";
 my $db_advice="(You should probably use dbpass to update $authfile)\n";
 if ($authfile) {
   open(TESTF, $authfile) ||
      die("$db_err Cannot open $authfile!\n");
   close(TESTF);
   }
  else { $authfile= $ENV{HOME}.'/.db_pass' }
 #--------- to return:
 my ($db, $server, $user, $pass, $srvtype, $srvport); 
 #only mysql returns $server as a hostname and also a $srvport
 my $srvhost; #only needed for mysql, to be returned instead of $server
 
  #  $dblocator format can be <dbname>[@<server>[/<server_type>]][:<user>]
 
 ($db, my $rest) = ($dblocator=~m/^([#\"\-\.\w]+)(.*)/);
 die "$db_err Cannot parse locator '$dblocator'!\n"
   unless $db;
 if ($rest) { # in here we can have server, server_type and/or user
  $rest=~tr/ //d;
  my @d=($rest=~m/([\:\@\/])(\w+)/g);
  my ($sep, $word);
  foreach (@d) {
   if ($sep) { $word=$_; 
     #--do stuff with $sep, $word
      if    ($sep eq ':') { $user=$word }
      elsif ($sep eq '@') { $server=$word }
      elsif ($sep eq '/') { $srvtype=$word }
     #--
     undef($sep); #re-init next pair
     }
    else { $sep=$_; }
   } #foreach
  } # additional locator info provided
 if ($server && $user && ($user eq $DBDEF_USER)) {
   $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
   my ($shost,$port)=split(/:/,$server);
   if (defined($port) && $port>0) { $srvport=$port; $server=$shost; }
   return ($server, $user, $DBDEF_PASS, $db, $srvtype, $srvport);
   }
   
 if (defined($flag) && $flag =~/ALWAYS/i) { 
   return (db_askpass($server, $srvtype, $user, $db));
   }
 my $askflag=($flag=~/\bASK\b/i) if defined($flag);
 local *AUTHFILE;
 unless (open(AUTHFILE, $authfile)) {
    if ($askflag) {
      return (&db_askpass($server, $srvtype, $user, $db));
      }
    $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
    $srvtype=lc($srvtype);
    $server=$DBDEF_SERVER unless ($server);
    my ($shost,$port)=split(/:/,$server);
    if ($port>0) { $srvport=$port; $server=$shost; }
    $user=$DBDEF_USER;
    $pass=$DBDEF_PASS;
    return ($server, $user, $pass, $db, $srvtype, $srvport);
    }
 #locate the server for this database 
 local $/="\n";
 my $auth_section='Authentication'; 
 my $def_section='Default';
 my $def_srvtype=$DBDEF_SRV_TYPE;
 my $def_server=$DBDEF_SERVER; 
 my ($section, $section_srvtype, $section_srvhost, $section_srvport); #current section
 my %srvauth; #  serverID:user => encpass
 local $_; 
 while (<AUTHFILE>) {
   s/\s+$//;s/^\s+//;
   next unless $_;   
   next if m/^\s*#/;
   if (m/^\s*\[\s*(\w+)(.*?)\]/) { #[section] line
      ($section, my $section_attr)=($1,$2);
      if ($section_attr) {
          my @d=($section_attr=~m/([\:\@\/])([\.\w]+)/g);
          my ($sep, $word);
          foreach (@d) {
            if ($sep) { $word=$_; 
              #--do stuff with $sep, $word
               if    ($sep eq '@') { $section_srvhost=$word }
               elsif ($sep eq '/') { $section_srvtype=$word }
               elsif ($sep eq ':') { $section_srvport=$word }
              #--
              undef($sep); #re-init next pair
              }
             else { $sep=$_; }
            } #foreach
          if ($server eq $section) {
            $srvtype=$section_srvtype unless $srvtype;
            $srvport=$section_srvport unless $srvport;
            $srvhost=$section_srvhost unless $srvhost;
            }
          }
      next;
      }
   #not a "[section]" line
   s/[\n\r]+$//s;
   if ($section ne $auth_section) {
      tr/ //d;
      next if ($server && $srvtype);
      if ($section eq $def_section) { # [Default] section?
          my ($var, $value)=split(/=/);
          $var=lc($var);
          if ($value) {
            if    ($var eq 'server')      { $def_server = uc($value) }
            elsif ($var eq 'server_type') { $def_srvtype = lc($value); 
                                            }
            }#if value
          next;
          } #[Default] section parsing
      #--
      next if $server; #we have the server, no need to search for it
      #[server] section line -- parse the databases
      my @dbs=split(/[\s\,\;]+/);
      foreach my $sdb (@dbs) {
        if ($sdb eq $db) {
           $server=$section;
           $srvhost=$section_srvhost;
           $srvtype=$section_srvtype;
           $srvport=$section_srvport;
           }
        }
      } #not an auth line
     else { #line in authentication section
      my ($asrv, $auserpass)=split(/:/,$_,2);
      next unless $auserpass;
      my ($auser, $apass)=split(/\//, $auserpass, 2);
      next unless $apass;
      my ($srv, $stype)=split(/\//,$asrv);
      $asrv = $stype ? uc($srv).'/'.lc($stype) : uc($asrv);
      my $skey=$asrv.':'.$auser;
      $srvauth{$skey}=[$apass] unless exists($srvauth{$skey});
      # alternate (fall-back) authentication:
      $srvauth{$asrv}=[$auser, $apass];
      if ($stype) { #server type was provided
        $skey=$srv.':'.$auser;
        $srvauth{$skey}=[$apass, $stype] unless exists($srvauth{$skey});
        #alternate (fall-back) authentication:
        $srvauth{$srv}=[$auser, $apass, $stype];
        }
      }
  } # --- while <AUTHFILE>
 close(AUTHFILE);
 #--
 unless ($server) {
  $server=$def_server;
  my ($shost,$port)=split(/:/,$server);
  if ($port>0) { $srvport=$port; $srvhost=$shost; }
  }

 #$srvtype=$def_srvtype unless $srvtype;
 $server=uc($server);
 $srvtype=lc($srvtype);

 #========> now retrieve the password for this db@server [ / srv_type ] 
 #========  and if the $user was given, try to retrieve the password
 #                                      for that $user and that $server.. 
 #          otherwise fall back to $DBDEF_USER/PASS
 #VVVVVVVVVVVVVVVVVVVVVVVVVVVV
 #$user=$ENV{'USER'} unless $user;
 my $srvkey = $server;
 #my $srvname= $server;
 $server=$srvhost if $srvhost;
 my ($encpass, $auth_srvtype);
 if ($user) {
   my $authd=$srvauth{$srvkey.':'.$user};
   $authd=$srvauth{$srvkey.'/'.$srvtype.':'.$user} unless $authd;
   $authd=$srvauth{$server.':'.$user} unless $authd;
   ($encpass, $auth_srvtype)=@$authd if $authd;
 }
 $srvtype=$auth_srvtype if $auth_srvtype;
 unless ($encpass) {
   if ($askflag && $user) {
      return (&db_askpass($server, $srvtype, $user, $db));
    }
    #look for any other authentication for this server:
    my $alternate=$srvauth{$srvkey};
    $alternate=$srvauth{$server} unless $alternate;
    if ($alternate) {
        ($user, $pass)=($$alternate[0], &sdecrypt($$alternate[1],$srvkey));
        $srvtype=$$alternate[2] unless $srvtype;
        #warn("..Found and returned user '$user' authentication instead.\n");
    }
    else {
        warn("..Returning default user ($DBDEF_USER) authentication instead.\n");
        ($user, $pass)=($DBDEF_USER, $DBDEF_PASS);
    }
    $srvtype=$def_srvtype unless $srvtype;
    return ($server, $user, $pass, $db, $srvtype, $srvport);
 }
 #else return the authentication data found
 $srvtype=$def_srvtype unless $srvtype;
 print STDERR "found server $server of type $srvtype, user $user, pass $encpass\n";
 return ($server, $user, &sdecrypt($encpass, $srvkey), $db, $srvtype, $srvport);
}

#=======================================================================
# simple encryption/decryption routine, only offering a very basic 
# "protection" against quick naked eye inspection..
#=======================================================================

sub xor_encode {
 my ($str, $key) = @_;
 $key=lc($key);
 $str=reverse($str);
 my $enc_str = '';
 for my $char (split //, $str){
        my $decode = chop $key;
        $enc_str .= chr(ord($char) ^ ord($decode));
        $key = $decode . $key;
    }
 return $enc_str;
}

sub __xor_encode {
 my ($str, $key) = @_;
 $key=lc($key);
 $str=reverse($str);
 my $enc_str = '';
 for my $char (split //, $str){
     my $decode = chop $key;
     $enc_str .= chr(ord($char) ^ ord($decode));
     $key = $decode . $key;
 }
 return $enc_str;
}

sub scrypt {
 my ($pass, $key)=@_;
 return encode_base64(xor_encode($pass, $key));
 #$seed=lc($seed);
 #$pass=reverse($pass).reverse(substr($seed,0,4));
 #my $mask = substr($seed  x (length($pass)/length($_[0]) + 1), 0, length($pass));
 #$mask &= (chr(15) x length($mask));
 #return ($pass ^ $mask);
}

sub sdecrypt {
 my ($crpass, $key)=@_;
 my $s=decode_base64($crpass);
 my $decoded=xor_encode(scalar(reverse($s)), $key);
 return scalar(reverse($decoded));
 #$seed=lc($seed);
 #my $mask = substr($seed  x (length($crpass)/length($_[0]) + 1), 0, length($crpass));
 #$mask &= (chr(15) x length($mask));
 #my $pass = ($crpass ^ $mask);
 #$pass=substr($pass, 0,length($pass)-length(substr($seed,0,4)));
 #return scalar(reverse($pass));
}

sub syb_MsgHandler {
    my($err, $sev, $state, $line, $server,
      $proc, $msg, $sql, $err_type) = @_;
    my @msg = ();
    if($err_type eq 'server') {
       return 0 if !$err; #this will obliterate useless warning messages
       push @msg,
         (sprintf('Server Message# %ld, Severity %ld, State %ld, Line %ld',
                  $err,$sev,$state,$line),
          (defined($server) ? "Server '$server' " : '') .
          (defined($proc) ? "Procedure '$proc'" : ''),
          "Message text: '$msg'");
    } else {
       push @msg,
         (sprintf('Open Client SEVERITY = (%ld) NUMBER = (%ld)',
                  $sev, $err),
          "Message text: $msg");
    }
    print STDERR join("\n",@msg)."\n";
    return 1;
}


#just a fancier exit to be used for fatal errors
#the first string is printed at STDOUT
#the second, if provided, is sent to STDERR
sub dbErrExit {
 $dbLastError="@_\n";
 print STDERR $_[0]."\n";
 exit(1) unless defined($_[1]);
 die "$_[1]\n";
 }

sub onErrExit {
 $dbExitSub=$_[0];
}



=head2 trim(<strings>...) 

 "in place" trimming of all spaces around each string given as a parameter
 The trimmed strings are also returned as a list.

=cut

#--remove spaces at both ends of strings;
sub trim {
  foreach (@_) {
    s/^\s+//; s/\s+$//;
    }
  return @_;
}

=head2 cur_status(<text_lines>..)

 Simply creates a file called 'current_status' in the current directory
 with the <text_lines> written in it.
 
=cut

sub cur_status {
 local *S_FILE;
 open(S_FILE, '>current_status');
 print S_FILE join("\n",@_);
 close S_FILE;
}


#===============================================
#ask_pass([user_prompt]) : string 
#-----------------------------------
# Ask for a password at the current STDIN terminal, without displaying 
# the keyboard entries
#
sub ask_pass {
 my $prompt=shift || "Password:";
 my $term     = POSIX::Termios->new();
 my $stdin=fileno(STDIN);
 $term->getattr($stdin);
 my $oterm     = $term->getlflag();
 my $echo     = ECHO | ECHOK | ICANON;
 # -----  i don't want echo:
 $term->setlflag(($oterm & ~$echo));  
 $term->setattr($stdin, TCSANOW);
 # -----  i don't want echo:
 print $prompt;
 local $_='';
 $_=<STDIN>;
 chomp;
 print "\n";
 $term->setlflag($oterm);  
 $term->setattr($stdin, TCSANOW);
 return $_;
}

#=============================================================
#ask_cpass([user_prompt], [pass_char]) : string 
#-----------------------------------------------
# Same as above, but every time the user presses a key, 
# a mask character (pass_char or '#' by default) is displayed.
# the ERASE key is supported! (backspace/delete)
sub ask_cpass {
 my $prompt=shift || "Password:";
 my $pc=shift || '#';
 my $term     = POSIX::Termios->new();
 my $stdin=fileno(STDIN);
 $term->getattr($stdin);
 my $erase = $term->getcc(VERASE);
 #this should be 8; if not, enforce it (on axp it's 127 not ?!?);
 $erase=8 if ($erase!=8);
 my $oterm = $term->getlflag();
 my $echo  = ECHO | ECHOK | ICANON;
 print $prompt;
 local $_='';
 local $|=1;
 my $key='';
 for (;;) {
  $term->setlflag(($oterm & ~$echo));  
  $term->setcc(VTIME, 1);
  $term->setattr($stdin, TCSANOW);
  sysread(STDIN, $key, 1);
  $term->setlflag(($oterm & ~$echo));  
  $term->setcc(VTIME, 0);
  $term->setattr($stdin, TCSANOW);
  last if $key eq "\n";
  if (ord($key)==$erase) {
     if (length($_)>0) { #show erase
        chop;
        print $key,' ',$key; #deal with the terminal display                          
        }
     }
   elsif (ord($key)>=32) {
     #printf $key;
     printf $pc;
     $_.=$key;
     }
  }
 $term->setlflag($oterm);  
 $term->setattr($stdin, TCSANOW);
 print "\n";
 return $_;
}

#returns the server type (postgres/oracle/sybase/mysql) for 
#a given dbh
sub db_srvtype {
 my $dbhdata=$dbhs{$_[0]};
 return $dbhdata ? $$dbhdata[1] : '';
}

=head2 db_login(<server>, <user>, <password>, [<database>[, <srvtype>]])

 RETURNS: a database handle (dbh)
 if a database name is provided, it is selected as the current database context

 If <user> and <password> are undefined or empty, the default read-only 
 login 'access' account is assumed.

 E.g. 
  db_login('SYBASESRV', undef, undef, 'mydb')
  
  .. will use the common 'access' account to login into SYBASESRV and
  use the database 'mydb'

=cut

sub db_login {
 my ($server, $user, $pass, $db,  $srvtype, $srvport)=@_;
 $server=$server.':'.$srvport if ($srvport);
 
 $user=$DBDEF_USER unless $user;
 $pass=$DBDEF_PASS unless $pass;
 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
 my $dbh;
 if ($srvtype eq 'postgres') { 
     $dbh=postgres('.', $server, $user, $pass, $db); }
  elsif ($srvtype eq 'oracle') { 
     $dbh=oracle('.', $server, $user, $pass, $db); }
  elsif ($srvtype eq 'sybase') {
     $dbh=sybase('.', $server, $user, $pass, $db); }
  elsif ($srvtype eq 'mysql') {
     $dbh=mysql('.', $server, $user, $pass, $db); }
  else {
   die("Error at db_login: invalid server type ('$srvtype')!\n");
   }
 $db_last_dbh=$dbh;
 return $dbh;
}

=head2 db_logout(<dbh>)
  
 Disconnects from the server (if <dbh> is defined)
  
=cut

sub db_logout {
 my $dbh=shift;
 if ($dbh) {
   $dbh->disconnect();
   }
 my $dbhdata=$dbhs{$dbh};
 if ($dbhdata) {
   $$dbhdata[0]=0; #not active
   }
}


sub db_lastlogin {
 my ($dbh, $dbhdata);
 if ($db_last_dbh) {
    $dbhdata=$dbhs{$db_last_dbh};
    if ($dbhdata) {
      my ($server, $user, $pass, $db, $srvtype)=@$dbhdata[1..4];      
      $dbh=&db_login($server, $user, $pass, $db, $srvtype);
      if ($dbh ne $db_last_dbh) {
         delete $dbhs{$db_last_dbh};
         $db_last_dbh=$dbh;
         }
      }
   }
 unless ($dbhdata) {
  &$dbExitSub("Error at db_lastlogin: no previous login data found!\n");
  }
 return $dbh;
}

sub getDate {
 my $date=localtime();
 #get rid of the day name so Sybase will accept it
 (my $wday,$date)=split(/\s+/,$date,2);
 return $date;
}

=head2 sql_do(<dbh>, <sql_statement> [, <ignore_failure>])

 Simply execute the given sql statement(s) (typically non-select ones 
 or not returning any result sets back)
 The script is terminated if any error code is returned by the server, 
 unless the <ignore_failure> parameter is defined and non-zero.

=cut
#Expects:  <dbh>, <command>, [<error message>]
#Returns: number of rows affected by the command.
sub sql_do {
  my $r;
  if ($_[2]) { #special case: just print the warning message, don't exit
    if ($_[2]) {#quiet!
        $r=$_[0]->do($_[1]);
        }
       else { 
        $r=$_[0]->do($_[1]) || &flog("sql_do failed at:\n$_[1]\n".$_[0]->errstr.$_[2]);
        }
    }
  else { # blow up if there was an error
    $r=$_[0]->do($_[1]) || &$dbExitSub("sql_do failed at:\n$_[1]\n".
      $_[0]->errstr);
    }
  return $r;
}


=head2 sql_exec(<dbhandle>, <sql_query> [, <binding_values>])

 RETURNS: a statement handle <sth> for the given query <sql_query>
 
 Prepares and executes the <sql_query> (presumably a select statement - 
 or even more than one in Sybase). Optional parameter binding values can 
 be given for every respective parameter or ? character in the <sql_query>.

  The returned <sth> can be used later for fetching the query 
 results in a loop - see sth_fetch()
 
=cut

#========================================================================
# sql_exec (<db_handle>, <query>, [<binding_params>]): <sth>
#     returns a statement handle (sth) for the query;
#     this sth can be used for fetching the query results in a loop
#========================================================================
sub sql_exec {
   my ($dbh, $query, @params) = @_;
   my $sth = $dbh->prepare($query) 
             || &$dbExitSub("Prepare failed for \n$query\n$DBI::errstr");
   my $rc = $sth->execute(@params)
             || &$dbExitSub("Execute failed for \n$query\n$DBI::errstr");
   return $sth;
}



=head2 sql_prepare(<dbh>, <sql_statement> [, <error message>])
  
  RETURNS: a statement handle <sth> for the prepared sql statement.

  Prepares an sql statement to the server. The statement is NOT executed,
  so <sth> cannot be used for fetching the results immediately.
  
  The typical use case for this is to have a dynamic <sql_statement> 
  (i.e. a statement with binding parameters) prepared only once, and then to 
  repeatedly call sth_exec() with various parameter values (e.g. scanning a 
  list of values), with a sth_fetch() session for each sth_exec(), like this:
  
    my $sth = sql_prepare($dbh, 'select name, date from orders where val=? and id=?');
    # assume @v is a list of [$val, $id]
    foreach my $d (@v) {
        sth_exec($sth, @$d);
        while (my $rowref = sth_fetch($sth)) {
           my ($name, $date)=@$rowref;
           #.. do something with the resulting row values
           #...
           } # result row fetching loop
        } # parameter value binding loop
  
=cut

sub sql_prepare { #expects:  <dbh>, <query>, [<error message>]
                  #returns statement handle
  my $sth=$_[0]->prepare($_[1]) || 
     &$dbExitSub("Error preparing:\n $_[1]\n".$_[2]."\n".$_[0]->errstr);
  return $sth;
}

=head2 sql_get_all(<dbh>, <query>);

#Execute a query and returns ALL the results as reference to an array 
# of references to field value lists

=cut

sub sql_get_all {
 my ($dbh, $query)=@_;
 my $aref=$dbh->selectall_arrayref($query) 
      || &$dbExitSub("Select all failed for:\n$query"); 
 
 return $aref;
}


=head2 sth_exec(<sth>[, <binding_values>..])

  Executes a previously prepared statement. 

  RETURNS: the number of rows affected (according to DBI specs, 
           but not all DBMSs can live up to it)

=cut

sub sth_exec {
 my $sth=shift;
 my $rc = $sth->execute(@_)
           || &$dbExitSub("*** sth_exec failed:\n$DBI::errstr");
 return $rc ; 
 # according to DBI specs, this should be the number of rows affected, 
 # or -1 if unknown
}




=head2 sth_fetch(<sth>)

 RETURNS: an array reference to a list of all values in a row of the result set.
 
 <sth> is a statement handle for an already EXECUTED sth statement (not just prepared). 
 This is meant to be used in a loop.
 
 Typical use:

   my $sth=&sql_exec($dbh, $sql_query);
   while (my $r=sth_fetch($sth)) { #while rows are returned..
    #..
    #do something with @$r ,which is the list of values for each field in a result row
    #..
    }
   

=cut

sub sth_fetch {
  my $sth=shift;
  my $r=$sth->fetch();
  &sth_checkErr($sth) unless ($r);
  return $r; 
}

=head2 sth_afetch(<sth>)
 
 RETURNS: an array of field values for a row in the result set
 Same as sth_fetch() but returns an array instead of a reference to an array. 
 
=cut


sub sth_afetch {
  my $sth=shift;
  my $r=$sth->fetch();
  &sth_checkErr($sth) unless ($r);    
  return defined($r)?(@$r):(); #returns a copy of referenced array
}

sub sth_checkErr {
 my $err=$_[0]->errstr;
 &$dbExitSub("*** fetch() failed :\n$err\n") if $err;
}


=head2 sql_get_value($dbh, $sql_query) 
 
 RETURNS: 
   (in scalar context): the first field of the first row in the result set
   (in array context) : the values in the first row in the result set

 It is meant for 'select count() ..' queries or other aggregate 
 queries or any other queries expected to return a result set with 
 only one row.
 
=cut

sub sql_get_value { #single row/value return from a simple SELECT
 my ($dbh, $sql)=@_;
 my $sth=&sql_exec($dbh, $sql);
 my $r=&sth_fetch($sth);
 $r=[undef] unless $r;
 $sth->cancel(); #not all DBDs can actually do this 
 undef($sth); #hopefully destroying the $sth will cancel it anyway..
 if (wantarray()) {
   return @$r;
   }
  else {
   return $$r[0];
   }
}

=head2 sql_get_values($dbh, $sql_query) 

Same as sql_get_value() but enforces a list context
(i.e. returns a LIST of field values for the first returned row)

=cut

sub sql_get_values {
 my @r=&sql_get_value(@_);
 return @r;
}

sub syb_dboalias {
 my $r=&sql_get_value($_[0],
   'select suid from sysalternates where suid=suser_id()');
 return $r;
}

=head2 confirm(<prompt>)
 
   displays an yes/no prompt waiting for user response
   RETURNS: 1 if user chooses 'yes' or 'y', 0 otherwise
   
=cut

sub confirm {
 my $kbstr;
 print STDERR "\n".$_[0]." (y/n) ";
 $kbstr = <STDIN>;
 return (uc(substr($kbstr,0,1)) eq 'Y');
}


=head2 nice_int (<intvalue>)

 RETURNS: a string representation of the integer value given with 
         commas inserted every 3 digits (right to left)

 e.g. 
   $n=12000000;
   $cn=nice_int($n) # $cn is: '12,000,000'

=cut
 

sub nice_int { 
 $_=$_[0]; #only the first parameter is accounted
 1 while s/^(-?\d+)(\d{3})/$1,$2/;
 return $_;
}


=head2 nice_intm(<intvalues>...)
 
 In place, multi-value version of nice_int()

 RETURNS: a list of string representations of the integer values given, with 
         commas inserted every 3 digits (right to left)

 The given parameters are also modified "in place" into their 'commified' 
 representation.

=cut

sub nice_intm {
 foreach (@_) {
   1 while s/^(-?\d+)(\d{3})/$1,$2/;
   }
 return @_;
}


=head2 sql_quote(<strings>..)

   Process single quotes within given strings - for safe use
   as single quoted string constants within sql statements:
   
    * all multiple successive quotes will be squashed into one.
    * all single quotes will be replaced by double quotes
    
  Gets a list of strings and directly updates them ("in place" modification)

=cut

sub sql_quote {
  foreach (@_) { 
     tr/'/'/s;
     s/'/''/g;
     }
  return @_;   
}

=head2 sql_dquote(<strings>..)

 Similar purpose to sql_quote(), but for use of the given <strings> as
 double quoted string constatns within sql statements.
 Every double quote character (") is simply translated into a single quote one (').
 
=cut
 
sub sql_dquote {
  tr/"/'/ foreach (@_); #"
  return @_;
}


sub fastaLineLen {
 $DEF_FASTA_LINELEN=$_[0] if $_[0];
 return $DEF_FASTA_LINELEN;
}

=head2 print_fasta(<rowref>, <useclr>)

FASTA-style formatting & printing to the current FILE selector
 <rowref> is expected to be a reference to a list of values in this order:
  
    <seqname>, <sequence>[, <clr5>, <clr3> [, other defline fields..]]

 If no <useclr> is provided, the whole <sequence> is formatted and printed 
 (clr5 and clr3 are ignored)
 
 The defline is printed only if <seqname> is non-zero length.
 
=cut

sub print_fasta { # direct printing of a formatted sequence 
                  # from a database returned reference to array
                  # CLR info is handled as usual
 my ($row,$clr)=@_; 
 my $other;
 my $hdr= ($$row[0]) ? '>'.$$row[0] : '';
 if ($clr) {#CLR range only, row[2] and row[3] must be end5, end3, respectively!
   #start index for other information is 5th column
   foreach my $part (@$row[4..@$row-1]) {
      $hdr.=' '.$part if ($part);
      }
   print $hdr."\n" if $hdr;
   my $pos=$$row[2]-1;
   while ($$row[3]-$pos>=$DEF_FASTA_LINELEN) {
        print uc(substr($$row[1],$pos,$DEF_FASTA_LINELEN))."\n";
        $pos+=$DEF_FASTA_LINELEN;
        }       
   print uc(substr($$row[1],$pos,$$row[3]-$pos))."\n" 
             if ($$row[3]-$pos>0); 
  }
  else {
   #ignore the clear range given
   #start index for other defline information is 3rd column
   foreach my $part (@$row[2..@$row-1]) {
      $hdr.=' '.$part if ($part);
      }
   print $hdr."\n";   
   my $len=length($$row[1]);
   my $pos=0;
   while ($pos<$len) {
    print uc(substr($$row[1],$pos,$DEF_FASTA_LINELEN))."\n"; 
    $pos+=$DEF_FASTA_LINELEN;
    }
  }
}

=head2 fmt_fasta(<defline>, <seqref>, <end5>, <end3>[, <nohtml>])
 
  In-memory fasta sequence formatting. <seqref> is just a reference to 
  an actual variable containing the  whole nucleotide sequence.
  If <end5>,<end3> are specified and valid, the clipped ends will 
  still be displayed but with by the "gray" CSS span class.
 
  A defline will be included only if <defline> has non-zero length.

  If <nohtml> attribute is given, no html formatting will take place 
  and only the given range will be returned (if valid).
 
=cut

sub fmt_fasta { #$seq MUST BE a reference to a string variable
 my ($defline, $seq, $e5, $e3, $nohtml) = @_;
 my $fmtseq;
 my $rest;
 my $width=$DEF_FASTA_LINELEN;
 $fmtseq = ">$defline\n" if $defline;
 if ($e5>0 && $e3>$e5)  { #valid CLR given
    if ($nohtml) { #plain CLR FASTA-formatting, CLR only!
      my $len=$e3-$e5+1;
      my $s=substr($$seq,$e5-1,$len);
      # my @lines=unpack("A$width" x (int(($len-1)/$width)+1),$s);
      $fmtseq.= join("\n", (unpack('(A'.$width.')*',$s)));
      }
     else {      
      $rest=$width;
      if ($e5>1) {
         $fmtseq.= '<span class="gray">';
         my $s=uc(substr($$seq,0,$e5-1));
         #my @lines=unpack("A$width" x (int((length($s)-1)/$width)+1),$s);
         my @lines=unpack('(A'.$width.')*',$s);
         $fmtseq.= join("\n", @lines);
         $rest=$width-length($lines[$#lines]);
         $fmtseq.= '</span>';
         }
      # $fmtseq.= '<span class="hilite">';
      my $s=uc(substr($$seq,$e5-1,$e3-$e5+1));
      #my @lines=unpack("A$rest"."A$width" x (int((length($s)-1-$rest)/$width)+1),$s);
      my @lines=unpack('(A'.$width.')*',$s);
      $fmtseq.= join("\n",@lines);
      $rest=$width-length($lines[$#lines]);
      # $fmtseq.= '</span>';
      if ($e3<length($$seq)){
        $fmtseq.= '<span class="gray">';
        my $s=uc(substr($$seq,$e3));
        #my @lines=unpack("A$rest"."A$width" x (int((length($s)-1-$rest)/$width)+1),$s);
        my @lines=unpack('(A'.$width.')*',$s);
        $fmtseq.= join("\n",@lines);
        $fmtseq.= '</span>';
        }
      } #html formatting
 } else { #no clear range provided
    my $len=length($$seq);
    #my @lines=unpack("A$width" x (int(($len-1)/$width)+1),$$seq);    
    $fmtseq.= join("\n",(unpack('(A'.$width.')*',$$seq)));
 }
 return $fmtseq;
}


#------- core function used by both print_sql and print_sql_fetch
sub print_sql_core {
 my ($sth, $csep, $rsep)=@_;
 my $total=0;
 my $had_results;
 do {
   my $numcols=$sth->{NUM_OF_FIELDS};
   if ($numcols>0) {
     $had_results=1;
     while (my $data=&sth_fetch($sth)) {
       $total++;
       if ($csep eq "\t") {#it's safer to avoid any tabs in there
         foreach my $d (@$data) {
           $d=~ tr/\t/ /; #replace spaces with tabs!
           }
         }
       #print "@$data[0..$numcols-1]";
       print join($csep, @$data).$rsep;
       }
     }
    else { $total=$sth->rows; }
    
   } while ($sth->{syb_more_results}); 
     #this will only be there for Sybase and SQL server..
return $had_results ? $total : 0;
}

=head2 print_sql(<dbhandle>, <query>, [, <col_sep>, <row_sep>]

  Print the results of an SQL query to the currently selected output.
  Unless custom column and row delimiters are given, they are
  tab and newline respectively.

 RETURNS: the number of rows printed/affected

=cut

sub print_sql {
 my ($dbh, $query, $csep, $rsep)=@_;
 $csep=0 if $csep eq '1'; # special case, to work with sql_execlist
 my $sth = &sql_prepare($dbh, $query);
 my $total=0;
 &sth_exec($sth);
 #my $numcols=$sth->{NUM_OF_FIELDS};
 $csep="\t" unless $csep;
 $rsep="\n" unless $rsep;
 return &print_sql_core($sth, $csep, $rsep);
}

=head2 sql_to_file(<db handle>, <filename>, <sql_query>)

  Simply calls print_sql and makes it print the results of 
  the <sql_query> into a new file <filename>.
  RETURNs: number of rows written

=cut

sub sql_to_file {
 my ($dbh, $file, $query)=@_;
 local *WFILE;
 open(WFILE, '>'.$file) || 
   &$dbExitSub("Error at sql_to_file(): cannot open $file for writing!");
 my $prevFH=select WFILE;
 my $r=&print_sql($dbh, $query);
 select($prevFH);
 close WFILE;
 return $r;
}

=head2 print_sql_fetch(<statement handle>[, <col_sep>, <row_sep>])

 Same as print_sql, but for prepared and executed statements.
 Custom column and row delimiters can be specified, otherwise they are
 tab and newline, respectively.

 RETURNS: the number of rows printed/affected

=cut

sub print_sql_fetch {
 my ($sth, $csep, $rsep)=@_;
 my $total=0;
 $csep=0 if $csep eq '1'; # special case, to work with sql_execlist
 $csep = "\t" unless $csep;
 $rsep = "\n" unless $rsep;
 return &print_sql_core($sth, $csep,$rsep);
}



#------ sql_execlist helpers:

sub fasta_sql_fetch {
 my ($sth, $clr)=@_;
 my $count=0;
 do {
   while (my $row = &sth_fetch($sth)) {
    $count++; 
    &print_fasta($row,$clr); #here we could have some choice for clear-range
    }
  } while ($sth->{syb_more_results});
 return $count;
}

sub fasta_sql {
 my ($dbh, $query, $clr)=@_;
 my $sth = &sql_exec($dbh, $query);
 return &fasta_sql_fetch($sth, $clr);
}

=head2 sql2fasta(<db_handle>, <query>, [<outfile>, <useclr>])

    RETURNS: the number of sequences extracted.

    Writes the queried sequences to an multi-FASTA format file;
    Assumes the column order is for the resulting rows is: 
        seq_name, sequence, end5, end3, other defline fields...


=cut

sub sql2fasta {
  my ($dbh, $query, $outfile, $clr) = @_;  
  local *OUTFILE;
  if ($outfile) {
     open (OUTFILE, ">$outfile") 
        || &$dbExitSub("Can't open $outfile for output");  
     select(OUTFILE);
     }
  my $count=&fasta_sql($dbh, $query, $clr);
  if ($outfile) {
    select(STDOUT);
    close OUTFILE;
    }
 return $count;
 }

sub sql2fasta_CLR {
 my ($dbh, $query, $outfile) = @_;
 return &sql2fasta($dbh, $query, $outfile, 1);
}

=head2 sql_cmdfile(<dbh>, <sql_cmd_filename> [, search/replace pairs...])

 Runs template sql commands loaded from the given file <sql_cmd_filename>.
 The provided search/replace pairs are used to search and replace expressions 
   in the content of the file.
   
    
Example:

  sql_cmdfile($dbh, 'populate_organism_tables.sql', 
                      '<db>', 'amoeba', #one search/replacement pair
                      '<prop>', 'feature' ) #another search/replacement pair

In this example, all the sql commands in the given file (populate_organism_tables.sql)
will be loaded and edited before execution by replacing all the occurences of 
the strings '<db>' and '<prop>' with the strings 'amoeba' and 'feature', respectively.

=cut

sub sql_cmdfile {
 my $dbh=shift;
 my $fname=shift;
 #-- add logging for easier debugging:
 &$dbExitSub("Even number of parameters for sql_cmdfile is required!\n @_ ") if (scalar(@_) % 2);
 # we can split by "go" separator in multiple commands instead of one batch
 # it seems this may lower the server overhead
 my @cmds;
 local *QFILE;
 open(QFILE, $fname) || &$dbExitSub("Cannot open sql file: $fname!");
 { 
   local $/=undef;
   my $file=<QFILE>;
   #@cmds=split(/;?\s*\ngo\b|\;\n/s, $file);
   @cmds=split(/\n\s*go\b/s, $file);
 }
 close(QFILE);
 foreach (@cmds) {
  chomp;
  #delete SQL comments and extra spaces:
  s/\-\-.*\n//sg;
  s/\s+\n//sg;
  s/^\s+//g;
  s/\n\s+//sg;
  my $i=0;
  while ($i<scalar(@_)) {
    s/$_[$i]/$_[$i+1]/sg;
    $i+=2;
    }
  } #for each sql command
 my $cnt;
 #debug feature:
 my $fdbg="sql_cmdfile_$ENV{USER}_$$.log";
 unlink($fdbg);
 local *SQL_CMDFILE;
 foreach my $cmd (@cmds) {
  open(SQL_CMDFILE, '>>'.$fdbg) || &$dbExitSub("Error at sql_cmdfile(): cannot append to $fdbg\n");
  print SQL_CMDFILE ">>>> running:\n$cmd\n<<<<\n";
  close SQL_CMDFILE;
  $cnt+=&sql_do($dbh, $cmd);
  }
 return $cnt;
}


=head2 sql_execlist(<dbh>, <sql_command>, <values_filename> [, <options> [, sub]]) 
 
 Repeatedly executes a query (prepared with binding parameters), fetching 
 the parameter values from the given file <values_filename> 
 (each line should have space delimited parameter values with one exec/fetch 
 loop per line)
 
 Any rows returned are printed to the default select output (usually stdout, 
 can be redirected using select()) and the total number of rows affected 
 (for all lines in the <values_filename>) will be returned.
  
  Tab delimited strings taken from <list_file> should be specified 
  either as :0, :1, :2, .. :9 (slower) or as '?' character is encountered
      the '?' method is faster, but less flexible and 
        it will not work for TEXT fields subs

  If present, <options> can have the following values:

    'F' = print fasta formatted output, assuming that the 1st selected 
         column is a sequence name and the 2nd is the actual sequence
    'C' = same as 'F', but only clear range is printed, assuming that 
          the 3rd selected column is end5 coordinate and the 4th is end3 
          coordinate

    if '|' character is present in <options>, the string following it 
    is taken as the delimiter <your_delim> for the values in each line 
    of the input file <values_filename> (instead of tab). Watch for 
    meta-characters as this string is taken as a perl regular expression 
    i.e. it is used as is in split(/<your_delim>/, <input_line>)

  If <sub> is a reference to a subroutine, that subroutine will be 
  executed for each exec cycle.
    
  For an usage example, see the batchsql script.
    
=cut 

sub sql_execlist {
 my ($dbh, $cmd, $datafile, $opt, $func)=@_;
 my @data;
 my $total;
 my $sep;
 ($opt, $sep)=split(/\|/,$opt);
 $sep='\t' unless $sep;
 $sep.='+' if $sep eq ' '; #special case: assume all the spaces should be trimmed
                    #this means no 'empty' fields are allowed!

 my @cmds=split(/;?\s*\ngo\b|\;\n/s, $cmd);
 my $dyncmd= ($cmd=~/\?/s);
 &$dbExitSub("Multiple independent commands are not accepted\n".
 "with '?' placeholders.\nUse :0, :1, :2 ... placeholders instead.\n")
   if (@cmds>1 && $dyncmd);
 local *XLSTFILE;
 open(XLSTFILE, "<$datafile")
  || &$dbExitSub("Error at sql_execlist(): Cannot open datafile $datafile!");
 my ($sth, $show_sql, $show_sql_fetch, $dofunc);
 my $clr=0;
 $dofunc=1 if ($func && ref($func) eq 'CODE');
 if ($opt eq 'F' || $opt eq 'C') {                      
            $show_sql=\&fasta_sql;
            $show_sql_fetch=\&fasta_sql_fetch;
            $clr=1 if $opt eq 'C';
            }
         else {                                 
            $show_sql=\&print_sql;
            $show_sql_fetch=\&print_sql_fetch;
            }
 if ($dyncmd) { # dynamic SQL, prepare/binding method - faster! 
                                                
      $sth=$dbh->prepare($cmd) || &$dbExitSub("Prepare failed:\n$cmd\n".$DBI::errstr);
      my $replcount=($cmd=~tr/\?//); #count the number of ? in $cmd
      $replcount--;                 
      while (<XLSTFILE>) {
        chomp;
        next if m/^\s*$/; #empty line
        @data=split(/$sep/);
        #@data=split(/\t/);
        #use only a slice of @data, otherwise DBI will complain
        &$func(@data[0..$replcount]) if $dofunc;
        my $rows=$sth->execute(@data[0..$replcount])
          || &$dbExitSub("Execute failed for $_\n".$DBI::errstr);
        #if it was a non-Select statement, the number of rows affected is returned
          my $fetchcount=&$show_sql_fetch($sth,$clr);
        #print STDERR "returned rows==$rows\n";
        #print STDERR "returned fetchcount=$fetchcount\n";
        if ($fetchcount>=0 && $rows == -1) {
           $total+=$fetchcount;
           }
         else {
           $total+=$rows;
           }
        }                      
     }
     else { #repeat query method, slower
      while (<XLSTFILE>) {
        chomp;
        s/'/''/g; #protect quotes, just in case...
        @data=split(/$sep/); #hoping there are exactly the delims we want... 
                                        
        foreach (@cmds) {
          next if /^\s*$/s;
          my $sq=$_;
          $sq=~s/\:(\d+)\b/$data[$1]/sg;
                #the parameters are numbered from 0, not from 1 !
                #so the first field from the file will be :0
          $total+=&$show_sql($dbh, $sq, $clr);
          }
        &$func(@data) if $dofunc;
        }
      }
 close (XLSTFILE); 
 return $total;
}

=head2 batchsql_to_file(<dbh>, <outfilename>, <sql_cmd>, <values_filename>[, <opt>, <sub>])

 Just a pre-made wrapper for sql_execlist() to write all the output of sql_execlist() 
 into the file <outfilename> (instead of STDOUT).

=cut

sub batchsql_to_file {
#just an extra wrapper for sql_execlist for the lazy
 my ($dbh, $outfile, $cmd, $datafile, $opt, $func)=@_;
 local *BATCHTOFILE;
 open (BATCHTOFILE, '>'.$outfile) 
     || &$dbExitSub("Error at batchsql_to_file(): Cannot create file $outfile!");
 my $prevsel=select BATCHTOFILE;
 my $r=&sql_execlist($dbh, $cmd, $datafile, $opt, $func);
 select $prevsel;
 close BATCHTOFILE;
 return $r;
}


#******************************************************************************
#
#===========------ the Object Oriented stuff: DbSession class
#
#******************************************************************************


sub new {
  my $class=shift;
  my ($server, $user, $pass, $db,  $srvtype, $srvport);
  my $uc=$_[0];
  $uc=uc($uc);
  if ($_[0] && ($_[0] ne $uc) && @_>0 && @_<3) {
    # dblocator format -- rests on db_perm to find the authentication info
   ($server, $user, $pass, $db,  $srvtype, $srvport) = db_perm(@_);
   }
  else { # first argument is all uppercase (server name) OR there are no arguments
         # OR there are least three arguments -> it must be server/user/pass style
   ($server, $user, $pass, $db, $srvtype)=@_;   
   if ($server) {
     my ($shost, $port)=split(/:/,$server);
     if (!$srvport && $port>0) { $server=$shost; $srvport=$port }
     if (!$srvtype && $server=~m/^(\w+)\/(\w+)/) {
       ($server, $srvtype)=($1,$2);
       }
     }
    else { $server=$DBDEF_SERVER }
   $user=$DBDEF_USER unless $user;
   $pass=$DBDEF_PASS unless $pass;
   $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
   }
  $server.=':'.$srvport if ($srvport);
  if ($srvtype eq 'postgres') { 
     return dbSession->postgres($server, $user, $pass, $db); }
  elsif ($srvtype eq 'oracle') { 
     return dbSession->oracle($server, $user, $pass, $db); }
  elsif ($srvtype eq 'sybase') {
     return dbSession->sybase($server, $user, $pass, $db); }
  elsif ($srvtype eq 'mysql') {
     return dbSession->mysql($server, $user, $pass, $db); }
  else {
   &$dbExitSub("Error at dbSession constructor: invalid server type ('$srvtype')!\n");
   }
}


sub login {
 return dbSession::new(@_);
}

sub connect {
 return dbSession::new(@_);
}

sub DESTROY {
  my $self  = shift;
  #my $class = ref $self;
  $self->logout();
  }


#-- accessor methods:
sub dbh {
 my $self=shift; return $self->[0];
 }

sub servertype {
 my $self=shift; return $self->[1];
}

sub servername {
 my $self=shift; return $self->[2];
}

sub serverport {
 my $self=shift; return $self->[3];
}

sub user {
 my $self=shift; return $self->[4];
}

sub pass {
 my $self=shift; return $self->[5];
}

sub initial_db {
 my $self=shift; return $self->[6];
}

sub last_sth { 
 my $self=shift; 
 #set it if given
 $self->[7]=shift if @_;
 return $self->[7];
 }

sub bless_dbSession {
  my $class=shift;
  #keep the object data in an array, to make it more compact and faster  
  #srv_type can be 'postgres', 'oracle', 'sybase', 'mysql'  
  #             0        1         2         3          4       5       6           7    
  #            dbh    srv_type    server   srv_port    user,   pass, initial_db, last_sth
  my $self  = [                                     @_                                   ];
  bless ($self, $class);
  return $self;
  }


sub sybase {
 my $class=shift;
 my ($pserver, $user, $pass, $db)=@_;
 my ($server, $srvport)=split(/:/,$pserver);
 my $dcn='dbi:Sybase:';
 if ($srvport && $srvport>0) {
   $dcn.="host=$server;port=$srvport";   
   }
 else {
   $dcn.="server=$server";
   }
 my $dbh = DBI->connect($dcn, $user, $pass)
     || die("Error at connect($dcn, $user, ...)\n");
 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'sybase'];
 $dbh->{RaiseError}=0; #croak on errors, do not count on error status
 $dbh->{syb_err_handler}=\&syb_MsgHandler;
 $dbh->{syb_show_eed}=1; #give extended error information 

 &sql_do($dbh, "use $db") if $db;
 &sql_do($dbh,"set textsize 50000000");
  if (ref($class)) { #called from instance (reconnect)
   $class->[0]=$dbh;
   return $class;
   }
  elsif ($class eq '.') { #called as plain subroutine from db_login
   return $dbh;
   }
  else { #called as constructor
   return bless_dbSession($class, $dbh, 'sybase', $server, $srvport, $user, $pass, $db, undef);
  }
}

sub oracle {
 my $class=shift;
 my ($pserver, $user, $pass, $db)=@_;
 my ($server, $srvport)=split(/:/,$pserver);

 my $dcn='dbi:Oracle:';
 my $userstr=$user;
 if ($srvport && $srvport>0) {
   $dcn.="host=$server;port=$srvport";
   }
  else {
   my ($oraclehome, $tnsadmin)=($ENV{'ORACLE_HOME'},$ENV{'TNS_ADMIN'});   
   $ENV{'ORACLE_HOME'}=$tnsadmin if $tnsadmin && !$oraclehome;
   $ENV{'TNS_ADMIN'}=$oraclehome if $oraclehome && !$tnsadmin;  
   $ENV{'TWO_TASK'}=$server;
   $userstr.='@'.$server;
   }
 my $dbh = DBI->connect($dcn, $userstr, $pass) ||
                 die("Error at connect($dcn, $userstr, ...)\n");
 $dbh->{RaiseError}=1; #croak on errors, do not count on error status
 $dbh->{AutoCommit}=1;
 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'oracle'];
 &sql_do($dbh, "alter session set current_schema = $db ") if $db;
  if (ref($class)) { #called from instance for reconnect
   $class->[0]=$dbh;
   return $class;
   }
  elsif ($class eq '.') { #called as plain subroutine from db_login
   return $dbh;
   }
  else { #called as constructor
   return bless_dbSession($class, $dbh, 'oracle', $server, $srvport, $user, $pass, $db, undef);
  }
}

sub mysql {
 my $class=shift;
 my ($pserver, $user, $pass, $db)=@_;
 my ($server, $srvport)=split(/:/,$pserver);
 die("Error: for mysql connect() a database must always be specified!\n") unless $db;
 #in mysql, a database must always be specified
 my $dcn="DBI:mysql:database=$db;host=$server";
 $dcn.=";port=$srvport" if $srvport && $srvport>0;
 my $dbh=DBI->connect($dcn, $user, $pass) ||
                 die("Error at connect($dcn, $user, ...)\n");
 $dbh->{RaiseError}=1;
 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'mysql'];
 if (ref($class)) { #called from instance (reconnect)
   $class->[0]=$dbh;
   return $class;
   }
  elsif ($class eq '.') { #called as plain subroutine from db_login
   return $dbh;
   }
  else { #called as constructor
  return bless_dbSession($class, $dbh, 'mysql', $server, $srvport, $user, $pass, $db, undef);
  }
}

sub postgres {
 my $class=shift;
 my ($pserver, $user, $pass, $db)=@_;
 my ($server, $srvport)=split(/:/,$pserver);
 die("Error: for postgres connect() a database must always be specified!\n") unless $db;
 #in mysql, a database must always be specified
 my $dsn="DBI:Pg:dbname=$db;host=$server";
 $dsn.=";port=$srvport" if $srvport && $srvport>0;
 my $dbh=DBI->connect($dsn, $user, $pass, { RaiseError => 1 } ) ||
                 die("Error at connect($dsn, $user, ...)\n");
 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'postgres'];
 if (ref($class)) { #called from instance (reconnect)
   $class->[0]=$dbh;
   return $class;
   }
  elsif ($class eq '.') { #called as plain subroutine from db_login
   return $dbh;
   }
  else { #called as constructor
  return bless_dbSession($class, $dbh, 'postgres', $server, $srvport, $user, $pass, $db, undef);
  }
}

sub dbms {
 my $self=shift;
 #my $dbh=$self->dbh();
 #my $dbms = srvtype || $dbh->{srvtype};
 # unfortunately Sybase doesn't implement it :(
 return $self->servertype();
}

sub use {
 return unless $_[1];
 my ($self, $db)=@_;
 my $dbh=$self->dbh();
 my $srvtype=$self->servertype();
 if ($srvtype eq 'postgres') {
   die("Error: cannot change database in postgres!\n");
 }
 elsif ($srvtype eq 'oracle') {
   &sql_do($dbh, "alter session set current_schema = $db ");
   }
  else {
   &sql_do($dbh, "use $db");
   }
}

sub do {
 my ($self, $sql, $noerror)=@_;
 return &sql_do($self->dbh(), $sql, $noerror);
}

#=====================================================================
# $db->repeat(<SQL command> [, <rowlimit>])
#
#  transaction-log safe operation for sybase
#        should be used only for extensive deletes, updates or inserts
#  RETURNS: the total number of rows affected;
#  <rowlimit> is set to 500 if not specified, which should be OK 
#  for most of the updates
#===================================================================== 
sub repeat {
 my $self=shift;
 my ($query, $rowlimit) = @_;
 my $srvtype=$self->servertype();
 $rowlimit=500 unless defined($rowlimit); 
 my $total;
 if ($srvtype eq 'sybase') {
   $self->do("set rowcount $rowlimit");
   $total=$self->getval(qq/
     declare \@total int, \@rc int
     select \@total=0
     while (1=1) begin
       $query
       select \@rc=\@\@rowcount
       select \@total=\@total+\@rc
       if \@rc<$rowlimit break
       end
     select \@total  
       /);
   $self->do("set rowcount 0");
   }
  else { # Oracle does good auto-management
   #of the transaction log
   #so we simply call the "do" method
   $total=$self->do($query);
   }
  return $total;
 }

sub prep {
 my ($self, $sql, $errmsg)=@_;
 return $self->last_sth(&sql_prepare($self->dbh(), $sql, $errmsg)); 
}

sub prepare {
 return dbSession::prep(@_);
}

sub exec {
 my ($self, $s, @params)=@_; 
 my $sth;
 if (ref($s)) { # it's a sth already
   $sth=$s;
   }
  else { # it's an sql command
   $sth=$self->last_sth(&sql_prepare($self->dbh(), $s));
   }
 #now execute it
 my $r=&sth_exec($sth, @params);
 return wantarray ? ($sth, $r) : $r;
}

sub fetch {
 my $self=shift(@_);
 my $sth=shift(@_) || $self->last_sth();
 return &sth_fetch($sth);
}

sub getval { #first row/value return from a simple SELECT
 my ($self, $sql)=@_;
 my $sth=&sql_exec($self->dbh(), $sql);
 my $r=&sth_fetch($sth);
 $r=[undef] unless $r;
 $sth->cancel(); #not all DBDs can actually do this 
 undef($sth); #hopefully destroying the $sth will cancel it anyway..
 if (wantarray()) {
   return @$r;
   }
  else {
   return $$r[0];
   }
}

sub logout {
 my $self=shift;
 my $dbh=$self->dbh();
 if ($dbh) {
   $dbh->disconnect();
   delete $dbhs{$dbh};
   undef($dbh);
   $self->[0]=undef;
   }
}

sub close {
 my $self=shift;
 my $dbh=$self->dbh();
 if ($dbh) {
   $dbh->disconnect();
   delete $dbhs{$dbh};
   undef($dbh);
   $self->[0]=undef;
   }
}

sub logoff {
 return dbSession::logout(@_); 
 }

sub lastlogin {
 my $self=shift; 
 die("Error at dbSession::lastlogin(): no previous login found!\n") 
           unless ref($self) && $self->pass();
 my ($srvtype,            $server,           $srvport , 
                 $user,            $pass,      $db) =  
    ($self->servertype(), $self->servername(), $self->serverport(), 
             $self->user(),    $self->pass(), $self->initial_db());
  $server.=':'.$srvport if ($srvport);
  if ($srvtype eq 'postgres') { 
     return $self->oracle($server, $user, $pass, $db); }
  elsif ($srvtype eq 'oracle') { 
     return $self->oracle($server, $user, $pass, $db); }
  elsif ($srvtype eq 'sybase') {
     return $self->sybase($server, $user, $pass, $db); }
  elsif ($srvtype eq 'mysql') {
     return $self->mysql($server, $user, $pass, $db); }
  else {
   die("Error at dbSession constructor: invalid server type ('$srvtype')!\n");
   }
}

sub relogin {
 return dbSession::lastlogin(@_);
 }

sub reconnect {
 return dbSession::lastlogin(@_);
 }

sub pullsql { #column version
 my $self=shift;
 my ($query, $csep, $rsep)=@_;
 return &print_sql($self->dbh(), $query, $csep, $rsep);
}

sub pullsqlfasta { #fasta version:
  #expects query to be 
 my $self=shift;
 my ($query, $clr)=@_;
 return &fasta_sql($self->dbh(), $query, $clr);
}

sub batchsql { #column version
 my $self=shift;
 my ($query, $infile, $csep, $sub)=@_;
 my $opts='';
 $opts='T|'.$csep if ($csep);
 return &sql_execlist($self->dbh(), $query, $infile, $opts, $sub);
}

sub batchsqlfasta { #fasta version
 my $self=shift;
 my ($query, $infile, $clr, $sub)=@_;
 my $opts=$clr ? 'C' : 'F';
 return &sql_execlist($self->dbh(), $query, $infile, $opts, $sub);
}

sub ErrExit {
 $dbLastError="@_\n";
 print STDERR $_[0]."\n";
 exit(1) unless defined($_[1]);
 die $_[1];
 }

sub syb_getIndexes {
 my ($dbh, $table, $doDrop, $clusteredToo)=@_;
 my $sth=&sql_exec($dbh, "sp_helpindex $table");
 my @create;
 my @drop;
 while (my $r=&sth_fetch($sth)) {
   next if ($$r[2] !~ /nonclustered/) && !$clusteredToo;
   push(@drop, "drop index $table.$$r[0]") if $doDrop;
   my $idxt=$$r[2];
   my $unique=($idxt=~s/\bunique\s*//) ? " unique ":'';
   my @idxtypes=split(/\,\s*/, $idxt);
   
   push(@create, "create $unique".join(' ',@idxtypes)." index $$r[0] on $table($$r[1])");
   }
foreach my $d (@drop) { 
  #print STDERR $d."\n";
  &sql_do($dbh, $d); 
  }
return @create;   
}

sub syb_putIndexes {
 #print STDERR "syb_putIndexes()\n";
 my ($dbh, @idx)=@_;
 foreach my $i (@idx) {
  #print STDERR " $i\n";
  &sql_do($dbh, $i);
  }
}