plperl_sql_ascii_regress-1.patch

diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
index 188d7d2..533b41d 100644
--- a/src/pl/plperl/GNUmakefile
+++ b/src/pl/plperl/GNUmakefile
@@ -44,7 +44,12 @@ PERLCHUNKS = plc_perlboot.pl plc_trusted.pl
 SHLIB_LINK = $(perl_embed_ldflags)
 
 REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-extension=plperl  --load-extension=plperlu
-REGRESS = plperl plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array
+ifeq ($(shell echo $(ENCODING) | tr "A-Z-" "a-z_"),sql_ascii)
+REGRESS_LC_OUT_ORG=expected/plperl_lc_sql_ascii.out
+else
+REGRESS_LC_OUT_ORG=expected/plperl_lc_utf8.out
+endif
+REGRESS = plperl plperl_lc plperl_trigger plperl_shared plperl_elog plperl_util plperl_init plperlu plperl_array
 # if Perl can support two interpreters in one backend,
 # test plperl-and-plperlu cases
 ifneq ($(PERL),)
@@ -98,6 +103,8 @@ uninstall-data:
 
 
 check: all submake
+	@echo Setting up per-locale regression
+	cp $(REGRESS_LC_OUT_ORG) expected/plperl_lc.out
 	$(pg_regress_check) $(REGRESS_OPTS) $(REGRESS)
 
 installcheck: submake
diff --git a/src/pl/plperl/expected/plperl.out b/src/pl/plperl/expected/plperl.out
index df54937..906dc15 100644
--- a/src/pl/plperl/expected/plperl.out
+++ b/src/pl/plperl/expected/plperl.out
@@ -650,16 +650,6 @@ CONTEXT:  PL/Perl anonymous code block
 DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
 ERROR:  Useless use of sort in scalar context at line 1.
 CONTEXT:  PL/Perl anonymous code block
---
--- Make sure strings are validated
--- Should fail for all encodings, as nul bytes are never permitted.
---
-CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
-  return "abcd\0efg";
-$$ LANGUAGE plperl;
-SELECT perl_zerob();
-ERROR:  invalid byte sequence for encoding "UTF8": 0x00
-CONTEXT:  PL/Perl function "perl_zerob"
 -- make sure functions marked as VOID without an explicit return work
 CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
    $_SHARED{myquote} = sub {
diff --git a/src/pl/plperl/expected/plperl_lc_sql_ascii.out b/src/pl/plperl/expected/plperl_lc_sql_ascii.out
new file mode 100644
index 0000000..c454c44
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_lc_sql_ascii.out
@@ -0,0 +1,41 @@
+--
+-- Make sure strings are validated
+-- Should fail for all encodings, as nul bytes are never permitted.
+--
+CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
+  return "abcd\0efg";
+$$ LANGUAGE plperl;
+SELECT perl_zerob();
+ERROR:  invalid byte sequence for encoding "SQL_ASCII": 0x00
+CONTEXT:  PL/Perl function "perl_zerob"
+CREATE OR REPLACE FUNCTION perl_0x80_in(text) RETURNS BOOL AS $$
+  return ($_[0] eq "abc\x80de" ? "true" : "false");
+$$ LANGUAGE plperl;
+SELECT perl_0x80_in(E'abc\x80de');
+ perl_0x80_in 
+--------------
+ t
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_0x80_out() RETURNS TEXT AS $$
+  return "abc\x80de";
+$$ LANGUAGE plperl;
+SELECT perl_0x80_out() = E'abc\x80de';
+ ?column? 
+----------
+ t
+(1 row)
+
+CREATE OR REPLACE FUNCTION perl_utf_inout(text) RETURNS TEXT AS $$
+  $str = $_[0]; $code = "NotUTF8:"; $match = "ab\xe5\xb1\xb1cd";
+  if (utf8::is_utf8($str)) {
+    $code = "UTF8:"; utf8::decode($str); $match="ab\x{5c71}cd";
+  }
+  return ($str ne $match ? $code."DIFFER" : $code."ab\x{5ddd}cd");
+$$ LANGUAGE plperl;
+SELECT encode(perl_utf_inout(E'ab\xe5\xb1\xb1cd')::bytea, 'escape')
+          encode          
+--------------------------
+ NotUTF8:ab\345\267\235cd
+(1 row)
+
diff --git a/src/pl/plperl/expected/plperl_lc_utf8.out b/src/pl/plperl/expected/plperl_lc_utf8.out
new file mode 100644
index 0000000..8557b46
--- /dev/null
+++ b/src/pl/plperl/expected/plperl_lc_utf8.out
@@ -0,0 +1,33 @@
+--
+-- Make sure strings are validated
+-- Should fail for all encodings, as nul bytes are never permitted.
+--
+CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
+  return "abcd\0efg";
+$$ LANGUAGE plperl;
+SELECT perl_zerob();
+ERROR:  invalid byte sequence for encoding "UTF8": 0x00
+CONTEXT:  PL/Perl function "perl_zerob"
+CREATE OR REPLACE FUNCTION perl_0x80_in(text) RETURNS BOOL AS $$
+  return ($_[0] eq "abc\x80de" ? "true" : "false");
+$$ LANGUAGE plperl;
+SELECT perl_0x80_in(E'abc\x80de');
+ERROR:  invalid byte sequence for encoding "UTF8": 0x80
+CREATE OR REPLACE FUNCTION perl_0x80_out() RETURNS TEXT AS $$
+  return "abc\x80de";
+$$ LANGUAGE plperl;
+SELECT perl_0x80_out() = E'abc\x80de';
+ERROR:  invalid byte sequence for encoding "UTF8": 0x80
+CREATE OR REPLACE FUNCTION perl_utf_inout(text) RETURNS TEXT AS $$
+  $str = $_[0]; $code = "NotUTF8:"; $match = "ab\xe5\xb1\xb1cd";
+  if (utf8::is_utf8($str)) {
+    $code = "UTF8:"; utf8::decode($str); $match="ab\x{5c71}cd";
+  }
+  return ($str ne $match ? $code."DIFFER" : $code."ab\x{5ddd}cd");
+$$ LANGUAGE plperl;
+SELECT encode(perl_utf_inout(E'ab\xe5\xb1\xb1cd')::bytea, 'escape')
+        encode         
+-----------------------
+ UTF8:ab\345\267\235cd
+(1 row)
+
diff --git a/src/pl/plperl/sql/plperl.sql b/src/pl/plperl/sql/plperl.sql
index 84af1fd..a5e3840 100644
--- a/src/pl/plperl/sql/plperl.sql
+++ b/src/pl/plperl/sql/plperl.sql
@@ -423,15 +423,6 @@ DO $do$ use strict; my $name = "foo"; my $ref = $$name; $do$ LANGUAGE plperl;
 -- yields "ERROR:  Useless use of sort in scalar context."
 DO $do$ use warnings FATAL => qw(void) ; my @y; my $x = sort @y; 1; $do$ LANGUAGE plperl;
 
---
--- Make sure strings are validated
--- Should fail for all encodings, as nul bytes are never permitted.
---
-CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
-  return "abcd\0efg";
-$$ LANGUAGE plperl;
-SELECT perl_zerob();
-
 -- make sure functions marked as VOID without an explicit return work
 CREATE OR REPLACE FUNCTION myfuncs() RETURNS void AS $$
    $_SHARED{myquote} = sub {
diff --git a/src/pl/plperl/sql/plperl_lc.sql b/src/pl/plperl/sql/plperl_lc.sql
new file mode 100644
index 0000000..fd75bc0
--- /dev/null
+++ b/src/pl/plperl/sql/plperl_lc.sql
@@ -0,0 +1,24 @@
+--
+-- Make sure strings are validated
+-- Should fail for all encodings, as nul bytes are never permitted.
+--
+CREATE OR REPLACE FUNCTION perl_zerob() RETURNS TEXT AS $$
+  return "abcd\0efg";
+$$ LANGUAGE plperl;
+SELECT perl_zerob();
+CREATE OR REPLACE FUNCTION perl_0x80_in(text) RETURNS BOOL AS $$
+  return ($_[0] eq "abc\x80de" ? "true" : "false");
+$$ LANGUAGE plperl;
+SELECT perl_0x80_in(E'abc\x80de');
+CREATE OR REPLACE FUNCTION perl_0x80_out() RETURNS TEXT AS $$
+  return "abc\x80de";
+$$ LANGUAGE plperl;
+SELECT perl_0x80_out() = E'abc\x80de';
+CREATE OR REPLACE FUNCTION perl_utf_inout(text) RETURNS TEXT AS $$
+  $str = $_[0]; $code = "NotUTF8:"; $match = "ab\xe5\xb1\xb1cd";
+  if (utf8::is_utf8($str)) {
+    $code = "UTF8:"; utf8::decode($str); $match="ab\x{5c71}cd";
+  }
+  return ($str ne $match ? $code."DIFFER" : $code."ab\x{5ddd}cd");
+$$ LANGUAGE plperl;
+SELECT encode(perl_utf_inout(E'ab\xe5\xb1\xb1cd')::bytea, 'escape')
diff --git a/src/tools/msvc/vcregress.pl b/src/tools/msvc/vcregress.pl
index ef70350..58ca5b2 100644
--- a/src/tools/msvc/vcregress.pl
+++ b/src/tools/msvc/vcregress.pl
@@ -183,11 +183,19 @@ sub plcheck
 		}
 		print "============================================================\n";
 		print "Checking $lang\n";
+		my @encoding =();
+		if ($lang eq 'plperl')
+		{
+			setupPlperlRegress("../../../$Config/psql/psql.exe");
+		}
+
 		my @args = (
 			"../../../$Config/pg_regress/pg_regress",
 			"--psqldir=../../../$Config/psql",
-			"--dbname=pl_regression",@lang_args,@tests
+			"--dbname=pl_regression",@encoding,@lang_args,@tests
 		);
+		print join('//', @args), '\n';
+
 		system(@args);
 		my $status = $? >> 8;
 		exit $status if $status;
@@ -197,6 +205,44 @@ sub plcheck
 	chdir "../../..";
 }
 
+sub setupPlperlRegress
+{
+	my $psql_cmd = shift;
+	my $encoding = `$psql_cmd -t -d postgres -c "select encoding from pg_database where datname='template0'"`;
+	my $status = $? >> 8;
+	my $expectfile = "expected/plperl_lc_utf8.out";
+	my @ret = ();
+	exit $status if $status;
+	
+	if ($encoding == 0)
+	{
+		$expectfile = "expected/plperl_lc_sql_ascii.out";
+		@ret = ("--encoding=SQL_ASCII");
+	}
+
+	print "Copy $expectfile as expected/plperl_lc.out\n";
+	simpleCopyFile($expectfile, 'expected/plperl_lc.out');
+
+	return @ret;
+}
+
+sub simpleCopyFile
+{
+	my ($from, $to) = @_;
+	my $inf;
+	my $outf;
+
+	# Copy expect file.
+	open($inf, "<$from") ||
+	    die "Failed to open file \'$from\': $!";
+	open($outf, ">expected/plperl_lc.out") ||
+	    die "Failed to open file \'$to\': $!";
+	print $outf $_ while(<$inf>);
+	close($inf);
+	close($outf);
+	
+}
+
 sub contribcheck
 {
 	chdir "../../../contrib";