# IBM_PROLOG_BEGIN_TAG # This is an automatically generated prolog. # # # # Licensed Materials - Property of IBM # # (C) COPYRIGHT International Business Machines Corp. 2003,2019 # All Rights Reserved # # US Government Users Restricted Rights - Use, duplication or # disclosure restricted by GSA ADP Schedule Contract with IBM Corp. # # IBM_PROLOG_END_TAG # -*- perl -*- # # DBD::RSCT - A DBI driver to access RMC classes through the RMC API commands # or System Registry tables through SR API commands. # # SYNOPSIS # use DBI; # my @dataSources = DBI->data_sources( $driver ); # $dbh = DBI->connect("DBI:RSCT:dbn=IBM") # or die "Cannot connect: " . $DBI::errstr; # $dbh->do("INSERT INTO Host (Name, NumProcessors) VALUES ('Host1', 1)") # or die "Cannot do: " . $DBI::errstr; # $sth = $dbh->prepare("SELECT * FROM Node") # or die "Cannot prepare: " . $dbh->errstr(); # $sth->execute() or die "Cannot execute: " . $sth->errstr(); # # $sth->finish(); # $dbh->disconnect(); # # The db name and table name will be mapped to an RMC resource class/SR table # concatenating the 2 with a dot or / between them. In the example above, the # resource class IBM.Node would be accessed. # # The SQL statements supported are: # SELECT: # - multiple column names are supported # - column names are always case sensitive (also in the WHERE clause) # - only 1 table name is supported # - WHERE is supported as follows: # - all the relational and logical operators are supported # - LIKE and IN are supported # - BETWEEN is not supported # - ORDER BY is not supported # - fetchrow_hashref() is supported in addition to the other fetch* and # select* calls # INSERT: # -one row at a time can be inserted # -only one table name is supported # -bind_param not supported # UPDATE: # -select string has to be provided # DELETE: # -select string has to be provided # CREATE: # -create a table in the System Registry. Tables cannot be created in /IBM # directory. /IBM is reserved for RMC resource classes # DROP: # -delete a table from System Registry. Tables from /IBM cannot be deleted # using this. # # DBD::RSCT uses DBD::Parser, a perl module for Parsing the SQL statements # # @(#)69 1.4 src/rsct/dbi/DBD/RSCT.pm.perl, dbi, rsct_rady, rady2035a 4/23/03 10:36:25 require 5.004; use strict; require DynaLoader; require DBI; use DBD::Parser; package DBD::RSCT; use vars qw(@ISA $VERSION $drh $err $errstr $sqlstate); BEGIN { if ($ENV{'RSCT_DBD_VERBOSE'}) { $::VERBOSE = 1; } } @ISA = qw(DynaLoader); $VERSION = '0.1'; $err = 0; # holds error code for DBI::err $errstr = ""; # holds error string for DBI::errstr $sqlstate = ""; # holds error state for DBI::state $drh = undef; # holds driver handle once initialised sub hello { print "Hello from DBD::RSCT!\n"; } sub driver ($;$) { my($class, $attr) = @_; #print "In DBD::RSCT->driver()...\n"; # I think all the evals are here to enable subclassing from the class. # We can probably do something simpler like: # return $drh if $drh; # $drh = DBI::_new_drh($class . "::dr", { # 'Name' => 'RSCT', # 'Version' => $VERSION, # 'Err' => \$DBD::RSCT::err, # 'Errstr' => \$DBD::RSCT::errstr, # 'State' => \$DBD::RSCT::state, # 'Attribution' => 'DBD::RSCT by Bruce Potter', # }); my $drh = eval '$' . $class . "::drh"; if (!$drh) { if (!$attr) { $attr = {} }; if (!exists($attr->{Attribution})) { $attr->{Attribution} = "$class by Bruce Potter"; } if (!exists($attr->{Version})) { $attr->{Version} = eval '$' . $class . '::VERSION'; } if (!exists($attr->{Err})) { $attr->{Err} = eval '\$' . $class . '::err'; } if (!exists($attr->{Errstr})) { $attr->{Errstr} = eval '\$' . $class . '::errstr'; } if (!exists($attr->{State})) { $attr->{State} = eval '\$' . $class . '::state'; } if (!exists($attr->{Name})) { my $c = $class; $c =~ s/^DBD\:\://; $attr->{Name} = $c; } $drh = DBI::_new_drh($class . "::dr", $attr); } $drh; } package DBD::RSCT::dr; # ====== DRIVER ====== $DBD::RSCT::dr::imp_data_size = 0; sub connect ($$;$$$) { my($drh, $dbname, $user, $auth, $attr)= @_; #print "In DBD::RSCT::dr->connect()...\n"; # create a 'blank' dbh my $this = DBI::_new_dbh($drh, { 'Name' => $dbname, 'USER' => $user, 'CURRENT_USER' => $user, }); # process the attributes passed in the dbname in the form "var1=val1;..." if ($this) { my($var, $val); while (length($dbname)) { if ($dbname =~ s/^((?:[^\\;]|\\.)*?);//s) { $var = $1; } else { $var = $dbname; $dbname = ''; } if ($var =~ /^(.+?)=(.*)/s) { $var = $1; ($val = $2) =~ s/\\(.)/$1/g; # the DBI::DBD man page says we should instead use: $dbh->STORE($var, $val); $this->{$var} = $val; } } } $this->{dbn} =~ s/^\/|\/$//g; #remove any starting and ending / $this; } # Supposed to return a list of databases available through this driver sub data_sources ($;$) { my($drh, $attr) = @_; my $cmd = "/usr/bin/lssr-api -R '' | /bin/grep '\/\$' | /bin/sort | /usr/bin/uniq 2>&1"; my @dsns; chop(@dsns=`$cmd`); my $i; for($i = 0; $i < @dsns; $i++) {$dsns[$i] = "DBI:RSCT:dbn=$dsns[$i]"; } @dsns; } sub disconnect_all { } sub DESTROY { undef; } package DBD::RSCT::db; # ====== DATABASE ====== $DBD::RSCT::db::imp_data_size = 0; my $parser; sub prepare ($$;@) { my($dbh, $statement, @attribs)= @_; #print "In DBD::RSCT::db->prepare(): dbn=$dbh->{dbn}.\n"; # create a 'blank' dbh my $sth = DBI::_new_sth($dbh, {'Statement' => $statement}); #print "statement=$sth->{'Statement'}.\n"; if ($sth) { $@ = ''; if ($::VERBOSE) { print "SQL statement = $statement.\n"; } # SQL::Statement does not handle the where clause well, so split it out my ($shortstmt, $wherestr) = &separateWhereStr($statement); my $rmcORsr = &isRMCorSR($sth); $sth->STORE('rmc_wherestr', $wherestr); #$sth->STORE('rmc_stmtstr', $statement); # this is done above in DBI::_new_sth() $sth->STORE('rmc_params', []); #$sth->STORE('NUM_OF_PARAMS', scalar($stmt->params())); $sth->STORE('rmc_or_sr', $rmcORsr); $sth->STORE('rmc_shortstmt', $shortstmt); } $sth; } # Separate the where clause from the rest of the stmt sub separateWhereStr { my $stmtstr = shift; my ($shortstmt, $wherestr) = split(/\sWHERE\s/i, $stmtstr); if (defined($wherestr)) { $wherestr =~ s/\sORDER\sBY\s.+$//i; } # strip off any ORDER BY clause return ($shortstmt, $wherestr); } sub isRMCorSR { my ($sth) = @_; my $isRMC; my $chkdbn = $sth->{Database}->{dbn}; if ($chkdbn =~ /^IBM$|^\/IBM$|^IBM\/$|^\/IBM\/$/) { if ($::VERBOSE) { print "RMC Query\n";} $isRMC = 1; #is a RMC resouce class } else { if ($::VERBOSE) { print "SR Query\n";} $isRMC = 0;# is a SR table } return $isRMC; } sub disconnect ($) { 1; } sub FETCH ($$) { my ($dbh, $attrib) = @_; if ($attrib eq 'AutoCommit') { return 1; } elsif ($attrib eq (lc $attrib)) { # Driver private attributes are lower cased return $dbh->{$attrib}; } # else pass up to DBI to handle return $dbh->DBD::_::db::FETCH($attrib); } sub STORE ($$$) { my ($dbh, $attrib, $value) = @_; if ($attrib eq 'AutoCommit') { return 1 if $value; # is already set die("Can't disable AutoCommit"); } elsif ($attrib eq (lc $attrib)) { # Driver private attributes are lower cased $dbh->{$attrib} = $value; return 1; } return $dbh->DBD::_::db::STORE($attrib, $value); } sub DESTROY ($) { undef; } # The most important thing this function does is to put a backslash in front # single quotes. (The default DBI implementation of quote() uses a 2nd single # quote instead of a backslash.) sub quote ($$;$) { my($self, $str, $type) = @_; if (defined($type) && ($type == DBI::SQL_NUMERIC() || $type == DBI::SQL_DECIMAL() || $type == DBI::SQL_INTEGER() || $type == DBI::SQL_SMALLINT() || $type == DBI::SQL_FLOAT() || $type == DBI::SQL_REAL() || $type == DBI::SQL_DOUBLE() || $type == DBI::TINYINT())) { return $str; } if (!defined($str)) { return "NULL" } $str =~ s/\\/\\\\/sg; $str =~ s/\0/\\0/sg; $str =~ s/\'/\\\'/sg; $str =~ s/\n/\\n/sg; $str =~ s/\r/\\r/sg; "'$str'"; } sub commit ($) { my($dbh) = shift; if ($dbh->FETCH('Warn')) { warn("Commit ineffective while AutoCommit is on", -1); } 1; } sub rollback ($) { my($dbh) = shift; if ($dbh->FETCH('Warn')) { warn("Rollback ineffective while AutoCommit is on", -1); } 0; } package DBD::RSCT::st; # ====== STATEMENT ====== $DBD::RSCT::st::imp_data_size = 0; sub bind_param ($$$;$) { my($sth, $pNum, $val, $attr) = @_; $sth->{rmc_params}->[$pNum-1] = $val; 1; } sub execute { my $sth = shift; my $params; if (@_) { $sth->{'rmc_params'} = ($params = [@_]); } else { $params = $sth->{'rmc_params'}; } my $stmtcmd = DBD::Parser::command($sth->{'Statement'});; my $numRows; if ($stmtcmd eq 'SELECT') { $numRows = &doSelect($sth); } elsif ($stmtcmd eq 'INSERT') { $numRows = &doInsert($sth); } elsif ($stmtcmd eq 'DELETE') { $numRows = &doDelete($sth); } elsif ($stmtcmd eq 'UPDATE') { $numRows = &doUpdate($sth); } elsif ($stmtcmd eq 'CREATE') {$numRows = &doCreate($sth); } elsif ($stmtcmd eq 'DROP') {$numRows = &doDrop($sth); } else { die "Error: RSCT DBD does not currently support the SQL command $stmtcmd!\n"; } if (defined($numRows)) { return $numRows || '0E0'; } else { return undef; } } sub rows { shift->{'num_of_rows'} }; # Process a SELECT query sub doSelect { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my @columns = DBD::Parser::columns($sth->{'rmc_shortstmt'}); my ($colstr, $attrtype, $outputFormat) = ('', '', ''); my $tablestr = &getTableStr($sth); my $wherestr = &getWhereStr($sth); if ($columns[0]->{'name'} eq "*") { #select * type query $colstr = ''; } else { my $c; $colstr = $columns[0]->{'name'}; foreach $c (@columns[1..$#columns]) { $colstr .= '::'.$c->{'name'}; } } $outputFormat = '-D ":|:"'; my $cmdlineinput; my $cmd; if ( $isRMC == 1) { #RMC Call if ($colstr eq "") { $cmdlineinput = $tablestr.'::'.$wherestr.'::'.'*b0x20'; } else { $cmdlineinput = $tablestr.'::'.$wherestr.'::'.$colstr; } $cmd = "/usr/bin/lsrsrc-api -n $outputFormat -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "RMC command = $cmd\n"; } } elsif ($isRMC == 0) { # SR Call if ($colstr eq "") { $cmdlineinput = $tablestr.'::'.$wherestr; } else { $cmdlineinput = $tablestr.'::'.$wherestr.'::'.$colstr; } $cmd = "/usr/bin/lssrtbl-api -n $outputFormat -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } else { die "Error: Not a recognized query.\n"; } my @lines; chop(@lines=`$cmd`); if ($?) { return $sth->DBI::set_err($?>>8, join("\n", @lines)); } # put the resulting data into $sth->{'rmc_data'} as a ref to an arrray of array refs, and return the number of rows my $data = []; # reference to a new anonymous array my $names = []; my ($l, $numFields); my %attrvals; foreach $l (@lines) { my $row = []; #this puts every pair consisting of attr& val into a hash %attrvals = split(/:\|:/, $l); # split is tolerant of the trailing delimeter @$row = values(%attrvals); foreach my $v (@$row) { $v=~s/^\"(.*)\"$/$1/; } # remove surrounding quotes, if there push(@$data, $row); if (!$numFields) { $numFields = scalar(@$row); } } #get the column names, needed for longFormat output if ($colstr eq "") { @$names = keys(%attrvals); } else { @$names = split('::', $colstr); } $sth->{'rmc_data'} = $data; $sth->{'NAME'} = $names; $sth->STORE('NUM_OF_FIELDS', $numFields || 1); return scalar(@$data); } sub doInsert { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my $tablestr = &getTableStr($sth); my $attrvalstr = &getAttrValueStr($sth); my $cmdlineinput = $tablestr.$attrvalstr; my $cmd; if ($isRMC == 1){ #RMC Call $cmd = "/usr/bin/mkrsrc-api $cmdlineinput 2>&1"; if ($::VERBOSE) { print "RMC command = $cmd\n"; } } else { #SR Call $cmd = "/usr/bin/mksrrow-api $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } my @lines; #chop(@lines=`$cmd`); # leave the newlines on it @lines = `$cmd`; if ($?) { return $sth->DBI::set_err($?>>8, join('', @lines)); } $sth->{'num_of_rows'} = 1; # there is a way to determine if the row was not inserted because it # already exists, but there is no good way to return that to the DBI # client other than an error, which is what we do return $sth->{'num_of_rows'}; } sub doDelete { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my $tablestr = &getTableStr($sth); my $wherestr = &getWhereStr($sth); my $cmdlineinput=$tablestr.'::'.$wherestr; my $cmd; if ($isRMC == 1) { $cmd = "/usr/bin/rmrsrc-api -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "RMC command = $cmd\n"; } } else { $cmd = "/usr/bin/rmsrrow-api -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } my @lines; #chop(@lines=`$cmd`); # leave the newlines on it @lines = `$cmd`; if ($?) { return $sth->DBI::set_err($?>>8, join('', @lines)); } $sth->{'num_of_rows'} = 1; # rmrsrc doesnt give us a way to determine the real # of deleted rows return $sth->{'num_of_rows'}; } sub doUpdate { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my $tablestr = &getTableStr($sth); my $wherestr = &getWhereStr($sth); if (!length($wherestr)) { $wherestr = "-s 1"; } # chrsrc requires a select string my $attrvalstr = &getAttrValueStr($sth); my $cmdlineinput = $tablestr.'::'.$wherestr.$attrvalstr; my $cmd; if ($isRMC == 1){#RMC query $cmd = "/usr/bin/chrsrc-api -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "RMC command = $cmd\n"; } } else { $cmd = "/usr/bin/chsrfld-api -s $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } my @lines; #chop(@lines=`$cmd`); # leave the newlines on it @lines = `$cmd`; my $rc = $? >> 8; #print "exitcode=$rc, " . substr($lines[0],0,8) . "\n"; # I opened defect 71892 to get a specific return code from chrsrc for the case of no resource found if ($rc == 5 && substr($lines[0],0,8) eq '2610-407') { # "no resource found" response from chrsrc $sth->{'num_of_rows'} = 0; } elsif ($rc) { return $sth->DBI::set_err($rc, join('', @lines)); } else { $sth->{'num_of_rows'} = 1; # dont know how to determine the real # of updated rows, but # for now setting it to non-zero is enough } return $sth->{'num_of_rows'}; } sub doCreate { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my $tablestr = &getTableStr($sth); my $colnametypestr = &getColNameTypeStr($sth); my $cmdlineinput = $tablestr.$colnametypestr; my $cmd; if ($isRMC == 1){ #RMC Call die "Error: Permission denied. Cannot create table in dsn=IBM.\n"; } else { #SR Call $cmd = "/usr/bin/mksrtbl-api $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } my @lines; #chop(@lines=`$cmd`); # leave the newlines on it @lines = `$cmd`; if ($?) { return $sth->DBI::set_err($?>>8, join('', @lines)); } $sth->{'num_of_rows'} = 1; # there is a way to determine if the row was not inserted because it # already exists, but there is no good way to return that to the DBI # client other than an error, which is what we do return $sth->{'num_of_rows'}; } sub doDrop { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; #SR or RMC query my $tablestr = &getTableStr($sth); my $cmdlineinput = $tablestr; my $cmd; if ($isRMC == 1){ #RMC Call die "Error: Permission denied. Cannot delete table in dsn=IBM.\n"; } else { #SR Call $cmd = "/usr/bin/rmsrtbl-api $cmdlineinput 2>&1"; if ($::VERBOSE) { print "SR command = $cmd\n"; } } my @lines; #chop(@lines=`$cmd`); # leave the newlines on it @lines = `$cmd`; if ($?) { return $sth->DBI::set_err($?>>8, join('', @lines)); } $sth->{'num_of_rows'} = 1; # there is a way to determine if the row was not inserted because it # already exists, but there is no good way to return that to the DBI # client other than an error, which is what we do return $sth->{'num_of_rows'}; } #get table string sub getTableStr { my ($sth) = @_; my $isRMC = $sth->{'rmc_or_sr'}; # don't forget to prepend dbh->{dnb} to the table name if (DBD::Parser::table($sth->{'rmc_shortstmt'}) eq undef) { die "Error: have to specify exactly 1 table!\n"; } my $tablestr; if ($isRMC == 0)#SR table - prepend and append a "/" to dbn { $tablestr = "\/".$sth->{Database}->{dbn} . "\/" . DBD::Parser::table($sth->{'rmc_shortstmt'});} else { $tablestr = $sth->{Database}->{dbn} . "." . DBD::Parser::table($sth->{'rmc_shortstmt'});} return $tablestr; } # Return a where option string for RSCT sub getWhereStr { my $sth = shift; my $actualwherestr = $sth->{'rmc_wherestr'}; if (!defined($actualwherestr) || !length($actualwherestr)) { return ''; } my $wherestr = "\"".$actualwherestr."\""; return $wherestr; } # Gets the columns and values from the SQL stmt and returns the string # ' attr="value" attr="value" ...' sub getAttrValueStr { my ($sth) = @_; my @columns = DBD::Parser::columns($sth->{'rmc_shortstmt'}); my @values = DBD::Parser::row_values($sth->{'rmc_shortstmt'}); my $rowValNums = DBD::Parser::row_values($sth->{'rmc_shortstmt'}); my $str = ''; for (my $i = 0; $i < @columns; $i++) { my $valstr = $values[$i]; # if the value has imbedded double quotes, use single quotes if ($valstr =~ /\"/) { $valstr = qq('$valstr'); } # use the other quotes else { $valstr = qq("$valstr"); } # preserve spaces and quotes $str .= '::'.$columns[$i]->{'name'}.'::'.$valstr; } return $str; } # Gets the columns and data types from the SQL DBD::Parser and returns the string # "col::aaa::type::bbb::qual::pk::col::......" # first column is assumed to be primary key column (Registry api needs primary # key to create table). Default values are not supported. sub getColNameTypeStr { my ($sth) = @_; my @columns = DBD::Parser::columns($sth->{'rmc_shortstmt'}); my $str = ''; for (my $i = 0; $i < @columns; $i++) { $str .= "::col::".$columns[$i]->{'name'}."::type::".$columns[$i]->{'type'}; if ($i == 0) { $str .= '::qual::pk'; } } return $str; } sub fetch ($) { my $sth = shift; my $data = $sth->{'rmc_data'}; if (!$data || ref($data) ne 'ARRAY') { DBI::set_err($sth, 52, "Attempt to fetch row from a Non-SELECT statement"); return undef; } my $dav = shift @$data; if (!$dav) { return undef; } if ($sth->FETCH('ChopBlanks')) { map { $_ =~ s/\s+$//; } @$dav; } $sth->_set_fbav($dav); } *fetchrow_arrayref = \&fetch; #removed sub FETCH sub STORE ($$$) { my ($sth, $attrib, $value) = @_; if ($attrib eq (lc $attrib)) { # Private driver attributes are lower cased $sth->{$attrib} = $value; return 1; } return $sth->DBD::_::st::STORE($attrib, $value); } sub DESTROY ($) { undef; } #sub rows ($) { shift->{'rmc_stmt'}->{'NUM_OF_ROWS'} }; sub finish ($) { 1; } 1;