Browse files

- Update all Copyright notices.

- New (undocumented) functions r_version(), plr_set_rhome(),
  and plr_unset_rhome().
- Use Rembedded.h if available
- If R_HOME environment variable is not defined, attempt to find it using
  pkg-config. (idea from Dirk Eddelbuettel)
- In any case, create define for default R_HOME based on pkg-config. Use
  the default R_HOME during R interpreter init if the environment variable
  is unset. (idea from Dirk Eddelbuettel)
- Use PGDLLIMPORT instead of DLLIMPORT is it is defined.
- Switch to Rf_isVectorList instead of IS_LIST for spi_execp argument test.
  Prior to R-2.4.0, the latter allows bad arguments to get past, causing
  a segfault in an R internal type coersion function. (found by Steve Singer)
- New spi cursor manupulation functions (patch courtesy of Steve Singer).
- Force R interpreter non-interactive mode. Fixes some cases that previously
  appeared to be hung postgres backends in certain errors occured in R
  (R was actually waiting for user input). On some platforms this situation
  caused segfaults instead. (found by Jie Zhang)
- When a plr function source is empty, plr tries to find a function by the
  same name within the R interpreter environment. If the function could not
  be found, it would cause a hang or segfault. This was not easily trapped
  in the R interpreter. Now, build and compile the equivalent plr source.
  This allows the R interpreter to trap the error properly when the function
  does not exist.
- PG_VERSION_NUM if available. (patch courtesy of Neal Conway)
- Plug memory leak in POP_PLERRCONTEXT. (patch courtesy of Steve Singer)
- Consolidated Makefile from plr-8.2.0.x, obsoleting Makefile.pgxs
  • Loading branch information...
1 parent 891c309 commit 748a174e00de3a9da01e930a37f8472cdaa75dbb jconway committed Sep 8, 2007
Showing with 2,253 additions and 151 deletions.
  1. +29 −2 Makefile
  2. +10 −2 README.plr
  3. +81 −10 doc/plr.sgml
  4. +868 −0 expected/plr.out.7.3
  5. +870 −0 expected/plr.out.7.4
  6. +8 −1 pg_backend_support.c
  7. +59 −95 pg_conversion.c
  8. +200 −3 pg_rsupport.c
  9. +35 −20 pg_userfuncs.c
  10. +44 −10 plr.c
  11. +17 −7 plr.h
  12. +18 −0 plr.sql.in
  13. +14 −1 sql/plr.sql
View
31 Makefile
@@ -1,8 +1,20 @@
# location of R library
+
+ifdef R_HOME
r_libdir1x = ${R_HOME}/bin
r_libdir2x = ${R_HOME}/lib
# location of R includes
r_includespec = ${R_HOME}/include
+else
+R_HOME := $(shell pkg-config --variable=rhome libR)
+r_libdir1x := $(shell pkg-config --variable=rlibdir libR)
+r_libdir2x := $(shell pkg-config --variable=rlibdir libR)
+r_includespec := $(shell pkg-config --variable=rincludedir libR)
+endif
+
+rhomedef := $(shell pkg-config --variable=rhome libR)
+
+ifneq (,${R_HOME})
MODULE_big := plr
PG_CPPFLAGS += -I$(r_includespec)
@@ -15,10 +27,15 @@ DOCS := README.plr
REGRESS := plr
EXTRA_CLEAN := doc/HTML.index expected/plr.out
+ifdef USE_PGXS
+PGXS := $(shell pg_config --pgxs)
+include $(PGXS)
+else
subdir = contrib/plr
top_builddir = ../..
include $(top_builddir)/src/Makefile.global
include $(top_srcdir)/contrib/contrib-global.mk
+endif
ifeq ($(PORTNAME), darwin)
DYSUFFIX = dylib
@@ -50,7 +67,7 @@ ifneq (,$(findstring yes, $(shared_libr)$(allow_nonpic_in_shlib)))
override CPPFLAGS := -I$(srcdir) -I$(r_includespec) $(CPPFLAGS)
override CPPFLAGS += -DPKGLIBDIR=\"$(pkglibdir)\" -DDLSUFFIX=\"$(DLSUFFIX)\"
-rpath :=
+override CPPFLAGS += -DR_HOME_DEFAULT=\"$(rhomedef)\"
installcheck: plrinstallcheck
@@ -70,4 +87,14 @@ all:
echo "*** the documentation for details."; \
echo ""
-endif # can't build
+endif # can't build - cannot find libR
+
+else # can't build - no R_HOME
+
+all:
+ @echo ""; \
+ echo "*** Cannot build PL/R because R_HOME cannot be found." ; \
+ echo "*** Refer to the documentation for details."; \
+ echo ""
+
+endif
View
12 README.plr
@@ -2,7 +2,7 @@
* PL/R - PostgreSQL support for R as a
* procedural language (PL)
*
- * Copyright (c) 2003-2006 by Joseph E. Conway
+ * Copyright (c) 2003-2007 by Joseph E. Conway
* ALL RIGHTS RESERVED
*
* Joe Conway <mail@joeconway.com>
@@ -29,8 +29,16 @@
* Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*
*/
+Version 0.1 (10 February, 2003):
+ - Initial release
-See http://www.joeconway.com/plr/ for release notes
+Version 0.2 (15 February, 2003):
+ - Incorporates fixes for lots of bugs and ommissions, in the code and
+ docs. Too many to mention, but faithfully recorded in cvs commit
+ messages.
+
+Version 0.5 (5 August, 2003) and afterward:
+ - See http://www.joeconway.com/plr/ for release notes and latest docs
Notes:
- R headers are required. Download and install R prior to building
View
91 doc/plr.sgml
@@ -3,7 +3,7 @@
<title>PL/R User's Guide - R Procedural Language</title>
<bookinfo>
<copyright>
- <year>2003-2006</year>
+ <year>2003</year>
<holder>Joseph E Conway</holder>
</copyright>
</bookinfo>
@@ -67,6 +67,14 @@
</programlisting>
</para>
+ <note>
+ <para>
+ PL/R should build cleanly with PostgreSQL 7.3.x, 7.4.x, and 8.0.x. and
+ R 1.6.2 and newer. The current release passed its regression test with
+ R 2.0.1 under Fedora Core 2.
+ </para>
+ </note>
+
<para>
You can use <literal>plr.sql</literal> (which is created in
<literal>contrib/plr</literal>) to create the language and support
@@ -106,24 +114,16 @@ CREATE LANGUAGE plr HANDLER plr_call_handler;
when it was configured, in order for the libR shared object library to be
available.
</para>
- </tip>
-
- <tip>
<para>
Additionally, libR must be findable by your runtime linker.
On Linux, this involves adding an entry in /etc/ld.so.conf for the
location of libR (typically $R_HOME/bin), and then running ldconfig.
Refer to <literal>man ldconfig</literal> or its equivalent for your system.
</para>
- </tip>
-
- <tip>
<para>
R_HOME must be defined in the environment of the user under which
PostgreSQL is started, <emphasis>before</emphasis> the postmaster
- is started. Otherwise PL/R will refuse to load. See plr_environ(),
- which allows examination of the environment available to the
- PostgreSQL postmaster process.
+ is started. Otherwise PL/R will refuse to load.
</para>
</tip>
@@ -790,6 +790,77 @@ select * from test_spi_execp('sp') as t(typeid oid, typename name);
</varlistentry>
<varlistentry>
+ <term>
+ <function>pg.spi.cursor_open</function>(
+ <type> character</type> <replaceable>cursor_name</replaceable>,
+ <type>external pointer</type> <replaceable>saved_plan</replaceable>,
+ <type>variable list</type> <replaceable>value_list</replaceable>)
+ </term>
+ <listitem>
+ <para>
+ Opens a cursor identified by cursor_name. The cursor can then be used to scroll through
+ the results of a query plan previously prepared by pg.spi.prepare. Any arguments to
+ the plan should be specified in argvalues similar to pg.spi.execp. Only read-only cursors
+ are supported at the moment.
+ <programlisting>
+plan <- pg.spi.prepare('SELECT * FROM pg_class');
+cursor_obj <- pg.spi.cursor_open('my_cursor',plan);
+ </programlisting>
+ </para>
+ <para>
+ Returns a cursor object that be be passed to <function>pg.spi.cursor_fetch</function>
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <function>pg.spi.cursor_fetch</function>(
+ <type>external pointer</type> <replaceable>cursor</replaceable>,
+ <type>boolean</type> <replaceable>forward</replaceable>,
+ <type>integer</type> <replaceable>rows</replaceable>)
+ </term>
+ <listitem>
+ <para>
+ Fetches rows from the cursor object previosuly returned by <function>pg.spi.cursor_open
+ </function>. If forward is TRUE then the cursor is moved forward to
+ fetch at most the number of rows required by the rows parameter. If forward is
+ FALSE then the cursor is moved backrwards at most the number of rows specified.
+ </para>
+ <para>
+ rows indicates the maximum number of rows that should be returned.
+ </para>
+ <para>
+ <programlisting>
+plan <- pg.spi.prepare('SELECT * FROM pg_class');
+cursor_obj <- pg.spi.cursor_open('my_cursor',plan);
+data <- pg.spi.cursor_forward(cursor_obj,TRUE,10);
+ </programlisting>
+ </para>
+ <para>
+ Returns a data frame containing the results.
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
+ <term>
+ <function>pg.spi.cursor_close</function>(
+ <type>external pointer</type><replaceable>cursor</replaceable>)
+ </term>
+ <listitem>
+ <para>
+ Closes a cursor previously opened by <function>pg.spi.cursor_open</function>
+ <programlisting>
+plan <- pg.spi.prepare('SELECT * FROM pg_class');
+cursor_obj <- pg.spi.cursor_open('my_cursor',plan);
+pg.spi.cursor_close(cursor_obj);
+ </programlisting>
+ </para>
+ </listitem>
+ </varlistentry>
+
+ <varlistentry>
<term><function>pg.spi.lastoid</function>()</term>
<listitem>
<para>
View
868 expected/plr.out.7.3
@@ -0,0 +1,868 @@
+--
+-- first, define the language and functions. Turn off echoing so that expected file
+-- does not depend on contents of plr.sql.
+--
+\set ECHO none
+-- make typenames available in the global namespace
+select load_r_typenames();
+ load_r_typenames
+------------------
+ OK
+(1 row)
+
+CREATE TABLE plr_modules (
+ modseq int4,
+ modsrc text
+);
+INSERT INTO plr_modules VALUES (0, 'pg.test.module.load <-function(msg) {print(msg)}');
+select reload_plr_modules();
+ reload_plr_modules
+--------------------
+ OK
+(1 row)
+
+--
+-- plr_modules test
+--
+create or replace function pg_test_module_load(text) returns text as 'pg.test.module.load(arg1)' language 'plr';
+select pg_test_module_load('hello world');
+ pg_test_module_load
+---------------------
+ hello world
+(1 row)
+
+--
+-- user defined R function test
+--
+select install_rcmd('pg.test.install <-function(msg) {print(msg)}');
+ install_rcmd
+--------------
+ OK
+(1 row)
+
+create or replace function pg_test_install(text) returns text as 'pg.test.install(arg1)' language 'plr';
+select pg_test_install('hello world');
+ pg_test_install
+-----------------
+ hello world
+(1 row)
+
+--
+-- a variety of plr functions
+--
+create or replace function throw_notice(text) returns text as 'pg.thrownotice(arg1)' language 'plr';
+select throw_notice('hello');
+NOTICE: hello
+ throw_notice
+--------------
+ hello
+(1 row)
+
+create or replace function paste(_text,_text,text) returns text[] as 'paste(arg1,arg2, sep = arg3)' language 'plr';
+select paste('{hello, happy}','{world, birthday}',' ');
+ paste
+----------------------------------
+ {"hello world","happy birthday"}
+(1 row)
+
+create or replace function vec(_float8) returns _float8 as 'arg1' language 'plr';
+select vec('{1.23, 1.32}'::float8[]);
+ vec
+-------------
+ {1.23,1.32}
+(1 row)
+
+create or replace function vec(float, float) returns _float8 as 'c(arg1,arg2)' language 'plr';
+select vec(1.23, 1.32);
+ vec
+-------------
+ {1.23,1.32}
+(1 row)
+
+create or replace function echo(text) returns text as 'print(arg1)' language 'plr';
+select echo('hello');
+ echo
+-------
+ hello
+(1 row)
+
+create or replace function reval(text) returns text as 'eval(parse(text = arg1))' language 'plr';
+select reval('a <- sd(c(1,2,3)); b <- mean(c(1,2,3)); a + b');
+ reval
+-------
+ 3
+(1 row)
+
+create or replace function "commandArgs"() returns text[] as '' language 'plr';
+select "commandArgs"();
+ commandArgs
+---------------------------
+ {PL/R,--silent,--no-save}
+(1 row)
+
+create or replace function vec(float) returns text as 'c(arg1)' language 'plr';
+select vec(1.23);
+ vec
+------
+ 1.23
+(1 row)
+
+create or replace function reval(_text) returns text as 'eval(parse(text = arg1))' language 'plr';
+select round(reval('{"sd(c(1.12,1.23,1.18,1.34))"}'::text[])::numeric,8);
+ round
+------------
+ 0.09322911
+(1 row)
+
+create or replace function print(text) returns text as '' language 'plr';
+select print('hello');
+ print
+-------
+ hello
+(1 row)
+
+create or replace function cube(int) returns float as 'sq <- function(x) {return(x * x)}; return(arg1 * sq(arg1))' language 'plr';
+select cube(3);
+ cube
+------
+ 27
+(1 row)
+
+create or replace function sd(_float8) returns float as 'sd(arg1)' language 'plr';
+select round(sd('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.08180261
+(1 row)
+
+create or replace function sd(_float8) returns float as '' language 'plr';
+select round(sd('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.08180261
+(1 row)
+
+create or replace function mean(_float8) returns float as '' language 'plr';
+select mean('{1.23,1.31,1.42,1.27}'::_float8);
+ mean
+--------
+ 1.3075
+(1 row)
+
+create or replace function sprintf(text,text,text) returns text as 'sprintf(arg1,arg2,arg3)' language 'plr';
+select sprintf('%s is %s feet tall', 'Sven', '7');
+ sprintf
+---------------------
+ Sven is 7 feet tall
+(1 row)
+
+--
+-- test aggregates
+--
+create table foo(f0 int, f1 text, f2 float8) with oids;
+insert into foo values(1,'cat1',1.21);
+insert into foo values(2,'cat1',1.24);
+insert into foo values(3,'cat1',1.18);
+insert into foo values(4,'cat1',1.26);
+insert into foo values(5,'cat1',1.15);
+insert into foo values(6,'cat2',1.15);
+insert into foo values(7,'cat2',1.26);
+insert into foo values(8,'cat2',1.32);
+insert into foo values(9,'cat2',1.30);
+create or replace function r_median(_float8) returns float as 'median(arg1)' language 'plr';
+select r_median('{1.23,1.31,1.42,1.27}'::_float8);
+ r_median
+----------
+ 1.29
+(1 row)
+
+CREATE AGGREGATE median (sfunc = plr_array_accum, basetype = float8, stype = _float8, finalfunc = r_median);
+select f1, median(f2) from foo group by f1 order by f1;
+ f1 | median
+------+--------
+ cat1 | 1.21
+ cat2 | 1.28
+(2 rows)
+
+create or replace function r_gamma(_float8) returns float as 'gamma(arg1)' language 'plr';
+select round(r_gamma('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.91075486
+(1 row)
+
+CREATE AGGREGATE gamma (sfunc = plr_array_accum, basetype = float8, stype = _float8, finalfunc = r_gamma);
+select f1, round(gamma(f2)::numeric,8) from foo group by f1 order by f1;
+ f1 | round
+------+------------
+ cat1 | 0.91557649
+ cat2 | 0.93304093
+(2 rows)
+
+--
+-- test returning vectors, arrays, matricies, and dataframes
+-- as scalars, arrays, and records
+--
+create or replace function test_vt() returns text as 'array(1:10,c(2,5))' language 'plr';
+select test_vt();
+ test_vt
+---------
+ 1
+(1 row)
+
+create or replace function test_vi() returns int as 'array(1:10,c(2,5))' language 'plr';
+select test_vi();
+ test_vi
+---------
+ 1
+(1 row)
+
+create or replace function test_mt() returns text as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mt();
+ test_mt
+---------
+ 1
+(1 row)
+
+create or replace function test_mi() returns int as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mi();
+ test_mi
+---------
+ 1
+(1 row)
+
+create or replace function test_dt() returns text as 'as.data.frame(array(1:10,c(2,5)))[[1]]' language 'plr';
+select test_dt();
+ test_dt
+---------
+ 1
+(1 row)
+
+create or replace function test_di() returns int as 'as.data.frame(array(1:10,c(2,5)))[[1]]' language 'plr';
+select test_di() as error;
+ error
+-------
+ 1
+(1 row)
+
+create or replace function test_vta() returns text[] as 'array(1:10,c(2,5))' language 'plr';
+select test_vta();
+ test_vta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_via() returns int[] as 'array(1:10,c(2,5))' language 'plr';
+select test_via();
+ test_via
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_mta() returns text[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mta();
+ test_mta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_mia() returns int[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mia();
+ test_mia
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dia() returns int[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr';
+select test_dia();
+ test_dia
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dta() returns text[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr';
+select test_dta();
+ test_dta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dta1() returns text[] as 'as.data.frame(array(letters[1:10], c(2,5)))' language 'plr';
+select test_dta1();
+ test_dta1
+---------------------------
+ {{a,c,e,g,i},{b,d,f,h,j}}
+(1 row)
+
+create or replace function test_dta2() returns text[] as 'as.data.frame(data.frame(letters[1:10],1:10))' language 'plr';
+select test_dta2();
+ test_dta2
+----------------------------------------------------------------
+ {{a,1},{b,2},{c,3},{d,4},{e,5},{f,6},{g,7},{h,8},{i,9},{j,10}}
+(1 row)
+
+-- generates expected error
+create or replace function test_dia1() returns int[] as 'as.data.frame(array(letters[1:10], c(2,5)))' language 'plr';
+select test_dia1() as error;
+ERROR: pg_atoi: error in "a": can't parse "a"
+create or replace function test_dtup() returns setof record as 'data.frame(letters[1:10],1:10)' language 'plr';
+select * from test_dtup() as t(f1 text, f2 int);
+ f1 | f2
+----+----
+ a | 1
+ b | 2
+ c | 3
+ d | 4
+ e | 5
+ f | 6
+ g | 7
+ h | 8
+ i | 9
+ j | 10
+(10 rows)
+
+create or replace function test_mtup() returns setof record as 'as.matrix(array(1:15,c(5,3)))' language 'plr';
+select * from test_mtup() as t(f1 int, f2 int, f3 int);
+ f1 | f2 | f3
+----+----+----
+ 1 | 6 | 11
+ 2 | 7 | 12
+ 3 | 8 | 13
+ 4 | 9 | 14
+ 5 | 10 | 15
+(5 rows)
+
+create or replace function test_vtup() returns setof record as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vtup() as t(f1 int);
+ f1
+----
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+create or replace function test_vint() returns setof int as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vint();
+ test_vint
+-----------
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+--
+-- try again with named tuple types
+--
+CREATE TYPE dtup AS (f1 text, f2 int);
+CREATE TYPE mtup AS (f1 int, f2 int, f3 int);
+CREATE TYPE vtup AS (f1 int);
+create or replace function test_dtup1() returns setof dtup as 'data.frame(letters[1:10],1:10)' language 'plr';
+select * from test_dtup1();
+ f1 | f2
+----+----
+ a | 1
+ b | 2
+ c | 3
+ d | 4
+ e | 5
+ f | 6
+ g | 7
+ h | 8
+ i | 9
+ j | 10
+(10 rows)
+
+create or replace function test_dtup2() returns setof dtup as 'data.frame(c("c","qw","ax","h","k","ax","l","t","b","u"),1:10)' language 'plr';
+select * from test_dtup2();
+ f1 | f2
+----+----
+ c | 1
+ qw | 2
+ ax | 3
+ h | 4
+ k | 5
+ ax | 6
+ l | 7
+ t | 8
+ b | 9
+ u | 10
+(10 rows)
+
+create or replace function test_mtup1() returns setof mtup as 'as.matrix(array(1:15,c(5,3)))' language 'plr';
+select * from test_mtup1();
+ f1 | f2 | f3
+----+----+----
+ 1 | 6 | 11
+ 2 | 7 | 12
+ 3 | 8 | 13
+ 4 | 9 | 14
+ 5 | 10 | 15
+(5 rows)
+
+create or replace function test_vtup1() returns setof vtup as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vtup1();
+ f1
+----
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+--
+-- test pg R support functions (e.g. SPI_exec)
+--
+create or replace function pg_quote_ident(text) returns text as 'pg.quoteident(arg1)' language 'plr';
+select pg_quote_ident('Hello World');
+ pg_quote_ident
+----------------
+ "Hello World"
+(1 row)
+
+create or replace function pg_quote_literal(text) returns text as 'pg.quoteliteral(arg1)' language 'plr';
+select pg_quote_literal('Hello\'World');
+ pg_quote_literal
+------------------
+ 'Hello''World'
+(1 row)
+
+create or replace function test_spi_t(text) returns text as '(pg.spi.exec(arg1))[[1]]' language 'plr';
+select test_spi_t('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''');
+ test_spi_t
+------------
+ 25
+(1 row)
+
+create or replace function test_spi_ta(text) returns text[] as 'pg.spi.exec(arg1)' language 'plr';
+select test_spi_ta('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''');
+ test_spi_ta
+----------------------
+ {{25,text},{26,oid}}
+(1 row)
+
+create or replace function test_spi_tup(text) returns setof record as 'pg.spi.exec(arg1)' language 'plr';
+select * from test_spi_tup('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''') as t(typeid oid, typename name);
+ typeid | typename
+--------+----------
+ 25 | text
+ 26 | oid
+(2 rows)
+
+create or replace function fetch_pgoid(text) returns int as 'pg.reval(arg1)' language 'plr';
+select fetch_pgoid('BYTEAOID');
+ fetch_pgoid
+-------------
+ 17
+(1 row)
+
+create or replace function test_spi_prep(text) returns text as 'sp <<- pg.spi.prepare(arg1, c(NAMEOID, NAMEOID)); print("OK")' language 'plr';
+select test_spi_prep('select oid, typname from pg_type where typname = $1 or typname = $2');
+ test_spi_prep
+---------------
+ OK
+(1 row)
+
+create or replace function test_spi_execp(text, text, text) returns setof record as 'pg.spi.execp(pg.reval(arg1), list(arg2,arg3))' language 'plr';
+select * from test_spi_execp('sp','oid','text') as t(typeid oid, typename name);
+ typeid | typename
+--------+----------
+ 25 | text
+ 26 | oid
+(2 rows)
+
+create or replace function test_spi_lastoid(text) returns text as 'pg.spi.exec(arg1); pg.spi.lastoid()/pg.spi.lastoid()' language 'plr';
+select test_spi_lastoid('insert into foo values(10,''cat3'',3.333)') as "ONE";
+ ONE
+-----
+ 1
+(1 row)
+
+--
+-- test NULL handling
+--
+CREATE OR REPLACE FUNCTION r_test (float8) RETURNS float8 AS 'arg1' LANGUAGE 'plr';
+select r_test(null) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+CREATE OR REPLACE FUNCTION r_max (integer, integer) RETURNS integer AS 'if (is.null(arg1) && is.null(arg2)) return(NA);if (is.null(arg1)) return(arg2);if (is.null(arg2)) return(arg1);if (arg1 > arg2) return(arg1);arg2' LANGUAGE 'plr';
+select r_max(1,2) as "TWO";
+ TWO
+-----
+ 2
+(1 row)
+
+select r_max(null,2) as "TWO";
+ TWO
+-----
+ 2
+(1 row)
+
+select r_max(1,null) as "ONE";
+ ONE
+-----
+ 1
+(1 row)
+
+select r_max(null,null) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+--
+-- test tuple arguments
+--
+create or replace function get_foo(int) returns foo as 'select * from foo where f0 = $1' language 'sql';
+create or replace function test_foo(foo) returns foo as 'return(arg1)' language 'plr';
+select * from test_foo(get_foo(1));
+ f0 | f1 | f2
+----+------+------
+ 1 | cat1 | 1.21
+(1 row)
+
+--
+-- test 2D array argument
+--
+create or replace function test_in_m_tup(_int4) returns setof record as 'arg1' language 'plr';
+select * from test_in_m_tup('{{1,3,5},{2,4,6}}') as t(f1 int, f2 int, f3 int);
+ f1 | f2 | f3
+----+----+----
+ 1 | 3 | 5
+ 2 | 4 | 6
+(2 rows)
+
+--
+-- test 3D array argument
+--
+create or replace function arr3d(_int4,int4,int4,int4) returns int4 as '
+if (arg2 < 1 || arg3 < 1 || arg4 < 1)
+ return(NA)
+if (arg2 > dim(arg1)[1] || arg3 > dim(arg1)[2] || arg4 > dim(arg1)[3])
+ return(NA)
+return(arg1[arg2,arg3,arg4])
+' language 'plr' WITH (isstrict);
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',2,3,1) as "231";
+ 231
+-----
+ 231
+(1 row)
+
+-- for sake of comparison, see what normal pgsql array operations produces
+select f1[2][3][1] as "231" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ 231
+-----
+ 231
+(1 row)
+
+-- out-of-bounds, returns null
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',1,4,1) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+select f1[1][4][1] is null as "NULL" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ NULL
+------
+ t
+(1 row)
+
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',0,1,1) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+select f1[0][1][1] is null as "NULL" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ NULL
+------
+ t
+(1 row)
+
+--
+-- test 3D array return value
+--
+create or replace function arr3d(_int4) returns int4[] as 'return(arg1)' language 'plr' WITH (isstrict);
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}');
+ arr3d
+-------------------------------------------------------------------
+ {{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}
+(1 row)
+
+--
+-- Trigger support tests
+--
+--
+-- test that NULL return value suppresses the change
+--
+create or replace function rejectfoo() returns trigger as 'return(NULL)' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure rejectfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+update foo set f1 = 'zzz';
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+delete from foo;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test that returning OLD/NEW as appropriate allow the change unmodified
+--
+create or replace function acceptfoo() returns trigger as '
+switch (pg.tg.op, INSERT = return(pg.tg.new), UPDATE = return(pg.tg.new), DELETE = return(pg.tg.old))
+' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure acceptfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test that returning modifed tuple successfully modifies the result
+--
+create or replace function modfoo() returns trigger as '
+if (pg.tg.op == "INSERT")
+{
+ retval <- pg.tg.new
+ retval$f1 <- "xxx"
+}
+if (pg.tg.op == "UPDATE")
+{
+ retval <- pg.tg.new
+ retval$f1 <- "aaa"
+}
+if (pg.tg.op == "DELETE")
+ retval <- pg.tg.old
+return(retval)
+' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure modfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | xxx | 1.89
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | aaa | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test statement level triggers and verify all arguments come
+-- across correctly
+--
+create or replace function foonotice() returns trigger as '
+msg <- paste(pg.tg.name,pg.tg.relname,pg.tg.when,pg.tg.level,pg.tg.op,pg.tg.args[1],pg.tg.args[2])
+pg.thrownotice(msg)
+return(NULL)
+' language plr;
+create trigger footrig after insert or update or delete on foo for each row execute procedure foonotice();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+NOTICE: footrig foo AFTER ROW INSERT NA NA
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+NOTICE: footrig foo AFTER ROW UPDATE NA NA
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+NOTICE: footrig foo AFTER ROW DELETE NA NA
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+create trigger footrig after insert or update or delete on foo for each statement execute procedure foonotice('hello','world');
+ERROR: CreateTrigger: STATEMENT triggers are unimplemented, yet
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+ERROR: DropTrigger: there is no trigger footrig on relation foo
+-- Test cursors: creating, scrolling forward, closing
+CREATE OR REPLACE FUNCTION cursor_fetch_test(integer,boolean) RETURNS SETOF integer AS 'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,10)"); cursor<-pg.spi.cursor_open("curs",plan); dat<-pg.spi.cursor_fetch(cursor,arg2,arg1); pg.spi.cursor_close(cursor); return (dat);' language 'plr';
+SELECT * FROM cursor_fetch_test(1,true);
+ cursor_fetch_test
+-------------------
+ 1
+(1 row)
+
+SELECT * FROM cursor_fetch_test(2,true);
+ cursor_fetch_test
+-------------------
+ 1
+ 2
+(2 rows)
+
+SELECT * FROM cursor_fetch_test(20,true);
+ cursor_fetch_test
+-------------------
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+(10 rows)
+
+--Test cursors: scrolling backwards
+CREATE OR REPLACE FUNCTION cursor_direction_test() RETURNS SETOF integer AS'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,10)"); cursor<-pg.spi.cursor_open("curs",plan); dat<-pg.spi.cursor_fetch(cursor,TRUE,as.integer(3)); dat2<-pg.spi.cursor_fetch(cursor,FALSE,as.integer(3)); pg.spi.cursor_close(cursor); return (dat2);' language 'plr';
+SELECT * FROM cursor_direction_test();
+ cursor_direction_test
+-----------------------
+ 2
+ 1
+(2 rows)
+
+--Test cursors: Passing arguments to a plan
+CREATE OR REPLACE FUNCTION cursor_fetch_test_arg(integer) RETURNS SETOF integer AS 'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,$1)",c(INT4OID)); cursor<-pg.spi.cursor_open("curs",plan,list(arg1)); dat<-pg.spi.cursor_fetch(cursor,TRUE,arg1); pg.spi.cursor_close(cursor); return (dat);' language 'plr';
+SELECT * FROM cursor_fetch_test_arg(3);
+ cursor_fetch_test_arg
+-----------------------
+ 1
+ 2
+ 3
+(3 rows)
+
View
870 expected/plr.out.7.4
@@ -0,0 +1,870 @@
+--
+-- first, define the language and functions. Turn off echoing so that expected file
+-- does not depend on contents of plr.sql.
+--
+\set ECHO none
+-- make typenames available in the global namespace
+select load_r_typenames();
+ load_r_typenames
+------------------
+ OK
+(1 row)
+
+CREATE TABLE plr_modules (
+ modseq int4,
+ modsrc text
+);
+INSERT INTO plr_modules VALUES (0, 'pg.test.module.load <-function(msg) {print(msg)}');
+select reload_plr_modules();
+ reload_plr_modules
+--------------------
+ OK
+(1 row)
+
+--
+-- plr_modules test
+--
+create or replace function pg_test_module_load(text) returns text as 'pg.test.module.load(arg1)' language 'plr';
+select pg_test_module_load('hello world');
+ pg_test_module_load
+---------------------
+ hello world
+(1 row)
+
+--
+-- user defined R function test
+--
+select install_rcmd('pg.test.install <-function(msg) {print(msg)}');
+ install_rcmd
+--------------
+ OK
+(1 row)
+
+create or replace function pg_test_install(text) returns text as 'pg.test.install(arg1)' language 'plr';
+select pg_test_install('hello world');
+ pg_test_install
+-----------------
+ hello world
+(1 row)
+
+--
+-- a variety of plr functions
+--
+create or replace function throw_notice(text) returns text as 'pg.thrownotice(arg1)' language 'plr';
+select throw_notice('hello');
+NOTICE: hello
+ throw_notice
+--------------
+ hello
+(1 row)
+
+create or replace function paste(_text,_text,text) returns text[] as 'paste(arg1,arg2, sep = arg3)' language 'plr';
+select paste('{hello, happy}','{world, birthday}',' ');
+ paste
+----------------------------------
+ {"hello world","happy birthday"}
+(1 row)
+
+create or replace function vec(_float8) returns _float8 as 'arg1' language 'plr';
+select vec('{1.23, 1.32}'::float8[]);
+ vec
+-------------
+ {1.23,1.32}
+(1 row)
+
+create or replace function vec(float, float) returns _float8 as 'c(arg1,arg2)' language 'plr';
+select vec(1.23, 1.32);
+ vec
+-------------
+ {1.23,1.32}
+(1 row)
+
+create or replace function echo(text) returns text as 'print(arg1)' language 'plr';
+select echo('hello');
+ echo
+-------
+ hello
+(1 row)
+
+create or replace function reval(text) returns text as 'eval(parse(text = arg1))' language 'plr';
+select reval('a <- sd(c(1,2,3)); b <- mean(c(1,2,3)); a + b');
+ reval
+-------
+ 3
+(1 row)
+
+create or replace function "commandArgs"() returns text[] as '' language 'plr';
+select "commandArgs"();
+ commandArgs
+---------------------------
+ {PL/R,--silent,--no-save}
+(1 row)
+
+create or replace function vec(float) returns text as 'c(arg1)' language 'plr';
+select vec(1.23);
+ vec
+------
+ 1.23
+(1 row)
+
+create or replace function reval(_text) returns text as 'eval(parse(text = arg1))' language 'plr';
+select round(reval('{"sd(c(1.12,1.23,1.18,1.34))"}'::text[])::numeric,8);
+ round
+------------
+ 0.09322911
+(1 row)
+
+create or replace function print(text) returns text as '' language 'plr';
+select print('hello');
+ print
+-------
+ hello
+(1 row)
+
+create or replace function cube(int) returns float as 'sq <- function(x) {return(x * x)}; return(arg1 * sq(arg1))' language 'plr';
+select cube(3);
+ cube
+------
+ 27
+(1 row)
+
+create or replace function sd(_float8) returns float as 'sd(arg1)' language 'plr';
+select round(sd('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.08180261
+(1 row)
+
+create or replace function sd(_float8) returns float as '' language 'plr';
+select round(sd('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.08180261
+(1 row)
+
+create or replace function mean(_float8) returns float as '' language 'plr';
+select mean('{1.23,1.31,1.42,1.27}'::_float8);
+ mean
+--------
+ 1.3075
+(1 row)
+
+create or replace function sprintf(text,text,text) returns text as 'sprintf(arg1,arg2,arg3)' language 'plr';
+select sprintf('%s is %s feet tall', 'Sven', '7');
+ sprintf
+---------------------
+ Sven is 7 feet tall
+(1 row)
+
+--
+-- test aggregates
+--
+create table foo(f0 int, f1 text, f2 float8) with oids;
+insert into foo values(1,'cat1',1.21);
+insert into foo values(2,'cat1',1.24);
+insert into foo values(3,'cat1',1.18);
+insert into foo values(4,'cat1',1.26);
+insert into foo values(5,'cat1',1.15);
+insert into foo values(6,'cat2',1.15);
+insert into foo values(7,'cat2',1.26);
+insert into foo values(8,'cat2',1.32);
+insert into foo values(9,'cat2',1.30);
+create or replace function r_median(_float8) returns float as 'median(arg1)' language 'plr';
+select r_median('{1.23,1.31,1.42,1.27}'::_float8);
+ r_median
+----------
+ 1.29
+(1 row)
+
+CREATE AGGREGATE median (sfunc = plr_array_accum, basetype = float8, stype = _float8, finalfunc = r_median);
+select f1, median(f2) from foo group by f1 order by f1;
+ f1 | median
+------+--------
+ cat1 | 1.21
+ cat2 | 1.28
+(2 rows)
+
+create or replace function r_gamma(_float8) returns float as 'gamma(arg1)' language 'plr';
+select round(r_gamma('{1.23,1.31,1.42,1.27}'::_float8)::numeric,8);
+ round
+------------
+ 0.91075486
+(1 row)
+
+CREATE AGGREGATE gamma (sfunc = plr_array_accum, basetype = float8, stype = _float8, finalfunc = r_gamma);
+select f1, round(gamma(f2)::numeric,8) from foo group by f1 order by f1;
+ f1 | round
+------+------------
+ cat1 | 0.91557649
+ cat2 | 0.93304093
+(2 rows)
+
+--
+-- test returning vectors, arrays, matricies, and dataframes
+-- as scalars, arrays, and records
+--
+create or replace function test_vt() returns text as 'array(1:10,c(2,5))' language 'plr';
+select test_vt();
+ test_vt
+---------
+ 1
+(1 row)
+
+create or replace function test_vi() returns int as 'array(1:10,c(2,5))' language 'plr';
+select test_vi();
+ test_vi
+---------
+ 1
+(1 row)
+
+create or replace function test_mt() returns text as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mt();
+ test_mt
+---------
+ 1
+(1 row)
+
+create or replace function test_mi() returns int as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mi();
+ test_mi
+---------
+ 1
+(1 row)
+
+create or replace function test_dt() returns text as 'as.data.frame(array(1:10,c(2,5)))[[1]]' language 'plr';
+select test_dt();
+ test_dt
+---------
+ 1
+(1 row)
+
+create or replace function test_di() returns int as 'as.data.frame(array(1:10,c(2,5)))[[1]]' language 'plr';
+select test_di() as error;
+ error
+-------
+ 1
+(1 row)
+
+create or replace function test_vta() returns text[] as 'array(1:10,c(2,5))' language 'plr';
+select test_vta();
+ test_vta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_via() returns int[] as 'array(1:10,c(2,5))' language 'plr';
+select test_via();
+ test_via
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_mta() returns text[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mta();
+ test_mta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_mia() returns int[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr';
+select test_mia();
+ test_mia
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dia() returns int[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr';
+select test_dia();
+ test_dia
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dta() returns text[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr';
+select test_dta();
+ test_dta
+----------------------------
+ {{1,3,5,7,9},{2,4,6,8,10}}
+(1 row)
+
+create or replace function test_dta1() returns text[] as 'as.data.frame(array(letters[1:10], c(2,5)))' language 'plr';
+select test_dta1();
+ test_dta1
+---------------------------
+ {{a,c,e,g,i},{b,d,f,h,j}}
+(1 row)
+
+create or replace function test_dta2() returns text[] as 'as.data.frame(data.frame(letters[1:10],1:10))' language 'plr';
+select test_dta2();
+ test_dta2
+----------------------------------------------------------------
+ {{a,1},{b,2},{c,3},{d,4},{e,5},{f,6},{g,7},{h,8},{i,9},{j,10}}
+(1 row)
+
+-- generates expected error
+create or replace function test_dia1() returns int[] as 'as.data.frame(array(letters[1:10], c(2,5)))' language 'plr';
+select test_dia1() as error;
+ERROR: invalid input syntax for integer: "a"
+CONTEXT: In PL/R function test_dia1
+create or replace function test_dtup() returns setof record as 'data.frame(letters[1:10],1:10)' language 'plr';
+select * from test_dtup() as t(f1 text, f2 int);
+ f1 | f2
+----+----
+ a | 1
+ b | 2
+ c | 3
+ d | 4
+ e | 5
+ f | 6
+ g | 7
+ h | 8
+ i | 9
+ j | 10
+(10 rows)
+
+create or replace function test_mtup() returns setof record as 'as.matrix(array(1:15,c(5,3)))' language 'plr';
+select * from test_mtup() as t(f1 int, f2 int, f3 int);
+ f1 | f2 | f3
+----+----+----
+ 1 | 6 | 11
+ 2 | 7 | 12
+ 3 | 8 | 13
+ 4 | 9 | 14
+ 5 | 10 | 15
+(5 rows)
+
+create or replace function test_vtup() returns setof record as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vtup() as t(f1 int);
+ f1
+----
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+create or replace function test_vint() returns setof int as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vint();
+ test_vint
+-----------
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+--
+-- try again with named tuple types
+--
+CREATE TYPE dtup AS (f1 text, f2 int);
+CREATE TYPE mtup AS (f1 int, f2 int, f3 int);
+CREATE TYPE vtup AS (f1 int);
+create or replace function test_dtup1() returns setof dtup as 'data.frame(letters[1:10],1:10)' language 'plr';
+select * from test_dtup1();
+ f1 | f2
+----+----
+ a | 1
+ b | 2
+ c | 3
+ d | 4
+ e | 5
+ f | 6
+ g | 7
+ h | 8
+ i | 9
+ j | 10
+(10 rows)
+
+create or replace function test_dtup2() returns setof dtup as 'data.frame(c("c","qw","ax","h","k","ax","l","t","b","u"),1:10)' language 'plr';
+select * from test_dtup2();
+ f1 | f2
+----+----
+ c | 1
+ qw | 2
+ ax | 3
+ h | 4
+ k | 5
+ ax | 6
+ l | 7
+ t | 8
+ b | 9
+ u | 10
+(10 rows)
+
+create or replace function test_mtup1() returns setof mtup as 'as.matrix(array(1:15,c(5,3)))' language 'plr';
+select * from test_mtup1();
+ f1 | f2 | f3
+----+----+----
+ 1 | 6 | 11
+ 2 | 7 | 12
+ 3 | 8 | 13
+ 4 | 9 | 14
+ 5 | 10 | 15
+(5 rows)
+
+create or replace function test_vtup1() returns setof vtup as 'as.vector(array(1:15,c(5,3)))' language 'plr';
+select * from test_vtup1();
+ f1
+----
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+ 11
+ 12
+ 13
+ 14
+ 15
+(15 rows)
+
+--
+-- test pg R support functions (e.g. SPI_exec)
+--
+create or replace function pg_quote_ident(text) returns text as 'pg.quoteident(arg1)' language 'plr';
+select pg_quote_ident('Hello World');
+ pg_quote_ident
+----------------
+ "Hello World"
+(1 row)
+
+create or replace function pg_quote_literal(text) returns text as 'pg.quoteliteral(arg1)' language 'plr';
+select pg_quote_literal('Hello\'World');
+ pg_quote_literal
+------------------
+ 'Hello''World'
+(1 row)
+
+create or replace function test_spi_t(text) returns text as '(pg.spi.exec(arg1))[[1]]' language 'plr';
+select test_spi_t('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''');
+ test_spi_t
+------------
+ 25
+(1 row)
+
+create or replace function test_spi_ta(text) returns text[] as 'pg.spi.exec(arg1)' language 'plr';
+select test_spi_ta('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''');
+ test_spi_ta
+----------------------
+ {{25,text},{26,oid}}
+(1 row)
+
+create or replace function test_spi_tup(text) returns setof record as 'pg.spi.exec(arg1)' language 'plr';
+select * from test_spi_tup('select oid, typname from pg_type where typname = ''oid'' or typname = ''text''') as t(typeid oid, typename name);
+ typeid | typename
+--------+----------
+ 25 | text
+ 26 | oid
+(2 rows)
+
+create or replace function fetch_pgoid(text) returns int as 'pg.reval(arg1)' language 'plr';
+select fetch_pgoid('BYTEAOID');
+ fetch_pgoid
+-------------
+ 17
+(1 row)
+
+create or replace function test_spi_prep(text) returns text as 'sp <<- pg.spi.prepare(arg1, c(NAMEOID, NAMEOID)); print("OK")' language 'plr';
+select test_spi_prep('select oid, typname from pg_type where typname = $1 or typname = $2');
+ test_spi_prep
+---------------
+ OK
+(1 row)
+
+create or replace function test_spi_execp(text, text, text) returns setof record as 'pg.spi.execp(pg.reval(arg1), list(arg2,arg3))' language 'plr';
+select * from test_spi_execp('sp','oid','text') as t(typeid oid, typename name);
+ typeid | typename
+--------+----------
+ 25 | text
+ 26 | oid
+(2 rows)
+
+create or replace function test_spi_lastoid(text) returns text as 'pg.spi.exec(arg1); pg.spi.lastoid()/pg.spi.lastoid()' language 'plr';
+select test_spi_lastoid('insert into foo values(10,''cat3'',3.333)') as "ONE";
+ ONE
+-----
+ 1
+(1 row)
+
+--
+-- test NULL handling
+--
+CREATE OR REPLACE FUNCTION r_test (float8) RETURNS float8 AS 'arg1' LANGUAGE 'plr';
+select r_test(null) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+CREATE OR REPLACE FUNCTION r_max (integer, integer) RETURNS integer AS 'if (is.null(arg1) && is.null(arg2)) return(NA);if (is.null(arg1)) return(arg2);if (is.null(arg2)) return(arg1);if (arg1 > arg2) return(arg1);arg2' LANGUAGE 'plr';
+select r_max(1,2) as "TWO";
+ TWO
+-----
+ 2
+(1 row)
+
+select r_max(null,2) as "TWO";
+ TWO
+-----
+ 2
+(1 row)
+
+select r_max(1,null) as "ONE";
+ ONE
+-----
+ 1
+(1 row)
+
+select r_max(null,null) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+--
+-- test tuple arguments
+--
+create or replace function get_foo(int) returns foo as 'select * from foo where f0 = $1' language 'sql';
+create or replace function test_foo(foo) returns foo as 'return(arg1)' language 'plr';
+select * from test_foo(get_foo(1));
+ f0 | f1 | f2
+----+------+------
+ 1 | cat1 | 1.21
+(1 row)
+
+--
+-- test 2D array argument
+--
+create or replace function test_in_m_tup(_int4) returns setof record as 'arg1' language 'plr';
+select * from test_in_m_tup('{{1,3,5},{2,4,6}}') as t(f1 int, f2 int, f3 int);
+ f1 | f2 | f3
+----+----+----
+ 1 | 3 | 5
+ 2 | 4 | 6
+(2 rows)
+
+--
+-- test 3D array argument
+--
+create or replace function arr3d(_int4,int4,int4,int4) returns int4 as '
+if (arg2 < 1 || arg3 < 1 || arg4 < 1)
+ return(NA)
+if (arg2 > dim(arg1)[1] || arg3 > dim(arg1)[2] || arg4 > dim(arg1)[3])
+ return(NA)
+return(arg1[arg2,arg3,arg4])
+' language 'plr' WITH (isstrict);
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',2,3,1) as "231";
+ 231
+-----
+ 231
+(1 row)
+
+-- for sake of comparison, see what normal pgsql array operations produces
+select f1[2][3][1] as "231" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ 231
+-----
+ 231
+(1 row)
+
+-- out-of-bounds, returns null
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',1,4,1) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+select f1[1][4][1] is null as "NULL" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ NULL
+------
+ t
+(1 row)
+
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',0,1,1) is null as "NULL";
+ NULL
+------
+ t
+(1 row)
+
+select f1[0][1][1] is null as "NULL" from (select '{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}'::int4[] as f1) as t;
+ NULL
+------
+ t
+(1 row)
+
+--
+-- test 3D array return value
+--
+create or replace function arr3d(_int4) returns int4[] as 'return(arg1)' language 'plr' WITH (isstrict);
+select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}');
+ arr3d
+-------------------------------------------------------------------
+ {{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}
+(1 row)
+
+--
+-- Trigger support tests
+--
+--
+-- test that NULL return value suppresses the change
+--
+create or replace function rejectfoo() returns trigger as 'return(NULL)' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure rejectfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+update foo set f1 = 'zzz';
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+delete from foo;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test that returning OLD/NEW as appropriate allow the change unmodified
+--
+create or replace function acceptfoo() returns trigger as '
+switch (pg.tg.op, INSERT = return(pg.tg.new), UPDATE = return(pg.tg.new), DELETE = return(pg.tg.old))
+' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure acceptfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test that returning modifed tuple successfully modifies the result
+--
+create or replace function modfoo() returns trigger as '
+if (pg.tg.op == "INSERT")
+{
+ retval <- pg.tg.new
+ retval$f1 <- "xxx"
+}
+if (pg.tg.op == "UPDATE")
+{
+ retval <- pg.tg.new
+ retval$f1 <- "aaa"
+}
+if (pg.tg.op == "DELETE")
+ retval <- pg.tg.old
+return(retval)
+' language plr;
+create trigger footrig before insert or update or delete on foo for each row execute procedure modfoo();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | xxx | 1.89
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | aaa | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+--
+-- test statement level triggers and verify all arguments come
+-- across correctly
+--
+create or replace function foonotice() returns trigger as '
+msg <- paste(pg.tg.name,pg.tg.relname,pg.tg.when,pg.tg.level,pg.tg.op,pg.tg.args[1],pg.tg.args[2])
+pg.thrownotice(msg)
+return(NULL)
+' language plr;
+create trigger footrig after insert or update or delete on foo for each row execute procedure foonotice();
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+NOTICE: footrig foo AFTER ROW INSERT NA NA
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+NOTICE: footrig foo AFTER ROW UPDATE NA NA
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+NOTICE: footrig foo AFTER ROW DELETE NA NA
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+create trigger footrig after insert or update or delete on foo for each statement execute procedure foonotice('hello','world');
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+insert into foo values(11,'cat99',1.89);
+NOTICE: footrig foo AFTER STATEMENT INSERT hello world
+select count(*) from foo;
+ count
+-------
+ 11
+(1 row)
+
+update foo set f1 = 'zzz' where f0 = 11;
+NOTICE: footrig foo AFTER STATEMENT UPDATE hello world
+select * from foo where f0 = 11;
+ f0 | f1 | f2
+----+-----+------
+ 11 | zzz | 1.89
+(1 row)
+
+delete from foo where f0 = 11;
+NOTICE: footrig foo AFTER STATEMENT DELETE hello world
+select count(*) from foo;
+ count
+-------
+ 10
+(1 row)
+
+drop trigger footrig on foo;
+-- Test cursors: creating, scrolling forward, closing
+CREATE OR REPLACE FUNCTION cursor_fetch_test(integer,boolean) RETURNS SETOF integer AS 'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,10)"); cursor<-pg.spi.cursor_open("curs",plan); dat<-pg.spi.cursor_fetch(cursor,arg2,arg1); pg.spi.cursor_close(cursor); return (dat);' language 'plr';
+SELECT * FROM cursor_fetch_test(1,true);
+ cursor_fetch_test
+-------------------
+ 1
+(1 row)
+
+SELECT * FROM cursor_fetch_test(2,true);
+ cursor_fetch_test
+-------------------
+ 1
+ 2
+(2 rows)
+
+SELECT * FROM cursor_fetch_test(20,true);
+ cursor_fetch_test
+-------------------
+ 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+ 10
+(10 rows)
+
+--Test cursors: scrolling backwards
+CREATE OR REPLACE FUNCTION cursor_direction_test() RETURNS SETOF integer AS'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,10)"); cursor<-pg.spi.cursor_open("curs",plan); dat<-pg.spi.cursor_fetch(cursor,TRUE,as.integer(3)); dat2<-pg.spi.cursor_fetch(cursor,FALSE,as.integer(3)); pg.spi.cursor_close(cursor); return (dat2);' language 'plr';
+SELECT * FROM cursor_direction_test();
+ cursor_direction_test
+-----------------------
+ 2
+ 1
+(2 rows)
+
+--Test cursors: Passing arguments to a plan
+CREATE OR REPLACE FUNCTION cursor_fetch_test_arg(integer) RETURNS SETOF integer AS 'plan<-pg.spi.prepare("SELECT * FROM generate_series(1,$1)",c(INT4OID)); cursor<-pg.spi.cursor_open("curs",plan,list(arg1)); dat<-pg.spi.cursor_fetch(cursor,TRUE,arg1); pg.spi.cursor_close(cursor); return (dat);' language 'plr';
+SELECT * FROM cursor_fetch_test_arg(3);
+ cursor_fetch_test_arg
+-----------------------
+ 1
+ 2
+ 3
+(3 rows)
+
View
9 pg_backend_support.c
@@ -2,7 +2,7 @@
* PL/R - PostgreSQL support for R as a
* procedural language (PL)
*
- * Copyright (c) 2003, 2004 by Joseph E. Conway
+ * Copyright (c) 2003-2007 by Joseph E. Conway
* ALL RIGHTS RESERVED
*
* Joe Conway <mail@joeconway.com>
@@ -41,10 +41,17 @@
#error "PKGLIBDIR needs to be defined to compile this file."
#endif
+#ifdef PGDLLIMPORT
+/* GUC variable */
+extern PGDLLIMPORT char *Dynamic_library_path;
+/* Postgres global */
+extern PGDLLIMPORT char pkglib_path[];
+#else
/* GUC variable */
extern DLLIMPORT char *Dynamic_library_path;
/* Postgres global */
extern DLLIMPORT char pkglib_path[];
+#endif /* PGDLLIMPORT */
/* compiled function hash table */
extern HTAB *plr_HashTable;
View
154 pg_conversion.c
@@ -2,7 +2,7 @@
* PL/R - PostgreSQL support for R as a
* procedural language (PL)
*
- * Copyright (c) 2003-2006 by Joseph E. Conway
+ * Copyright (c) 2003-2007 by Joseph E. Conway
* ALL RIGHTS RESERVED
*
* Joe Conway <mail@joeconway.com>
@@ -105,7 +105,7 @@ pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char
*/
SEXP result;
char *value;
- ArrayType *v = DatumGetArrayTypeP(dvalue);
+ ArrayType *v = (ArrayType *) dvalue;
Oid element_type;
int i, j, k,
nitems,
@@ -114,9 +114,7 @@ pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char
nz = 1,
ndim,
*dim;
- int elem_idx = 0;
- Datum *elem_values;
- bool *elem_nulls;
+ char *p;
/* short-circuit for NULL datums */
if (dvalue == (Datum) NULL)
@@ -125,10 +123,7 @@ pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char
ndim = ARR_NDIM(v);
element_type = ARR_ELEMTYPE(v);
dim = ARR_DIMS(v);
-
- deconstruct_array(v, element_type,
- typlen, typbyval, typalign,
- &elem_values, &elem_nulls, &nitems);
+ nitems = ArrayGetNItems(ndim, dim);
/* array is empty */
if (nitems == 0)
@@ -161,32 +156,30 @@ pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char
PROTECT(result = get_r_vector(element_type, nitems));
/* Convert all values to their R form and build the vector */
+ p = ARR_DATA_PTR(v);
for (i = 0; i < nr; i++)
{
for (j = 0; j < nc; j++)
{
for (k = 0; k < nz; k++)
{
Datum itemvalue;
- bool isnull;
int idx = (k * nr * nc) + (j * nr) + i;
- isnull = elem_nulls[elem_idx];
- itemvalue = elem_values[elem_idx++];
-
- if (!isnull)
- {
- value = DatumGetCString(FunctionCall3(&out_func,
+ itemvalue = fetch_att(p, typbyval, typlen);
+ value = DatumGetCString(FunctionCall3(&out_func,
itemvalue,
(Datum) 0,
Int32GetDatum(-1)));
- }
- else
- value = NULL;
+ p = att_addlength(p, typlen, PointerGetDatum(p));
+ p = (char *) att_align(p, typalign);
/*
* Note that pg_get_one_r() replaces NULL values with
- * the NA value appropriate for the data type.
+ * the NA value appropriate for the data type. Not presently
+ * a concern anyway, but when Postgres arrays start allowing
+ * NULL elements, nothing needs to change here. That's a
+ * Good Thing.
*/
pg_get_one_r(value, element_type, &result, idx);
}
@@ -245,7 +238,7 @@ pg_tuple_get_r_frame(int ntuples, HeapTuple *tuples, TupleDesc tupdesc)
* and also allocate a names vector for the column names
*/
PROTECT(result = NEW_LIST(nc_non_dropped));
- PROTECT(names = NEW_CHARACTER(nc_non_dropped));
+ PROTECT(names = NEW_CHARACTER(nc_non_dropped));
/*
* Loop by columns
@@ -321,19 +314,19 @@ pg_tuple_get_r_frame(int ntuples, HeapTuple *tuples, TupleDesc tupdesc)
}
/* attach the column names */
- setAttrib(result, R_NamesSymbol, names);
+ setAttrib(result, R_NamesSymbol, names);
/* attach row names - basically just the row number, zero based */
PROTECT(row_names = allocVector(STRSXP, nr));
for (i=0; i<nr; i++)
{
- sprintf(buf, "%d", i+1);
- SET_STRING_ELT(row_names, i, COPY_TO_USER_STRING(buf));
+ sprintf(buf, "%d", i+1);
+ SET_STRING_ELT(row_names, i, COPY_TO_USER_STRING(buf));
}
setAttrib(result, R_RowNamesSymbol, row_names);
/* finally, tell R we are a "data.frame" */
- setAttrib(result, R_ClassSymbol, mkString("data.frame"));
+ setAttrib(result, R_ClassSymbol, mkString("data.frame"));
UNPROTECT(3);
return result;
@@ -354,7 +347,7 @@ get_r_vector(Oid typtype, int numels)
case INT4OID:
/* 2 and 4 byte integer pgsql datatype => use R INTEGER */
PROTECT(result = NEW_INTEGER(numels));
- break;
+ break;
case INT8OID:
case FLOAT4OID:
case FLOAT8OID:
@@ -366,10 +359,10 @@ get_r_vector(Oid typtype, int numels)
* because R INTEGER is only 4 byte
*/
PROTECT(result = NEW_NUMERIC(numels));
- break;
+ break;
case BOOLOID:
PROTECT(result = NEW_LOGICAL(numels));
- break;
+ break;
default:
/* Everything else is defaulted to string */
PROTECT(result = NEW_CHARACTER(numels));
@@ -395,7 +388,7 @@ pg_get_one_r(char *value, Oid typtype, SEXP *obj, int elnum)
INTEGER_DATA(*obj)[elnum] = atoi(value);
else
INTEGER_DATA(*obj)[elnum] = NA_INTEGER;
- break;
+ break;
case INT8OID:
case FLOAT4OID:
case FLOAT8OID:
@@ -410,13 +403,13 @@ pg_get_one_r(char *value, Oid typtype, SEXP *obj, int elnum)
NUMERIC_DATA(*obj)[elnum] = atof(value);
else
NUMERIC_DATA(*obj)[elnum] = NA_REAL;
- break;
+ break;
case BOOLOID:
if (value)
LOGICAL_DATA(*obj)[elnum] = ((*value == 't') ? 1 : 0);
else
LOGICAL_DATA(*obj)[elnum] = NA_LOGICAL;
- break;
+ break;
default:
/* Everything else is defaulted to string */
if (value)
@@ -625,7 +618,7 @@ get_trigger_tuple(SEXP rval, plr_function *function, FunctionCallInfo fcinfo, bo
for (j = 0; j < nc; j++)
if (values[j] != NULL)
pfree(values[j]);
- }
+ }
MemoryContextSwitchTo(oldcontext);
@@ -783,7 +776,17 @@ get_array_datum(SEXP rval, plr_function *function, int col, bool *isnull)
else
{
/* create an empty array */
- return PointerGetDatum(construct_empty_array(function->result_elem));
+ ArrayType *array;
+ int nbytes = ARR_OVERHEAD(0);
+ Oid result_elem = function->result_elem;
+
+ array = (ArrayType *) palloc(nbytes);
+ array->size = nbytes;
+ array->ndim = 0;
+ array->flags = 0;
+ array->elemtype = result_elem;
+
+ return PointerGetDatum(array);
}
}
@@ -809,12 +812,6 @@ get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull)
int idx;
SEXP dfcol = NULL;
int j;
- bool *nulls = NULL;
- bool have_nulls = FALSE;
-
- if (nc < 1)
- /* internal error */
- elog(ERROR, "plr: bad internal representation of data.frame");
if (function->result_istuple)
{
@@ -855,7 +852,6 @@ get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull)
{
nr = length(obj);
dvalues = (Datum *) palloc(nr * nc * sizeof(Datum));
- nulls = (bool *) palloc(nr * nc * sizeof(bool));
}
for(i = 0; i < nr; i++)
@@ -864,19 +860,15 @@ get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull)
idx = ((i * nc) + j);
if (STRING_ELT(obj, i) == NA_STRING || value == NULL)
- {
- nulls[idx] = TRUE;
- have_nulls = TRUE;
- }
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("cannot return array with NULL elements")));
else
- {
- nulls[idx] = FALSE;
dvalues[idx] = FunctionCall3(&in_func,
CStringGetDatum(value),
(Datum) 0,
Int32GetDatum(-1));
- }
- }
+ }
UNPROTECT(2);
}
@@ -885,12 +877,8 @@ get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull)
lbs[0] = 1;
lbs[1] = 1;
- if (!have_nulls)
- array = construct_md_array(dvalues, NULL, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
- else
- array = construct_md_array(dvalues, nulls, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
+ array = construct_md_array(dvalues, ndims, dims, lbs,
+ result_elem, typlen, typbyval, typalign);
dvalue = PointerGetDatum(array);
@@ -920,8 +908,6 @@ get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *
int lbs[ndims];
int idx;
int cntr = 0;
- bool *nulls;
- bool have_nulls = FALSE;
if (function->result_istuple)
{
@@ -950,13 +936,13 @@ get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *
{
case 0:
nr = dims[i];
- break;
+ break;
case 1:
nc = dims[i];
- break;
+ break;
case 2:
nz = dims[i];
- break;
+ break;
default:
/* anything higher is currently unsupported */
ereport(ERROR,
@@ -970,7 +956,6 @@ get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *
nitems = nr * nc * nz;
dvalues = (Datum *) palloc(nitems * sizeof(Datum));
- nulls = (bool *) palloc(nitems * sizeof(bool));
PROTECT(obj = AS_CHARACTER(rval));
for (i = 0; i < nr; i++)
@@ -979,35 +964,25 @@ get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *
{
for (k = 0; k < nz; k++)
{
- int arridx = cntr++;
-
idx = (k * nr * nc) + (j * nr) + i;
value = CHAR(STRING_ELT(obj, idx));
if (STRING_ELT(obj, idx) == NA_STRING || value == NULL)
- {
- nulls[arridx] = TRUE;
- have_nulls = TRUE;
- }
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("cannot return array with NULL elements")));
else
- {
- nulls[arridx] = FALSE;
- dvalues[arridx] = FunctionCall3(&in_func,
+ dvalues[cntr++] = FunctionCall3(&in_func,
CStringGetDatum(value),
(Datum) 0,
Int32GetDatum(-1));
- }
}
}
}
UNPROTECT(1);
- if (!have_nulls)
- array = construct_md_array(dvalues, NULL, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
- else
- array = construct_md_array(dvalues, nulls, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
+ array = construct_md_array(dvalues, ndims, dims, lbs,
+ result_elem, typlen, typbyval, typalign);
dvalue = PointerGetDatum(array);
@@ -1032,8 +1007,6 @@ get_generic_array_datum(SEXP rval, plr_function *function, int col, bool *isnull
int ndims = 1;
int dims[ndims];
int lbs[ndims];
- bool *nulls;
- bool have_nulls = FALSE;
if (function->result_istuple)
{
@@ -1053,7 +1026,6 @@ get_generic_array_datum(SEXP rval, plr_function *function, int col, bool *isnull
}
dvalues = (Datum *) palloc(objlen * sizeof(Datum));
- nulls = (bool *) palloc(objlen * sizeof(bool));
PROTECT(obj = AS_CHARACTER(rval));
/* Loop is needed here as result value might be of length > 1 */
@@ -1062,30 +1034,22 @@ get_generic_array_datum(SEXP rval, plr_function *function, int col, bool *isnull
value = CHAR(STRING_ELT(obj, i));
if (STRING_ELT(obj, i) == NA_STRING || value == NULL)
- {
- nulls[i] = TRUE;
- have_nulls = TRUE;
- }
+ ereport(ERROR,
+ (errcode(ERRCODE_FEATURE_NOT_SUPPORTED),
+ errmsg("cannot return array with NULL elements")));
else
- {
- nulls[i] = FALSE;
dvalues[i] = FunctionCall3(&in_func,
CStringGetDatum(value),
(Datum) 0,
Int32GetDatum(-1));
- }
- }
+ }
UNPROTECT(1);
dims[0] = objlen;
lbs[0] = 1;
- if (!have_nulls)
- array = construct_md_array(dvalues, NULL, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
- else
- array = construct_md_array(dvalues, nulls, ndims, dims, lbs,
- result_elem, typlen, typbyval, typalign);
+ array = construct_md_array(dvalues, ndims, dims, lbs,
+ result_elem, typlen, typbyval, typalign);
dvalue = PointerGetDatum(array);
@@ -1330,7 +1294,7 @@ get_matrix_tuplestore(SEXP rval,
/* now reset the context */
MemoryContextSwitchTo(oldcontext);
- }
+ }
UNPROTECT(1);
oldcontext = MemoryContextSwitchTo(per_query_ctx);
@@ -1395,7 +1359,7 @@ get_generic_tuplestore(SEXP rval,
/* now reset the context */
MemoryContextSwitchTo(oldcontext);
- }
+ }
UNPROTECT(1);
oldcontext = MemoryContextSwitchTo(per_query_ctx);
View
203 pg_rsupport.c
@@ -2,7 +2,7 @@
* PL/R - PostgreSQL support for R as a
* procedural language (PL)
*
- * Copyright (c) 2003, 2004 by Joseph E. Conway
+ * Copyright (c) 2003-2007 by Joseph E. Conway
* ALL RIGHTS RESERVED
*
* Joe Conway <mail@joeconway.com>
@@ -475,7 +475,7 @@ plr_SPI_execp(SEXP rsaved_plan, SEXP rargvalues)
if (nargs > 0)
{
- if (!IS_LIST(rargvalues))
+ if (!Rf_isVectorList(rargvalues))
error("%s", "second parameter must be a list of arguments " \
"to the prepared plan");
@@ -589,7 +589,7 @@ plr_SPI_execp(SEXP rsaved_plan, SEXP rargvalues)
return result;
}
-/*
+/*
* plr_SPI_lastoid - return the last oid. To be used after insert queries.
*/
SEXP
@@ -604,6 +604,203 @@ plr_SPI_lastoid(void)
return result;
}
+/*
+ * Takes the prepared plan rsaved_plan and creates a cursor
+ * for it using the values specified in ragvalues.
+ *
+ */
+SEXP
+plr_SPI_cursor_open(SEXP cursor_name_arg,SEXP rsaved_plan, SEXP rargvalues)
+{
+ saved_plan_desc *plan_desc = (saved_plan_desc *) R_ExternalPtrAddr(rsaved_plan);
+ void *saved_plan = plan_desc->saved_plan;
+ int nargs = plan_desc->nargs;
+ Oid *typelems = plan_desc->typelems;
+ FmgrInfo *typinfuncs = plan_desc->typinfuncs;
+ int i;
+ Datum *argvalues = NULL;
+ char *nulls = NULL;
+ bool isnull = false;
+ SEXP obj;
+ SEXP result = NULL;
+ MemoryContext oldcontext;
+ char cursor_name[64];
+ Portal portal=NULL;
+ PREPARE_PG_TRY;
+ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_open");
+
+ /* Divide rargvalues */
+ if (nargs > 0)
+ {
+ if (!Rf_isVectorList(rargvalues))
+ error("%s", "second parameter must be a list of arguments " \
+ "to the prepared plan");
+
+ if (length(rargvalues) != nargs)
+ error("list of arguments (%d) is not the same length " \
+ "as that of the prepared plan (%d)",
+ length(rargvalues), nargs);
+
+ argvalues = (Datum *) palloc(nargs * sizeof(Datum));
+ nulls = (char *) palloc(nargs * sizeof(char));
+ }
+
+ for (i = 0; i < nargs; i++)
+ {
+ PROTECT(obj = VECTOR_ELT(rargvalues, i));
+
+ argvalues[i] = get_scalar_datum(obj, typinfuncs[i], typelems[i], &isnull);
+ if (!isnull)
+ nulls[i] = ' ';
+ else
+ nulls[i] = 'n';
+
+ UNPROTECT(1);
+ }
+ strncpy(cursor_name, CHAR(STRING_ELT(cursor_name_arg,0)), 64);
+
+ /* switch to SPI memory context */
+ oldcontext = MemoryContextSwitchTo(plr_SPI_context);
+
+ /*
+ * trap elog/ereport so we can let R finish up gracefully
+ * and generate the error once we exit the interpreter
+ */
+ PG_TRY();
+ {
+ /* Open the cursor */
+ portal = SPI_cursor_open(cursor_name,saved_plan, argvalues, nulls,1);
+
+ }
+ PLR_PG_CATCH();
+ PLR_PG_END_TRY();
+
+ /* back to caller's memory context */
+ MemoryContextSwitchTo(oldcontext);
+
+ if(portal==NULL)
+ error("SPI_cursor_open() failed");
+ else
+ result = R_MakeExternalPtr(portal, R_NilValue, R_NilValue);
+
+ POP_PLERRCONTEXT;
+ return result;
+}
+
+SEXP
+plr_SPI_cursor_fetch(SEXP cursor_in,SEXP forward_in, SEXP rows_in)
+{
+ Portal portal=NULL;
+ int ntuples;
+ SEXP result = NULL;
+ MemoryContext oldcontext;
+ int forward;
+ int rows;
+ PREPARE_PG_TRY;
+ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_fetch");
+
+ portal = R_ExternalPtrAddr(cursor_in);
+ if(!IS_LOGICAL(forward_in))
+ {
+ error("pg.spi.cursor_fetch arg2 must be boolean");
+ return result;
+ }
+ if(!IS_INTEGER(rows_in))
+ {
+ error("pg.spi.cursor_fetch arg3 must be an integer");
+ return result;
+ }
+ forward = LOGICAL_DATA(forward_in)[0];
+ rows = INTEGER_DATA(rows_in)[0];
+
+ /* switch to SPI memory context */
+ oldcontext = MemoryContextSwitchTo(plr_SPI_context);
+ PG_TRY();
+ {
+ /* Open the cursor */
+ SPI_cursor_fetch(portal,forward,rows);
+
+ }
+ PLR_PG_CATCH();
+ PLR_PG_END_TRY();
+ /* back to caller's memory context */
+ MemoryContextSwitchTo(oldcontext);
+
+ /* check the result */
+ ntuples = SPI_processed;
+ if (ntuples > 0)
+ {
+ result = rpgsql_get_results(ntuples, SPI_tuptable);
+ SPI_freetuptable(SPI_tuptable);
+ }
+ else
+ result = R_NilValue;
+
+ POP_PLERRCONTEXT;
+ return result;
+}
+
+void
+plr_SPI_cursor_close(SEXP cursor_in)
+{
+ Portal portal=NULL;
+ MemoryContext oldcontext;
+ PREPARE_PG_TRY;
+ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_close");
+
+ portal = R_ExternalPtrAddr(cursor_in);
+
+ /* switch to SPI memory context */
+ oldcontext = MemoryContextSwitchTo(plr_SPI_context);
+ PG_TRY();
+ {
+ /* Open the cursor */
+ SPI_cursor_close(portal);
+ }
+ PLR_PG_CATCH();
+ PLR_PG_END_TRY();
+ /* back to caller's memory context */
+ MemoryContextSwitchTo(oldcontext);
+}
+
+void
+plr_SPI_cursor_move(SEXP cursor_in,SEXP forward_in, SEXP rows_in)
+{
+ Portal portal=NULL;
+ MemoryContext oldcontext;
+ int forward;
+ int rows;
+ PREPARE_PG_TRY;
+ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.cursor_move");
+
+ portal = R_ExternalPtrAddr(cursor_in);
+ if(!IS_LOGICAL(forward_in))