view release on metacpan or  search on metacpan

lib/DBD/Teradata.pm  view on Meta::CPAN

	$sth->finish
		if $sthp->[26];
	delete $iobj->[1]{$sthp->[12]}
		if defined($sthp->[12]);
	my $params = $attrs->{_fetch_sub} ? undef :
		(scalar @bind_values) ? \@bind_values :
		$sthp->[5];
	$params = delete $attrs->{_residual}
		if $attrs->{_residual};
	my $numParam = $sth->{NUM_OF_PARAMS} || 0;
	if ($sth->{tdat_vartext_in} && ($#bind_values >= 0)) {
		return undef
			unless $sth->bind_param(1, $bind_values[0]);
		$params = $sthp->[5];
	}
	my ($ptypes, $plens, $usephs) =
		($sthp->[2], $sthp->[9], $sthp->[15]);
	my ($sessno, $dbh, $partition) =
		($sth->{tdat_sessno}, $sthp->[23], $iobj->[19]);
	my $loading = (($partition == 5) || ($partition == 4));
	my ($use_cursor, $cursnm, $cursth) = (0, '', undef);
	if ($sth->{Statement}=~/\s+WHERE\s+CURRENT\s+OF\s+([^\s;]+)\s*;?$/i) {
		$cursnm = uc $1;
		$cursth = $dbh->{_cursors}{$cursnm};
		return $sth->DBI::set_err(-1, 'Specified cursor not defined or not updatable.', 'S1000')
			unless $cursth;
		return $sth->DBI::set_err(-1, 'Specified cursor not positioned on a valid row.', 'S1000')
			unless $cursth->{_p}[6];
		$use_cursor = 1;
	}
	$iobj->[14] = 0,
	$sth->{tdat_keepresp} = 1
		if ($sth->{Statement}=~/\s+FOR\s+CURSOR\s*;?$/i);
	my $rawmode = $sth->{tdat_raw_in};
	my $modepcl =
		($partition == 4) ? 104 :
		(($partition == 6) ||
			($rawmode && ($rawmode eq 'RecordMode'))) ? 3 :
				68;
	$numParam = 0
		unless ($partition != 6) ||
			($iobj->[6] && ($#$params >= 0));
	return $sth->DBI::set_err(-1, 'Too many parameters provided.', 'S1000')
		if defined($params) && (@$params > $numParam);
	return $sth->DBI::set_err(-1, 'No parameters provided for parameterized statement.', 'S1000')
		unless ($numParam == 0) || defined($params) || defined($dbh->{tdat_loading}) ||
			$attrs->{_fetch_sub};
	my $stmtno = 0;
	my $maxparmlen = 1;
	if ($attrs->{_fetch_sub}) {
		$maxparmlen = MAX_PARM_TUPLES;
	}
	else {
		foreach (0..$numParam-1) {
			$maxparmlen = scalar(@{$$params[$_]})
				if (ref $$params[$_] eq 'ARRAY') &&
					(scalar(@{$$params[$_]}) > $maxparmlen);
		}
	}
	my $fldcnt = $numParam;
	my ($tuples, $datainfo, $indicdata) = (0, '', '');
	my $pos = 0;
	if (($params && scalar @$params) || $attrs->{_fetch_sub}) {
		($tuples, $datainfo, $indicdata) =
			$usephs ? _process_ph_params($sth, $fldcnt, $params, $attrs) :
				_process_using_params($sth, $fldcnt, $rawmode, $modepcl, $params, $attrs);
		return undef
			unless $tuples;
	}
	$iobj->io_tddo('BT'),
	$iobj->[11] = 1
		if ($partition == 1) && (!$dbh->{AutoCommit}) &&
			($dbh->{tdat_mode} ne 'ANSI') && ($iobj->[11] == 0);
	$iobj->[11] = 1
		if ($partition == 1) && ($dbh->{tdat_mode} eq 'ANSI');
	return $tuples
		if $attrs->{_fetch_sub};
	my $rowcnt = $iobj->io_execute($sth, $datainfo, $indicdata,
		($use_cursor ? $cursth->{_p}[6] : undef));
	$sthp->[13] = $rowcnt;
	return $sth->DBI::set_err($iobj->io_get_error())
		unless defined($rowcnt);
	$sth->{Active} = ($sth->{NUM_OF_FIELDS} != 0);
	undef $sthp->[6]
		if ($sth->{Statement}=~/^DELETE\s+.+\s+WHERE\s+CURRENT\s+OF\s+\w+$/i);
	$sthp->[26] = 1
		unless $sthp->[22] && (! $sth->{tdat_keepresp});
	return ($rowcnt == 0) ? -1 : $rowcnt
		if ($sth->{tdat_compatible} lt '2.0');
	return ($rowcnt == 0) ? '0E0' : $rowcnt;
}
sub _gen_datainfo {
	my ($fldcnt, $ptypes, $plens, $maxszs) = @_;
	my $packstr = '';
	my $datainfo = pack('S', $fldcnt) . ("\0" x ($fldcnt * 4));
	my $prec;
	my $j = 2;
	foreach (0..$fldcnt-1) {
		my $tdtype = $td_type_dbi2code{$ptypes->[$_]}+1;
		$plens->[$_] ||= 0
			if ($ptypes->[$_] == 12) || ($ptypes->[$_] == -3);
		$prec = ($ptypes->[$_] == 3) ?
			$td_decszs[($plens->[$_] >> 8) & 31] : $plens->[$_];
		$packstr .=
			(($ptypes->[$_] == -2) ||
			($ptypes->[$_] == 3))		? "a$prec " :
			($ptypes->[$_] == 1) 		? "A$prec " :
				$td_type_dbi2pack{$ptypes->[$_]} . ' ';
		$prec = 2 + $plens->[$_]
			if ($maxszs->[$_] < $plens->[$_]) &&
				(($ptypes->[$_] == 12) ||
					($ptypes->[$_] == -3));
		substr($datainfo, $j, 4) = pack('SS', $tdtype, $plens->[$_]);
		$maxszs->[$_] = $prec;
		$j += 4;
	}
	return ($datainfo, $packstr);
}
sub _process_ph_params {
	my ($sth, $fldcnt, $params, $attrs) = @_;
	my $indicdata;
	my $pos = 0;
	my $maxsz = 100;
	my ($i, $p);
	my $sthp = $sth->{_p};
	my $iobj = $sthp->[11];
	my $ptypes = $sthp->[2];
	my $plens = $sthp->[9];
	my $fetch_sub = $attrs->{_fetch_sub};
	my @maxszs = ((0) x $fldcnt);
	my ($datainfo, $packstr) = _gen_datainfo($fldcnt, $ptypes, $plens, \@maxszs);
	my @tmpary = ();
	my $ttype = 12;
	my @indicvec = ();
	my $tuples = 0;
	my $deccvt =
		($sth->{tdat_no_bigint} || (!$has_bigint)) ? \&cvt_flt2dec :
		($^O eq 'MSWin32') ? \&cvt_bigint2dec :
		\&cvt_eval_bigint2dec;
	$params = &$fetch_sub()
		unless $params && scalar @$params;
	while ($params) {
		@indicvec = (0xFF) x (($fldcnt & 7) ?
			($fldcnt>>3) + 1 : $fldcnt>>3);
		$pos = 0;
		@tmpary = ();
		foreach (0..$fldcnt-1) {
			$ttype = $ptypes->[$_];
			$p = $params->[$_];
			$p = (ref $p eq 'ARRAY') ? $p->[0] : $$p
				if defined($p) && (ref $p);
			push(@tmpary, $nullvals{$ttype}),
			$pos +=
				(($ttype == 12) ||
				($ttype == -3))	? 2 : $maxszs[$_],
			next
				unless defined($p);
			$indicvec[$_>>3] &= $td_indicmasks[$_ & 7],
			push(@tmpary,
				($ttype == 3)				? $deccvt->($p, $plens->[$_]) :
				(($ttype == 6) && $use_arm) ? cvt_arm_flt($p) : $p);
			$pos +=
				(($ttype == 12) ||
				($ttype == -3))	? 2 + length($p) :
				($ttype == 3)		? $td_decszs[(($plens->[$_]>>8) & 31)] :
				$plens->[$_];
			$maxszs[$_] = length($p) + 2,
			substr($datainfo, 4 + ($_ << 2), 2, pack('S', $maxszs[$_]))
				if (($ttype == 12) || ($ttype == -3)) &&
					($maxszs[$_] < length($p) + 2);
		}
		map { $maxsz += $_; } @maxszs;
		$maxsz += scalar @indicvec;
		$indicdata = "\0" x $maxsz;
		substr($indicdata, 0, scalar(@indicvec), pack('C*', @indicvec));
		substr($indicdata, scalar(@indicvec), $pos, pack($packstr, @tmpary));
		$pos += scalar(@indicvec);
		return (++$tuples, $datainfo, substr($indicdata, 0, $pos))
			;
	}
	substr($iobj->[16], $attrs->{_datainfop}, length($datainfo), $datainfo);
	return ($tuples, undef, undef);
}
sub _process_using_params {
	my ($sth, $fldcnt, $rawmode, $modepcl, $params, $attrs) = @_;
	my $indicdata;
	my $pos = 0;
	my $maxsz = (($fldcnt & 7) ? ($fldcnt>>3) + 1 : $fldcnt>>3);
	my ($i, $k, $p);
	my $sthp = $sth->{_p};
	my $iobj = $sthp->[11];
	my $ptypes = $sthp->[2];
	my $plens = $sthp->[9];
	my $packstr = $sthp->[18];
	my $fetch_sub = $attrs->{_fetch_sub};
	my $tuples = 0;
	my $deccvt =
		($sth->{tdat_no_bigint} || (!$has_bigint)) ? \&cvt_flt2dec :
		($^O eq 'MSWin32') ? \&cvt_bigint2dec :
		\&cvt_eval_bigint2dec;
	unless ($rawmode) {
		for ($i = 0; $i < $fldcnt; $i++) {
			$maxsz += (($ptypes->[$i] == 3) ?
				$td_decszs[(($plens->[$i]>>8) & 31)] : $plens->[$i]);
			$maxsz += 2
				if ($ptypes->[$i] == 12) || ($ptypes->[$i] == -3);
		}
	}
	my @tmpary = ();
	my $ttype = 12;
	my @indicvec = ();
	$params = &$fetch_sub()
		unless $params && scalar @$params;
	my $is_vartext = $sth->{tdat_vartext_in};
	my @ps;
	my $notbar = ($is_vartext && ($is_vartext eq '|')) ? undef : $is_vartext;
	while ($params) {
		if ($is_vartext && (scalar @$params == 1)) {
			@$params = $notbar ? split($notbar, $params->[0]) : split('\|', $params->[0]);
			foreach (0..$fldcnt-1) {
				$plens->[$_] = length($params->[$_])
					if defined($params->[$_]) && ($plens->[$_] < length($params->[$_]));
			}
		}
		unless ($rawmode) {
			@indicvec = (0xFF) x (($fldcnt & 7) ? ($fldcnt>>3) + 1 : $fldcnt>>3);
			$pos = 0;
			@tmpary = ();
			foreach (0..$fldcnt-1) {
				$ttype = $ptypes->[$_];
				$p = $params->[$_];
				$p = (ref $p eq 'ARRAY') ? $p->[0] : $$p
					if defined($p) && (ref $p);
				push(@tmpary, $nullvals{$ttype}),
				$pos +=
					(($ttype == 12) ||
					($ttype == -3))	? 2 :
					($ttype == 3)		? $td_decszs[($plens->[$_] >> 8) & 31] :
						$plens->[$_],
				next
					unless defined($p);
				$indicvec[$_>>3] &= $td_indicmasks[$_ & 7],
				push(@tmpary,
					($ttype == 3)				? $deccvt->($p, $plens->[$_]) :
					(($ttype == 6) && $use_arm) ? cvt_arm_flt($p) : $p);
				$pos +=
					(($ttype == 12) ||
					($ttype == -3))	? 2 + length($p) :
					($ttype == 3)		? $td_decszs[(($plens->[$_]>>8) & 31)] :
					$plens->[$_];
					$ttype = $ptypes->[$i];
					$p = $params->[$i];
					$p = $$p
						if defined($p) && (ref $p);
			}
			$indicdata = "\0" x $maxsz;
			substr($indicdata, 0, scalar(@indicvec), pack('C*', @indicvec));
			substr($indicdata, scalar(@indicvec), $pos, pack($packstr, @tmpary));
			$pos += scalar(@indicvec);
		}
		else {
			$p = $params->[0];
			$p = (ref $p eq 'ARRAY') ? $p->[0] : $$p
				if defined($p) && (ref $p);
			$pos = length($p) - 3;
			$indicdata = substr($p, 2, $pos);
		}
		return (++$tuples, undef, substr($indicdata, 0, $pos))
		;
	}
	return ($tuples, undef, undef);
}
sub Realize {
	return defined($_[0]->{_p}[11]->io_Realize($_[0])) ?
		1 : $_[0]->DBI::set_err($_[0]->{_p}[11]->io_get_error());
}
*tdat_Realize = \&Realize;
sub tdat_Rewind {
	return $_[0]->{_p}[11]->io_rewind($_[0]);
}
sub fetch {
	return $_[0]->tdat_Unpack();
}
sub tdat_Unpack {
	my ($sth, $rec, $recmode) = @_;
	my $sthp = $sth->{_p};
	my $sessno = $sth->{tdat_sessno};
	my $stmtno = $sth->{tdat_stmt_num};
	my $nowait = $sth->{tdat_nowait};
	my $stmtinfo = $sth->{tdat_stmt_info};
	my $rawmode = $sth->{tdat_raw_out};
	my $vartext = $sth->{tdat_vartext_out};
	my $colary = $sthp->[1];
	my $maxlen = $sthp->[14];
	my $iobj = $sthp->[11];
	my $data = '';
	my @tmpary = ();
	my $ary = (defined($colary) ? ($rawmode ? $$colary[0] : \@tmpary) : undef);
	my $rc;
	if (defined($rec)) {
		$data = $rec;
		$rc = 1;
	}
	else {
		$rc = $iobj->io_fetch($sth, $ary, \$data);
		return $sth->DBI::set_err($iobj->io_get_error())
			unless defined($rc);
		$sth->{Active} = undef
			unless ($rc > 0) || $sth->{tdat_more_results};
		return $rc if ($rc <= 0);
	}
	my $loopcnt = $rc;
	my $ftypes = $sth->{TYPE};
	my $fprec = $sth->{PRECISION};
	my $fscale = $sth->{SCALE};
	my $stmthash = $$stmtinfo[$stmtno];
	my $isCall = ($stmthash->{ActivityType} eq 'Call');
	my $actends = $stmthash->{EndsAt};
	my $actstarts = $stmthash->{StartsAt};
	my $actsumstarts = $stmthash->{SummaryStarts};
	my $actsumends = $stmthash->{SummaryEnds};
	my $issum = $stmthash->{IsSummary};
	my $numflds = defined($issum) ?
		$$actsumends[$issum] - $$actsumstarts[$issum] + 1 :
		$actends - $actstarts + 1;
	my $unpackstr = $sthp->[10][
		(defined($issum) ? $$actsumstarts[$issum] : $actstarts)];
	my $ibytes = ((($numflds & 7) !=  0) ? ($numflds>>3) + 1 : $numflds>>3);

lib/DBD/Teradata.pm  view on Meta::CPAN

					next
						unless ($datatype & 3);
					$$parmdesc[$$parmnum] |= 4;
					$$parmmap{$$phnum} = $nextcol
						if ($$parmdesc[$$parmnum] & 1);
					$$parmnum++;
					$stmtinfo->{EndsAt} = $nextcol;
				}
				$datatype &= 0xfffc;
			}
			$sthargs->{NAME}[$nextcol] = ($cname eq '') ?
				(($ctitle eq '') ? "COLUMN$nextcol" : $ctitle) :
				$cname;
			my $ttype = $sthargs->{TYPE}[$nextcol] =
				$td_type_code2dbi{$datatype & 0xfffe};
			$sthargs->{NULLABLE}[$nextcol] = ($activity == 105) ?
				1 : $datatype & 1;
			$sthargs->{tdat_TITLE}[$nextcol] = $ctitle;
			$cfmt = uc $cfmt;
			$cfmt = '-(' . (length($1) + 1) . ")$2"
				if ($cfmt=~/^(-+)(.*)/);
			$sthargs->{tdat_FORMAT}[$nextcol] = $cfmt;
			my $prec = $sthargs->{PRECISION}[$nextcol] = ($ttype == 3) ?
				(($datalen >> 8) & 31) : $datalen;
			my $scale = $sthargs->{SCALE}[$nextcol] = ($ttype == 3) ?
				($datalen & 255) : 0;
			my $len = ($ttype == 3) ? $td_decszs[$prec] : $datalen;
			$packstr .=
				(($ttype == -2) || ($ttype == 3)) ? "a$len " :
				(($ttype == 1)								? "A$len " :
					($td_type_dbi2pack{$ttype}) . ' ');
			$sthargs->{tdat_FORMAT}[$nextcol] = "6($prec)"
				if ($ttype == -2) || ($ttype == -3);
			my $typestr = $td_type_dbi2str{$ttype};
			$typestr .= '(' . $prec .
				(($ttype == 3) ? ", $scale)" : ')')
				if $td_type_str2baseprec{$typestr};
			$sthargs->{tdat_TYPESTR}[$nextcol] = $typestr;
			DBI->trace_msg(
				($ttype != 3) ?
		"$sthargs->{NAME}[$nextcol]\: $ttype LENGTH $prec\n" :
		"$sthargs->{NAME}[$nextcol]\: DECIMAL($prec, $scale) LENGTH $td_decszs[$len]\n",
					1)
				if $debug;
		}
		my $packidx = $nextsum ? $stmtinfo->{SummaryStarts}[$nextsum - 1] : $stmtinfo->{StartsAt};
		$packstr=~s/\*//g;
		$sthargs->{_unpackstr}[$packidx] = $packstr;
		$packstr = '';
		last unless $sumcnt;
		$colcnt = unpack('S', substr($pcl, $curpos));
		$stmtinfo->{SummaryStarts}[$nextsum] = $nextcol;
		$stmtinfo->{SummaryEnds}[$nextsum] = $nextcol + $colcnt - 1;
		$nextsum++;
		$curpos += 2;
		$sumcnt--;
	}
	return $nextcol;
}
sub io_execute {
	my ($obj, $sth, $datainfo, $indicdata, $rowid) = @_;
	$obj->[18] = 0;
	$obj->[24] = '00000';
	$obj->[17] = '';
	my $stmtinfo = $sth->{tdat_stmt_info};
	my $stmtno = $sth->{tdat_stmtno};
	my $nowait = $sth->{tdat_nowait};
	my $stmt = $sth->{Statement} || '';
	my $keepresp = ($sth->{tdat_keepresp} || ($stmt=~/\s+FOR\s+CURSOR\s*$/i));
	my $rawmode = $sth->{tdat_raw_in};
	my $reqmsg = '';
	my $reqlen = 0;
	my $modepcl = ($rawmode && defined($rawmodes{$rawmode})) ?
		$rawmodes{$rawmode} : 68;
	my $partition = $obj->[19];
	my $reqfac = $obj->[38];
	$stmt=~s/\s+WHERE\s+CURRENT\s+OF\s+([^\s;]+)\s*;?\s*$/ WHERE CURRENT/i;
	my $forCursor = ($stmt=~/\s+WHERE\s+CURRENT$/i) && $rowid;
	if (($partition == 1) ||
		(($partition == 6) && ($stmt ne ';'))) {
		$reqlen = 4 + length($stmt) + 6 +
			((defined($datainfo) && length($datainfo)) ? 4 + length($datainfo) : 0) +
			((defined($indicdata) && length($indicdata)) ? 4 + length($indicdata) : 0) +
			($forCursor ? 4 + length($rowid) : 0) +
			($sth->{tdat_mload} ? 14 : 0);
		if ($reqlen > 65535) {
			$reqlen += 4 + 4 + (length($datainfo) ? 4 : 0) +
				(length($indicdata) ? 4 : 0) + (($forCursor && $rowid) ? 4 : 0);
			$obj->[26] = 1;
		}
		else {
			$obj->[26] = undef;
		}
	}
	if ($sth->{Statement}=~/^\s*(CREATE|REPLACE)\s+PROCEDURE\s+/i) {
		my $pos = 0;
		my $segment = 1;
		my $len = length($sth->{Statement});
		my $sz = 0;
		while ($len) {
			$sz = ($len > 64000) ? 64000 : $len;
			$len -= $sz;
			($reqmsg, $pos) = $reqfac->spRequest($obj, $sz, $pos, $segment, $sth, $obj->[3]);
			$segment++;
			my $treqno = $obj->[2];
			$obj->io_quicksend(length($reqmsg), undef, $reqmsg) or return undef;
			$obj->[1]{$treqno} = $sth;
			$sth->{_p}[12] = $treqno;
			last unless $len;
			return undef unless defined($obj->io_Realize($sth));
		}
		return ($nowait ? -1 : $obj->io_Realize($sth));
	}
	return $obj->io_set_error('Maximum request size exceeded.')
		if ($obj->[40] < 5000000) && ($reqlen > 65535);
	if ($partition == 1) {
		$reqmsg = $reqfac->sqlRequest($obj, $sth, $forCursor, $rowid, $modepcl, $keepresp,
			$obj->[3], $stmt, $datainfo, $indicdata);
	}
	delete $obj->[1]{$_}
		foreach (keys %{$obj->[1]});
	my $treqno = $obj->[2];
	if (($partition == 5) || ($partition == 4)) {
		$obj->io_quicksend($obj->[32], undef, $obj->[16])
			or return undef;
	}
	else {
		$obj->io_tdsend($reqmsg) or return undef;
	}
	$obj->[1]{$treqno} = $sth;
	$sth->{_p}[12] = $treqno;
	return ($nowait) ? -1 : $obj->io_Realize($sth);
}
sub io_fetch {
	my ($obj, $sth, $ary, $retstr) = @_;
	$obj->[18] = 0;
	$obj->[24] = '00000';
	$obj->[17] = '';
	my $sthp = $sth->{_p};
	return 0 unless $sthp->[17];
	my $maxlen = ($ary) ? $sthp->[14] : 1;
	my $stmtno = $sth->{tdat_stmt_num};
	my ($f, $l, $failed) = (0,0,0,0);
	my $rspmsg = $sthp->[17];
	my $pos = $sthp->[19];
	my $rsplen = ($$rspmsg) ? length($$rspmsg) : 0;
	my $partition = $obj->[19];
	my $stmtinfo = $sth->{tdat_stmt_info};
	my $stmthash = ($stmtno) ? $$stmtinfo[$stmtno] : undef;
	my $endstmt = 0;
	my $total_activity = 0;
	my $arycnt = 0;
	if ($pos >= $rsplen) {
		$rspmsg = $obj->io_tdcontinue($sth, 0);
		return 0 unless $$rspmsg;
		$sthp->[17] = $rspmsg;
		$rsplen = length($$rspmsg);
		$obj->io_tdcontinue($sth, 1)
			if (! $sthp->[22]) && $obj->[14];
		$pos = 52;
	}
	my ($pclhdrsz, $rowcnt, $tderr, $fldcount, $activity, $tdelen, $tdemsg);
	($f, $l, $pclhdrsz) = _getPclHeader($$rspmsg, $pos);
	$sth->{tdat_more_results} = 1;
	while (($f != 10) && ($f != 105)) {
		$sthp->[19] = $pos + $l;
		if ($f == 12) {
			$sthp->[17] = undef;
			$sthp->[19] = 0;
			$sth->{tdat_more_results} = 0;
			$obj->io_tddo('COMMIT WORK'),
			$obj->[11] = 0
				if ($obj->[10] eq 'ANSI') &&
					$obj->[11] && $obj->[31]{AutoCommit};
			$sth->{tdat_more_results} = 0,
			delete $obj->[1]{$sthp->[12]},
			$sthp->[12] = 0,
				unless ($obj->[19] == 3) ||