ViewVC Help
View File | Revision Log | Show Annotations | View Changeset | Root Listing
root/gclib/scripts/dbSession.pm
Revision: 24
Committed: Tue Jul 26 21:46:39 2011 UTC (8 years, 1 month ago) by gpertea
File size: 55713 byte(s)
Log Message:
Line File contents
1 package dbSession;
2 # -*- perl -*-
3 use strict;
4 use POSIX;
5
6 =head1 NAME
7
8 dbSession - a DBI wrapper with various db helpers and utils
9
10 =cut
11
12 =head1 SYNOPSIS
13
14 use dbSession;
15
16 #constructors:
17
18 my $ds = dbSession->new($db_locator [, $authfile]);
19 my $ds = dbSession->new([$server[:$port], $user, $pass, $server_type]);
20
21 #direct connection:
22 my $ds = dbSession->oracle($server, $user, $password, $db);
23 my $ds = dbSession->sybase($server, $user, $password, $db);
24 my $ds = dbSession->mysql($serverhost, $user, $password, $db);
25
26 # methods:
27 my $dbh = $ds->dbh(); # get DBI's database handle
28 my $res = $ds->do($sql); #non-query SQL execution
29 my $sth = $ds->prep($sql); #prepare SQL for execution
30 my $sth = $ds->prepare($sql); # ditto
31 my $sth = $ds->exec($sql, ...); #prepare and execute an SQL
32 my $sth = $ds->exec($sth, ...); #execute a previously prepared $sth
33 my $aref = $ds->fetch($sth); #fetches next row as an array ref
34 my $aref = $ds->fetch(); # fetches next row for the most recent $sth
35 # (generated by the last prep() or exec())
36 my @rowvalues = $db->getval($sql); #returns a single row (the first)
37 my $fieldvalue = $db->getval($sql); #in scalar context returns the first field
38
39
40 =head1 DESCRIPTION
41
42 A wrapper module for DBI, with various helper subroutines
43
44 =cut
45
46 use Exporter;
47 use DBI;
48 our ($VERSION, @ISA, @EXPORT);
49 @ISA = qw(Exporter);
50 @EXPORT = qw( initLog restoreSTD resumeLog flog
51 db_perm scrypt sdecrypt db_srvtype db_login db_logout db_lastlogin
52 onErrExit trim cur_status ask_pass ask_cpass getDate
53 sql_do sql_exec sql_prepare sth_exec sth_fetch sth_afetch
54 sql_get_value sql_get_values sql_get_all syb_dboalias
55 confirm nice_int nice_intm sql_quote sql_dquote
56 print_sql print_sql_fetch sql_to_file ErrExit
57 fmt_fasta print_fasta sql2fasta sql2fasta_CLR fetch2fasta
58 sub sql_cmdfile sql_execlist batchsql_to_file
59 syb_getIndexes syb_putIndexes);
60
61 #-- package variables (static):
62 #-- these will be overriden by the [Default] section of ~/.db_pass
63 # or the authentication file, or whatever extra info the user
64 # provides in the locator string
65 # if no .db_pass or other authentication file/data is given,
66 # these defaults MUST BE edited apropriately for local compliance
67 # before installing the module
68 # Example, for sybase:
69 # our $DBDEF_SRV_TYPE='sybase';
70 # our $DBDEF_SERVER = $ENV{'DSQUERY'} || 'SYBEST';
71 # our $DBDEF_USER='access';
72 # our $DBDEF_PASS='access';
73
74 our $DBDEF_SRV_TYPE='mysql';
75 our $DBDEF_SERVER = 'localhost';
76 # for mysql, this is the host name, and it may include ":<port#>"
77 our $DBDEF_USER='access';
78 our $DBDEF_PASS='access';
79
80 our $dbExitSub=\&dbErrExit;
81 our $dbLastError='';
82
83 our $DEF_FASTA_LINELEN=60;
84
85 #--procedural interface helpers:
86
87 our %dbhs; # dbh -> [valid, server[:port], user, pass, initdb, servertype]
88 our $db_last_dbh;
89
90 our ($file_log, $stdout_log, $stderr_log);
91 local *__OLDERR;
92 local *__OLDSTD;
93
94 #-- we could test for CGI environment e.g.:
95 # unless ($ENV{HTTP_ACCEPT} || $ENV{HTTP_HOST}) { ... }
96 #-- to avoid ~/.db_pass parsing and instead just use the DBDEF_* values above
97
98 return 1;
99
100 =head1 GLOBAL (non-OO) SUBROUTINES
101
102 ----------------------------------------------------------------
103
104 =cut
105
106 =head2 initLog(<logfilename> [, <STDOUT_redirect_file>, <STDERR_redirect_file>])
107
108 Initializes the logging system. Subsequent flog() calls will write
109 into <logfilename> Beware that <logfilename>, if exists, is deleted
110 and then created again at each initLog() call.
111
112 May optionally redirect STDOUT and/or STDERR to the provided log
113 file(s)
114
115 =cut
116
117 sub initLog {
118 ($file_log, $stdout_log, $stderr_log) = @_;
119 return unless ($file_log);
120 unlink($file_log);
121 #also saves STDOUT, STDERR;
122 open(__OLDOUT, ">&STDOUT") if $stdout_log;
123 open(__OLDERR, ">&STDERR") if $stderr_log;
124
125 if ($stdout_log) {
126 open(STDOUT, ">$stdout_log")
127 || &$dbExitSub("Cannot redirect STDOUT to file $stdout_log");
128 }
129 if ($stderr_log) {
130 if ($stderr_log eq $stdout_log) {
131 open(STDERR, ">&STDOUT");
132 }
133 else {
134 open(STDERR, ">$stderr_log")
135 || &$dbExitSub("Cannot redirect STDERR to file $stderr_log");
136 }
137 }
138 }
139
140
141 =head2 restoreSTD( )
142
143 Restores the STDERR and STDOUT if they were previously redirected by initLog()
144
145 =cut
146
147
148 sub restoreSTD {
149 return unless ($file_log);
150 close STDERR if ($stderr_log);
151 close STDOUT if ($stdout_log);
152 open(STDOUT, ">&__OLDOUT");
153 open(STDERR, ">&__OLDERR");
154 }
155
156 sub resumeLog {
157 if ($stdout_log) {
158 open(STDOUT, ">>$stdout_log")
159 || &$dbExitSub("Cannot redirect STDOUT to file $stdout_log");
160 }
161 if ($stderr_log) {
162 if ($stderr_log eq $stdout_log) {
163 open(STDERR, ">&STDOUT");
164 }
165 else {
166 open(STDERR, ">>$stderr_log")
167 || &$dbExitSub("Cannot redirect STDERR to file $stderr_log");
168 }
169 }
170 }
171
172
173 =head2 flog(<text>..)
174
175 The given text lines are written to STDERR and to the log file if such
176 was established by initLog()
177
178 =cut
179
180 sub flog {
181 if ($file_log) {
182 local *LOG_FILE;
183 open(LOG_FILE, ">>$file_log");
184 print LOG_FILE join("\n",@_)."\n";
185 print __OLDERR join("\n",@_)."\n";
186 #print STDERR join("\n",@_)."\n";
187 close LOG_FILE;
188 }
189 else {
190 print STDERR join("\n",@_)."\n";
191 }
192 }
193
194 sub db_askpass {
195 my ($server, $srvtype, $user, $db)=@_;
196 $user=$ENV{'USER'} unless $user;
197 $user=$ENV{'USERNAME'} unless $user;
198 $server=$DBDEF_SERVER unless $server;
199 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
200 # script instructed to ask for password always
201 my $pass=&ask_pass("Enter password for user '$user' on server '$server',\n database $db");
202 return ($server, $user, $pass, $db, $srvtype);
203 }
204
205 =head2 db_perm(<db> [,<auth_file>] [, 'ASK'])
206
207 returns: (server_name, user, pass, db, server_type, server_port)
208
209 (if server_port is returned non-zero, then server_name is actually a hostname and
210 server_port is optional)
211
212 if no <auth_file> is specified, ~/.db_pass is read.
213
214 Parses <auth_file> looking for server and user authentication data
215 necessary for initiating a connection to the database $db, (using
216 the current Unix user as the username, unless :<user> is included in
217 $db)
218
219 $db parameter can also have a more complex locator format:
220
221 <dbschema>[@<server>[/<server_type>]][:<user>]
222
223 ..where <server_type> can be 'oracle', 'sybase' or 'mysql'. None of
224 <server>,<user>,<server_type> are necessary except to avoid ambiguity
225 when multiple servers with the same name (but different DBMS) exist in
226 the <auth_file>
227
228 If a server name is not found for the current <dbname>, the [Default]
229 section is looked-up in <auth_file>; if that section is missing,
230 hardcoded defaults are used instead.
231
232 If the 3rd parameter of this function is the string 'ASK', db_perm will
233 stop and ask for the specified user's password interactively.
234
235 The <auth_file> contains the encrypted passwords just for very basic
236 visual protection (use dbpass utility to update the passwords; see
237 the subroutines scrypt and sdecrypt in this module)
238
239
240 ----------------------------------------
241 [Default]
242 server_type=oracle
243 server=BIOCOMPD
244
245 [BIOCOMPD]
246 db1, db2, db3, ...
247
248 [MYSERVER/oracle@orclhost.dfci.harvard.edu:3139]
249 db1_1, db1_2, db1_3, ...
250
251 [MYSERVER/mysql@tools.dfci.harvard.edu]
252 db1_1, db1_2, db1_3, ...
253
254 [MYSQLSRV/mysql@mysqlhost:port]
255 db2_1, db2_2, db2_3, ...
256
257 [Authentication]
258 BIOCOMPD:username/encpassword
259 MYSERVER/oracle:username/encpassword
260 MYSERVER/mysql:username/encpassword
261 MYSQLSRV:username/encpassword
262 -----------------------------------------
263
264 The server name can be optionally followed by '/<srv_type>'
265 and/or '@<host>' (optionally ':<port>'), otherwise Default values
266 are assumed.
267
268 If server names are uniquely assigned and the DBD driver has a mechanism
269 of resolving the host name based on the server name (e.g. like Oracle does by
270 using environment variables like TNS_ADMIN, TWO_TASK, etc.), a ~/db_pass file
271 can be as simple as this:
272 ---------------------------------
273 [Default]
274 server_type=oracle
275
276 [BIOCOMPD]
277 db1, db2, db3...
278
279 [Authentication]
280 BIOCOMPD:username:encpassword
281 ------------------------------------
282
283 IMPORTANT: the [Authentication] section MUST be the last section in the
284 file, while [Default] section MUST be the first (to speed up parsing).
285
286 =cut
287
288 sub db_perm {
289 my ($dblocator, $authfile, $flag)=@_;
290 $authfile='' unless defined($authfile);
291 $flag=$authfile if $authfile =~ '/\bASK\b/i' && !defined($flag);
292 my $db_err="Error at db_perm('$dblocator', '$authfile'):";
293 my $db_advice="(You should probably use dbpass to update $authfile)\n";
294 if ($authfile) {
295 open(TESTF, $authfile) ||
296 die("$db_err Cannot open $authfile!\n");
297 close(TESTF);
298 }
299 else { $authfile= $ENV{HOME}.'/.db_pass' }
300 #--------- to return:
301 my ($db, $server, $user, $pass, $srvtype, $srvport);
302 #only mysql returns $server as a hostname and also a $srvport
303 my $srvhost; #only needed for mysql, to be returned instead of $server
304
305 # $dblocator format can be <dbname>[@<server>[/<server_type>]][:<user>]
306
307 ($db, my $rest) = ($dblocator=~m/^([#\"\-\.\w]+)(.*)/);
308 die "$db_err Cannot parse locator '$dblocator'!\n"
309 unless $db;
310 if ($rest) { # in here we can have server, server_type and/or user
311 $rest=~tr/ //d;
312 my @d=($rest=~m/([\:\@\/])(\w+)/g);
313 my ($sep, $word);
314 foreach (@d) {
315 if ($sep) { $word=$_;
316 #--do stuff with $sep, $word
317 if ($sep eq ':') { $user=$word }
318 elsif ($sep eq '@') { $server=$word }
319 elsif ($sep eq '/') { $srvtype=$word }
320 #--
321 undef($sep); #re-init next pair
322 }
323 else { $sep=$_; }
324 } #foreach
325 } # additional locator info provided
326 if ($server && $user && ($user eq $DBDEF_USER)) {
327 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
328 my ($shost,$port)=split(/:/,$server);
329 if (defined($port) && $port>0) { $srvport=$port; $server=$shost; }
330 return ($server, $user, $DBDEF_PASS, $db, $srvtype, $srvport);
331 }
332
333 if (defined($flag) && $flag =~/ALWAYS/i) {
334 return (db_askpass($server, $srvtype, $user, $db));
335 }
336 my $askflag=($flag=~/\bASK\b/i) if defined($flag);
337 local *AUTHFILE;
338 unless (open(AUTHFILE, $authfile)) {
339 if ($askflag) {
340 return (&db_askpass($server, $srvtype, $user, $db));
341 }
342 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
343 $srvtype=lc($srvtype);
344 $server=$DBDEF_SERVER unless ($server);
345 my ($shost,$port)=split(/:/,$server);
346 if ($port>0) { $srvport=$port; $server=$shost; }
347 $user=$DBDEF_USER;
348 $pass=$DBDEF_PASS;
349 return ($server, $user, $pass, $db, $srvtype, $srvport);
350 }
351 #locate the server for this database
352 local $/="\n";
353 my $auth_section='Authentication';
354 my $def_section='Default';
355 my $def_srvtype=$DBDEF_SRV_TYPE;
356 my $def_server=$DBDEF_SERVER;
357 my ($section, $section_srvtype, $section_srvhost, $section_srvport); #current section
358 my %srvauth; # serverID:user => encpass
359 local $_;
360 while (<AUTHFILE>) {
361 s/\s+$//;s/^\s+//;
362 next unless $_;
363 next if m/^\s*#/;
364 if (m/^\s*\[\s*(\w+)(.*?)\]/) { #[section] line
365 ($section, my $section_attr)=($1,$2);
366 if ($section_attr) {
367 my @d=($section_attr=~m/([\:\@\/])([\.\w]+)/g);
368 my ($sep, $word);
369 foreach (@d) {
370 if ($sep) { $word=$_;
371 #--do stuff with $sep, $word
372 if ($sep eq '@') { $section_srvhost=$word }
373 elsif ($sep eq '/') { $section_srvtype=$word }
374 elsif ($sep eq ':') { $section_srvport=$word }
375 #--
376 undef($sep); #re-init next pair
377 }
378 else { $sep=$_; }
379 } #foreach
380 if ($server eq $section) {
381 $srvtype=$section_srvtype unless $srvtype;
382 $srvport=$section_srvport unless $srvport;
383 $srvhost=$section_srvhost unless $srvhost;
384 }
385 }
386 next;
387 }
388 #not a "[section]" line
389 s/[\n\r]+$//s;
390 if ($section ne $auth_section) {
391 tr/ //d;
392 next if ($server && $srvtype);
393 if ($section eq $def_section) { # [Default] section?
394 my ($var, $value)=split(/=/);
395 $var=lc($var);
396 if ($value) {
397 if ($var eq 'server') { $def_server = uc($value) }
398 elsif ($var eq 'server_type') { $def_srvtype = lc($value);
399 }
400 }#if value
401 next;
402 } #[Default] section parsing
403 #--
404 next if $server; #we have the server, no need to search for it
405 #[server] section line -- parse the databases
406 my @dbs=split(/[\s\,\;]+/);
407 foreach my $sdb (@dbs) {
408 if ($sdb eq $db) {
409 $server=$section;
410 $srvhost=$section_srvhost;
411 $srvtype=$section_srvtype;
412 $srvport=$section_srvport;
413 }
414 }
415 } #not an auth line
416 else { #line in authentication section
417 my ($asrv, $auserpass)=split(/:/,$_,2);
418 next unless $auserpass;
419 my ($auser, $apass)=split(/\//, $auserpass, 2);
420 next unless $apass;
421 my ($srv, $stype)=split(/\//,$asrv);
422 $asrv = $stype ? uc($srv).'/'.lc($stype) : uc($asrv);
423 my $skey=$asrv.':'.$auser;
424 $srvauth{$skey}=[$apass] unless exists($srvauth{$skey});
425 # alternate (fall-back) authentication:
426 $srvauth{$asrv}=[$auser, $apass];
427 if ($stype) { #server type was provided
428 $skey=$srv.':'.$auser;
429 $srvauth{$skey}=[$apass, $stype] unless exists($srvauth{$skey});
430 #alternate (fall-back) authentication:
431 $srvauth{$srv}=[$auser, $apass, $stype];
432 }
433 }
434 } # --- while <AUTHFILE>
435 close(AUTHFILE);
436 #--
437 unless ($server) {
438 $server=$def_server;
439 my ($shost,$port)=split(/:/,$server);
440 if ($port>0) { $srvport=$port; $srvhost=$shost; }
441 }
442
443 #$srvtype=$def_srvtype unless $srvtype;
444 $server=uc($server);
445 $srvtype=lc($srvtype);
446 #========> now retrieve the password for this db@server [ / srv_type ]
447 #======== and if the $user was given, try to retrieve the password
448 # for that $user and that $server..
449 # else try the Unix user
450 # otherwise fall back to $DBDEF_USER/PASS
451 #VVVVVVVVVVVVVVVVVVVVVVVVVVVV
452 $user=$ENV{'USER'} unless $user;
453 my $srvkey = $server;
454 #my $srvname= $server;
455 $server=$srvhost if $srvhost; # why?!
456 my $authd=$srvauth{$srvkey.':'.$user};
457 $authd=$srvauth{$srvkey.'/'.$srvtype.':'.$user} unless $authd;
458 $authd=$srvauth{$server.':'.$user} unless $authd;
459 my ($encpass, $auth_srvtype)=@$authd if $authd;
460 $srvtype=$auth_srvtype if $auth_srvtype;
461 unless ($encpass) {
462 if ($askflag) {
463 return (&db_askpass($server, $srvtype, $user, $db));
464 }
465 warn("WARNING: $dblocator authentication not found for user $user on server $srvkey\n");
466 warn($db_advice."\n");
467 #look for any other authentication for this server:
468 my $alternate=$srvauth{$srvkey};
469 $alternate=$srvauth{$server} unless $alternate;
470 if ($alternate) {
471 ($user, $pass)=($$alternate[0], &sdecrypt($$alternate[1],$srvkey));
472 $srvtype=$$alternate[2] unless $srvtype;
473 warn("..Found and returned user '$user' authentication instead.\n");
474 }
475 else {
476 warn("..Returning default user ($DBDEF_USER) authentication instead.\n");
477 ($user, $pass)=($DBDEF_USER, $DBDEF_PASS);
478 }
479 $srvtype=$def_srvtype unless $srvtype;
480 return ($server, $user, $pass, $db, $srvtype, $srvport);
481 }
482 #else return the authentication data found
483 $srvtype=$def_srvtype unless $srvtype;
484 return ($server, $user, &sdecrypt($encpass, $srvkey), $db, $srvtype, $srvport);
485 }
486
487 #=======================================================================
488 # simple encryption/decryption routines (uselessly complicated just for
489 # the fun of it) of course, they only offer a very basic "protection"
490 # against quick naked eye inspection..
491 #=======================================================================
492 sub scrypt {
493 my ($pass, $seed)=@_;
494 $seed=lc($seed);
495 $pass=reverse($pass).reverse(substr($seed,0,4));
496 my $mask = substr($seed x (length($pass)/length($_[0]) + 1), 0, length($pass));
497 $mask &= (chr(15) x length($mask));
498 return ($pass ^ $mask);
499 }
500
501 sub sdecrypt {
502 my ($crpass, $seed)=@_;
503 $seed=lc($seed);
504 my $mask = substr($seed x (length($crpass)/length($_[0]) + 1), 0, length($crpass));
505 $mask &= (chr(15) x length($mask));
506 my $pass = ($crpass ^ $mask);
507 $pass=substr($pass, 0,length($pass)-length(substr($seed,0,4)));
508 return scalar(reverse($pass));
509 }
510
511 sub syb_MsgHandler {
512 my($err, $sev, $state, $line, $server,
513 $proc, $msg, $sql, $err_type) = @_;
514 my @msg = ();
515 if($err_type eq 'server') {
516 return 0 if !$err; #this will obliterate useless warning messages
517 push @msg,
518 (sprintf('Server Message# %ld, Severity %ld, State %ld, Line %ld',
519 $err,$sev,$state,$line),
520 (defined($server) ? "Server '$server' " : '') .
521 (defined($proc) ? "Procedure '$proc'" : ''),
522 "Message text: '$msg'");
523 } else {
524 push @msg,
525 (sprintf('Open Client SEVERITY = (%ld) NUMBER = (%ld)',
526 $sev, $err),
527 "Message text: $msg");
528 }
529 print STDERR join("\n",@msg)."\n";
530 return 1;
531 }
532
533
534 #just a fancier exit to be used for fatal errors
535 #the first string is printed at STDOUT
536 #the second, if provided, is sent to STDERR
537 sub dbErrExit {
538 $dbLastError="@_\n";
539 print STDERR $_[0]."\n";
540 exit(1) unless defined($_[1]);
541 die "$_[1]\n";
542 }
543
544 sub onErrExit {
545 $dbExitSub=$_[0];
546 }
547
548
549
550 =head2 trim(<strings>...)
551
552 "in place" trimming of all spaces around each string given as a parameter
553 The trimmed strings are also returned as a list.
554
555 =cut
556
557 #--remove spaces at both ends of strings;
558 sub trim {
559 foreach (@_) {
560 s/^\s+//; s/\s+$//;
561 }
562 return @_;
563 }
564
565 =head2 cur_status(<text_lines>..)
566
567 Simply creates a file called 'current_status' in the current directory
568 with the <text_lines> written in it.
569
570 =cut
571
572 sub cur_status {
573 local *S_FILE;
574 open(S_FILE, '>current_status');
575 print S_FILE join("\n",@_);
576 close S_FILE;
577 }
578
579
580 #===============================================
581 #ask_pass([user_prompt]) : string
582 #-----------------------------------
583 # Ask for a password at the current STDIN terminal, without displaying
584 # the keyboard entries
585 #
586 sub ask_pass {
587 my $prompt=shift || "Password:";
588 my $term = POSIX::Termios->new();
589 my $stdin=fileno(STDIN);
590 $term->getattr($stdin);
591 my $oterm = $term->getlflag();
592 my $echo = ECHO | ECHOK | ICANON;
593 # ----- i don't want echo:
594 $term->setlflag(($oterm & ~$echo));
595 $term->setattr($stdin, TCSANOW);
596 # ----- i don't want echo:
597 print $prompt;
598 local $_='';
599 $_=<STDIN>;
600 chomp;
601 print "\n";
602 $term->setlflag($oterm);
603 $term->setattr($stdin, TCSANOW);
604 return $_;
605 }
606
607 #=============================================================
608 #ask_cpass([user_prompt], [pass_char]) : string
609 #-----------------------------------------------
610 # Same as above, but every time the user presses a key,
611 # a mask character (pass_char or '#' by default) is displayed.
612 # the ERASE key is supported! (backspace/delete)
613 sub ask_cpass {
614 my $prompt=shift || "Password:";
615 my $pc=shift || '#';
616 my $term = POSIX::Termios->new();
617 my $stdin=fileno(STDIN);
618 $term->getattr($stdin);
619 my $erase = $term->getcc(VERASE);
620 #this should be 8; if not, enforce it (on axp it's 127 not ?!?);
621 $erase=8 if ($erase!=8);
622 my $oterm = $term->getlflag();
623 my $echo = ECHO | ECHOK | ICANON;
624 print $prompt;
625 local $_='';
626 local $|=1;
627 my $key='';
628 for (;;) {
629 $term->setlflag(($oterm & ~$echo));
630 $term->setcc(VTIME, 1);
631 $term->setattr($stdin, TCSANOW);
632 sysread(STDIN, $key, 1);
633 $term->setlflag(($oterm & ~$echo));
634 $term->setcc(VTIME, 0);
635 $term->setattr($stdin, TCSANOW);
636 last if $key eq "\n";
637 if (ord($key)==$erase) {
638 if (length($_)>0) { #show erase
639 chop;
640 print $key,' ',$key; #deal with the terminal display
641 }
642 }
643 elsif (ord($key)>=32) {
644 #printf $key;
645 printf $pc;
646 $_.=$key;
647 }
648 }
649 $term->setlflag($oterm);
650 $term->setattr($stdin, TCSANOW);
651 print "\n";
652 return $_;
653 }
654
655 #returns the server type (oracle/sybase/mysql) for
656 #a given dbh
657 sub db_srvtype {
658 my $dbhdata=$dbhs{$_[0]};
659 return $dbhdata ? $$dbhdata[1] : '';
660 }
661
662 =head2 db_login(<server>, <user>, <password>, [<database>[, <srvtype>]])
663
664 RETURNS: a database handle (dbh)
665 if a database name is provided, it is selected as the current database context
666
667 If <user> and <password> are undefined or empty, the default read-only
668 login 'access' account is assumed.
669
670 E.g.
671 db_login('SYBASESRV', undef, undef, 'mydb')
672
673 .. will use the common 'access' account to login into SYBASESRV and
674 use the database 'mydb'
675
676 =cut
677
678 sub db_login {
679 my ($server, $user, $pass, $db, $srvtype, $srvport)=@_;
680 $server=$server.':'.$srvport if ($srvport);
681
682 $user=$DBDEF_USER unless $user;
683 $pass=$DBDEF_PASS unless $pass;
684 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
685 my $dbh;
686 if ($srvtype eq 'oracle') {
687 $dbh=oracle('.', $server, $user, $pass, $db); }
688 elsif ($srvtype eq 'sybase') {
689 $dbh=sybase('.', $server, $user, $pass, $db); }
690 elsif ($srvtype eq 'mysql') {
691 $dbh=mysql('.', $server, $user, $pass, $db); }
692 else {
693 die("Error at db_login: invalid server type ('$srvtype')!\n");
694 }
695 $db_last_dbh=$dbh;
696 return $dbh;
697 }
698
699 =head2 db_logout(<dbh>)
700
701 Disconnects from the server (if <dbh> is defined)
702
703 =cut
704
705 sub db_logout {
706 my $dbh=shift;
707 if ($dbh) {
708 $dbh->disconnect();
709 }
710 my $dbhdata=$dbhs{$dbh};
711 if ($dbhdata) {
712 $$dbhdata[0]=0; #not active
713 }
714 }
715
716
717 sub db_lastlogin {
718 my ($dbh, $dbhdata);
719 if ($db_last_dbh) {
720 $dbhdata=$dbhs{$db_last_dbh};
721 if ($dbhdata) {
722 my ($server, $user, $pass, $db, $srvtype)=@$dbhdata[1..4];
723 $dbh=&db_login($server, $user, $pass, $db, $srvtype);
724 if ($dbh ne $db_last_dbh) {
725 delete $dbhs{$db_last_dbh};
726 $db_last_dbh=$dbh;
727 }
728 }
729 }
730 unless ($dbhdata) {
731 &$dbExitSub("Error at db_lastlogin: no previous login data found!\n");
732 }
733 return $dbh;
734 }
735
736 sub getDate {
737 my $date=localtime();
738 #get rid of the day name so Sybase will accept it
739 (my $wday,$date)=split(/\s+/,$date,2);
740 return $date;
741 }
742
743 =head2 sql_do(<dbh>, <sql_statement> [, <ignore_failure>])
744
745 Simply execute the given sql statement(s) (typically non-select ones
746 or not returning any result sets back)
747 The script is terminated if any error code is returned by the server,
748 unless the <ignore_failure> parameter is defined and non-zero.
749
750 =cut
751 #Expects: <dbh>, <command>, [<error message>]
752 #Returns: number of rows affected by the command.
753 sub sql_do {
754 my $r;
755 if ($_[2]) { #special case: just print the warning message, don't exit
756 if ($_[2]) {#quiet!
757 $r=$_[0]->do($_[1]);
758 }
759 else {
760 $r=$_[0]->do($_[1]) || &flog("sql_do failed at:\n$_[1]\n".$_[0]->errstr.$_[2]);
761 }
762 }
763 else { # blow up if there was an error
764 $r=$_[0]->do($_[1]) || &$dbExitSub("sql_do failed at:\n$_[1]\n".
765 $_[0]->errstr);
766 }
767 return $r;
768 }
769
770
771 =head2 sql_exec(<dbhandle>, <sql_query> [, <binding_values>])
772
773 RETURNS: a statement handle <sth> for the given query <sql_query>
774
775 Prepares and executes the <sql_query> (presumably a select statement -
776 or even more than one in Sybase). Optional parameter binding values can
777 be given for every respective parameter or ? character in the <sql_query>.
778
779 The returned <sth> can be used later for fetching the query
780 results in a loop - see sth_fetch()
781
782 =cut
783
784 #========================================================================
785 # sql_exec (<db_handle>, <query>, [<binding_params>]): <sth>
786 # returns a statement handle (sth) for the query;
787 # this sth can be used for fetching the query results in a loop
788 #========================================================================
789 sub sql_exec {
790 my ($dbh, $query, @params) = @_;
791 my $sth = $dbh->prepare($query)
792 || &$dbExitSub("Prepare failed for \n$query\n$DBI::errstr");
793 my $rc = $sth->execute(@params)
794 || &$dbExitSub("Execute failed for \n$query\n$DBI::errstr");
795 return $sth;
796 }
797
798
799
800 =head2 sql_prepare(<dbh>, <sql_statement> [, <error message>])
801
802 RETURNS: a statement handle <sth> for the prepared sql statement.
803
804 Prepares an sql statement to the server. The statement is NOT executed,
805 so <sth> cannot be used for fetching the results immediately.
806
807 The typical use case for this is to have a dynamic <sql_statement>
808 (i.e. a statement with binding parameters) prepared only once, and then to
809 repeatedly call sth_exec() with various parameter values (e.g. scanning a
810 list of values), with a sth_fetch() session for each sth_exec(), like this:
811
812 my $sth = sql_prepare($dbh, 'select name, date from orders where val=? and id=?');
813 # assume @v is a list of [$val, $id]
814 foreach my $d (@v) {
815 sth_exec($sth, @$d);
816 while (my $rowref = sth_fetch($sth)) {
817 my ($name, $date)=@$rowref;
818 #.. do something with the resulting row values
819 #...
820 } # result row fetching loop
821 } # parameter value binding loop
822
823 =cut
824
825 sub sql_prepare { #expects: <dbh>, <query>, [<error message>]
826 #returns statement handle
827 my $sth=$_[0]->prepare($_[1]) ||
828 &$dbExitSub("Error preparing:\n $_[1]\n".$_[2]."\n".$_[0]->errstr);
829 return $sth;
830 }
831
832 =head2 sql_get_all(<dbh>, <query>);
833
834 #Execute a query and returns ALL the results as reference to an array
835 # of references to field value lists
836
837 =cut
838
839 sub sql_get_all {
840 my ($dbh, $query)=@_;
841 my $aref=$dbh->selectall_arrayref($query)
842 || &$dbExitSub("Select all failed for:\n$query");
843
844 return $aref;
845 }
846
847
848 =head2 sth_exec(<sth>[, <binding_values>..])
849
850 Executes a previously prepared statement.
851
852 RETURNS: the number of rows affected (according to DBI specs,
853 but not all DBMSs can live up to it)
854
855 =cut
856
857 sub sth_exec {
858 my $sth=shift;
859 my $rc = $sth->execute(@_)
860 || &$dbExitSub("*** sth_exec failed:\n$DBI::errstr");
861 return $rc ;
862 # according to DBI specs, this should be the number of rows affected,
863 # or -1 if unknown
864 }
865
866
867
868
869 =head2 sth_fetch(<sth>)
870
871 RETURNS: an array reference to a list of all values in a row of the result set.
872
873 <sth> is a statement handle for an already EXECUTED sth statement (not just prepared).
874 This is meant to be used in a loop.
875
876 Typical use:
877
878 my $sth=&sql_exec($dbh, $sql_query);
879 while (my $r=sth_fetch($sth)) { #while rows are returned..
880 #..
881 #do something with @$r ,which is the list of values for each field in a result row
882 #..
883 }
884
885
886 =cut
887
888 sub sth_fetch {
889 my $sth=shift;
890 my $r=$sth->fetch();
891 &sth_checkErr($sth) unless ($r);
892 return $r;
893 }
894
895 =head2 sth_afetch(<sth>)
896
897 RETURNS: an array of field values for a row in the result set
898 Same as sth_fetch() but returns an array instead of a reference to an array.
899
900 =cut
901
902
903 sub sth_afetch {
904 my $sth=shift;
905 my $r=$sth->fetch();
906 &sth_checkErr($sth) unless ($r);
907 return defined($r)?(@$r):(); #returns a copy of referenced array
908 }
909
910 sub sth_checkErr {
911 my $err=$_[0]->errstr;
912 &$dbExitSub("*** fetch() failed :\n$err\n") if $err;
913 }
914
915
916 =head2 sql_get_value($dbh, $sql_query)
917
918 RETURNS:
919 (in scalar context): the first field of the first row in the result set
920 (in array context) : the values in the first row in the result set
921
922 It is meant for 'select count() ..' queries or other aggregate
923 queries or any other queries expected to return a result set with
924 only one row.
925
926 =cut
927
928 sub sql_get_value { #single row/value return from a simple SELECT
929 my ($dbh, $sql)=@_;
930 my $sth=&sql_exec($dbh, $sql);
931 my $r=&sth_fetch($sth);
932 $r=[undef] unless $r;
933 $sth->cancel(); #not all DBDs can actually do this
934 undef($sth); #hopefully destroying the $sth will cancel it anyway..
935 if (wantarray()) {
936 return @$r;
937 }
938 else {
939 return $$r[0];
940 }
941 }
942
943 =head2 sql_get_values($dbh, $sql_query)
944
945 Same as sql_get_value() but enforces a list context
946 (i.e. returns a LIST of field values for the first returned row)
947
948 =cut
949
950 sub sql_get_values {
951 my @r=&sql_get_value(@_);
952 return @r;
953 }
954
955 sub syb_dboalias {
956 my $r=&sql_get_value($_[0],
957 'select suid from sysalternates where suid=suser_id()');
958 return $r;
959 }
960
961 =head2 confirm(<prompt>)
962
963 displays an yes/no prompt waiting for user response
964 RETURNS: 1 if user chooses 'yes' or 'y', 0 otherwise
965
966 =cut
967
968 sub confirm {
969 my $kbstr;
970 print STDERR "\n".$_[0]." (y/n) ";
971 $kbstr = <STDIN>;
972 return (uc(substr($kbstr,0,1)) eq 'Y');
973 }
974
975
976 =head2 nice_int (<intvalue>)
977
978 RETURNS: a string representation of the integer value given with
979 commas inserted every 3 digits (right to left)
980
981 e.g.
982 $n=12000000;
983 $cn=nice_int($n) # $cn is: '12,000,000'
984
985 =cut
986
987
988 sub nice_int {
989 $_=$_[0]; #only the first parameter is accounted
990 1 while s/^(-?\d+)(\d{3})/$1,$2/;
991 return $_;
992 }
993
994
995 =head2 nice_intm(<intvalues>...)
996
997 In place, multi-value version of nice_int()
998
999 RETURNS: a list of string representations of the integer values given, with
1000 commas inserted every 3 digits (right to left)
1001
1002 The given parameters are also modified "in place" into their 'commified'
1003 representation.
1004
1005 =cut
1006
1007 sub nice_intm {
1008 foreach (@_) {
1009 1 while s/^(-?\d+)(\d{3})/$1,$2/;
1010 }
1011 return @_;
1012 }
1013
1014
1015 =head2 sql_quote(<strings>..)
1016
1017 Process single quotes within given strings - for safe use
1018 as single quoted string constants within sql statements:
1019
1020 * all multiple successive quotes will be squashed into one.
1021 * all single quotes will be replaced by double quotes
1022
1023 Gets a list of strings and directly updates them ("in place" modification)
1024
1025 =cut
1026
1027 sub sql_quote {
1028 foreach (@_) {
1029 tr/'/'/s;
1030 s/'/''/g;
1031 }
1032 return @_;
1033 }
1034
1035 =head2 sql_dquote(<strings>..)
1036
1037 Similar purpose to sql_quote(), but for use of the given <strings> as
1038 double quoted string constatns within sql statements.
1039 Every double quote character (") is simply translated into a single quote one (').
1040
1041 =cut
1042
1043 sub sql_dquote {
1044 tr/"/'/ foreach (@_); #"
1045 return @_;
1046 }
1047
1048
1049 sub fastaLineLen {
1050 $DEF_FASTA_LINELEN=$_[0] if $_[0];
1051 return $DEF_FASTA_LINELEN;
1052 }
1053
1054 =head2 print_fasta(<rowref>, <useclr>)
1055
1056 FASTA-style formatting & printing to the current FILE selector
1057 <rowref> is expected to be a reference to a list of values in this order:
1058
1059 <seqname>, <sequence>[, <clr5>, <clr3> [, other defline fields..]]
1060
1061 If no <useclr> is provided, the whole <sequence> is formatted and printed
1062 (clr5 and clr3 are ignored)
1063
1064 The defline is printed only if <seqname> is non-zero length.
1065
1066 =cut
1067
1068 sub print_fasta { # direct printing of a formatted sequence
1069 # from a database returned reference to array
1070 # CLR info is handled as usual
1071 my ($row,$clr)=@_;
1072 my $other;
1073 my $hdr= ($$row[0]) ? '>'.$$row[0] : '';
1074 if ($clr) {#CLR range only, row[2] and row[3] must be end5, end3, respectively!
1075 #start index for other information is 5th column
1076 foreach my $part (@$row[4..@$row-1]) {
1077 $hdr.=' '.$part if ($part);
1078 }
1079 print $hdr."\n" if $hdr;
1080 my $pos=$$row[2]-1;
1081 while ($$row[3]-$pos>=$DEF_FASTA_LINELEN) {
1082 print uc(substr($$row[1],$pos,$DEF_FASTA_LINELEN))."\n";
1083 $pos+=$DEF_FASTA_LINELEN;
1084 }
1085 print uc(substr($$row[1],$pos,$$row[3]-$pos))."\n"
1086 if ($$row[3]-$pos>0);
1087 }
1088 else {
1089 #ignore the clear range given
1090 #start index for other defline information is 3rd column
1091 foreach my $part (@$row[2..@$row-1]) {
1092 $hdr.=' '.$part if ($part);
1093 }
1094 print $hdr."\n";
1095 my $len=length($$row[1]);
1096 my $pos=0;
1097 while ($pos<$len) {
1098 print uc(substr($$row[1],$pos,$DEF_FASTA_LINELEN))."\n";
1099 $pos+=$DEF_FASTA_LINELEN;
1100 }
1101 }
1102 }
1103
1104 =head2 fmt_fasta(<defline>, <seqref>, <end5>, <end3>[, <nohtml>])
1105
1106 In-memory fasta sequence formatting. <seqref> is just a reference to
1107 an actual variable containing the whole nucleotide sequence.
1108 If <end5>,<end3> are specified and valid, the clipped ends will
1109 still be displayed but with by the "gray" CSS span class.
1110
1111 A defline will be included only if <defline> has non-zero length.
1112
1113 If <nohtml> attribute is given, no html formatting will take place
1114 and only the given range will be returned (if valid).
1115
1116 =cut
1117
1118 sub fmt_fasta { #$seq MUST BE a reference to a string variable
1119 my ($defline, $seq, $e5, $e3, $nohtml) = @_;
1120 my $fmtseq;
1121 my $rest;
1122 my $width=$DEF_FASTA_LINELEN;
1123 $fmtseq = ">$defline\n" if $defline;
1124 if ($e5>0 && $e3>$e5) { #valid CLR given
1125 if ($nohtml) { #plain CLR FASTA-formatting, CLR only!
1126 my $len=$e3-$e5+1;
1127 my $s=substr($$seq,$e5-1,$len);
1128 # my @lines=unpack("A$width" x (int(($len-1)/$width)+1),$s);
1129 $fmtseq.= join("\n", (unpack('(A'.$width.')*',$s)));
1130 }
1131 else {
1132 $rest=$width;
1133 if ($e5>1) {
1134 $fmtseq.= '<span class="gray">';
1135 my $s=uc(substr($$seq,0,$e5-1));
1136 #my @lines=unpack("A$width" x (int((length($s)-1)/$width)+1),$s);
1137 my @lines=unpack('(A'.$width.')*',$s);
1138 $fmtseq.= join("\n", @lines);
1139 $rest=$width-length($lines[$#lines]);
1140 $fmtseq.= '</span>';
1141 }
1142 # $fmtseq.= '<span class="hilite">';
1143 my $s=uc(substr($$seq,$e5-1,$e3-$e5+1));
1144 #my @lines=unpack("A$rest"."A$width" x (int((length($s)-1-$rest)/$width)+1),$s);
1145 my @lines=unpack('(A'.$width.')*',$s);
1146 $fmtseq.= join("\n",@lines);
1147 $rest=$width-length($lines[$#lines]);
1148 # $fmtseq.= '</span>';
1149 if ($e3<length($$seq)){
1150 $fmtseq.= '<span class="gray">';
1151 my $s=uc(substr($$seq,$e3));
1152 #my @lines=unpack("A$rest"."A$width" x (int((length($s)-1-$rest)/$width)+1),$s);
1153 my @lines=unpack('(A'.$width.')*',$s);
1154 $fmtseq.= join("\n",@lines);
1155 $fmtseq.= '</span>';
1156 }
1157 } #html formatting
1158 } else { #no clear range provided
1159 my $len=length($$seq);
1160 #my @lines=unpack("A$width" x (int(($len-1)/$width)+1),$$seq);
1161 $fmtseq.= join("\n",(unpack('(A'.$width.')*',$$seq)));
1162 }
1163 return $fmtseq;
1164 }
1165
1166
1167 #------- core function used by both print_sql and print_sql_fetch
1168 sub print_sql_core {
1169 my ($sth, $csep, $rsep)=@_;
1170 my $total=0;
1171 my $had_results;
1172 do {
1173 my $numcols=$sth->{NUM_OF_FIELDS};
1174 if ($numcols>0) {
1175 $had_results=1;
1176 while (my $data=&sth_fetch($sth)) {
1177 $total++;
1178 if ($csep eq "\t") {#it's safer to avoid any tabs in there
1179 foreach my $d (@$data) {
1180 $d=~ tr/\t/ /; #replace spaces with tabs!
1181 }
1182 }
1183 #print "@$data[0..$numcols-1]";
1184 print join($csep, @$data).$rsep;
1185 }
1186 }
1187 else { $total=$sth->rows; }
1188
1189 } while ($sth->{syb_more_results});
1190 #this will only be there for Sybase and SQL server..
1191 return $had_results ? $total : 0;
1192 }
1193
1194 =head2 print_sql(<dbhandle>, <query>, [, <col_sep>, <row_sep>]
1195
1196 Print the results of an SQL query to the currently selected output.
1197 Unless custom column and row delimiters are given, they are
1198 tab and newline respectively.
1199
1200 RETURNS: the number of rows printed/affected
1201
1202 =cut
1203
1204 sub print_sql {
1205 my ($dbh, $query, $csep, $rsep)=@_;
1206 $csep=0 if $csep eq '1'; # special case, to work with sql_execlist
1207 my $sth = &sql_prepare($dbh, $query);
1208 my $total=0;
1209 &sth_exec($sth);
1210 #my $numcols=$sth->{NUM_OF_FIELDS};
1211 $csep="\t" unless $csep;
1212 $rsep="\n" unless $rsep;
1213 return &print_sql_core($sth, $csep, $rsep);
1214 }
1215
1216 =head2 sql_to_file(<db handle>, <filename>, <sql_query>)
1217
1218 Simply calls print_sql and makes it print the results of
1219 the <sql_query> into a new file <filename>.
1220 RETURNs: number of rows written
1221
1222 =cut
1223
1224 sub sql_to_file {
1225 my ($dbh, $file, $query)=@_;
1226 local *WFILE;
1227 open(WFILE, '>'.$file) ||
1228 &$dbExitSub("Error at sql_to_file(): cannot open $file for writing!");
1229 my $prevFH=select WFILE;
1230 my $r=&print_sql($dbh, $query);
1231 select($prevFH);
1232 close WFILE;
1233 return $r;
1234 }
1235
1236 =head2 print_sql_fetch(<statement handle>[, <col_sep>, <row_sep>])
1237
1238 Same as print_sql, but for prepared and executed statements.
1239 Custom column and row delimiters can be specified, otherwise they are
1240 tab and newline, respectively.
1241
1242 RETURNS: the number of rows printed/affected
1243
1244 =cut
1245
1246 sub print_sql_fetch {
1247 my ($sth, $csep, $rsep)=@_;
1248 my $total=0;
1249 $csep=0 if $csep eq '1'; # special case, to work with sql_execlist
1250 $csep = "\t" unless $csep;
1251 $rsep = "\n" unless $rsep;
1252 return &print_sql_core($sth, $csep,$rsep);
1253 }
1254
1255
1256
1257 #------ sql_execlist helpers:
1258
1259 sub fasta_sql_fetch {
1260 my ($sth, $clr)=@_;
1261 my $count=0;
1262 do {
1263 while (my $row = &sth_fetch($sth)) {
1264 $count++;
1265 &print_fasta($row,$clr); #here we could have some choice for clear-range
1266 }
1267 } while ($sth->{syb_more_results});
1268 return $count;
1269 }
1270
1271 sub fasta_sql {
1272 my ($dbh, $query, $clr)=@_;
1273 my $sth = &sql_exec($dbh, $query);
1274 return &fasta_sql_fetch($sth, $clr);
1275 }
1276
1277 =head2 sql2fasta(<db_handle>, <query>, [<outfile>, <useclr>])
1278
1279 RETURNS: the number of sequences extracted.
1280
1281 Writes the queried sequences to an multi-FASTA format file;
1282 Assumes the column order is for the resulting rows is:
1283 seq_name, sequence, end5, end3, other defline fields...
1284
1285
1286 =cut
1287
1288 sub sql2fasta {
1289 my ($dbh, $query, $outfile, $clr) = @_;
1290 local *OUTFILE;
1291 if ($outfile) {
1292 open (OUTFILE, ">$outfile")
1293 || &$dbExitSub("Can't open $outfile for output");
1294 select(OUTFILE);
1295 }
1296 my $count=&fasta_sql($dbh, $query, $clr);
1297 if ($outfile) {
1298 select(STDOUT);
1299 close OUTFILE;
1300 }
1301 return $count;
1302 }
1303
1304 sub sql2fasta_CLR {
1305 my ($dbh, $query, $outfile) = @_;
1306 return &sql2fasta($dbh, $query, $outfile, 1);
1307 }
1308
1309 =head2 sql_cmdfile(<dbh>, <sql_cmd_filename> [, search/replace pairs...])
1310
1311 Runs template sql commands loaded from the given file <sql_cmd_filename>.
1312 The provided search/replace pairs are used to search and replace expressions
1313 in the content of the file.
1314
1315
1316 Example:
1317
1318 sql_cmdfile($dbh, 'populate_organism_tables.sql',
1319 '<db>', 'amoeba', #one search/replacement pair
1320 '<prop>', 'feature' ) #another search/replacement pair
1321
1322 In this example, all the sql commands in the given file (populate_organism_tables.sql)
1323 will be loaded and edited before execution by replacing all the occurences of
1324 the strings '<db>' and '<prop>' with the strings 'amoeba' and 'feature', respectively.
1325
1326 =cut
1327
1328 sub sql_cmdfile {
1329 my $dbh=shift;
1330 my $fname=shift;
1331 #-- add logging for easier debugging:
1332 &$dbExitSub("Even number of parameters for sql_cmdfile is required!\n @_ ") if (scalar(@_) % 2);
1333 # we can split by "go" separator in multiple commands instead of one batch
1334 # it seems this may lower the server overhead
1335 my @cmds;
1336 local *QFILE;
1337 open(QFILE, $fname) || &$dbExitSub("Cannot open sql file: $fname!");
1338 {
1339 local $/=undef;
1340 my $file=<QFILE>;
1341 #@cmds=split(/;?\s*\ngo\b|\;\n/s, $file);
1342 @cmds=split(/\n\s*go\b/s, $file);
1343 }
1344 close(QFILE);
1345 foreach (@cmds) {
1346 chomp;
1347 #delete SQL comments and extra spaces:
1348 s/\-\-.*\n//sg;
1349 s/\s+\n//sg;
1350 s/^\s+//g;
1351 s/\n\s+//sg;
1352 my $i=0;
1353 while ($i<scalar(@_)) {
1354 s/$_[$i]/$_[$i+1]/sg;
1355 $i+=2;
1356 }
1357 } #for each sql command
1358 my $cnt;
1359 #debug feature:
1360 my $fdbg="sql_cmdfile_$ENV{USER}_$$.log";
1361 unlink($fdbg);
1362 local *SQL_CMDFILE;
1363 foreach my $cmd (@cmds) {
1364 open(SQL_CMDFILE, '>>'.$fdbg) || &$dbExitSub("Error at sql_cmdfile(): cannot append to $fdbg\n");
1365 print SQL_CMDFILE ">>>> running:\n$cmd\n<<<<\n";
1366 close SQL_CMDFILE;
1367 $cnt+=&sql_do($dbh, $cmd);
1368 }
1369 return $cnt;
1370 }
1371
1372
1373 =head2 sql_execlist(<dbh>, <sql_command>, <values_filename> [, <options> [, sub]])
1374
1375 Repeatedly executes a query (prepared with binding parameters), fetching
1376 the parameter values from the given file <values_filename>
1377 (each line should have space delimited parameter values with one exec/fetch
1378 loop per line)
1379
1380 Any rows returned are printed to the default select output (usually stdout,
1381 can be redirected using select()) and the total number of rows affected
1382 (for all lines in the <values_filename>) will be returned.
1383
1384 Tab delimited strings taken from <list_file> should be specified
1385 either as :0, :1, :2, .. :9 (slower) or as '?' character is encountered
1386 the '?' method is faster, but less flexible and
1387 it will not work for TEXT fields subs
1388
1389 If present, <options> can have the following values:
1390
1391 'F' = print fasta formatted output, assuming that the 1st selected
1392 column is a sequence name and the 2nd is the actual sequence
1393 'C' = same as 'F', but only clear range is printed, assuming that
1394 the 3rd selected column is end5 coordinate and the 4th is end3
1395 coordinate
1396
1397 if '|' character is present in <options>, the string following it
1398 is taken as the delimiter <your_delim> for the values in each line
1399 of the input file <values_filename> (instead of tab). Watch for
1400 meta-characters as this string is taken as a perl regular expression
1401 i.e. it is used as is in split(/<your_delim>/, <input_line>)
1402
1403 If <sub> is a reference to a subroutine, that subroutine will be
1404 executed for each exec cycle.
1405
1406 For an usage example, see the batchsql script.
1407
1408 =cut
1409
1410 sub sql_execlist {
1411 my ($dbh, $cmd, $datafile, $opt, $func)=@_;
1412 my @data;
1413 my $total;
1414 my $sep;
1415 ($opt, $sep)=split(/\|/,$opt);
1416 $sep='\t' unless $sep;
1417 $sep.='+' if $sep eq ' '; #special case: assume all the spaces should be trimmed
1418 #this means no 'empty' fields are allowed!
1419
1420 my @cmds=split(/;?\s*\ngo\b|\;\n/s, $cmd);
1421 my $dyncmd= ($cmd=~/\?/s);
1422 &$dbExitSub("Multiple independent commands are not accepted\n".
1423 "with '?' placeholders.\nUse :0, :1, :2 ... placeholders instead.\n")
1424 if (@cmds>1 && $dyncmd);
1425 local *XLSTFILE;
1426 open(XLSTFILE, "<$datafile")
1427 || &$dbExitSub("Error at sql_execlist(): Cannot open datafile $datafile!");
1428 my ($sth, $show_sql, $show_sql_fetch, $dofunc);
1429 my $clr=0;
1430 $dofunc=1 if ($func && ref($func) eq 'CODE');
1431 if ($opt eq 'F' || $opt eq 'C') {
1432 $show_sql=\&fasta_sql;
1433 $show_sql_fetch=\&fasta_sql_fetch;
1434 $clr=1 if $opt eq 'C';
1435 }
1436 else {
1437 $show_sql=\&print_sql;
1438 $show_sql_fetch=\&print_sql_fetch;
1439 }
1440 if ($dyncmd) { # dynamic SQL, prepare/binding method - faster!
1441
1442 $sth=$dbh->prepare($cmd) || &$dbExitSub("Prepare failed:\n$cmd\n".$DBI::errstr);
1443 my $replcount=($cmd=~tr/\?//); #count the number of ? in $cmd
1444 $replcount--;
1445 while (<XLSTFILE>) {
1446 chomp;
1447 next if m/^\s*$/; #empty line
1448 @data=split(/$sep/);
1449 #@data=split(/\t/);
1450 #use only a slice of @data, otherwise DBI will complain
1451 &$func(@data[0..$replcount]) if $dofunc;
1452 my $rows=$sth->execute(@data[0..$replcount])
1453 || &$dbExitSub("Execute failed for $_\n".$DBI::errstr);
1454 #if it was a non-Select statement, the number of rows affected is returned
1455 my $fetchcount=&$show_sql_fetch($sth,$clr);
1456 #print STDERR "returned rows==$rows\n";
1457 #print STDERR "returned fetchcount=$fetchcount\n";
1458 if ($fetchcount>=0 && $rows == -1) {
1459 $total+=$fetchcount;
1460 }
1461 else {
1462 $total+=$rows;
1463 }
1464 }
1465 }
1466 else { #repeat query method, slower
1467 while (<XLSTFILE>) {
1468 chomp;
1469 s/'/''/g; #protect quotes, just in case...
1470 @data=split(/$sep/); #hoping there are exactly the delims we want...
1471
1472 foreach (@cmds) {
1473 next if /^\s*$/s;
1474 my $sq=$_;
1475 $sq=~s/\:(\d+)\b/$data[$1]/sg;
1476 #the parameters are numbered from 0, not from 1 !
1477 #so the first field from the file will be :0
1478 $total+=&$show_sql($dbh, $sq, $clr);
1479 }
1480 &$func(@data) if $dofunc;
1481 }
1482 }
1483 close (XLSTFILE);
1484 return $total;
1485 }
1486
1487 =head2 batchsql_to_file(<dbh>, <outfilename>, <sql_cmd>, <values_filename>[, <opt>, <sub>])
1488
1489 Just a pre-made wrapper for sql_execlist() to write all the output of sql_execlist()
1490 into the file <outfilename> (instead of STDOUT).
1491
1492 =cut
1493
1494 sub batchsql_to_file {
1495 #just an extra wrapper for sql_execlist for the lazy
1496 my ($dbh, $outfile, $cmd, $datafile, $opt, $func)=@_;
1497 local *BATCHTOFILE;
1498 open (BATCHTOFILE, '>'.$outfile)
1499 || &$dbExitSub("Error at batchsql_to_file(): Cannot create file $outfile!");
1500 my $prevsel=select BATCHTOFILE;
1501 my $r=&sql_execlist($dbh, $cmd, $datafile, $opt, $func);
1502 select $prevsel;
1503 close BATCHTOFILE;
1504 return $r;
1505 }
1506
1507
1508 #******************************************************************************
1509 #
1510 #===========------ the Object Oriented stuff: DbSession class
1511 #
1512 #******************************************************************************
1513
1514
1515 sub new {
1516 my $class=shift;
1517 my ($server, $user, $pass, $db, $srvtype, $srvport);
1518 my $uc=$_[0];
1519 $uc=uc($uc);
1520 if ($_[0] && ($_[0] ne $uc) && @_>0 && @_<3) {
1521 # dblocator format -- rests on db_perm to find the authentication info
1522 ($server, $user, $pass, $db, $srvtype, $srvport) = db_perm(@_);
1523 }
1524 else { # first argument is all uppercase (server name) OR there are no arguments
1525 # OR there are least three arguments -> it must be server/user/pass style
1526 ($server, $user, $pass, $db, $srvtype)=@_;
1527 if ($server) {
1528 my ($shost, $port)=split(/:/,$server);
1529 if (!$srvport && $port>0) { $server=$shost; $srvport=$port }
1530 if (!$srvtype && $server=~m/^(\w+)\/(\w+)/) {
1531 ($server, $srvtype)=($1,$2);
1532 }
1533 }
1534 else { $server=$DBDEF_SERVER }
1535 $user=$DBDEF_USER unless $user;
1536 $pass=$DBDEF_PASS unless $pass;
1537 $srvtype=$DBDEF_SRV_TYPE unless $srvtype;
1538 }
1539 $server.=':'.$srvport if ($srvport);
1540 if ($srvtype eq 'oracle') {
1541 return dbSession->oracle($server, $user, $pass, $db); }
1542 elsif ($srvtype eq 'sybase') {
1543 return dbSession->sybase($server, $user, $pass, $db); }
1544 elsif ($srvtype eq 'mysql') {
1545 return dbSession->mysql($server, $user, $pass, $db); }
1546 else {
1547 &$dbExitSub("Error at dbSession constructor: invalid server type ('$srvtype')!\n");
1548 }
1549 }
1550
1551
1552 sub login {
1553 return dbSession::new(@_);
1554 }
1555
1556 sub connect {
1557 return dbSession::new(@_);
1558 }
1559
1560 sub DESTROY {
1561 my $self = shift;
1562 #my $class = ref $self;
1563 $self->logout();
1564 }
1565
1566
1567 #-- accessor methods:
1568 sub dbh {
1569 my $self=shift; return $self->[0];
1570 }
1571
1572 sub servertype {
1573 my $self=shift; return $self->[1];
1574 }
1575
1576 sub servername {
1577 my $self=shift; return $self->[2];
1578 }
1579
1580 sub serverport {
1581 my $self=shift; return $self->[3];
1582 }
1583
1584 sub user {
1585 my $self=shift; return $self->[4];
1586 }
1587
1588 sub pass {
1589 my $self=shift; return $self->[5];
1590 }
1591
1592 sub initial_db {
1593 my $self=shift; return $self->[6];
1594 }
1595
1596 sub last_sth {
1597 my $self=shift;
1598 #set it if given
1599 $self->[7]=shift if @_;
1600 return $self->[7];
1601 }
1602
1603 sub bless_dbSession {
1604 my $class=shift;
1605 #keep the object data in an array, to make it more compact and faster
1606 #srv_type can be 'oracle', 'sybase', 'mysql'
1607 # 0 1 2 3 4 5 6 7
1608 # dbh srv_type server srv_port user, pass, initial_db, last_sth
1609 my $self = [ @_ ];
1610 bless ($self, $class);
1611 return $self;
1612 }
1613
1614
1615 sub sybase {
1616 my $class=shift;
1617 my ($pserver, $user, $pass, $db)=@_;
1618 my ($server, $srvport)=split(/:/,$pserver);
1619 my $dcn='dbi:Sybase:';
1620 if ($srvport && $srvport>0) {
1621 $dcn.="host=$server;port=$srvport";
1622 }
1623 else {
1624 $dcn.="server=$server";
1625 }
1626 my $dbh = DBI->connect($dcn, $user, $pass)
1627 || die("Error at connect($dcn, $user, ...)\n");
1628 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'sybase'];
1629 $dbh->{RaiseError}=0; #croak on errors, do not count on error status
1630 $dbh->{syb_err_handler}=\&syb_MsgHandler;
1631 $dbh->{syb_show_eed}=1; #give extended error information
1632
1633 &sql_do($dbh, "use $db") if $db;
1634 &sql_do($dbh,"set textsize 50000000");
1635 if (ref($class)) { #called from instance (reconnect)
1636 $class->[0]=$dbh;
1637 return $class;
1638 }
1639 elsif ($class eq '.') { #called as plain subroutine from db_login
1640 return $dbh;
1641 }
1642 else { #called as constructor
1643 return bless_dbSession($class, $dbh, 'sybase', $server, $srvport, $user, $pass, $db, undef);
1644 }
1645 }
1646
1647 sub oracle {
1648 my $class=shift;
1649 my ($pserver, $user, $pass, $db)=@_;
1650 my ($server, $srvport)=split(/:/,$pserver);
1651
1652 my $dcn='dbi:Oracle:';
1653 my $userstr=$user;
1654 if ($srvport && $srvport>0) {
1655 $dcn.="host=$server;port=$srvport";
1656 }
1657 else {
1658 my ($oraclehome, $tnsadmin)=($ENV{'ORACLE_HOME'},$ENV{'TNS_ADMIN'});
1659 $ENV{'ORACLE_HOME'}=$tnsadmin if $tnsadmin && !$oraclehome;
1660 $ENV{'TNS_ADMIN'}=$oraclehome if $oraclehome && !$tnsadmin;
1661 $ENV{'TWO_TASK'}=$server;
1662 $userstr.='@'.$server;
1663 }
1664 my $dbh = DBI->connect($dcn, $userstr, $pass) ||
1665 die("Error at connect($dcn, $userstr, ...)\n");
1666 $dbh->{RaiseError}=1; #croak on errors, do not count on error status
1667 $dbh->{AutoCommit}=1;
1668 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'oracle'];
1669 &sql_do($dbh, "alter session set current_schema = $db ") if $db;
1670 if (ref($class)) { #called from instance for reconnect
1671 $class->[0]=$dbh;
1672 return $class;
1673 }
1674 elsif ($class eq '.') { #called as plain subroutine from db_login
1675 return $dbh;
1676 }
1677 else { #called as constructor
1678 return bless_dbSession($class, $dbh, 'oracle', $server, $srvport, $user, $pass, $db, undef);
1679 }
1680 }
1681
1682 sub mysql {
1683 my $class=shift;
1684 my ($pserver, $user, $pass, $db)=@_;
1685 my ($server, $srvport)=split(/:/,$pserver);
1686 die("Error: for mysql connect() a database must always be specified!\n") unless $db;
1687 #in mysql, a database must always be specified
1688 my $dcn="DBI:mysql:database=$db;host=$server";
1689 $dcn.=";port=$srvport" if $srvport && $srvport>0;
1690 my $dbh=DBI->connect($dcn, $user, $pass) ||
1691 die("Error at connect($dcn, $user, ...)\n");
1692 $dbh->{RaiseError}=1;
1693 $dbhs{$dbh} = [1, $pserver, $user, $pass, $db, 'mysql'];
1694 if (ref($class)) { #called from instance (reconnect)
1695 $class->[0]=$dbh;
1696 return $class;
1697 }
1698 elsif ($class eq '.') { #called as plain subroutine from db_login
1699 return $dbh;
1700 }
1701 else { #called as constructor
1702 return bless_dbSession($class, $dbh, 'mysql', $server, $srvport, $user, $pass, $db, undef);
1703 }
1704 }
1705
1706 sub dbms {
1707 my $self=shift;
1708 #my $dbh=$self->dbh();
1709 #my $dbms = srvtype || $dbh->{srvtype};
1710 # unfortunately Sybase doesn't implement it :(
1711 return $self->servertype();
1712 }
1713
1714
1715 sub use {
1716 return unless $_[1];
1717 my ($self, $db)=@_;
1718 my $dbh=$self->dbh();
1719 my $srvtype=$self->servertype();
1720 if ($srvtype eq 'oracle') {
1721 &sql_do($dbh, "alter session set current_schema = $db ");
1722 }
1723 else {
1724 &sql_do($dbh, "use $db");
1725 }
1726 }
1727
1728 sub do {
1729 my ($self, $sql, $noerror)=@_;
1730 return &sql_do($self->dbh(), $sql, $noerror);
1731 }
1732
1733 #=====================================================================
1734 # $db->repeat(<SQL command> [, <rowlimit>])
1735 #
1736 # transaction-log safe operation for sybase
1737 # should be used only for extensive deletes, updates or inserts
1738 # RETURNS: the total number of rows affected;
1739 # <rowlimit> is set to 500 if not specified, which should be OK
1740 # for most of the updates
1741 #=====================================================================
1742 sub repeat {
1743 my $self=shift;
1744 my ($query, $rowlimit) = @_;
1745 my $srvtype=$self->servertype();
1746 $rowlimit=500 unless defined($rowlimit);
1747 my $total;
1748 if ($srvtype eq 'sybase') {
1749 $self->do("set rowcount $rowlimit");
1750 $total=$self->getval(qq/
1751 declare \@total int, \@rc int
1752 select \@total=0
1753 while (1=1) begin
1754 $query
1755 select \@rc=\@\@rowcount
1756 select \@total=\@total+\@rc
1757 if \@rc<$rowlimit break
1758 end
1759 select \@total
1760 /);
1761 $self->do("set rowcount 0");
1762 }
1763 else { # Oracle does good auto-management
1764 #of the transaction log
1765 #so we simply call the "do" method
1766 $total=$self->do($query);
1767 }
1768 return $total;
1769 }
1770
1771 sub prep {
1772 my ($self, $sql, $errmsg)=@_;
1773 return $self->last_sth(&sql_prepare($self->dbh(), $sql, $errmsg));
1774 }
1775
1776 sub prepare {
1777 return dbSession::prep(@_);
1778 }
1779
1780 sub exec {
1781 my ($self, $s, @params)=@_;
1782 my $sth;
1783 if (ref($s)) { # it's a sth already
1784 $sth=$s;
1785 }
1786 else { # it's an sql command
1787 $sth=$self->last_sth(&sql_prepare($self->dbh(), $s));
1788 }
1789 #now execute it
1790 my $r=&sth_exec($sth, @params);
1791 return wantarray ? ($sth, $r) : $r;
1792 }
1793
1794 sub fetch {
1795 my $self=shift(@_);
1796 my $sth=shift(@_) || $self->last_sth();
1797 return &sth_fetch($sth);
1798 }
1799
1800 sub getval { #first row/value return from a simple SELECT
1801 my ($self, $sql)=@_;
1802 my $sth=&sql_exec($self->dbh(), $sql);
1803 my $r=&sth_fetch($sth);
1804 $r=[undef] unless $r;
1805 $sth->cancel(); #not all DBDs can actually do this
1806 undef($sth); #hopefully destroying the $sth will cancel it anyway..
1807 if (wantarray()) {
1808 return @$r;
1809 }
1810 else {
1811 return $$r[0];
1812 }
1813 }
1814
1815 sub logout {
1816 my $self=shift;
1817 my $dbh=$self->dbh();
1818 if ($dbh) {
1819 $dbh->disconnect();
1820 delete $dbhs{$dbh};
1821 undef($dbh);
1822 $self->[0]=undef;
1823 }
1824 }
1825
1826 sub close {
1827 my $self=shift;
1828 my $dbh=$self->dbh();
1829 if ($dbh) {
1830 $dbh->disconnect();
1831 delete $dbhs{$dbh};
1832 undef($dbh);
1833 $self->[0]=undef;
1834 }
1835 }
1836
1837 sub logoff {
1838 return dbSession::logout(@_);
1839 }
1840
1841 sub lastlogin {
1842 my $self=shift;
1843 die("Error at dbSession::lastlogin(): no previous login found!\n")
1844 unless ref($self) && $self->pass();
1845 my ($srvtype, $server, $srvport ,
1846 $user, $pass, $db) =
1847 ($self->servertype(), $self->servername(), $self->serverport(),
1848 $self->user(), $self->pass(), $self->initial_db());
1849 $server.=':'.$srvport if ($srvport);
1850 if ($srvtype eq 'oracle') {
1851 return $self->oracle($server, $user, $pass, $db); }
1852 elsif ($srvtype eq 'sybase') {
1853 return $self->sybase($server, $user, $pass, $db); }
1854 elsif ($srvtype eq 'mysql') {
1855 return $self->mysql($server, $user, $pass, $db); }
1856 else {
1857 die("Error at dbSession constructor: invalid server type ('$srvtype')!\n");
1858 }
1859 }
1860
1861 sub relogin {
1862 return dbSession::lastlogin(@_);
1863 }
1864
1865 sub reconnect {
1866 return dbSession::lastlogin(@_);
1867 }
1868
1869 sub pullsql { #column version
1870 my $self=shift;
1871 my ($query, $csep, $rsep)=@_;
1872 return &print_sql($self->dbh(), $query, $csep, $rsep);
1873 }
1874
1875 sub pullsqlfasta { #fasta version:
1876 #expects query to be
1877 my $self=shift;
1878 my ($query, $clr)=@_;
1879 return &fasta_sql($self->dbh(), $query, $clr);
1880 }
1881
1882 sub batchsql { #column version
1883 my $self=shift;
1884 my ($query, $infile, $csep, $sub)=@_;
1885 my $opts='';
1886 $opts='T|'.$csep if ($csep);
1887 return &sql_execlist($self->dbh(), $query, $infile, $opts, $sub);
1888 }
1889
1890 sub batchsqlfasta { #fasta version
1891 my $self=shift;
1892 my ($query, $infile, $clr, $sub)=@_;
1893 my $opts=$clr ? 'C' : 'F';
1894 return &sql_execlist($self->dbh(), $query, $infile, $opts, $sub);
1895 }
1896
1897 sub ErrExit {
1898 $dbLastError="@_\n";
1899 print STDERR $_[0]."\n";
1900 exit(1) unless defined($_[1]);
1901 die $_[1];
1902 }
1903
1904 sub syb_getIndexes {
1905 my ($dbh, $table, $doDrop, $clusteredToo)=@_;
1906 my $sth=&sql_exec($dbh, "sp_helpindex $table");
1907 my @create;
1908 my @drop;
1909 while (my $r=&sth_fetch($sth)) {
1910 next if ($$r[2] !~ /nonclustered/) && !$clusteredToo;
1911 push(@drop, "drop index $table.$$r[0]") if $doDrop;
1912 my $idxt=$$r[2];
1913 my $unique=($idxt=~s/\bunique\s*//) ? " unique ":'';
1914 my @idxtypes=split(/\,\s*/, $idxt);
1915
1916 push(@create, "create $unique".join(' ',@idxtypes)." index $$r[0] on $table($$r[1])");
1917 }
1918 foreach my $d (@drop) {
1919 #print STDERR $d."\n";
1920 &sql_do($dbh, $d);
1921 }
1922 return @create;
1923 }
1924
1925 sub syb_putIndexes {
1926 #print STDERR "syb_putIndexes()\n";
1927 my ($dbh, @idx)=@_;
1928 foreach my $i (@idx) {
1929 #print STDERR " $i\n";
1930 &sql_do($dbh, $i);
1931 }
1932 }