The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!perl

## Test of placeholders

use 5.006;
use strict;
use warnings;
use Test::More;
use lib 't','.';
use DBI qw/:sql_types/;
use DBD::Pg qw/:pg_types/;
require 'dbdpg_test_setup.pl';
select(($|=1,select(STDERR),$|=1)[1]);

my $dbh = connect_database();

if (! $dbh) {
	plan skip_all => 'Connection to database failed, cannot continue testing';
}
plan tests => 243;

my $t='Connect to database for placeholder testing';
isnt ($dbh, undef, $t);

my ($pglibversion,$pgversion) = ($dbh->{pg_lib_version},$dbh->{pg_server_version});
if ($pgversion >= 80100) {
  $dbh->do('SET escape_string_warning = false');
}

my ($result, $SQL, $qresult);

# Make sure that quoting works properly.
$t='Quoting works properly';
my $E = $pgversion >= 80100 ? q{E} : q{};
my $quo = $dbh->quote('\\\'?:');
is ($quo, qq{${E}'\\\\''?:'}, $t);

$t='Quoting works with a function call';
# Make sure that quoting works with a function call.
# It has to be in this function, otherwise it doesn't fail the
# way described in https://rt.cpan.org/Ticket/Display.html?id=4996.
sub checkquote {
    my $str = shift;
    return is ($dbh->quote(substr($str, 0, 10)), "'$str'", $t);
}

checkquote('one');
checkquote('two');
checkquote('three');
checkquote('four');

$t='Fetch returns the correct quoted value';
my $sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test (id,pname) VALUES (?, $quo)});
$sth->execute(100);
my $sql = "SELECT pname FROM dbd_pg_test WHERE pname = $quo";
$sth = $dbh->prepare($sql);
$sth->execute();
my ($retr) = $sth->fetchrow_array();
is ($retr, '\\\'?:', $t);

$t='Execute with one bind param where none expected fails';
eval {
	$sth = $dbh->prepare($sql);
	$sth->execute('foo');
};
like ($@, qr{when 0 are needed}, $t);

$t='Execute with ? placeholder works';
$sql = 'SELECT pname FROM dbd_pg_test WHERE pname = ?';
$sth = $dbh->prepare($sql);
$sth->execute('\\\'?:');
($retr) = $sth->fetchrow_array();
is ($retr, '\\\'?:', $t);

$t='Execute with :1 placeholder works';
$sql = 'SELECT pname FROM dbd_pg_test WHERE pname = :1';
$sth = $dbh->prepare($sql);
$sth->bind_param(':1', '\\\'?:');
$sth->execute();
($retr) = $sth->fetchrow_array();
is ($retr, '\\\'?:', $t);

$t='Execute with $1 placeholder works';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = $1 AND pname <> 'foo'};
$sth = $dbh->prepare($sql);
$sth->execute('\\\'?:');
($retr) = $sth->fetchrow_array();
is ($retr, '\\\'?:', $t);

$t='Execute with quoted ? fails with a placeholder';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '?'};
eval {
	$sth = $dbh->prepare($sql);
	$sth->execute('foo');
};
like ($@, qr{when 0 are needed}, $t);

$t='Execute with quoted :1 fails with a placeholder';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = ':1'};
eval {
	$sth = $dbh->prepare($sql);
	$sth->execute('foo');
};
like ($@, qr{when 0 are needed}, $t);

$t='Execute with quoted ? fails with a placeholder';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = '\\\\' AND pname = '?'};
eval {
	$sth = $dbh->prepare($sql);
	$sth->execute('foo');
};
like ($@, qr{when 0 are needed}, $t);

$t='Execute with named placeholders works';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar2 AND pname = :foobar AND pname = :foobar2};
eval {
	$sth = $dbh->prepare($sql);
	$sth->bind_param(':foobar', 123);
	$sth->bind_param(':foobar2', 456);
	$sth->execute();
};
is ($@, q{}, $t);

## Same, but fiddle with whitespace
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar2 AND pname = :foobar2};
eval {
	$sth = $dbh->prepare($sql);
	$sth->bind_param(':foobar', 123);
	$sth->bind_param(':foobar2', 456);
	$sth->execute();
};
is ($@, q{}, $t);

$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar AND pname = :foobar2 };
eval {
	$sth = $dbh->prepare($sql);
	$sth->bind_param(':foobar', 123);
	$sth->bind_param(':foobar2', 456);
	$sth->execute();
};
is ($@, q{}, $t);

$t='Execute with repeated named placeholders works';
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar };
eval {
	$sth = $dbh->prepare($sql);
	$sth->bind_param(':foobar', 123);
	$sth->execute();
};
is ($@, q{}, $t);

## Same thing, different whitespace
$sql = q{SELECT pname FROM dbd_pg_test WHERE pname = :foobar AND pname = :foobar};
eval {
	$sth = $dbh->prepare($sql);
	$sth->bind_param(':foobar', 123);
	$sth->execute();
};
is ($@, q{}, $t);

$t='Prepare with large number of parameters works';
## Test large number of placeholders
$sql = 'SELECT 1 FROM dbd_pg_test WHERE id IN (' . '?,' x 300 . '?)';
my @args = map { $_ } (1..301);
$sth = $dbh->prepare($sql);
my $count = $sth->execute(@args);
$sth->finish();
is ($count, 1, $t);

$sth->finish();

## Force client encoding, as we cannot use backslashes in client-only encodings
my $old_encoding = $dbh->selectall_arrayref('SHOW client_encoding')->[0][0];
if ($old_encoding ne 'UTF8') {
	$dbh->do(q{SET NAMES 'UTF8'});
}

$t='Prepare with backslashes inside quotes works';
$SQL = q{SELECT setting FROM pg_settings WHERE name = 'backslash_quote'};
$count = $dbh->selectall_arrayref($SQL)->[0];
my $backslash = defined $count ? $count->[0] : 0;
my $scs = $dbh->{pg_standard_conforming_strings};
$SQL = $scs ? q{SELECT E'\\'?'} : q{SELECT '\\'?'};
$sth = $dbh->prepare($SQL);
eval {
	$sth->execute();
};
my $expected = $backslash eq 'off' ? qr{unsafe} : qr{};
like ($@, $expected, $t);

## Test quoting of geometric types

my @geotypes = qw/point line lseg box path polygon circle/;

eval { $dbh->do('DROP TABLE dbd_pg_test_geom'); }; $dbh->commit();

$SQL = 'CREATE TABLE dbd_pg_test_geom (';
for my $type (@geotypes) {
	$SQL .= "x$type $type,";
}
$SQL =~ s/,$/)/;
$dbh->do($SQL);
$dbh->commit();

my %typemap = (
	point   => PG_POINT,
	line    => PG_LINE,
	lseg    => PG_LSEG,
	box     => PG_BOX,
	path    => PG_PATH,
	polygon => PG_POLYGON,
	circle  => PG_CIRCLE,
);

my $testdata = q{
point datatype integers
12,34
'12,34'
(12,34)

point datatype floating point numbers
1.34,667
'1.34,667'
(1.34,667)

point datatype exponential numbers
1e134,9E4
'1e134,9E4'
(1e+134,90000)

point datatype plus and minus signs
1e+134,-.45
'1e+134,-.45'
(1e+134,-0.45)

point datatype invalid number
123,abc
ERROR: Invalid input for geometric type
ERROR: any

point datatype invalid format
123
'123'
ERROR: any

point datatype invalid format
123,456,789
'123,456,789'
ERROR: any

point datatype invalid format
<(2,4),6>
ERROR: Invalid input for geometric type
ERROR: any

point datatype invalid format
[(1,2)]
ERROR: Invalid input for geometric type
ERROR: any

line datatype integers
12,34
'12,34'
ERROR: not yet implemented

line datatype floating point numbers
1.34,667
'1.34,667'
ERROR: not yet implemented

line datatype exponential numbers
1e134,9E4
'1e134,9E4'
ERROR: not yet implemented

line datatype plus and minus signs
1e+134,-.45
'1e+134,-.45'
ERROR: not yet implemented

line datatype invalid number
123,abc
ERROR: Invalid input for geometric type
ERROR: not yet implemented


lseg datatype invalid format
12,34
'12,34'
ERROR: any

lseg datatype integers
(12,34),(56,78)
'(12,34),(56,78)'
[(12,34),(56,78)]

lseg datatype floating point and exponential numbers
(1.2,3.4),(5e3,7E1)
'(1.2,3.4),(5e3,7E1)'
[(1.2,3.4),(5000,70)]


box datatype invalid format
12,34
'12,34'
ERROR: any

box datatype integers
(12,34),(56,78)
'(12,34),(56,78)'
(56,78),(12,34)

box datatype floating point and exponential numbers
(1.2,3.4),(5e3,7E1)
'(1.2,3.4),(5e3,7E1)'
(5000,70),(1.2,3.4)


path datatype invalid format
12,34
'12,34'
ERROR: any

path datatype integers
(12,34),(56,78)
'(12,34),(56,78)'
((12,34),(56,78))

path datatype floating point and exponential numbers
(1.2,3.4),(5e3,7E1)
'(1.2,3.4),(5e3,7E1)'
((1.2,3.4),(5000,70))

path datatype alternate bracket format
[(1.2,3.4),(5e3,7E1)]
'[(1.2,3.4),(5e3,7E1)]'
[(1.2,3.4),(5000,70)]

path datatype many elements
(1.2,3.4),(5,6),(7,8),(-9,10)
'(1.2,3.4),(5,6),(7,8),(-9,10)'
((1.2,3.4),(5,6),(7,8),(-9,10))

path datatype fails with braces
{(1,2),(3,4)}
ERROR: Invalid input for path type
ERROR: any


polygon datatype invalid format
12,34
'12,34'
ERROR: any

polygon datatype integers
(12,34),(56,78)
'(12,34),(56,78)'
((12,34),(56,78))

polygon datatype floating point and exponential numbers
(1.2,3.4),(5e3,7E1)
'(1.2,3.4),(5e3,7E1)'
((1.2,3.4),(5000,70))

polygon datatype many elements
(1.2,3.4),(5,6),(7,8),(-9,10)
'(1.2,3.4),(5,6),(7,8),(-9,10)'
((1.2,3.4),(5,6),(7,8),(-9,10))

polygon datatype fails with brackets
[(1,2),(3,4)]
ERROR: Invalid input for geometric type
ERROR: any



circle datatype invalid format
(12,34)
'(12,34)'
ERROR: any

circle datatype integers
<(12,34),5>
'<(12,34),5>'
<(12,34),5>

circle datatype floating point and exponential numbers
<(-1.2,2E2),3e3>
'<(-1.2,2E2),3e3>'
<(-1.2,200),3000>

circle datatype fails with brackets
[(1,2),(3,4)]
ERROR: Invalid input for circle type
ERROR: any

};

$testdata =~ s/^\s+//;
my $curtype = '';
for my $line (split /\n\n+/ => $testdata) {
	my ($text,$input,$quoted,$rows) = split /\n/ => $line;
	next if ! $text;
	$t = "Geometric type test: $text";
	(my $type) = ($text =~ m{(\w+)});
	last if $type eq 'LAST';
	if ($curtype ne $type) {
		$curtype = $type;
		eval { $dbh->do('DEALLOCATE geotest'); }; $dbh->commit();
		$dbh->do(qq{PREPARE geotest($type) AS INSERT INTO dbd_pg_test_geom(x$type) VALUES (\$1)});
		$sth = $dbh->prepare(qq{INSERT INTO dbd_pg_test_geom(x$type) VALUES (?)});
		$sth->bind_param(1, '', {pg_type => $typemap{$type} });
	}
	$dbh->do('DELETE FROM dbd_pg_test_geom');
	eval { $qresult = $dbh->quote($input, {pg_type => $typemap{$type}}); };
	if ($@) {
		if ($quoted !~ /ERROR: (.+)/) {
			fail ("$t error: $@");
		}
		else {
			like ($@, qr{$1}, $t);
		}
	}
	else {
		is ($qresult, $quoted, $t);
	}
	$dbh->commit();

	eval { $dbh->do("EXECUTE geotest('$input')"); };
	if ($@) {
		if ($rows !~ /ERROR: (.+)/) {
			fail ("$t error: $@");
		}
		else {
			## Do any error for now: i18n worries
			pass ($t);
		}
	}
	$dbh->commit();

	eval { $sth->execute($input); };
	if ($@) {
		if ($rows !~ /ERROR: (.+)/) {
			fail ($t);
		}
		else {
			## Do any error for now: i18n worries
			pass ($t);
		}
	}
	$dbh->commit();

	if ($rows !~ /ERROR/) {
		$SQL = "SELECT x$type FROM dbd_pg_test_geom";
		$expected = [[$rows],[$rows]];
		$result = $dbh->selectall_arrayref($SQL);
		is_deeply ($result, $expected, $t);
	}
}

$t='Calling do() with non-DML placeholder works';
$sth->finish();
$dbh->commit();
eval {
  $dbh->do(q{SET search_path TO ?}, undef, 'pg_catalog');
};
is ($@, q{}, $t);

$t='Calling do() with DML placeholder works';
$dbh->commit();
eval {
  $dbh->do(q{SELECT ?::text}, undef, 'public');
};
is ($@, q{}, $t);

SKIP: {
	if ($pglibversion < 80000) {
		skip ('Skipping specific placeholder test on 7.4-compiled servers', 1);
	}
	$t='Calling do() with invalid crowded placeholders fails cleanly';
	$dbh->commit();
	eval {
		$dbh->do(q{SELECT ??}, undef, 'public', 'error');
	};
	is($dbh->state, '42601', $t);
}

$t='Prepare/execute with non-DML placeholder works';
$dbh->commit();
eval {
  $sth = $dbh->prepare(q{SET search_path TO ?});
  $sth->execute('pg_catalog');
};
is ($@, q{}, $t);
$dbh->do(q{SET search_path TO DEFAULT});

$t='Prepare/execute does not allow geometric operators';
$dbh->commit();
eval {
	$sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'});
	$sth->execute();
};
like ($@, qr{unbound placeholder}, $t);

$t='Prepare/execute allows geometric operator ?- when dollaronly is set';
$dbh->commit();
$dbh->{pg_placeholder_dollaronly} = 1;
eval {
	$sth = $dbh->prepare(q{SELECT ?- lseg '(1,0),(1,1)'});
	$sth->execute();
	$sth->finish();
};
is ($@, q{}, $t);

$t='Prepare/execute allows geometric operator ?# when dollaronly set';
$dbh->commit();
eval {
	$sth = $dbh->prepare(q{SELECT lseg'(1,0),(1,1)' ?# lseg '(2,3),(4,5)'});
	$sth->execute();
	$sth->finish();
};
is ($@, q{}, $t);

$t=q{Value of placeholder_dollaronly can be retrieved};
is ($dbh->{pg_placeholder_dollaronly}, 1, $t);

$t=q{Prepare/execute does not allow use of raw ? and :foo forms};
$dbh->{pg_placeholder_dollaronly} = 0;
eval {
	$sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1});
	$sth->execute();
	$sth->finish();
};
like ($@, qr{mix placeholder}, $t);

$t='Prepare/execute allows use of raw ? and :foo forms when dollaronly set';
$dbh->{pg_placeholder_dollaronly} = 1;
eval {
	$sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1});
	$sth->{pg_placeholder_dollaronly} = 1;
	$sth->execute();
	$sth->finish();
};
like ($@, qr{unbound placeholder}, $t);

$t='Prepare works with pg_placeholder_dollaronly';
$dbh->{pg_placeholder_dollaronly} = 0;
eval {
	$sth = $dbh->prepare(q{SELECT uno ?: dos ? tres :foo bar $1}, {pg_placeholder_dollaronly => 1});
	$sth->execute();
	$sth->finish();
};
like ($@, qr{unbound placeholder}, $t);

$t='Prepare works with identical named placeholders';
eval {
	$sth = $dbh->prepare(q{SELECT :row, :row, :row, :yourboat});
	$sth->finish();
};
is ($@, q{}, $t);

SKIP: {
	skip 'Cannot run some quote tests on very old versions of Postgres', 14 if $pgversion < 80000;

$t='Prepare works with placeholders after double slashes';
eval {
	$dbh->do(q{CREATE OPERATOR // ( PROCEDURE=bit, LEFTARG=int, RIGHTARG=int )});
	$sth = $dbh->prepare(q{SELECT ? // ?});
	$sth->execute(1,2);
	$sth->finish();
};
is ($@, q{}, $t);

$t='Dollar quotes starting with a number are not treated as valid identifiers';
eval {
	$sth = $dbh->prepare(q{SELECT $123$  $123$});
	$sth->execute(1);
	$sth->finish();
};
like ($@, qr{Invalid placeholders}, $t);

$t='Dollar quotes with invalid characters are not parsed as identifiers';
for my $char (qw!+ / : @ [ `!) { ## six characters
	eval {
		$sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$});
		$sth->execute();
		$sth->finish();
	};
	like ($@, qr{syntax error}, "$t: char=$char");
}

$t='Dollar quotes with valid characters are parsed as identifiers';
$dbh->rollback();
for my $char (qw{0 9 A Z a z}) { ## six letters
	eval {
		$sth = $dbh->prepare(qq{SELECT \$abc${char}\$ 123 \$abc${char}\$});
		$sth->execute();
		$sth->finish();
	};
	is ($@, q{}, $t);
}

for my $ident (qq{\x{5317}}, qq{abc\x{5317}}, qq{_cde\x{5317}}) { ## hi-bit chars
	eval {
		$sth = $dbh->prepare(qq{SELECT \$$ident\$ 123 \$$ident\$});
		$sth->execute();
		$sth->finish();
	};
	is ($@, q{}, $t);
}

}

SKIP: {
	skip 'Cannot run backslash_quote test on Postgres < 8.2', 1 if $pgversion < 80200;

	$t='Backslash quoting inside double quotes is parsed correctly';
	$dbh->do(q{SET backslash_quote = 'on'});
	$dbh->commit();
	eval {
		$sth = $dbh->prepare(q{SELECT * FROM "\" WHERE a=?});
		$sth->execute(1);
		$sth->finish();
	};
	like ($@, qr{relation ".*" does not exist}, $t);
}

$dbh->rollback();

SKIP: {
	skip 'Cannot adjust standard_conforming_strings for testing on this version of Postgres', 2 if $pgversion < 80200;
	$t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings off';
	eval {
		$dbh->do(q{SET standard_conforming_strings = 'off'});
		local $dbh->{Warn} = '';
		$sth = $dbh->prepare(q{SELECT '\', ?});
		$sth->execute();
		$sth->finish();
	};
	like ($@, qr{unterminated quoted string}, $t);
	$dbh->rollback();

	$t='Backslash quoting inside single quotes is parsed correctly with standard_conforming_strings on';
	eval {
		$dbh->do(q{SET standard_conforming_strings = 'on'});
		$sth = $dbh->prepare(q{SELECT '\', ?::int});
		$sth->execute(1);
		$sth->finish();
	};
	is ($@, q{}, $t);
}


$t='Valid integer works when quoting with SQL_INTEGER';
my $val;
$val = $dbh->quote('123', SQL_INTEGER);
is ($val, 123, $t);

$t='Invalid integer fails to pass through when quoting with SQL_INTEGER';
$val = -1;
eval {
	$val = $dbh->quote('123abc', SQL_INTEGER);
};
like ($@, qr{Invalid integer}, $t);
is($val, -1, $t);

my $prefix = 'Valid float value works when quoting with SQL_FLOAT';
for my $float ('123','0.00','0.234','23.31562', '1.23e04','6.54e+02','4e-3','NaN','Infinity','-infinity') {
	$t = "$prefix (value=$float)";
	$val = -1;
	eval { $val = $dbh->quote($float, SQL_FLOAT); };
	is ($@, q{}, $t);
	is ($val, $float, $t);

	next unless $float =~ /\w/;

	my $lcfloat = lc $float;
	$t = "$prefix (value=$lcfloat)";
	$val = -1;
	eval { $val = $dbh->quote($lcfloat, SQL_FLOAT); };
	is ($@, q{}, $t);
	is ($val, $lcfloat, $t);

	my $ucfloat = uc $float;
	$t = "$prefix (value=$ucfloat)";
	$val = -1;
	eval { $val = $dbh->quote($ucfloat, SQL_FLOAT); };
	is ($@, q{}, $t);
	is ($val, $ucfloat, $t);
}

$prefix = 'Invalid float value fails when quoting with SQL_FLOAT';
for my $float ('3abc','123abc','','NaNum','-infinitee') {
	$t = "$prefix (value=$float)";
	$val = -1;
	eval { $val = $dbh->quote($float, SQL_FLOAT); };
	like ($@, qr{Invalid float}, $t);
	is ($val, -1, $t);
}

$dbh->rollback();

## Test placeholders plus binding
$t='Bound placeholders enforce data types when not using server side prepares';
$dbh->trace(0);
$dbh->{pg_server_prepare} = 0;
$sth = $dbh->prepare('SELECT (1+?+?)::integer');
$sth->bind_param(1, 1, SQL_INTEGER);
eval {
	$sth->execute('10foo',20);
};
like ($@, qr{Invalid integer}, 'Invalid integer test 2');

## Test quoting of the "name" type
$prefix = q{The 'name' data type does correct quoting};

for my $word (qw/User user USER trigger Trigger/) {
	$t = qq{$prefix for the word "$word"};
	my $got = $dbh->quote($word, { pg_type => PG_NAME });
	$expected = qq{"$word"};
	is($got, $expected, $t);
}

for my $word (qw/auser userz user-user/) {
	$t = qq{$prefix for the word "$word"};
	my $got = $dbh->quote($word, { pg_type => PG_NAME });
	$expected = qq{$word};
	is($got, $expected, $t);
}

## Test quoting of booleans

my %booltest = ( ## no critic (Lax::ProhibitLeadingZeros::ExceptChmod, ValuesAndExpressions::ProhibitLeadingZeros)
undef         => 'NULL',
't'           => 'TRUE',
'T'           => 'TRUE',
'true'        => 'TRUE',
'TRUE'        => 'TRUE',
1             => 'TRUE',
01            => 'TRUE',
'1'           => 'TRUE',
'0E0'         => 'TRUE',
'0e0'         => 'TRUE',
'0 but true'  => 'TRUE',
'0 BUT TRUE'  => 'TRUE',
'f'           => 'FALSE',
'F'           => 'FALSE',
0             => 'FALSE',
00            => 'FALSE',
'0'           => 'FALSE',
'false'       => 'FALSE',
'FALSE'       => 'FALSE',
12            => 'ERROR',
'01'          => 'ERROR',
'00'          => 'ERROR',
' false'      => 'ERROR',
' TRUE'       => 'ERROR',
'FALSEY'      => 'ERROR',
'trueish'     => 'ERROR',
'0E0E0'       => 'ERROR', ## Jungle love...
'0 but truez' => 'ERROR',
);

while (my ($name,$res) = each %booltest) {
	$name = undef if $name eq 'undef';
	$t = sprintf 'Boolean quoting of %s',
		defined $name ? qq{"$name"} : 'undef';
	eval { $result = $dbh->quote($name, {pg_type => PG_BOOL}); };
	if ($@) {
		if ($res eq 'ERROR' and $@ =~ /Invalid boolean/) {
			pass ($t);
		}
		else {
			fail ("Failure at $t: $@");
		}
		$dbh->rollback();
	}
	else {
		is ($result, $res, $t);
	}
}

## Begin custom type testing

$dbh->rollback();

cleanup_database($dbh,'test');
$dbh->disconnect();