Add regression tests for previously-untested PL/Perl features. From

Neil Conway · Neil Conway · commit 11a0c3741f3c · 2005-05-24T08:05:36.000Z
Andrew Dunstan.
diff --git a/src/pl/plperl/GNUmakefile b/src/pl/plperl/GNUmakefile
@@ -1,5 +1,5 @@
 # Makefile for PL/Perl
-# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.20 2005/05/17 18:26:22 tgl Exp $
+# $PostgreSQL: pgsql/src/pl/plperl/GNUmakefile,v 1.21 2005/05/24 08:05:36 neilc Exp $
 
 subdir = src/pl/plperl
 top_builddir = ../../..
@@ -37,7 +37,7 @@ OBJS = plperl.o spi_internal.o SPI.o
 SHLIB_LINK = $(perl_embed_ldflags) $(BE_DLLLIBS)
 
 REGRESS_OPTS = --dbname=$(PL_TESTDB) --load-language=plperl
-REGRESS = plperl
+REGRESS = plperl plperl_trigger plperl_shared
 
 include $(top_srcdir)/src/Makefile.shlib
 
diff --git a/src/pl/plperl/expected/plperl_shared.out b/src/pl/plperl/expected/plperl_shared.out
@@ -0,0 +1,26 @@
+-- test the shared hash
+create function setme(key text, val text) returns void language plperl as $$
+
+  my $key = shift;
+  my $val = shift;
+  $_SHARED{$key}= $val;
+
+$$;
+create function getme(key text) returns text language plperl as $$
+
+  my $key = shift;
+  return $_SHARED{$key};
+
+$$;
+select setme('ourkey','ourval');
+ setme 
+-------
+ 
+(1 row)
+
+select getme('ourkey');
+ getme  
+--------
+ ourval
+(1 row)
+
diff --git a/src/pl/plperl/expected/plperl_trigger.out b/src/pl/plperl/expected/plperl_trigger.out
@@ -0,0 +1,67 @@
+-- test plperl triggers
+CREATE TABLE trigger_test (
+        i int,
+        v varchar
+);
+CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
+
+    if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0))
+    {
+        return "SKIP";   # Skip INSERT/UPDATE command
+    } 
+    elsif ($_TD->{new}{v} ne "immortal") 
+    {
+        $_TD->{new}{v} .= "(modified by trigger)";
+        return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command
+    } 
+    else 
+    {
+        return;          # Proceed INSERT/UPDATE command
+    }
+$$ LANGUAGE plperl;
+CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE "valid_id"();
+INSERT INTO trigger_test (i, v) VALUES (1,'first line');
+INSERT INTO trigger_test (i, v) VALUES (2,'second line');
+INSERT INTO trigger_test (i, v) VALUES (3,'third line');
+INSERT INTO trigger_test (i, v) VALUES (4,'immortal');
+INSERT INTO trigger_test (i, v) VALUES (101,'bad id');
+SELECT * FROM trigger_test;
+ i |                v                 
+---+----------------------------------
+ 1 | first line(modified by trigger)
+ 2 | second line(modified by trigger)
+ 3 | third line(modified by trigger)
+ 4 | immortal
+(4 rows)
+
+UPDATE trigger_test SET i = 5 where i=3;
+UPDATE trigger_test SET i = 100 where i=1;
+SELECT * FROM trigger_test;
+ i |                          v                           
+---+------------------------------------------------------
+ 1 | first line(modified by trigger)
+ 2 | second line(modified by trigger)
+ 4 | immortal
+ 5 | third line(modified by trigger)(modified by trigger)
+(4 rows)
+
+CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$
+    if ($_TD->{old}{v} eq $_TD->{args}[0])
+    {
+        return "SKIP"; # Skip DELETE command
+    } 
+    else 
+    { 
+        return;        # Proceed DELETE command
+    };
+$$ LANGUAGE plperl;
+CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE immortal('immortal');
+DELETE FROM trigger_test;
+SELECT * FROM trigger_test;
+ i |    v     
+---+----------
+ 4 | immortal
+(1 row)
+
diff --git a/src/pl/plperl/sql/plperl_shared.sql b/src/pl/plperl/sql/plperl_shared.sql
@@ -0,0 +1,22 @@
+-- test the shared hash
+
+create function setme(key text, val text) returns void language plperl as $$
+
+  my $key = shift;
+  my $val = shift;
+  $_SHARED{$key}= $val;
+
+$$;
+
+create function getme(key text) returns text language plperl as $$
+
+  my $key = shift;
+  return $_SHARED{$key};
+
+$$;
+
+select setme('ourkey','ourval');
+
+select getme('ourkey');
+
+
diff --git a/src/pl/plperl/sql/plperl_trigger.sql b/src/pl/plperl/sql/plperl_trigger.sql
@@ -0,0 +1,61 @@
+-- test plperl triggers
+
+CREATE TABLE trigger_test (
+        i int,
+        v varchar
+);
+
+CREATE OR REPLACE FUNCTION valid_id() RETURNS trigger AS $$
+
+    if (($_TD->{new}{i}>=100) || ($_TD->{new}{i}<=0))
+    {
+        return "SKIP";   # Skip INSERT/UPDATE command
+    } 
+    elsif ($_TD->{new}{v} ne "immortal") 
+    {
+        $_TD->{new}{v} .= "(modified by trigger)";
+        return "MODIFY"; # Modify tuple and proceed INSERT/UPDATE command
+    } 
+    else 
+    {
+        return;          # Proceed INSERT/UPDATE command
+    }
+$$ LANGUAGE plperl;
+
+CREATE TRIGGER "test_valid_id_trig" BEFORE INSERT OR UPDATE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE "valid_id"();
+
+INSERT INTO trigger_test (i, v) VALUES (1,'first line');
+INSERT INTO trigger_test (i, v) VALUES (2,'second line');
+INSERT INTO trigger_test (i, v) VALUES (3,'third line');
+INSERT INTO trigger_test (i, v) VALUES (4,'immortal');
+
+INSERT INTO trigger_test (i, v) VALUES (101,'bad id');
+
+SELECT * FROM trigger_test;
+
+UPDATE trigger_test SET i = 5 where i=3;
+
+UPDATE trigger_test SET i = 100 where i=1;
+
+SELECT * FROM trigger_test;
+
+CREATE OR REPLACE FUNCTION immortal() RETURNS trigger AS $$
+    if ($_TD->{old}{v} eq $_TD->{args}[0])
+    {
+        return "SKIP"; # Skip DELETE command
+    } 
+    else 
+    { 
+        return;        # Proceed DELETE command
+    };
+$$ LANGUAGE plperl;
+
+CREATE TRIGGER "immortal_trig" BEFORE DELETE ON trigger_test
+FOR EACH ROW EXECUTE PROCEDURE immortal('immortal');
+
+DELETE FROM trigger_test;
+
+
+SELECT * FROM trigger_test;
+
