# Dbi.pm: Class Used for Database Macros package RDA::Library::Dbi; # $Id: Dbi.pm,v 1.34 2015/08/28 07:26:21 RDA Exp $ # ARCS: $Header: /home/cvs/cvs/RDA_8/src/scripting/lib/RDA/Library/Dbi.pm,v 1.34 2015/08/28 07:26:21 RDA Exp $ # # Change History # 20150828 MSC Add the isDbEnabled macro. =head1 NAME RDA::Library::Dbi - Class Used for Database Macros =head1 SYNOPSIS require RDA::Library::Dbi; =head1 DESCRIPTION The objects of the C class are used to interface with database-related macros. The following methods are available: =cut use strict; BEGIN { use Exporter; use IO::Handle; use RDA::Text qw(get_string); use RDA::Alarm qw(clear_alarm set_alarm); use RDA::Driver::Dbd; use RDA::Driver::Jdbc; use RDA::Driver::Library; use RDA::Driver::Sqlplus; use RDA::Driver::WinOdbc; use RDA::Object; use RDA::Object::Access qw($RE_EXT check_dsn check_sid norm_credential); use RDA::Object::Buffer; use RDA::Object::Rda; use RDA::Object::View; use RDA::Value::List; use RDA::Value::Scalar qw(:value new_number); } # Define the global public variables use vars qw($STRINGS $SUSPEND $VERSION @ISA); $SUSPEND = { _buf => sub {return {}}, _cat => undef, _chr => undef, _cur => undef, _dbh => undef, _dsc => sub {return {}}, _hit => sub {return []}, _nvl => undef, _tgt => undef, }; $VERSION = sprintf('%d.%02d', q$Revision: 1.34 $ =~ /(\d+)\.(\d+)/); @ISA = qw(RDA::Driver::Library Exporter); # Define the global private constants my $BUF = qr/^___Capture(_Only)?_(\w+)___$/; my $EOC = q{___End_Capture___}; my $LOG = qr/^((ORA|SP2)-\d{4,}):\s*(.*)/; my $MAC = qr/^___Macro_(caller:)?(\w+)\((\d+)\)___$/; my $RPT = qr/^RDA::Object::(Pipe|Report)/i; ## no critic (Numbered) my $ERR1 = '^ERROR( at line \d+| in \S+ request):$'; my $ERR2 = 'error possibly near <\*> indicator'; my $ERR3 = '^(\[\S*\]\s*){3}'; my $ERR = qr/($ERR1|$ERR2|$ERR3)/i; ## use critic # Define the global private variables my %tb_cat = ( q{?} => sub {return join(q{ || }, @_)}, q{adaptive server anywhere} => sub {return join(q{ || }, @_)}, q{db2/nt} => sub {return join(q{ || }, @_)}, q{microsoft sql server} => sub {return join(q{ + }, @_)}, q{odbc} => sub {return '{fn CONCAT('.join(q{,}, @_).')}'}, q{oracle} => sub {return join(q{ || }, @_)}, ); my %tb_chr = ( q{?} => sub {return q{CHR(}.$_[0].q{)}}, q{microsoft sql server} => sub {return q{CHAR(}.$_[0].q{)}}, ); my %tb_enc = ( 32 => q{ }, 60 => q{<}, 62 => q{>}, ); my %tb_fct = ( 'allowDbNull' => [\&_m_allow_null, 'T', 1], 'checkDsn' => [\&_m_check_dsn, 'T', 0], 'clearDbBuffer' => [\&_m_clear_buffer, 'N', 0], 'clearDbColumns' => [\&_m_clear_columns, 'N', 0], 'clearLastDb' => [\&_m_clear_last, 'N', 0], 'concatDb' => [\&_m_concat, 'T', 1], 'encodeDbColumns' => [\&_m_encode_columns, 'N', 0], 'encodeDbView' => [\&_m_encode_view, 'N', 0], 'getDataSources' => [\&_m_get_sources, 'L', 1], 'getDbBuffer' => [\&_m_get_buffer, 'O', 0], 'getDbChr' => [\&_m_get_chr, 'T', 1], 'getDbColumns' => [\&_m_get_columns, 'L', 1], 'getDbDesc' => [\&_m_get_desc, 'L', 0], 'getDbHits' => [\&_m_get_hits, 'L', 0], 'getDbInfo' => [\&_m_get_info, 'L', 1], 'getDbLines' => [\&_m_get_lines, 'L', 0], 'getDbMessage' => [\&_m_get_message, 'T', 1], 'getDbProvider' => [\&_m_get_provider, 'T', 1], 'getDbTarget' => [\&_m_get_target, 'O', 0], 'getDbTimeout' => [\&_m_get_timeout, 'N', 1], 'getDbVersion' => [\&_m_get_version, 'T', 1], 'getDbView' => [\&_m_get_view, 'L', 1], 'getDrivers' => [\&_m_get_drivers, 'L', 0], 'grepDb' => [\&_m_grep_db, 'L', 1], 'grepDbBuffer' => [\&_m_grep_buffer, 'L', 0], 'grepLastDb' => [\&_m_grep_last, 'L', 0], 'isDbEnabled' => [\&_m_is_enabled, 'N', 1], 'isDriverAvailable' => [\&_m_is_available, 'T', 0], 'loadDb' => [\&_m_load_db, 'N', 1], 'normDbSource' => [\&_m_norm_source, 'L', 0], 'resetDbTimeout' => [\&_m_reset_timeout, 'N', 1], 'setDbColumns' => [\&_m_set_columns, 'N', 0], 'setDbHeader' => [\&_m_set_header, 'N', 0], 'setDbTarget' => [\&_m_set_target, 'O', 0], 'setDbTimeout' => [\&_m_set_timeout, 'N', 1], 'setDbType' => [\&_m_set_type, 'N', 0], 'setDbView' => [\&_m_set_view, 'N', 0], 'testDb' => [\&_m_test_db, 'T', 1], 'writeDb' => [\&_m_write_db, 'N', 1], 'writeLastDb' => [\&_m_write_last, 'N', 1], ); my %tb_jus = ( DECIMAL => 'L', FLOAT => 'L', INT => 'L', NUMBER => 'L', NUMERIC => 'L', ); my %tb_nvl = ( q{?} => sub {return $_[0]}, q{db2/nt} => sub {return q{COALESCE(}.$_[0].q{,'')}}, ); my %tb_typ = ( q{?} => { CHAR => q{%s}, DATE => q{%s}, FLOAT => q{%s}, NCHAR => q{%s}, NUMBER => q{%s}, NVARCHAR2 => q{%s}, TIMESTAMP => q{%s}, VARCHAR2 => q{%s}, date => q{%s}, number => q{%s}, string => q{%s}, }, q{adaptive server anywhere} => { CHAR => q{%s}, DATE => q{dateformat(%s,'DD-Mmm-YYYY HH:NN:SS')}, FLOAT => q{%s}, NCHAR => q{%s}, NUMBER => q{%s}, NVARCHAR2 => q{%s}, TIMESTAMP => q{dateformat(%s,'DD-Mmm-YYYY HH:NN:SS.SS')}, VARCHAR2 => q{%s}, date => q{dateformat(%s,'DD-Mmm-YYYY HH:NN:SS')}, number => q{%s}, string => q{%s}, }, q{db2/nt} => { DECIMAL => q{VARCHAR_FORMAT(%s)}, TIMESTAMP => q{TO_CHAR(%s,'DD-Mon-YYYY HH24:MI:SS')}, VARCHAR => q{%s}, date => q{TO_CHAR(%s,'DD-Mon-YYYY HH24:MI:SS')}, number => q{VARCHAR_FORMAT(%s)}, string => q{%s}, }, q{microsoft sql server} => { BIGINT => q{CAST(%s as varchar)}, DATETIME => q{REPLACE(CONVERT(VARCHAR(11),%s,106),' ','-') + ' ' + }. q{CONVERT(VARCHAR(8),%s,114)}, INT => q{CAST(%s as varchar)}, FLOAT => q{CAST(%s as varchar)}, NUMERIC => q{CAST(%s as varchar)}, NVARCHAR => q{%s}, SMALLINT => q{CAST(%s as varchar)}, VARCHAR => q{%s}, date => q{REPLACE(CONVERT(VARCHAR(11),%s,106),' ','-') + ' ' + }. q{CONVERT(VARCHAR(8),%s,114)}, number => q{CAST(%s as varchar)}, string => q{%s}, }, q{odbc} => { CHAR => q{%s}, DATE => \&_get_date_fmt, FLOAT => q{%s}, NCHAR => q{%s}, NUMBER => q{%s}, NVARCHAR2 => q{%s}, TIMESTAMP => \&_get_date_fmt, VARCHAR2 => q{%s}, date => \&_get_date_fmt, number => q{%s}, string => q{%s}, }, q{oracle} => { CHAR => q{%s}, DATE => q{TO_CHAR(%s,'DD-Mon-YYYY HH24:MI:SS')}, FLOAT => q{%s}, NCHAR => q{%s}, NUMBER => q{%s}, NVARCHAR2 => q{%s}, TIMESTAMP => q{TO_CHAR(%s,'DD-Mon-YYYY HH24:MI:SSxFF')}, VARCHAR2 => q{%s}, date => q{TO_CHAR(%s,'DD-Mon-YYYY HH24:MI:SS')}, number => q{%s}, string => q{%s}, }, ); my %tb_vie = ( DAT => [q{R}, q{date}], NUM => [q{L}, q{number}], STR => [q{R}, q{string}], VRB => [q{R}, q{string}, q{'%s'}], ); # Report the package version sub Version { return $VERSION; } =head2 S<$h = RDA::Library::Dbi-Enew($driver,$collector)> The object constructor. It takes the library driver and collector references as arguments. C is represented by a blessed hash reference. The following special keys are used: =over 12 =item S< B<'_buf'> > Buffer hash =item S< B<'_cat'> > Concatenation function =item S< B<'_chr'> > CHR function =item S< B<'_ctl'> > Reference to the target control object =item S< B<'_col'> > Reference to the collector object =item S< B<'_cur'> > Reference to the current handle target object =item S< B<'_dbh'> > Current database handle =item S< B<'_dbi'> > Available DBI drivers =item S< B<'_dsc'> > Table description hash =item S< B<'_err'> > Number of SQL request errors =item S< B<'_frk'> > Fork indicator =item S< B<'_hit'> > Lines captured when executing SQL statements =item S< B<'_lim'> > Execution time limit (in sec) =item S< B<'_not'> > Statistics note =item S< B<'_nvl'> > NVL function =item S< B<'_out'> > Number of SQL requests timed out =item S< B<'_req'> > Number of SQL requests =item S< B<'_skp'> > Number of SQL requests skipped =item S< B<'_sql'> > Last SQL result =item S< B<'_tgt'> > Reference to the current query target object =back Internal keys are prefixed by an underscore. =cut sub new { my ($cls, $drv, $col) = @_; my ($slf); # Create the macro object $slf = bless { _buf => {}, _dbi => {}, _dsc => {}, _err => 0, _hit => [], _lim => 0, _not => q{}, _out => 0, _req => 0, _skp => 0, _sql => [], }, ref($cls) || $cls; # Setup some parameters by default $slf->{'_frk'} = $col->get_config->can_fork > 0; # Register the macros $drv->register($slf, [keys(%tb_fct)], qw(rda refresh reload suspend usage thread)); # Return the object reference return refresh($slf, $col); } =head2 S<$h-Ecall($name,...)> This method executes the macro code. =cut sub call { my ($slf, $nam, @arg) = @_; my ($rec); $rec = $tb_fct{$nam}; return ($rec->[2] && exists($slf->{'_tgt'})) ? $slf->{'_ctl'}->switch_target($slf->{'_tgt'}, $rec->[0], $slf, @arg) : &{$rec->[0]}($slf, @arg); } =head2 S<$h-Eclr_stats> This method resets the statistics and clears corresponding module settings. =cut sub clr_stats { my ($slf) = @_; delete($slf->{'_cur'}); delete($slf->{'_tgt'}); $slf->{'_buf'} = {}; $slf->{'_dsc'} = {}; $slf->{'_hit'} = {}; $slf->{'_not'} = q{}; $slf->{'_req'} = $slf->{'_err'} = $slf->{'_out'} = $slf->{'_skp'} = 0; return; } =head2 S<$h-Edelete_object> This method deletes the library control object. =cut sub delete_object { RDA::Object::dump_caller($_[0], 'Library') if $RDA::Object::DELETE; undef %{$_[0]}; undef $_[0]; return; } =head2 S<$h-Eget_stats> This method reports the library statistics in the specified module. =cut sub get_stats { my ($slf) = @_; my ($use); # Add last database handle contribution _clr_dbh($slf); # Generate the statistics if ($slf->{'_req'}) { # Get the statistics record $use = $slf->{'_col'}->get_usage; $use->{'DBI'} = {err => 0, not => q{}, out => 0, req => 0, skp => 0} unless exists($use->{'DBI'}); $use = $use->{'DBI'}; # Indicate the current timeout when there is no other note $slf->{'_not'} = 'DBI execution limited to '.$slf->{'_lim'}.'s' unless $use->{'not'} || $slf->{'_not'} ## no critic (Unless) || $slf->{'_lim'} <= 0; # Generate the module statistics $use->{'err'} += $slf->{'_err'}; $use->{'out'} += $slf->{'_out'}; $use->{'req'} += $slf->{'_req'}; $use->{'skp'} += $slf->{'_skp'}; $use->{'not'} = $slf->{'_not'} if $slf->{'_not'}; # Reset the statistics clr_stats($slf); } return; } =head2 S<$h-Erefresh($col)> This method updates the library control object for a new collector. =cut sub refresh { my ($slf, $col) = @_; my ($tbl); $slf->{'_col'} = $col; $slf->{'_ctl'} = $col->get_target; # Set the available drivers if ($col->get_first('DEFAULT.B_NO_DBI')) { delete($slf->{'_dbi'}); } else { eval { require DBI; $slf->{'_dbi'} = $tbl = {}; foreach my $drv (DBI->available_drivers) { $tbl->{lc($1)} = $1 if $drv =~ m/^(\w+)$/; } delete($tbl->{'oracle'}) if $col->get_agent->get_env('RDA_NO_DBD_ORACLE'); }; } return $slf; } =head2 S<$h-Ereset> This method resets the object for its new environment to allow a thread-save execution. =cut sub reset ## no critic (Builtin) { my ($slf) = @_; $slf->{'_dbh'}->reset if exists($slf->{'_dbh'}); return; } =head2 S<$h-Erun($name,$arg,$ctx)> This method executes the macro with the specified argument list in a given context. =cut sub run { my ($slf, $nam, $arg, $ctx) = @_; my ($rec); $rec = $tb_fct{$nam}; return ($rec->[2] && exists($slf->{'_tgt'})) ? $slf->{'_ctl'}->switch_target($slf->{'_tgt'}, \&_run, $slf, $rec->[0], $rec->[1], $arg, $ctx) : _run($slf, $rec->[0], $rec->[1], $arg, $ctx); } sub _run { my ($slf, $fct, $typ, $arg, $ctx) = @_; my ($ret); return ($typ eq 'L') ? RDA::Value::List::new_from_data(&$fct($slf, $ctx, $arg->eval_as_array)) : defined($ret = &$fct($slf, $ctx, $arg->eval_as_array)) ? RDA::Value::Scalar->new($typ, $ret) : $VAL_UNDEF; } =head1 DATABASE MACROS =head2 S This macro transforms the argument for converting a null value into an empty string. It does not transform an undefined argument. =cut sub _m_allow_null { my ($slf, $ctx, $val) = @_; return defined($val) ? &{_get_nvl($slf, $ctx)}($val) : undef; } =head2 S This macro checks the data source name and returns a normalized string for password management. =cut sub _m_check_dsn { my ($slf, $ctx, $dsn, $dft) = @_; return check_dsn($dsn, $dft); } =head2 S This macro deletes the specified capture buffers. The capture buffer names are not case sensitive. It deletes all capture buffers when called without arguments. =cut sub _m_clear_buffer { my ($slf, $ctx, @arg) = @_; if (@arg) { foreach my $nam (@arg) { delete($slf->{'_buf'}->{lc($nam)}) if defined($nam); } } else { $slf->{'_buf'} = {}; } return 0; } =head2 S This macro clears all information associated with the specified table identifier. =cut sub _m_clear_columns { my ($slf, $ctx, $tid) = @_; delete($slf->{'_dsc'}->{$tid}) if $tid; return 0; } =head2 S This macro clears the last SQL result. =cut sub _m_clear_last { return shift->{'_sql'} = []; } =head2 S This macro returns how to concatenate the specified fields. It ignores invalid arguments. It returns an undefined value in the absence of valid arguments. =cut sub _m_concat { my ($slf, $ctx, @arg) = @_; my (@tbl); return (@tbl = grep {defined($_) && !ref($_)} @arg) ? &{_get_concat($slf, $ctx)}(@tbl) : undef; } =head2 S This macro encodes the specified characters in the specified columns. It replaces line feeds by C<%BR%>, and spaces by non-blanking spaces. When the first argument is an array reference, it includes the character list and the initial transformation. =cut sub _m_encode_columns { my ($slf, $ctx, $enc, $tid, @col) = @_; my ($dsc, $val); # Create the formating directive return 0 unless $tid && defined($val = _fmt_enc($slf, $ctx, $enc)); # Manage select list contributions foreach my $col (@col) { $slf->{'_dsc'}->{$tid}->{'col'}->{lc($col)} = sprintf($val, $col) if defined($col); } return 1; } =head2 S This macro encodes the specified characters in specified columns of one or more tables. It replaces line feeds by C<%BR%>, and spaces by non-blanking spaces. When the first argument is an array reference, it includes the character list and the initial transformation. =cut sub _m_encode_view { my ($slf, $ctx, $enc, @col) = @_; my ($val); # Create the formating directive return 0 unless defined($val = _fmt_enc($slf, $ctx, $enc)); # Manage select list contributions foreach my $col (@col) { $slf->{'_dsc'}->{$1}->{'col'}->{lc($2)} = sprintf($val, $col) if defined($col) && $col =~ m/^(\w+)\.(.*)$/; } return 1; } sub _fmt_enc { my ($slf, $ctx, $enc) = @_; my ($ref, $val); $ref = ref($enc); ($ref, $enc, $val) = (undef, @{$enc->eval_as_data(1)}) if $ref =~ m/^RDA::Value::(Array|List)$/; return unless !$ref && defined($enc) && length($enc); ## no critic (Unless) $val = q{%s} unless defined($val); foreach my $chr (unpack('c*', $enc)) { $val = ($chr == 10) ? sprintf(q{REPLACE(%s,%s,'%%%%BR%%%%')}, $val, &{_get_chr($slf, $ctx)}($chr)) : exists($tb_enc{$chr}) ? sprintf(q{REPLACE(%s,'%c','%s')}, $val, $chr, $tb_enc{$chr}) : sprintf(q{REPLACE(%s,'%c','&#%d;')}, $val, $chr, $chr); } return $val; } =head2 S This macro returns the list of data sources. =cut sub _m_get_sources { my ($slf, $ctx, $pat) = @_; return _get_dbh($slf, $ctx)->get_sources($pat); } =head2 S This macro returns the specified capture buffer or the hit buffer when the name is undefined. The capture buffer names are not case sensitive. Unless the flag is set, it assumes Wiki data. =cut sub _m_get_buffer { my ($slf, $ctx, $nam, $flg) = @_; return RDA::Object::Buffer->new($flg ? 'L' : 'l', defined($nam) ? $slf->{'_buf'}->{lc($nam)} : $slf->{'_hit'}); } =head2 S This macro returns the expression to transform the specified value in the corresponding character. It returns an undefined value when the argument is not an unsigned integer number. =cut sub _m_get_chr { my ($slf, $ctx, $chr) = @_; return (defined($chr) && $chr =~ m/^(\d+)$/) ? &{_get_chr($slf, $ctx)}($1) : undef; } =head2 S This macro determines if the specified columns are present in the table and generates the header string and the select list accordingly. You can provide specific headers or select contributions through the C, C and C macros. RDA supports predefined data types only unless an explicit select contribution or an extra conversion format is specified. You can manage the data types list with the C macro. When no columns are specified, all table columns are considered. This macro returns a list containing the corresponding header and select list. If the table is not found or if the query identifier is missing, then the header and select list are undefined. =cut sub _m_get_columns ## no critic (Complex) { my ($slf, $ctx, $tid, $obj, @arg) = @_; my ($col, $dsc, $hdr, $jus, $row, $str, $typ, @hdr, @sel, @tbl); # Get the table description and reject an unknown table return () unless $tid; $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid}); unless (exists($slf->{'_dsc'}->{$tid}->{'typ'})) { $dsc = _get_dbh($slf, $ctx)->describe($ctx, $obj); $slf->{'_dsc'}->{$tid}->{'row'} = $dsc->{'row'}; $slf->{'_dsc'}->{$tid}->{'typ'} = $dsc->{'typ'}; $slf->{'_dsc'}->{$tid}->{'nul'} = $dsc->{'nul'}; } $dsc = $slf->{'_dsc'}->{$tid}; return () unless (@{$row = $dsc->{'row'}}); # Generate the row $row = \@arg if @arg; foreach my $nam (@{$row}) { $col = lc($nam); # Reject unknown column next unless exists($dsc->{'typ'}->{$col}) && defined($typ = $dsc->{'typ'}->{$col}); # Determine how to justify the column $jus = exists($dsc->{'jus'}->{$col}) ? $dsc->{'jus'}->{$col} : exists($tb_jus{$typ}) ? $tb_jus{$typ} : 'R'; # Identify the header contribution if (exists($dsc->{'hdr'}->{$col})) { $hdr = $dsc->{'hdr'}->{$col}; } else { $hdr = qq{*$col*}; $hdr =~ s{_}{ }g; $hdr =~ s{\b([a-z])}{\U$1}g; $hdr = " $hdr" if $jus =~ m/L/; $hdr = "$hdr " if $jus =~ m/R/; } # Identify the select contribution $str = exists($dsc->{'col'}->{$col}) ? $dsc->{'col'}->{$col} : _desc_typ($slf, $ctx, $dsc, $col, $typ); next unless $str; $str = &{_get_nvl($slf, $ctx)}($str) if $dsc->{'nul'}->{$col}; $str = &{_get_concat($slf, $ctx)}(q{'}, qq{\n $str}, q{'}); $str =~ s/\s\n/\n/g; $str = " $str" if $jus =~ m/L/; $str = "$str " if $jus =~ m/R/; push(@sel, $str); push(@hdr, $hdr); } # Return the header and select strings return (scalar @sel) ? (q{|}.join(q{|}, @hdr).q{|}, q{'|}.join(q{|},@sel).q{|'}) : (); } sub _desc_typ { my ($slf, $ctx, $dsc, $col, $typ) = @_; my ($fmt); return exists($dsc->{'fmt'}->{$typ}) ? _replace($dsc->{'fmt'}->{$typ}, $col) : _desc_sel($slf, $ctx, $col, $typ); } sub _desc_sel { my ($slf, $ctx, $col, $typ) = @_; my ($fmt); foreach my $dia (_get_dbh($slf, $ctx)->get_dialects($ctx)) { if (exists($tb_typ{$dia}) && exists($tb_typ{$dia}->{$typ})) { $fmt = $tb_typ{$dia}->{$typ}; $fmt = &$fmt($slf, $ctx) if ref($fmt) eq 'CODE'; return _replace($fmt, $col) if defined($fmt); } } return q{}; } =head2 S This macro returns the description of the column as a list containing the column position, its type, and an indicator of possible NULL values. Column positions start from 1. Unless the flag is set, only eligible columns are considered. The list is empty when the column is not found. =cut sub _m_get_desc { my ($slf, $ctx, $tid, $col, $flg) = @_; my ($cnt, $dsc, $val); # Get the query entry return () unless $col && $tid && exists($slf->{'_dsc'}->{$tid}); $dsc = $slf->{'_dsc'}->{$tid}; # Validate the column $col = lc($col); return () unless exists($dsc->{'typ'}->{$col}) && defined($dsc->{'typ'}->{$col}); # Search for the column $cnt = 0; foreach my $nam (@{$dsc->{'row'}}) { # Identify the select contribution unless ($flg) { $val = exists($dsc->{'col'}->{$nam}) ? $dsc->{'col'}->{$nam} : _desc_typ($slf, $ctx, $dsc, $nam, $dsc->{'typ'}->{$nam}); next unless $val; } # Check the column ++$cnt; return ($cnt, $dsc->{'typ'}->{$col}, $dsc->{'nul'}->{$col}) if $col eq $nam; } # Indicate that the column has not been found return (); } =head2 S This macro returns the list of lines captured during the last C. =cut sub _m_get_hits { return @{shift->{'_hit'}}; } =head2 S This macro returns the elements to manage the user password and to connect to the database. The result list contains the credential type, the system identifier, the user name, the connection suffix, and the target context. =cut sub _m_get_info { my ($slf, $ctx) = @_; return @{_get_dbh($slf, $ctx)->get_connection}; } =head2 S This macro returns a range of the lines of the last SQL result. It assumes the first and last line as the default for the range definition. You can use negative line numbers to specify lines from the buffer end. =cut sub _m_get_lines { my ($slf, $ctx, $min, $max) = @_; my $buf; # Validate the range $buf = $slf->{'_sql'}; $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 : ($min < 0) ? $#$buf + $min + 1 : $min; $max = (!defined($max)) ? $#$buf : (($#$buf + $max) < -1) ? 0 : ($max < 0) ? $#$buf + $max + 1 : ($max > $#$buf) ? $#$buf : $max; # Return the line range return @{$buf}[$min..$max]; } =head2 S This macro returns the error message of the last SQL execution. If no error is detected, it returns C. =cut sub _m_get_message { my ($slf, $ctx) = @_; return _get_dbh($slf, $ctx)->get_message; } =head2 S This macro returns the name of the database provider of the current connection. It returns an undefined value in case of connection problems. =cut sub _m_get_provider { my ($slf, $ctx) = @_; return _get_dbh($slf, $ctx)->get_provider($ctx); } =head2 S This macro returns a reference to the current query target or an undefined value when no target is currently set. =cut sub _m_get_target { my ($slf) = @_; return exists($slf->{'_tgt'}) ? $slf->{'_tgt'} : undef; } =head2 S This macro returns the current duration of the SQL timeout. If this mechanism is disabled, it returns 0. =cut sub _m_get_timeout { my ($slf, $ctx) = @_; return _get_dbh($slf, $ctx)->get_timeout; } =head2 S This macro returns the database version of the current connection. It returns an undefined value in case of connection problems. =cut sub _m_get_version { my ($slf, $ctx) = @_; return _get_dbh($slf, $ctx)->get_version($ctx); } =head2 S This macro determines if the specified columns are present in the specified tables and generates the header string and the select list accordingly. All tables are defined through a hash where the keys are the table identifiers, which are also prefixing the column names and used as alias in the from clause. You can provide specific headers or select contributions through the C, C, and C macros. RDA supports predefined data types only unless an explicit select contribution or an extra conversion format is specified. You can manage the data types list with the C macro. You can specify pseudo columns as hash references, for specifying counts, date, numeric, or string expressions. The hash supports the following keys: =over 10 =item B< 'col' > Column name =item B< 'hdr' > Column heading =item B< 'fct' > Function: C, C, C, C, C, or C =item B< 'nul' > NULL indicator =item B< 'tid' > Table identifier =item B< 'val' > Value =back This macro returns a list containing the corresponding header and select list. If the table is not found or if the query identifier is missing, then the header and select list are undefined. =cut sub _m_get_view ## no critic (Complex) { my ($slf, $ctx, $hsh, @arg) = @_; my ($col, $dsc, $hdr, $jus, $nul, $ref, $str, $typ, @hdr, @sel, @tbl); # Get the table descriptions and reject unknown tables return () unless ref($hsh) =~ m/^RDA::Value::(Assoc|Hash)$/; foreach my $tid (keys(%{$hsh = $hsh->eval_as_data(1)})) { $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid}); unless (exists($slf->{'_dsc'}->{$tid}->{'typ'})) { $dsc = _get_dbh($slf, $ctx)->describe($ctx, $hsh->{$tid}); $slf->{'_dsc'}->{$tid}->{'row'} = $dsc->{'row'}; $slf->{'_dsc'}->{$tid}->{'typ'} = $dsc->{'typ'}; $slf->{'_dsc'}->{$tid}->{'nul'} = $dsc->{'nul'}; } return () unless (@{$slf->{'_dsc'}->{$tid}->{'row'}}); } # Generate the row foreach my $arg (@arg) { # Normalize the argument $ref = ref($arg); if ($ref =~ m/^RDA::Value::(Assoc|Hash)$/) { $arg = $arg->eval_as_data(1); next unless defined($arg->{'fct'}); } else { next if $ref || !defined($arg) || $arg !~ m/^(\w+)\.(.*)$/; $arg = {fct => 'SEL', tid => $1, col => $2, sel => $arg}; } # Treat the argument if ($arg->{'fct'} eq 'SEL') { my ($tid); # Reject an unknown column next unless exists($arg->{'tid'}) && exists($arg->{'col'}); $col = lc($arg->{'col'}); $dsc = $slf->{'_dsc'}->{$tid = $arg->{'tid'}}; next unless exists($dsc->{'typ'}->{$col}) && defined($typ = $dsc->{'typ'}->{$col}); # Determine how to justify the column $jus = exists($dsc->{'jus'}->{$col}) ? $dsc->{'jus'}->{$col} : exists($tb_jus{$typ}) ? $tb_jus{$typ} : 'R'; # Identify the header contribution if (exists($arg->{'hdr'})) { $hdr = $arg->{'hdr'}; } elsif (exists($dsc->{'hdr'}->{$col})) { $hdr = $dsc->{'hdr'}->{$col}; } else { $hdr = qq{*$col*}; $hdr =~ s{_}{ }g; $hdr =~ s{\b([a-z])}{\U$1}g; $hdr = " $hdr" if $jus =~ m/L/; $hdr = "$hdr " if $jus =~ m/R/; } # Identify the select contribution $nul = $dsc->{'nul'}->{$col}; $str = exists($dsc->{'col'}->{$col}) ? $dsc->{'col'}->{$col} : _desc_typ($slf, $ctx, $dsc, qq{$tid.$col}, $typ); } elsif ($arg->{'fct'} eq 'CNT') { my ($tid); # Reject an unknown column next unless exists($arg->{'tid'}) && exists($arg->{'col'}); $col = lc($arg->{'col'}); $dsc = $slf->{'_dsc'}->{$tid = $arg->{'tid'}}; next unless exists($dsc->{'typ'}->{$col}) && defined($typ = $dsc->{'typ'}->{$col}); # Determine how to justify the column $jus = 'L'; # Identify the header contribution if (exists($arg->{'hdr'})) { $hdr = $arg->{'hdr'}; } else { $hdr = qq{ *$col Count*}; $hdr =~ s{_}{ }g; $hdr =~ s{\b([a-z])}{\U$1}g; } # Identify the select contribution $nul = $dsc->{'nul'}->{$col}; $str = _desc_sel($slf, $ctx, qq{COUNT($tid.$col)}, 'number'); } elsif (exists($tb_vie{$arg->{'fct'}})) { my ($fmt); next unless exists($arg->{'val'}) && exists($arg->{'hdr'}); # When requested, reject an unknown column if (exists($arg->{'tid'}) && exists($arg->{'col'})) { $col = lc($arg->{'col'}); $dsc = $slf->{'_dsc'}->{$arg->{'tid'}}; next unless exists($dsc->{'typ'}->{$col}) && defined($typ = $dsc->{'typ'}->{$col}); } # Determine how to justify the column ($jus, $typ, $fmt) = @{$tb_vie{$arg->{'fct'}}}; # Identify the header contribution $hdr = $arg->{'hdr'}; # Identify the select contribution $nul = $arg->{'nul'}; $str = _desc_sel($slf, $ctx, defined($fmt) ? sprintf($fmt, $arg->{'val'}) : $arg->{'val'}, $typ); } else { $str = undef; } # Add the column contributions next unless $str; $str = &{_get_nvl($slf, $ctx)}($str) if $nul; $str = &{_get_concat($slf, $ctx)}(q{'}, qq{\n $str}, q{'}); $str =~ s/\s\n/\n/g; $str = " $str" if $jus =~ m/L/; $str = "$str " if $jus =~ m/R/; push(@sel, $str); push(@hdr, $hdr); } # Return the header and select strings return (scalar @sel) ? (q{|}.join(q{|}, @hdr).q{|}, q{'|}.join(q{|},@sel).q{|'}) : (); } =head2 S This macro returns the list of available drivers. =cut sub _m_get_drivers { return (sort values(%{shift->{'_dbi'}})); } =head2 S This macro returns the lines of the last SQL result that match the regular expression. It supports the same options as C. =cut sub _m_grep_last { my ($slf, $ctx, $re, $opt) = @_; return _grep_buffer($slf->{'_sql'}, $re, $opt); } =head2 S This macro returns the lines that match the regular expression. The following options are supported: =over 9 =item B< 'f' > Stops scanning on the first match. =item B< 'i' > Ignores case distinctions in both the pattern and the results. =item B< 'v' > Inverts the sense of matching to select non-matching lines. =item B< (n) > Returns the (n)th capture buffer instead of the line. =back =cut sub _m_grep_db { my ($slf, $ctx, $sql, $pat, $opt) = @_; my ($flg, $inv, $one, $pos, @tbl); # Determine the options $opt = q{} unless defined($opt); $one = index($opt, 'f') >= 0; $pat = RDA::Object::View->is_match($pat, index($opt, 'i') < 0); $inv = index($opt, 'v') >= 0; $pos = ($opt =~ m/(\d+)/) ? $1 : 0; # Check the SQL output _get_dbh($slf, $ctx)->execute($ctx, $sql, 1, \&_grep_db, [$pat, \@tbl, $inv, $one, $pos]) if $pat; return @tbl; } sub _grep_db { my ($dbh, $rec, $lin) = @_; # Interrupt when a SQL error is encountered die get_string('ERR_SQL') if $lin =~ $ERR && $dbh->get_target->is_fatal; # Check if the line matches the pattern if ($rec->[2] xor $lin =~ $rec->[0]) { $lin = eval "\$$rec->[4]" if $rec->[4]; ## no critic (Eval) push(@{$rec->[1]}, $lin); return $rec->[3]; } # Continue the search return 0; } =head2 S This macro returns the lines of the specified capture buffer that match the regular expression. It supports the same options as C. =cut sub _m_grep_buffer { my ($slf, $ctx, $nam, $re, $opt) = @_; return () unless defined($nam) && exists($slf->{'_buf'}->{$nam = lc($nam)}); return _grep_buffer($slf->{'_buf'}->{$nam}, $re, $opt); } sub _grep_buffer { my ($buf, $pat, $opt) = @_; my ($inv, $one, $pos, @tbl); if ($pat) { # Determine the options $opt = q{} unless defined($opt); $one = index($opt, 'f') >= 0; $pat = RDA::Object::View->is_match($pat, index($opt, 'i') < 0); $inv = index($opt, 'v') >= 0; $pos = ($opt =~ m/(\d+)/) ? $1 : 0; # Check the last SQL result foreach my $lin (@{$buf}) { if ($inv xor $lin =~ $pat) { $lin = eval "\$$pos" if $pos; ## no critic (Eval) push(@tbl, $lin); last if $one; } } } return @tbl; } =head2 S This macro indicates whether the database connections are enabled. =cut sub _m_is_enabled { my ($slf, $ctx) = @_; eval {_get_dbh($slf, $ctx)}; return $@ ? $@ : $slf->{'_cur'}->is_enabled ? 1 : 0; } =head2 S This macro indicates whether a driver is available for the specified database type. =cut sub _m_is_available { my ($slf, $ctx, $typ) = @_; return exists($slf->{'_dbi'}->{lc($typ)}) ? $slf->{'_dbi'}->{lc($typ)} : undef; } =head2 S This macro loads the output of the SQL statement as the last SQL result. It clears the previous result unless the flag is set. It returns 1 for a successful completion. If the execution time exceeds the limit or if the maximum number of attempts has been reached, then it returns 0. It is possible to increase the execution limit by specifying an increasing factor as an argument. A negative value disables any timeout. Only lines between C<___Cut___> lines are inserted in the last SQL result. =cut sub _m_load_db { my ($slf, $ctx, $sql, $flg, $inc) = @_; $slf->{'_sql'} = [] unless $flg; return _get_dbh($slf, $ctx)->execute($ctx, $sql, $inc, \&_load_db, [$ctx, $slf->{'_sql'}]); } sub _load_db { my ($dbh, $rec, $lin) = @_; # Interrupt when a SQL error is encountered die get_string('ERR_SQL') if $lin =~ $ERR && $dbh->get_target->is_fatal; # Save the line in the last SQL result push(@{$rec->[1]}, $lin); # Continue the result processing return 0; } =head2 S This macro returns a list containing a normalized description of the source as used to manage credentials. =cut sub _m_norm_source { my ($slf, $ctx, $typ, $src, $usr) = @_; return norm_credential($typ, $src, $usr); } =head2 S This macro resets the remaining alarm time to the SQL timeout value. To allow more time for executing statements, you can specify a factor as an argument. 1 is the default. For a positive value, the maximum execution time is obtained by multiplying the SQL timeout value by this factor. Otherwise, it disables the alarm mechanism. The effective value is returned. =cut sub _m_reset_timeout { my ($slf, $ctx, $inc) = @_; return _get_dbh($slf, $ctx)->reset_timeout($inc); } =head2 S This macro specifies the select list contribution for one or more columns. An undefined value deletes an existing contribution. When no columns are specified, all previous declarations are deleted. =cut sub _m_set_columns { my ($slf, $ctx, $tid, @arg) = @_; my ($dsc, $key, $val); # Get the query entry return 0 unless $tid; $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid}); $dsc = $slf->{'_dsc'}->{$tid}; # Manage select list contributions if (@arg) { while (($key, $val) = splice(@arg, 0, 2)) { if (defined($val)) { $dsc->{'col'}->{lc($key)} = $val; } else { delete($dsc->{'col'}->{lc($key)}); } } } else { delete($dsc->{'col'}); } return 1; } =head2 S This macro specifies the header contribution for one or more columns. The justification is deduced from the presence of leading and/or trailing spaces. An undefined value deletes an existing contribution. When no columns are specified, all previous declarations are removed. =cut sub _m_set_header { my ($slf, $ctx, $tid, @arg) = @_; my ($dsc, $key, $val); # Get the query entry return 0 unless $tid; $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid}); $dsc = $slf->{'_dsc'}->{$tid}; # Manage header contributions if (@arg) { while (($key, $val) = splice(@arg, 0, 2)) { $key = lc($key); if (defined($val)) { $dsc->{'hdr'}->{$key} = $val; $dsc->{'jus'}->{$key} = ($val =~ m/^\s+\*/ ? 'L' : q{}) .($val =~ m/\*\s+$/ ? 'R' : q{}); } else { delete($dsc->{'hdr'}->{$key}); delete($dsc->{'jus'}->{$key}); } } } else { delete($dsc->{'hdr'}); delete($dsc->{'jus'}); } return 1; } =head2 S This macro switches the database context to the specified target. It returns a reference to the previous target. =cut sub _m_set_target { my ($slf, $ctx, $tgt) = @_; my ($cls, $old, $ref); # Reset the context $old = _clr_dbh($slf); # Assign the new target and store any provided password $ref = ref($tgt); if ($ref =~ m/^RDA::Target::Dbi?$/) { $slf->{'_tgt'} = $tgt; } elsif ($ref eq 'RDA::Object::Item') { $cls = $tgt->get_first('W_CLASS', q{}); die get_string('BAD_ITEM', $cls) unless $cls =~ m/^[DS]Q$/; $slf->{'_tgt'} = _set_target($slf, $tgt); } elsif ($ref eq 'RDA::Value::Assoc') { $slf->{'_tgt'} = _set_target($slf, 'DQ_TMP$$', ## no critic (Interpolation) $tgt->eval_as_data(1)); } elsif ($ref eq 'HASH') { $slf->{'_tgt'} = _set_target($slf, 'DQ_TMP$$', ## no critic (Interpolation) $tgt); } elsif (defined($tgt)) { die get_string('BAD_TARGET', $tgt); } # Return a reference to the previous target return $old; } sub _set_target { my ($slf, @def) = @_; my ($tgt); eval {$tgt = $slf->{'_ctl'}->add_target(@def)}; return $@ ? $slf->{'_ctl'}->add_bad('DQ', $slf->{'_msg'} = $@) : $tgt; } =head2 S This macro sets the SQL timeout, specified in seconds, only if the value is greater than zero. Otherwise, the timeout mechanism is disabled. It is disabled also if the alarm function is not implemented. It returns the effective value. =cut sub _m_set_timeout { my ($slf, $ctx, $val) = @_; return $slf->{'_lim'} = _get_dbh($slf, $ctx)->set_timeout($val); } =head2 S This macro specifies how to format data types. You can use an empty string to reject a predefined data type. An undefined value deletes an existing declaration. When no types are specified, all previous declarations are deleted. =cut sub _m_set_type { my ($slf, $ctx, $tid, @arg) = @_; my ($dsc, $key, $val); # Get the query entry return 0 unless $tid; $slf->{'_dsc'}->{$tid} = {} unless exists($slf->{'_dsc'}->{$tid}); $dsc = $slf->{'_dsc'}->{$tid}; # Manage select list contributions if (@arg) { while (($key, $val) = splice(@arg, 0, 2)) { if (defined($val)) { $dsc->{'fmt'}->{uc($key)} = $val; } else { delete($dsc->{'fmt'}->{uc($key)}); } } } else { delete($dsc->{'fmt'}); } return 1; } =head2 S This macro specifies the select list contribution for columns in one or more tables. An undefined value deletes an existing contribution. =cut sub _m_set_view { my ($slf, $ctx, @arg) = @_; my ($col, $val); while (($col, $val) = splice(@arg, 0, 2)) { next unless defined($col) && $col =~ m/^(\w+)\.(.*)$/; if (defined($val)) { $slf->{'_dsc'}->{$1}->{'col'}->{lc($2)} = $val; } else { delete($slf->{'_dsc'}->{$1}->{'col'}->{lc($2)}); } } return 1; } =head2 S This macro tests the database connection. Unless the flag is set, it performs the test once. In case of problems, it disables further access. =cut sub _m_test_db { my ($slf, $ctx, $flg) = @_; my ($dbh, $val); eval {$dbh = _get_dbh($slf, $ctx)}; return $@ ? $@ : defined($val = $slf->{'_cur'}->is_tested($flg)) ? $val : $dbh->test($ctx); } =head2 S This macro writes a line range from the last SQL result to the report file. It assumes the first and last line as the default respectively for the range definition. You can use negative line numbers to specify lines from the buffer end. It returns 1 for a successful completion. Otherwise, it returns 0. =cut sub _m_write_last { my ($slf, $ctx, $arg, @arg) = @_; my ($rpt); return (ref($arg) =~ $RPT) ? _s_write_last($slf, $ctx, $arg, @arg) : ($rpt = $ctx->get_report) ? _s_write_last($slf, $ctx, $rpt, $arg, @arg) : 0; } sub _s_write_last { my ($slf, $ctx, $rpt, $min, $max) = @_; my ($buf, $rec); # Validate the range $buf = $slf->{'_sql'}; $min = (!defined($min) || ($#$buf + $min) < -1) ? 0 : ($min < 0) ? $#$buf + $min + 1 : $min; $max = (!defined($max)) ? $#$buf : (($#$buf + $max) < -1) ? 0 : ($max < 0) ? $#$buf + $max + 1 : $max; $rec = [$ctx, $rpt, undef, 0]; foreach my $lin (@{$buf}[$min..$max]) { return 0 if _write_db($slf, $rec, $lin); } return 1; } =head2 S This macro writes the output of the SQL statements in the report file. The request job is composed of following directives: =over 4 =item * C<#CALL EnameE(EnE)> It executes the specified macro before treating the next directive. =item * C<#CAPTURE EnameE> It copies the following lines in the named capture buffer. It clears the capture buffer unless its name is in lower case. =item * C<#CAPTURE ONLY EnameE> It removes the following lines from the result flow and add them in the named capture buffer. It clears the capture buffer unless its name is in lower case. =item * C<#CUT> It inserts a C<___Cut___> line in the result flow. =item * C<#ECHO EstrE> It inserts the string as a line in the result flow. =item * C<#END> It disables any previous line capture. =item * C<#EXIT> It disconnects from the database and aborts the job. =item * C<#LONG(EnE)> It indicates the maximum length of C type fields that the driver can read. It resets the default length at job completion. =item * C<#MACRO EnameE(EnE)> It inserts a C<___Macro_EnameE(EnumE)___> line in the result flow. Those lines are replaced by the execution of the specified macro with CnumE> as an argument. A positive return value resets the alarm. =item * C<#PLSQL> or C<#PLSQLEnE> It extract all lines until it finds a C line. It considers them as a PL/SQL block and inserts its output in the result flow. A number can be included in the directive to better locate instructions causing timeouts. =item * C<#QUIT> It disconnects from the database and aborts the job. =item * C<#SLEEP(EnE)> It creates a suspension for the specified number of seconds. =item * C<#SQL> or C<#SQLEnE> It extract all lines until it finds a C line. It considers these lines as a SQL statement and inserts its result in the result flow. A number can be included in the directive to better locate instructions causing timeouts. =back Only lines between C<___Cut___> lines are inserted in the report file. It is possible to increase the execution limit by specifying an increasing factor as an argument. A negative value disables timeout. It returns 1 for a successful completion. If the execution time exceeds the limit or if the maximum number of attempts has been reached, it returns 0. =cut sub _m_write_db { my ($slf, $ctx, $arg, @arg) = @_; my ($rpt); return (ref($arg) =~ $RPT) ? _s_write_db($slf, $ctx, $arg, @arg) : ($rpt = $ctx->get_report) ? _s_write_db($slf, $ctx, $rpt, $arg, @arg) : 0; } sub _s_write_db { my ($slf, $ctx, $rpt, $sql, $inc, @arg) = @_; my ($dbh, $tbl); # Get the regular expressions foreach my $str (@arg) { next unless defined($str); $tbl = [] unless ref($tbl); push(@{$tbl}, RDA::Object::View->is_pattern($str)); } # Execute the SQL statement $dbh = _get_dbh($slf, $ctx); return $dbh->execute($ctx, $sql, $inc, \&_write_db, [$ctx, $rpt, undef, $slf->{'_frk'} ? $dbh->use_alarm($inc) : 0, $tbl, $slf->{'_hit'} = [], $slf->{'_buf'}]); } sub _write_db ## no critic (Complex) { my ($dbh, $rec, $lin) = @_; if ($lin =~ $MAC) { my ($blk, $val); # Suspend alarm $dbh->{'dur'} = $rec->[3] ? clear_alarm() + 1 : 0; # Execute a macro $blk = $1 ? $rec->[0]->get_current : $rec->[0]; $val = new_number($3); $val = RDA::Value::List->new($val); $val = $blk->define_operator([$2, '.macro.'], $blk, $2, $val); eval { $val = $val->eval_as_number; $dbh->reset_timeout($val) if $rec->[3] && $val > 0; }; # Must clear it, to execute a prefix block on next write $rec->[2] = undef; # Restart the alarm when suspended alarm($dbh->{'dur'}) if $dbh->{'dur'}; } elsif ($lin =~ $ERR && $dbh->get_target->is_fatal) { # Generate a SQL error die get_string('ERR_SQL'); } elsif ($lin =~ $BUF) { $rec->[7] = lc($2); $rec->[8] = $1; $rec->[6]->{$rec->[7]} = [] unless $2 eq $rec->[7]; } elsif ($lin eq $EOC) { $rec->[7] = $rec->[8] = undef; } elsif ($rec->[8]) { push(@{$rec->[6]->{$rec->[7]}}, $lin); } else { my ($lim); # Get the report file handle, with the alarm suspended unless ($rec->[2]) { $lim = $rec->[3] ? clear_alarm() + 1 : 0; $rec->[2] = $rec->[1]->get_handle; set_alarm($lim) if $lim; } # Write the line to the report file $rec->[1]->write("$lin\n"); if ($rec->[4]) { foreach my $re (@{$rec->[4]}) { if ($lin =~ $re) { push(@{$rec->[5]}, $lin); last; } } } push(@{$rec->[6]->{$rec->[7]}}, $lin) if $rec->[7]; } # Continue the result processing return 0; } # --- Database handle management routines ------------------------------------- # Release the database handle sub _clr_dbh { my ($slf) = @_; my ($dbh, $rec); if (defined($dbh = delete($slf->{'_dbh'}))) { # Get the database handle contribution $rec = $dbh->get_usage; # Increment the couters $slf->{'_req'} += $rec->{'req'}; $slf->{'_err'} += $rec->{'err'}; $slf->{'_out'} += $rec->{'out'}; $slf->{'_skp'} += $rec->{'skp'}; # Manage the note if (exists($rec->{'not'})) { $slf->{'_not'} = $rec->{'not'}; } elsif (!exists($slf->{'_not'}) && $rec->{'_lim'} > 0) { $slf->{'_not'} = 'SQL execution limited to '.$rec->{'_lim'}.'s' } # Clear the function cache delete($slf->{'_cat'}); delete($slf->{'_chr'}); delete($slf->{'_nvl'}); # Delete the database handle $dbh->delete_object; } delete($slf->{'_cur'}); return delete($slf->{'_tgt'}); } # Get the database handle sub _get_dbh { my ($slf, $ctx) = @_; my ($cur); # Create a database handle on first use _set_dbh($slf, $ctx, $slf->{'_ctl'}->get_current) unless exists($slf->{'_dbh'}); # Detect an explicit target use return $slf->{'_dbh'} if exists($slf->{'_tgt'}); # Detect a target change $cur = $slf->{'_ctl'}->get_current; return $slf->{'_dbh'} if $cur == $slf->{'_cur'}; return _set_dbh($slf, $ctx, $cur); } # Define a database handle sub _set_dbh { my ($slf, $ctx, $tgt) = @_; my ($typ); # Clear the function cache delete($slf->{'_cat'}); delete($slf->{'_chr'}); delete($slf->{'_nvl'}); # Validate the target class $typ = ref($tgt); die get_string('BAD_CLASS', $typ) unless $typ =~ m/^RDA::Target::Dbi?$/; # Validate the target type $typ = lc($tgt->get_info('typ', 'oracle')); return $slf->{'_dbh'} = RDA::Driver::Jdbc->new($slf->{'_col'}, $slf->{'_cur'} = $tgt, $ctx) if $typ eq 'jdbc'; return $slf->{'_dbh'} = RDA::Driver::Dbd->new($slf->{'_dbi'}->{$typ}, $slf->{'_col'}, $slf->{'_cur'} = $tgt) if exists($slf->{'_dbi'}->{$typ}); return $slf->{'_dbh'} = RDA::Driver::Sqlplus->new($slf->{'_col'}, $slf->{'_cur'} = $tgt) if $typ eq q{+} || $typ eq 'oracle'; return $slf->{'_dbh'} = RDA::Driver::WinOdbc->new($slf->{'_col'}, $slf->{'_cur'} = $tgt) if $typ eq q{-} || $typ eq 'odbc'; die get_string('BAD_TYPE', $typ); } # --- Internal routines ------------------------------------------------------- # Get the concatenation function sub _get_concat { my ($slf, $ctx) = @_; return $slf->{'_cat'} if exists($slf->{'_cat'}); foreach my $dia (_get_dbh($slf, $ctx)->get_dialects($ctx)) { return $slf->{'_cat'} = $tb_cat{$dia} if exists($tb_cat{$dia}); } return $slf->{'_cat'} = $tb_cat{q{?}}; } # Get the CHR function sub _get_chr { my ($slf, $ctx) = @_; return $slf->{'_chr'} if exists($slf->{'_chr'}); foreach my $dia (_get_dbh($slf, $ctx)->get_dialects($ctx)) { return $slf->{'_chr'} = $tb_chr{$dia} if exists($tb_chr{$dia}); } return $slf->{'_chr'} = $tb_chr{q{?}}; } # Get the date function sub _get_date_fmt { my ($slf, $ctx) = @_; return _get_dbh($slf, $ctx)->get_date_fmt(_get_concat($slf, $ctx)); } # Get the NVL function sub _get_nvl { my ($slf, $ctx) = @_; return $slf->{'_nvl'} if exists($slf->{'_nvl'}); foreach my $dia (_get_dbh($slf, $ctx)->get_dialects($ctx)) { return $slf->{'_nvl'} = $tb_nvl{$dia} if exists($tb_nvl{$dia}); } return $slf->{'_nvl'} = $tb_nvl{q{?}}; } # Replace all occurrences of %s sub _replace { my ($str, $val) = @_; $str =~ s/\%s/$val/g; return $str; } 1; __END__ =head1 SEE ALSO L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L, L =head1 COPYRIGHT NOTICE Copyright (c) 2002, 2016, Oracle and/or its affiliates. All rights reserved. =head1 TRADEMARK NOTICE Oracle and Java are registered trademarks of Oracle and/or its affiliates. Other names may be trademarks of their respective owners. =cut