pax_global_header00006660000000000000000000000064127727423660014532gustar00rootroot0000000000000052 comment=8c4febef154dc3f0c16e69c39004085ac803b981 plr-REL8_3_0_17/000077500000000000000000000000001277274236600133535ustar00rootroot00000000000000plr-REL8_3_0_17/.travis.yml000066400000000000000000000017441277274236600154720ustar00rootroot00000000000000os: - linux language: c sudo : required before_script: - sudo sh -c 'echo "deb http://apt.postgresql.org/pub/repos/apt/ precise-pgdg main 9.5" >> /etc/apt/sources.list.d/postgresql.list' - wget --quiet -O - https://www.postgresql.org/media/keys/ACCC4CF8.asc | sudo apt-key add - - sudo apt-get update -qq - sudo apt-get install -qq r-base - sudo apt-get install -qq r-base-dev - sudo /etc/init.d/postgresql stop - sudo apt-get remove postgresql - sudo apt-get install postgresql-9.5 - sudo apt-get install postgresql-server-dev-9.5 script: - sudo pg_lsclusters - export USE_PGXS=1 - export PGPORT=5433 - sudo -u postgres sh -c '/usr/lib/postgresql/9.5/bin/createuser -s -d -w travis -U postgres' - make - sudo make install - /usr/lib/postgresql/9.5/bin/pg_config - psql --version - /usr/lib/postgresql/9.5/lib/pgxs/src/makefiles/../../src/test/regress/pg_regress --inputdir=./ --bindir='/usr/lib/postgresql/9.5/bin/' --dbname=contrib_regression plr plr-REL8_3_0_17/Makefile000077500000000000000000000051361277274236600150230ustar00rootroot00000000000000# location of R library ifdef R_HOME r_libdir1x = ${R_HOME}/bin r_libdir2x = ${R_HOME}/lib # location of R includes r_includespec = -I${R_HOME}/include rhomedef = ${R_HOME} 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 --cflags-only-I libR) rhomedef := $(shell pkg-config --variable=rhome libR) endif ifneq (,${R_HOME}) EXTENSION = plr MODULE_big = plr PG_CPPFLAGS += $(r_includespec) SRCS += plr.c pg_conversion.c pg_backend_support.c pg_userfuncs.c pg_rsupport.c OBJS := $(SRCS:.c=.o) SHLIB_LINK += -L$(r_libdir1x) -L$(r_libdir2x) -lR DATA_built = plr.sql DATA = plr--8.3.0.17.sql plr--unpackaged--8.3.0.17.sql DOCS = README.plr REGRESS = plr EXTRA_CLEAN = doc/html/* doc/plr-US.aux doc/plr-*.log doc/plr-*.out doc/plr-*.pdf doc/plr-*.tex-pdf ifdef USE_PGXS ifndef PG_CONFIG PG_CONFIG := pg_config endif 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 DLPREFIX = libR else ifeq ($(PORTNAME), win32) DLPREFIX = R else DLPREFIX = libR endif endif # we can only build PL/R if libR is available # Since there is no official way to determine this, # we see if there is a file that is named like a shared library. ifneq ($(PORTNAME), darwin) ifneq (,$(wildcard $(r_libdir1x)/$(DLPREFIX)*$(DLSUFFIX)*)$(wildcard $(r_libdir2x)/$(DLPREFIX)*$(DLSUFFIX)*)) shared_libr = yes; endif else ifneq (,$(wildcard $(r_libdir1x)/$(DLPREFIX)*$(DYSUFFIX)*)$(wildcard $(r_libdir2x)/$(DLPREFIX)*$(DYSUFFIX)*)) shared_libr = yes endif endif # If we don't have a shared library and the platform doesn't allow it # to work without, we have to skip it. ifneq (,$(findstring yes, $(shared_libr)$(allow_nonpic_in_shlib))) override CPPFLAGS := -I"$(srcdir)" -I"$(r_includespec)" $(CPPFLAGS) override CPPFLAGS += -DPKGLIBDIR=\"$(pkglibdir)\" -DDLSUFFIX=\"$(DLSUFFIX)\" override CPPFLAGS += -DR_HOME_DEFAULT=\"$(rhomedef)\" else # can't build all: @echo ""; \ echo "*** Cannot build PL/R because libR is not a shared library." ; \ echo "*** You might have to rebuild your R installation. Refer to"; \ echo "*** the documentation for details."; \ echo "" 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 plr-REL8_3_0_17/README.plr000077500000000000000000000040021277274236600150260ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * */ See http://www.joeconway.com/plr/ for release notes and latest docs Notes: - R headers are required. Download and install R prior to building PL/R. - R must have been built with the --enable-R-shlib option when it was configured, in order for the libR shared object library to be available. - R_HOME must be defined in the environment of the user under which PostgreSQL is started, before the postmaster is started. Otherwise PL/R will refuse to load. Installation: See http://www.joeconway.com/plr/doc/plr-install.html for the most up-to-date instructions. Documentation: See the following: See http://www.joeconway.com/plr/doc/ doc/plr.sgml - PL/R documentation source doc/*.html - Preprocessed html version of the documentation ====================================================================== -- Joe Conway plr-REL8_3_0_17/compilingplr.md000066400000000000000000000115071277274236600164000ustar00rootroot00000000000000I successfully did the following recently in order to build 64 bit PL/R on Windows 7: ---------------- dumpbin /exports R.dll > R.dump.csv Note that I used the csv extension so OpenOffice would import the file into a spreadsheet conveniently. Edit R.dump.csv to produce a one column file of symbols called R.def. cat R.dump.csv | tr -s ' ' | cut -d ' ' -f 5 > R.def Add the following two lines to the top of the file: LIBRARY R EXPORTS Then run the following using R.def lib /def:R.def /out:R.lib cd ../../../contrib/plr "../../Release/pg_regress/pg_regress" --psqldir="../../Release/psql" --dbname=contrib_regression plr msvc.diff ```diff diff -cNr msvc.orig/config.pl msvc/config.pl *** msvc.orig/config.pl 1969-12-31 16:00:00.000000000 -0800 --- msvc/config.pl 2011-08-26 09:24:56.734375000 -0700 *************** *** 0 **** --- 1,27 ---- + # Configuration arguments for vcbuild. + use strict; + use warnings; + + our $config = { + asserts=>0, # --enable-cassert + # integer_datetimes=>1, # --enable-integer-datetimes - on is now default + # float4byval=>1, # --disable-float4-byval, on by default + # float8byval=>0, # --disable-float8-byval, off by default + # blocksize => 8, # --with-blocksize, 8kB by default + # wal_blocksize => 8, # --with-wal-blocksize, 8kb by default + # wal_segsize => 16, # --with-wal-segsize, 16MB by default + ldap=>1, # --with-ldap + nls=>undef, # --enable-nls= + tcl=>undef, # --with-tls= + perl=>undef, # --with-perl + python=>undef, # --with-python= + krb5=>undef, # --with-krb5= + openssl=>undef, # --with-ssl= + uuid=>undef, # --with-ossp-uuid + xml=>undef, # --with-libxml= + xslt=>undef, # --with-libxslt= + iconv=>undef, # (not in configure, path to iconv) + zlib=>undef # --with-zlib= + }; + + 1; diff -cNr msvc.orig/Mkvcbuild.pm msvc/Mkvcbuild.pm *** msvc.orig/Mkvcbuild.pm 2010-07-02 16:25:27.000000000 -0700 --- msvc/Mkvcbuild.pm 2011-08-26 13:08:41.796875000 -0700 *************** *** 35,41 **** 'cube' => ['cubescan.l','cubeparse.y'], 'seg' => ['segscan.l','segparse.y'] }; ! my @contrib_excludes = ('pgcrypto','intagg','sepgsql'); sub mkvcbuild { --- 35,41 ---- 'cube' => ['cubescan.l','cubeparse.y'], 'seg' => ['segscan.l','segparse.y'] }; ! my @contrib_excludes = ('pgcrypto','intagg','sepgsql','plr'); sub mkvcbuild { *************** *** 377,382 **** --- 377,392 ---- my $mf = Project::read_file('contrib/pgcrypto/Makefile'); GenerateContribSqlFiles('pgcrypto', $mf); + my $plr = $solution->AddProject('plr','dll','plr'); + $plr->AddFiles( + 'contrib\plr','plr.c','pg_conversion.c','pg_backend_support.c','pg_userfuncs.c','pg_rsupport.c' + ); + $plr->AddReference($postgres); + $plr->AddLibrary('C:\R\R-2.13.1\bin\R.lib'); + $plr->AddIncludeDir('C:\R\R-2.13.1\include'); + my $mfplr = Project::read_file('contrib/plr/Makefile'); + GenerateContribSqlFiles('plr', $mfplr); + my $D; opendir($D, 'contrib') || croak "Could not opendir on contrib!\n"; while (my $d = readdir($D)) *************** *** 596,601 **** --- 606,619 ---- } } } + else + { + print "GenerateContribSqlFiles skipping $n\n"; + if ($n eq 'plr') + { + print "mf: $mf\n"; + } + } } sub AdjustContribProj diff -cNr msvc.orig/Solution.pm msvc/Solution.pm *** msvc.orig/Solution.pm 2010-04-09 06:05:58.000000000 -0700 --- msvc/Solution.pm 2010-10-04 10:54:52.507549000 -0700 *************** *** 443,448 **** --- 443,449 ---- $proj->AddIncludeDir($self->{options}->{xslt} . '\include'); $proj->AddLibrary($self->{options}->{xslt} . '\lib\libxslt.lib'); } + $proj->AddIncludeDir('C:\Program Files\Microsoft Platform SDK\Include'); return $proj; } diff -cNr msvc.orig/vcregress.pl msvc/vcregress.pl *** msvc.orig/vcreg } } } + else + { + print "ress.pl 2010-04-09 06:05:58.000000000 -0700 --- msvc/vcregress.pl 2011-08-26 13:32:32.593750000 -0700 *************** *** 184,190 **** { chdir "../../../contrib"; my $mstat = 0; ! foreach my $module (glob("*")) { next if ($module eq 'xml2' && !$config->{xml}); next --- 184,190 ---- { chdir "../../../contrib"; my $mstat = 0; ! foreach my $module (glob("plr")) { next if ($module eq 'xml2' && !$config->{xml}); next *************** *** 201,206 **** --- 201,207 ---- "--psqldir=../../$Config/psql", "--dbname=contrib_regression",@opts,@tests ); + print join(" ", @args) . "\n"; system(@args); my $status = $? >> 8; $mstat ||= } } } + else + { + print " $status; ``` plr-REL8_3_0_17/doc/000077500000000000000000000000001277274236600141205ustar00rootroot00000000000000plr-REL8_3_0_17/doc/pg_doc000077500000000000000000000005111277274236600152760ustar00rootroot00000000000000#!/bin/bash jade -c ${DOCBOOKSTYLE}/catalog -d ${PGSRCROOT}/doc/src/sgml/stylesheet.dsl -i output-html -t sgml $1 openjade -D . -c ${DOCBOOKSTYLE}/catalog -d ${PGSRCROOT}/doc/src/sgml/stylesheet.dsl -t tex -V tex-backend -i output-print -V texpdf-output -V '%paper-type%'=USletter -o plr-US.tex-pdf $1 pdfjadetex plr-US.tex-pdfplr-REL8_3_0_17/doc/plr.sgml000077500000000000000000001701471277274236600156160ustar00rootroot00000000000000 PL/R User's Guide - R Procedural Language 2003-2009 Joseph E Conway Overview PL/R is a loadable procedural language that enables you to write PostgreSQL functions and triggers in the R programming language. PL/R offers most (if not all) of the capabilities a function writer has in the R language. Commands are available to access the database via the PostgreSQL Server Programming Interface (SPI) and to raise messages via elog() . There is no way to access internals of the database backend. However the user is able to gain OS-level access under the permissions of the PostgreSQL user ID, as with a C function. Thus, any unprivileged database user should not be permitted to use this language. It must be installed as an untrusted procedural language so that only database superusers can create functions in it. The writer of a PL/R function must take care that the function cannot be used to do anything unwanted, since it will be able to do anything that could be done by a user logged in as the database administrator. An implementation restriction is that PL/R procedures cannot be used to create input/output functions for new data types. Installation If you are going to compile PostgreSQL from the source, use the follwing commands from the untared and unzipped file downloaded from http://www.postgresql.org/ftp/source/: ./configure --enable-R-shlib --prefix=/opt/postgres_plr && make && make install Place source tar file in contrib in the PostgreSQL source tree and untar it. The shared object for the R call handler is built and installed in the PostgreSQL library directory via the following commands (starting from /path/to/postgresql_source/contrib): cd plr make make install You may explicitly include the path of pg_config to PATH, such as cd plr PATH=/usr/pgsql-9.4/bin/:$PATH; USE_PGXS=1 make echo 'PATH=/usr/pgsql-9.4/bin/:$PATH; USE_PGXS=1 make install' | sudo sh If you want to use git to pull the repository, run the following command before the make command: git clone https://github.com/jconway/plr As of PostgreSQL 8.0.0, PL/R can also be built without the PostgreSQL source tree. Untar PL/R whereever you prefer. The shared object for the R call handler is built and installed in the PostgreSQL library directory via the following commands (starting from /path/to/plr): cd plr USE_PGXS=1 make USE_PGXS=1 make install Win32 - adjust paths according to your own setup, and be sure to restart the PostgreSQL service after changing: In Windows environment: R_HOME=C:\Progra~1\R\R-2.5.0 Path=%PATH%;C:\Progra~1\R\R-2.5.0\bin In MSYS: export R_HOME=/c/progra~1/R/R-2.5.0 export PATH=$PATH:/c/progra~1/PostgreSQL/8.2/bin USE_PGXS=1 make USE_PGXS=1 make install You can use plr.sql (which is created in contrib/plr) to create the language and support functions in your database of choice: psql mydatabase < plr.sql Alternatively you can create the language manually using SQL commands: CREATE FUNCTION plr_call_handler() RETURNS LANGUAGE_HANDLER AS '$libdir/plr' LANGUAGE C; CREATE LANGUAGE plr HANDLER plr_call_handler; As of PostgreSQL 9.1 you can use the new CREATE EXTENSION command: CREATE EXTENSION plr; This is not only simple, it has the added advantage of tracking all PL/R installed objects as dependent on the extension, and therefore they can be removed just as easily if desired: DROP EXTENSION plr; If a language is installed into template1, all subsequently created databases will have the language installed automatically. In addition to the documentation, the plr.out.* files in plr/expected are a good source of usage examples. R headers are required. Download and install R prior to building PL/R. R must have been built with the --enable-R-shlib option when it was configured, in order for the libR shared object library to be available. 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 or $R_HOME/lib), and then running ldconfig. Refer to man ldconfig or its equivalent for your system. R_HOME must be defined in the environment of the user under which PostgreSQL is started, before 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. Functions and Arguments To create a function in the PL/R language, use standard R syntax, but without the enclosing braces or function assignment. Instead of myfunc <- function(arguments) { function body }, the body of your PL/R function is just function body CREATE OR REPLACE FUNCTION funcname (argument-types) RETURNS return-type AS ' function body ' LANGUAGE 'plr'; The body of the function is simply a piece of R script. When the function is called, the argument values are passed as variables arg1 ... argN to the R script. The result is returned from the R code in the usual way. For example, a function returning the greater of two integer values could be defined as: CREATE OR REPLACE FUNCTION r_max (integer, integer) RETURNS integer AS ' if (arg1 > arg2) return(arg1) else return(arg2) ' LANGUAGE 'plr' STRICT; Starting with PostgreSQL 8.0, arguments may be explicitly named when creating a function. If an argument is explicitly named at function creation time, that name will be available to your R script in place of the usual argN variable. For example: CREATE OR REPLACE FUNCTION sd(vals float8[]) RETURNS float AS ' sd(vals) ' LANGUAGE 'plr' STRICT; Starting with PostgreSQL 8.4, a PL/R function may be declared to be a WINDOW. In this case, in addition to the usual argN (or named) variables, PL/R automatically creates several other arguments to your function. For each explicit argument, a corresponding variable called farg1 ... fargN is passed to the R script. These contain an R vector of all the values of the related argument for the moving WINDOW frame within the current PARTITION. For example: CREATE OR REPLACE FUNCTION r_regr_slope(float8, float8) RETURNS float8 AS $BODY$ slope <- NA y <- farg1 x <- farg2 if (fnumrows==9) try (slope <- lm(y ~ x)$coefficients[2]) return(slope) $BODY$ LANGUAGE plr WINDOW; In the preceding example, farg1 and farg2 are R vectors containing the current row's data plus that of related rows. The determination as to which rows qualify as related is determined by the frame specification of the query at run time. The example also illustrates one of two additional autogenerated arguments. fnumrows is the number of rows in the current WINDOW frame. The other (not shown) auto-argument is called prownum. This argument provides the 1-based row offset of the current row in the current PARTITION. See for more information and a more complete example. In some of the the definitions above, note the clause STRICT, which saves us from having to think about NULL input values: if a NULL is passed, the function will not be called at all, but will just return a NULL result automatically. In a non-strict function, if the actual value of an argument is NULL, the corresponding argN variable will be set to a NULL R object. For example, suppose that we wanted r_max with one null and one non-null argument to return the non-null argument, rather than NULL: CREATE OR REPLACE FUNCTION r_max (integer, integer) RETURNS integer AS ' if (is.null(arg1) && is.null(arg2)) return(NULL) if (is.null(arg1)) return(arg2) if (is.null(arg2)) return(arg1) if (arg1 > arg2) return(arg1) arg2 ' LANGUAGE 'plr'; As shown above, to return a NULL value from a PL/R function, return NULL. This can be done whether the function is strict or not. Composite-type (tuple) arguments are passed to the procedure as R data.frames. The element names of the frame are the attribute names of the composite type. If an attribute in the passed row has the NULL value, it will appear as an "NA" in the frame. Here is an example: CREATE TABLE emp (name text, age int, salary numeric(10,2)); INSERT INTO emp VALUES ('Joe', 41, 250000.00); INSERT INTO emp VALUES ('Jim', 25, 120000.00); INSERT INTO emp VALUES ('Jon', 35, 50000.00); CREATE OR REPLACE FUNCTION overpaid (emp) RETURNS bool AS ' if (200000 < arg1$salary) { return(TRUE) } if (arg1$age < 30 && 100000 < arg1$salary) { return(TRUE) } return(FALSE) ' LANGUAGE 'plr'; SELECT name, overpaid(emp) FROM emp; name | overpaid ------+---------- Joe | t Jim | t Jon | f (3 rows) There is also support for returning a composite-type result value: CREATE OR REPLACE FUNCTION get_emps() RETURNS SETOF emp AS ' names <- c("Joe","Jim","Jon") ages <- c(41,25,35) salaries <- c(250000,120000,50000) df <- data.frame(name = names, age = ages, salary = salaries) return(df) ' LANGUAGE 'plr'; select * from get_emps(); name | age | salary ------+-----+----------- Jim | 41 | 250000.00 Joe | 25 | 120000.00 Jon | 35 | 50000.00 (3 rows) An alternative method may be used to create a function in PL/R, if certain criteria are met. First, the function must be a simple call to an existing R function. Second, the function name used for the PL/R function must match that of the R function exactly. If these two criteria are met, the PL/R function may be defined with no body, and the arguments will be passed directly to the R function of the same name. For example: 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) Because the function body is passed as an SQL string literal to CREATE FUNCTION, you have to escape single quotes and backslashes within your R source, typically by doubling them. Passing Data Values The argument values supplied to a PL/R function's script are the input arguments converted to a corresponding R form. See . Scalar PostgreSQL values become single element R vectors. One exception to this are scalar bytea values. These are first converted to R raw type, and then processed by the R unserialize command. One-dimensional PostgreSQL arrays are converted to multi-element R vectors, two-dimensional PostgreSQL arrays are mapped to R matrixes, and three-dimensional PostgreSQL arrays are converted to three-dimensional R arrays. Greater than three-dimensional arrays are not supported. Composite-types are transformed into R data.frames. Function Arguments PostgreSQL type R type boolean logical int2, int4 integer int8, float4, float8, cash, numeric numeric bytea object everything else character
Conversely, the return values are first coerced to R character, and therefore anything that resolves to a string that is acceptable input format for the function's declared return type will produce a result. Again, there is an exception for scalar bytea return values. In this case, the R object being returned is first processed by the R serialize command, and then the binary result is directly mapped into a PostgreSQL bytea datum. Similar to argument conversion, there is also a mapping between the dimensionality of the declared PostgreSQL return type and the type of R object. That mapping is shown in Function Result Dimensionality PgSQL return type R type Result Example scalar array, matrix, vector first column of first row c(1,2,3) in R returns 1 in PostgreSQL setof scalar 1D array, greater than 2D array, vector multi-row, 1 column set array(1:10) in R returns 10 rows in PostgreSQL scalar data.frame textual representation of the first column's vector data.frame(c(1,2,3)) in R returns 'c(1, 2, 3)' setof scalar 2D array, matrix, data.frame #columns > 1, error; #columns == 1, multi-row, 1 column set (as.data.frame(array(1:10,c(2,5))))[,1] in R returns 2 rows of scalar array 1D array, greater than 3D array, vector 1D array array(1:8,c(2,2,2,2)) in R returns {1,2,3,4,5,6,7,8,1,2,3,4,5,6,7,8} array 2D array, matrix, data.frame 2D array array(1:4,c(2,2)) in R returns {{1,3},{2,4}} array 3D array 3D array array(1:8,c(2,2,2)) in R returns {{{1,5},{3,7}},{{2,6},{4,8}}} composite 1D array, greater than 2D array, vector first row, 1 column array(1:8,c(2,2,2)) in R returns 1 row of scalar setof composite 1D array, greater than 2D array, vector multi-row, 1 column set array(1:8,c(2,2,2)) in R returns 8 rows of scalar composite 2D array, matrix, data.frame first row, multi-column array(1:4,c(2,2)) in R returns 1 row of 2 columns setof composite 2D array, matrix, data.frame multi-row, multi-column set array(1:4,c(2,2)) in R returns 2 rows of 2 columns
Using Global Data Sometimes it is useful to have some global status data that is held between two calls to a procedure or is shared between different procedures. Equally useful is the ability to create functions that your PL/R functions can share. This is easily done since all PL/R procedures executed in one backend share the same R interpreter. So, any global R variable is accessible to all PL/R procedure calls, and will persist for the duration of the SQL client connection. An example of using a global object appears in the pg.spi.execp example, in . A globally available, user named, R function (the R function name of PL/R functions is not the same as its PostgreSQL function name; see: ) can be created dynamically using the provided PostgreSQL function install_rcmd(text). Here is an example: 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 globally available, user named, R function can also be automatically created and installed in the R interpreter. See: PL/R also provides a global variable called pg.state.firstpass. This variable is reset to TRUE the first time each PL/R function is called, for a particular query. On subsequent calls the value is left unchanged. This allows one or more PL/R functions to perform a possibly expensive initialization on the first call, and reuse the results for the remaining rows in the query. For example: create table t (f1 int); insert into t values (1); insert into t values (2); insert into t values (3); create or replace function f1() returns int as ' msg <- paste("enter f1, pg.state.firstpass is", pg.state.firstpass) pg.thrownotice(msg) if (pg.state.firstpass == TRUE) pg.state.firstpass <<- FALSE msg <- paste("exit f1, pg.state.firstpass is", pg.state.firstpass) pg.thrownotice(msg) return(0) ' language plr; create or replace function f2() returns int as ' msg <- paste("enter f2, pg.state.firstpass is", pg.state.firstpass) pg.thrownotice(msg) if (pg.state.firstpass == TRUE) pg.state.firstpass <<- FALSE msg <- paste("exit f2, pg.state.firstpass is", pg.state.firstpass) pg.thrownotice(msg) return(0) ' language plr; select f1(), f2(), f1 from t; NOTICE: enter f1, pg.state.firstpass is TRUE NOTICE: exit f1, pg.state.firstpass is FALSE NOTICE: enter f2, pg.state.firstpass is TRUE NOTICE: exit f2, pg.state.firstpass is FALSE NOTICE: enter f1, pg.state.firstpass is FALSE NOTICE: exit f1, pg.state.firstpass is FALSE NOTICE: enter f2, pg.state.firstpass is FALSE NOTICE: exit f2, pg.state.firstpass is FALSE NOTICE: enter f1, pg.state.firstpass is FALSE NOTICE: exit f1, pg.state.firstpass is FALSE NOTICE: enter f2, pg.state.firstpass is FALSE NOTICE: exit f2, pg.state.firstpass is FALSE f1 | f2 | f1 ----+----+---- 0 | 0 | 1 0 | 0 | 2 0 | 0 | 3 (3 rows) create or replace function row_number() returns int as ' if (pg.state.firstpass) { assign("pg.state.firstpass", FALSE, env=.GlobalEnv) lclcntr <- 1 } else lclcntr <- plrcounter + 1 assign("plrcounter", lclcntr, env=.GlobalEnv) return(lclcntr) ' language 'plr'; SELECT row_number(), f1 from t; row_number | f1 ------------+---- 1 | 1 2 | 2 3 | 3 (3 rows) Database Access and Support Functions The following commands are available to access the database from the body of a PL/R procedure, or in support thereof: Normal Support pg.spi.exec (character query) Execute an SQL query given as a string. An error in the query causes an error to be raised. Otherwise, the command's return value is the number of rows processed for INSERT, UPDATE, or DELETE statements, or zero if the query is a utility statement. If the query is a SELECT statement, the values of the selected columns are placed in an R data.frame with the target column names used as the frame column names. However, non-numeric columns are not converted to factors. If you want all non-numeric columns converted to factors, a convenience function pg.spi.factor (described below) is provided. If a field of a SELECT result is NULL, the target variable for it is set to NA. For example: 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, NULL::text as nullcol, typname from pg_type where typname = ''oid'' or typname = ''text''') as t(typeid oid, nullcol text, typename name); typeid | nullcol | typename --------+---------+---------- 25 | | text 26 | | oid (2 rows) The NULL values were passed to R as NA, and on return to PostgreSQL they were converted back to NULL. pg.spi.prepare (character query, integer vector type_vector) Prepares and saves a query plan for later execution. The saved plan will be retained for the life of the current backend. The query may use arguments, which are placeholders for values to be supplied whenever the plan is actually executed. In the query string, refer to arguments by the symbols $1 ... $n. If the query uses arguments, the values of the argument types must be given as a vector. Pass NA for type_vector if the query has no arguments. The argument types must be identified by the type Oids, shown in pg_type. Global variables are provided for this use. They are named according to the convention TYPENAMEOID, where the actual name of the type, in all capitals, is substituted for TYPENAME. A support function, load_r_typenames() must be used to make the predefined global variables available for use: select load_r_typenames(); load_r_typenames ------------------ OK (1 row) Another support function, r_typenames() may be used to list the predefined Global variables: select * from r_typenames(); typename | typeoid -----------------+--------- ABSTIMEOID | 702 ACLITEMOID | 1033 ANYARRAYOID | 2277 ANYOID | 2276 BITOID | 1560 BOOLOID | 16 [...] TRIGGEROID | 2279 UNKNOWNOID | 705 VARBITOID | 1562 VARCHAROID | 1043 VOIDOID | 2278 XIDOID | 28 (59 rows) The return value from pg.spi.prepare is a query ID to be used in subsequent calls to pg.spi.execp. See spi_execp for an example. pg.spi.execp (external pointer saved_plan, variable listvalue_list) Execute a query previously prepared with pg.spi.prepare . saved_plan is the external pointer returned by pg.spi.prepare. If the query references arguments, a value_list must be supplied: this is an R list of actual values for the plan arguments. It must be the same length as the argument type_vector previously given to pg.spi.prepare. Pass NA for value_list if the query has no arguments. The following illustrates the use of pg.spi.prepare and pg.spi.execp with and without query arguments: 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_prep(text) returns text as ' sp <<- pg.spi.prepare(arg1, NA); print("OK") ' language 'plr'; select test_spi_prep('select oid, typname from pg_type where typname = ''bytea'' or typname = ''text'''); test_spi_prep --------------- OK (1 row) create or replace function test_spi_execp(text) returns setof record as ' pg.spi.execp(pg.reval(arg1), NA) ' language 'plr'; select * from test_spi_execp('sp') as t(typeid oid, typename name); typeid | typename --------+---------- 17 | bytea 25 | text (2 rows) create or replace function test_spi_prep(text) returns text as ' sp <<- pg.spi.prepare(arg1); print("OK") ' language 'plr'; select test_spi_prep('select oid, typname from pg_type where typname = ''bytea'' or typname = ''text'''); test_spi_prep --------------- OK (1 row) create or replace function test_spi_execp(text) returns setof record as ' pg.spi.execp(pg.reval(arg1)) ' language 'plr'; select * from test_spi_execp('sp') as t(typeid oid, typename name); typeid | typename --------+---------- 17 | bytea 25 | text (2 rows) NULL arguments should be passed as individual NA values in value_list. Except for the way in which the query and its arguments are specified, pg.spi.execp works just like pg.spi.exec. pg.spi.cursor_open( character cursor_name, external pointer saved_plan, variable list value_list) 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. plan <- pg.spi.prepare('SELECT * FROM pg_class'); cursor_obj <- pg.spi.cursor_open('my_cursor',plan); Returns a cursor object that be be passed to pg.spi.cursor_fetch pg.spi.cursor_fetch( external pointer cursor, boolean forward, integer rows) Fetches rows from the cursor object previosuly returned by pg.spi.cursor_open . 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. rows indicates the maximum number of rows that should be returned. plan <- pg.spi.prepare('SELECT * FROM pg_class'); cursor_obj <- pg.spi.cursor_open('my_cursor',plan); data <- pg.spi.cursor_fetch(cursor_obj,TRUE,as.integer(10)); Returns a data frame containing the results. pg.spi.cursor_close( external pointercursor) Closes a cursor previously opened by pg.spi.cursor_open plan <- pg.spi.prepare('SELECT * FROM pg_class'); cursor_obj <- pg.spi.cursor_open('my_cursor',plan); pg.spi.cursor_close(cursor_obj); pg.spi.lastoid() Returns the OID of the row inserted by the last query executed via pg.spi.exec or pg.spi.execp, if that query was a single-row INSERT. (If not, you get zero.) pg.quoteliteral (character SQL_string) Duplicates all occurrences of single quote and backslash characters in the given string. This may be used to safely quote strings that are to be inserted into SQL queries given to pg.spi.exec or pg.spi.prepare. pg.quoteident (character SQL_string) Return the given string suitably quoted to be used as an identifier in an SQL query string. Quotes are added only if necessary (i.e., if the string contains non-identifier characters or would be case-folded). Embedded quotes are properly doubled. This may be used to safely quote strings that are to be inserted into SQL queries given to pg.spi.exec or pg.spi.prepare. pg.thrownotice (character message) pg.throwerror (character message) Emit a PostgreSQL NOTICE or ERROR message. ERROR also raises an error condition: further execution of the function is abandoned, and the current transaction is aborted. pg.spi.factor (data.frame data) Accepts an R data.frame as input, and converts all non-numeric columns to factors. This may be useful for data.frames produced by pg.spi.exec or pg.spi.prepare, because the PL/R conversion mechanism does not do that for you. RPostgreSQL Compatibility Support The following functions are intended to provide some level of compatibility between PL/R and RPostgreSQL (PostgreSQL DBI package). This allows, for example, a function to be first prototyped using an R client, and then easily moved to PL/R for production use. dbDriver (character dvr_name) dbConnect (DBIDriver drv, character user, character password, character host, character dbname, character port, character tty, character options) dbSendQuery (DBIConnection conn, character sql) fetch (DBIResult rs, integer num_rows) dbClearResult (DBIResult rs) dbGetQuery (DBIConnection conn, character sql) dbReadTable (DBIConnection conn, character name) dbDisconnect (DBIConnection conn) dbUnloadDriver (DBIDriver drv) These functions nominally work like their RPostgreSQL counterparts except that all queries are performed in the current database. Therefore all driver and connection related parameters are ignored, and dbDriver, dbConnect, dbDisconnect, and dbUnloadDriver are no-ops. PostgreSQL Support Functions The following commands are available to use in PostgreSQL queries to aid in the use of PL/R functions: plr_version() Displays PL/R version as a text string. install_rcmd (text R_code) Install R code, given as a string, into the interpreter. See for an example. reload_plr_modules () Force re-loading of R code from the plr_modules table. It is useful after modifying the contents of plr_modules, so that the change will have an immediate effect. plr_singleton_array (float8 first_element) Creates a new PostgreSQL array, using element first_element. This function is predefined to accept one float8 value and return a float8 array. The C function that implements this PostgreSQL function is capable of accepting and returning other data types, although the return type must be an array of the input parameter type. It can also accept multiple input parameters. For example, to define a plr_array function to create a text array from two input text values: CREATE OR REPLACE FUNCTION plr_array (text, text) RETURNS text[] AS '$libdir/plr','plr_array' LANGUAGE 'C' WITH (isstrict); select plr_array('hello','world'); plr_array --------------- {hello,world} (1 row) plr_array_push (float8[] array, float8 next_element) Pushes a new element onto the end of an existing PostgreSQL array. This function is predefined to accept one float8 array and a float8 value, and return a float8 array. The C function that implements this PostgreSQL function is capable of accepting and returning other data types. For example, to define a plr_array_push function to add a text value to an existing text array: CREATE OR REPLACE FUNCTION plr_array_push (_text, text) RETURNS text[] AS '$libdir/plr','plr_array_push' LANGUAGE 'C' WITH (isstrict); select plr_array_push(plr_array('hello','world'), 'how are you'); plr_array_push ----------------------------- {hello,world,"how are you"} (1 row) plr_array_accum (float8[] state_value, float8 next_element) Creates a new array using next_element if state_value is NULL. Otherwise, pushes next_element onto the end of state_value. This function is predefined to accept one float8 array and a float8 value, and return a float8 array. The C function that implements this PostgreSQL function is capable of accepting and returning other data types. For example, to define a plr_array_accum function to add an int4 value to an existing int4 array: CREATE OR REPLACE FUNCTION plr_array_accum (_int4, int4) RETURNS int4[] AS '$libdir/plr','plr_array_accum' LANGUAGE 'C'; select plr_array_accum(NULL, 42); plr_array_accum ------------- {42} (1 row) select plr_array_accum('{23,35}', 42); plr_array_accum ----------------- {23,35,42} (1 row) This function may be useful for creating custom aggregates. See for an example. load_r_typenames() Installs datatype Oid variables into the R interpreter as globals. See also r_typenames below. r_typenames() Displays the datatype Oid variables installed into the R interpreter as globals. See for an example. plr_environ() Displays the environment under which the Postmaster is currently running. This may be useful to debug issues related to R specific environment variables. This function is installed with EXECUTE permission revoked from PUBLIC. plr_set_display(text display) Sets the DISPLAY environment vaiable under which the Postmaster is currently running. This may be useful if using R to plot to a virtual frame buffer. This function is installed with EXECUTE permission revoked from PUBLIC. plr_get_raw(bytea serialized_object) By default, when R objects are returned as type bytea, the R object is serialized using an internal R function prior to sending to PostgreSQL. This function unserializes the R object using another internal R function, and returns the pure raw bytes to PostgreSQL. This is useful, for example, if the R object being returned is a JPEG or PNG graphic for use outside of R. Aggregate Functions Aggregates in PostgreSQL are extensible via SQL commands. In general, to create a new aggregate, a state transition function and possibly a final function are specified. The final function is used in case the desired output of the aggregate is different from the data that needs to be kept in the running state value. There is more than one way to create a new aggregate using PL/R. A simple aggregate can be defined using the predefined PostgreSQL C function, plr_array_accum (see ) as a state transition function, and a PL/R function as a finalizer. For example: create or replace function r_median(_float8) returns float as ' median(arg1) ' language 'plr'; CREATE AGGREGATE median ( sfunc = plr_array_accum, basetype = float8, stype = _float8, finalfunc = r_median ); create table foo(f0 int, f1 text, f2 float8); 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); select f1, median(f2) from foo group by f1 order by f1; f1 | median ------+-------- cat1 | 1.21 cat2 | 1.28 (2 rows) A more complex aggregate might be created by using a PL/R functions for both state transition and finalizer. Window Functions Starting with version 8.4, PostgreSQL supports WINDOW functions which provide the ability to perform calculations across sets of rows that are related to the current query row. This is comparable to the type of calculation that can be done with an aggregate function. But unlike regular aggregate functions, use of a window function does not cause rows to become grouped into a single output row; the rows retain their separate identities. Behind the scenes, the window function is able to access more than just the current row of the query result. See the PostgreSQL documentation for more general information related to the use of this capability. PL/R functions may be defined as WINDOW. For example: CREATE OR REPLACE FUNCTION r_regr_slope(float8, float8) RETURNS float8 AS $BODY$ slope <- NA y <- farg1 x <- farg2 if (fnumrows==9) try (slope <- lm(y ~ x)$coefficients[2]) return(slope) $BODY$ LANGUAGE plr WINDOW; A number of variables are automatically provided by PL/R to the R interpreter: fargN farg1 and farg2 are R vectors containing the current row's data plus that of the related rows. fnumrows The number of rows in the current WINDOW frame. prownum (not shown) Provides the 1-based row offset of the current row in the current PARTITION. A more complete example follows: -- create test table CREATE TABLE test_data ( fyear integer, firm float8, eps float8 ); -- insert randomly pertubated data for test INSERT INTO test_data SELECT (b.f + 1) % 10 + 2000 AS fyear, floor((b.f+1)/10) + 50 AS firm, f::float8/100 + random()/10 AS eps FROM generate_series(-500,499,1) b(f); CREATE OR REPLACE FUNCTION r_regr_slope(float8, float8) RETURNS float8 AS $BODY$ slope <- NA y <- farg1 x <- farg2 if (fnumrows==9) try (slope <- lm(y ~ x)$coefficients[2]) return(slope) $BODY$ LANGUAGE plr WINDOW; SELECT *, r_regr_slope(eps, lag_eps) OVER w AS slope_R FROM (SELECT firm, fyear, eps, lag(eps) OVER (ORDER BY firm, fyear) AS lag_eps FROM test_data) AS a WHERE eps IS NOT NULL WINDOW w AS (ORDER BY firm, fyear ROWS 8 PRECEDING); In this example, the variables farg1 and farg2 contain the current row value for eps and lag_eps, as well as the preceding 8 rows which are also in the same WINDOW frame within the same PARTITION. In this case since no PARTITION is explicitly defined, the PARTITION is the entire set of rows returned from the inner sub-select. Another interesting example follows. The idea of Winsorizing is to return either the original value or, if that value is outside certain bounds, a trimmed value. So for example winsor(eps, 0.1) would return the value at the 10th percentile for values of eps less that that, the value of the 90th percentile for eps greater than that value, and the unmodified value of eps otherwise. CREATE OR REPLACE FUNCTION winsorize(float8, float8) RETURNS float8 AS $BODY$ library(psych) return(winsor(as.vector(farg1), arg2)[prownum]) $BODY$ LANGUAGE plr VOLATILE WINDOW; SELECT fyear, eps, winsorize(eps, 0.1) OVER (PARTITION BY fyear) AS w_eps FROM test_data ORDER BY fyear, eps; In this example, use of the variable prownum is illustrated. Loading R Modules at Startup PL/R has support for auto-loading R code during interpreter initialization. It uses a special table, plr_modules, which is presumed to contain modules of R code. If this table exists, the modules defined are fetched from the table and loaded into the R interpreter immediately after creation. The definition of the table plr_modules is as follows: CREATE TABLE plr_modules ( modseq int4, modsrc text ); The field modseq is used to control the order of installation. The field modsrc contains the full text of the R code to be executed, including assignment if that is desired. Consider, for example, the following statement: INSERT INTO plr_modules VALUES (0, 'pg.test.module.load <-function(msg) {print(msg)}'); This statement will cause an R function named pg.test.module.load to be created in the R interpreter on initialization. A PL/R function may now simply reference the function directly as follows: 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) The table plr_modules must be readable by all, but it is wise to make it owned and writable only by the database administrator. R Function Names In PostgreSQL, one and the same function name can be used for different functions as long as the number of arguments or their types differ. R, however, requires all function names to be distinct. PL/R deals with this by constructing the internal R function names as a concatenation of the string PLR with the object ID of the procedure's pg_proc. Thus, PostgreSQL functions with the same name and different argument types will be different R functions too. This is not normally a concern for a PL/R programmer, but it might be visible when debugging. If a specific, known, function name is needed so that an R function can be referenced by one or more PL/R functions, the install_rcmd(text) command can be used. See . Trigger Procedures triggers in PL/R Trigger procedures can be written in PL/R. PostgreSQL requires that a procedure that is to be called as a trigger must be declared as a function with no arguments and a return type of trigger. The information from the trigger manager is passed to the procedure body in the following variables: pg.tg.name The name of the trigger from the CREATE TRIGGER statement. pg.tg.relid The object ID of the table that caused the trigger procedure to be invoked. pg.tg.relname The name of the table that caused the trigger procedure to be invoked. pg.tg.when The string BEFORE or AFTER depending on the type of trigger call. pg.tg.level The string ROW or STATEMENT depending on the type of trigger call. pg.tg.op The string INSERT, UPDATE, or DELETE depending on the type of trigger call. pg.tg.new When the trigger is defined FOR EACH ROW, a data.frame containing the values of the new table row for INSERT or UPDATE actions. For triggers defined FOR EACH STATEMENT and for DELETE actions, set to NULL. The atribute names are the table's column names. Columns that are null will be represented as NA. pg.tg.old When the trigger is defined FOR EACH ROW, a data.frame containing the values of the old table row for DELETE or UPDATE actions. For triggers defined FOR EACH STATEMENT and for INSERT actions, set to NULL. The atribute names are the table's column names. Columns that are null will be represented as NA. pg.tg.args A vector of the arguments to the procedure as given in the CREATE TRIGGER statement. The return value from a trigger procedure can be NULL or a one row data.frame matching the number and type of columns in the trigger table. NULL tells the trigger manager to silently suppress the operation for this row. If a one row data.frame is returned, it tells PL/R to return a possibly modified row to the trigger manager that will be inserted instead of the one given in pg.tg.new. This works for INSERT and UPDATE only. Needless to say that all this is only meaningful when the trigger is BEFORE and FOR EACH ROW; otherwise the return value is ignored. Here's a little example trigger procedure that forces an integer value in a table to keep track of the number of updates that are performed on the row. For new rows inserted, the value is initialized to 0 and then incremented on every update operation. CREATE FUNCTION trigfunc_modcount() RETURNS trigger AS ' if (pg.tg.op == "INSERT") { retval <- pg.tg.new retval[pg.tg.args[1]] <- 0 } if (pg.tg.op == "UPDATE") { retval <- pg.tg.new retval[pg.tg.args[1]] <- pg.tg.old[pg.tg.args[1]] + 1 } if (pg.tg.op == "DELETE") retval <- pg.tg.old return(retval) ' LANGUAGE plr; CREATE TABLE mytab (num integer, description text, modcnt integer); CREATE TRIGGER trig_mytab_modcount BEFORE INSERT OR UPDATE ON mytab FOR EACH ROW EXECUTE PROCEDURE trigfunc_modcount('modcnt'); Notice that the trigger procedure itself does not know the column name; that's supplied from the trigger arguments. This lets the trigger procedure be reused with different tables. License License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA plr-REL8_3_0_17/doc/stylesheet.css000077500000000000000000000025371277274236600170350ustar00rootroot00000000000000BODY { color: #000000; background: #FFFFFF; } A { font-weight: normal; color: #020169; text-decoration: none; } A:link { color: #000066; } A:visited { color: #000099; } A:active { color: #FF0000; } A:hover { color: red; } BODY.BOOK H1.TITLE, BODY.SET H1.TITLE { text-align: center; font-size: 150%; font-family: helvetica,arial,sans-serif; color: #020167; } H3.CORPAUTHOR, H3.CORPAUTHOR { text-align: center; font-style: italic; font-weight: normal; } .COPYRIGHT, .COPYRIGHT { text-align: center; } DIV.EXAMPLE { padding-left: 15px; border-style: solid; border-width: 0px; border-left-width: 2px; border-color: black; margin: 0.5ex; } .SCREEN, .SYNOPSIS, .PROGRAMLISTING { margin-left: 4ex; } .NAVHEADER TH { font-style: italic; } .COMMENT { color: red; } VAR { font-family: monospace; font-style: inherit; } /* Konqueror's standard style for ACRONYM is italic. */ ACRONYM { font-style: inherit; } LI { font-family: helvetica,arial,sans-serif; } BIG { text-decoration: none; font-family: helvetica,arial,sans-serif; font-weight: bold; font-size: 14px; } SMALL { text-decoration: none; font-family: helvetica,arial,sans-serif; font-weight: normal; font-size: 10px; } ol, ul, p, body, td, tr, th, form, span, div { font-family: helvetica,arial,sans-serif; font-size: 12px; } h1, h2, h3, h4, h5, h6 { font-family: helvetica,arial,sans-serif; } plr-REL8_3_0_17/expected/000077500000000000000000000000001277274236600151545ustar00rootroot00000000000000plr-REL8_3_0_17/expected/plr.out000077500000000000000000001217761277274236600165230ustar00rootroot00000000000000-- -- first, define the language and functions. Turn off echoing so that expected file -- does not depend on contents of plr.sql. -- \set ECHO none -- check version SELECT plr_version(); plr_version ------------- 08.03.00.17 (1 row) -- 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) -- -- test simple input/output types -- CREATE OR REPLACE FUNCTION rint2(i int2) RETURNS int2 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint2(1::int2); rint2 ------- 1 (1 row) select rint2(NULL); rint2 ------- (1 row) CREATE OR REPLACE FUNCTION rint4(i int4) RETURNS int4 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint4(1::int4); rint4 ------- 1 (1 row) select rint4(NULL); rint4 ------- (1 row) CREATE OR REPLACE FUNCTION rint8(i int8) RETURNS int8 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint8(1::int8); rint8 ------- 1 (1 row) select rint8(NULL); rint8 ------- (1 row) CREATE OR REPLACE FUNCTION rbool(b bool) RETURNS bool AS $$ return (as.logical(b)) $$ LANGUAGE plr; select rbool('t'); rbool ------- t (1 row) select rbool('f'); rbool ------- f (1 row) select rbool(NULL); rbool ------- (1 row) CREATE OR REPLACE FUNCTION rfloat4(f float4) RETURNS float4 AS $$ return (as.numeric(f)) $$ LANGUAGE plr; select rfloat4(1::int4); rfloat4 --------- 1 (1 row) select rfloat4(NULL); rfloat4 --------- (1 row) CREATE OR REPLACE FUNCTION rfloat8(f float8) RETURNS float8 AS $$ return (as.numeric(f)) $$ LANGUAGE plr; select rfloat8(1::float8); rfloat8 --------- 1 (1 row) select rfloat8(NULL); rfloat8 --------- (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,--slave,--silent,--no-save,--no-restore} (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) --Test bytea arguments and return values: serialize/unserialize create or replace function test_serialize(text) returns bytea as ' mydf <- pg.spi.exec(arg1) return (mydf) ' language 'plr'; create or replace function restore_df(bytea) returns setof record as ' return (arg1) ' language 'plr'; select * from restore_df((select test_serialize('select oid, typname from pg_type where typname in (''oid'',''name'',''int4'')'))) as t(oid oid, typname name); oid | typname -----+--------- 19 | name 23 | int4 26 | oid (3 rows) --Test WINDOW functions -- create test table CREATE TABLE test_data ( fyear integer, firm float8, eps float8 ); -- insert data for test INSERT INTO test_data SELECT (b.f + 1) % 10 + 2000 AS fyear, floor((b.f+1)/10) + 50 AS firm, f::float8/100 AS eps FROM generate_series(-200,199,1) b(f); CREATE OR REPLACE FUNCTION r_regr_slope(float8, float8) RETURNS float8 AS $BODY$ slope <- NA y <- farg1 x <- farg2 if (fnumrows==9) try (slope <- lm(y ~ x)$coefficients[2]) return(slope) $BODY$ LANGUAGE plr WINDOW; SELECT *, round((r_regr_slope(eps, lag_eps) OVER w)::numeric,6) AS slope_R FROM (SELECT firm, fyear, eps, lag(eps) OVER (ORDER BY firm, fyear) AS lag_eps FROM test_data) AS a WHERE eps IS NOT NULL WINDOW w AS (ORDER BY firm, fyear ROWS 8 PRECEDING); firm | fyear | eps | lag_eps | slope_r ------+-------+-------+---------+---------- 31 | 1991 | -2 | | 31 | 1992 | -1.99 | -2 | 31 | 1993 | -1.98 | -1.99 | 31 | 1994 | -1.97 | -1.98 | 31 | 1995 | -1.96 | -1.97 | 31 | 1996 | -1.95 | -1.96 | 31 | 1997 | -1.94 | -1.95 | 31 | 1998 | -1.93 | -1.94 | 31 | 1999 | -1.92 | -1.93 | 1.000000 31 | 2000 | -1.91 | -1.92 | 1.000000 32 | 1991 | -1.9 | -1.91 | 1.000000 32 | 1992 | -1.89 | -1.9 | 1.000000 32 | 1993 | -1.88 | -1.89 | 1.000000 32 | 1994 | -1.87 | -1.88 | 1.000000 32 | 1995 | -1.86 | -1.87 | 1.000000 32 | 1996 | -1.85 | -1.86 | 1.000000 32 | 1997 | -1.84 | -1.85 | 1.000000 32 | 1998 | -1.83 | -1.84 | 1.000000 32 | 1999 | -1.82 | -1.83 | 1.000000 32 | 2000 | -1.81 | -1.82 | 1.000000 33 | 1991 | -1.8 | -1.81 | 1.000000 33 | 1992 | -1.79 | -1.8 | 1.000000 33 | 1993 | -1.78 | -1.79 | 1.000000 33 | 1994 | -1.77 | -1.78 | 1.000000 33 | 1995 | -1.76 | -1.77 | 1.000000 33 | 1996 | -1.75 | -1.76 | 1.000000 33 | 1997 | -1.74 | -1.75 | 1.000000 33 | 1998 | -1.73 | -1.74 | 1.000000 33 | 1999 | -1.72 | -1.73 | 1.000000 33 | 2000 | -1.71 | -1.72 | 1.000000 34 | 1991 | -1.7 | -1.71 | 1.000000 34 | 1992 | -1.69 | -1.7 | 1.000000 34 | 1993 | -1.68 | -1.69 | 1.000000 34 | 1994 | -1.67 | -1.68 | 1.000000 34 | 1995 | -1.66 | -1.67 | 1.000000 34 | 1996 | -1.65 | -1.66 | 1.000000 34 | 1997 | -1.64 | -1.65 | 1.000000 34 | 1998 | -1.63 | -1.64 | 1.000000 34 | 1999 | -1.62 | -1.63 | 1.000000 34 | 2000 | -1.61 | -1.62 | 1.000000 35 | 1991 | -1.6 | -1.61 | 1.000000 35 | 1992 | -1.59 | -1.6 | 1.000000 35 | 1993 | -1.58 | -1.59 | 1.000000 35 | 1994 | -1.57 | -1.58 | 1.000000 35 | 1995 | -1.56 | -1.57 | 1.000000 35 | 1996 | -1.55 | -1.56 | 1.000000 35 | 1997 | -1.54 | -1.55 | 1.000000 35 | 1998 | -1.53 | -1.54 | 1.000000 35 | 1999 | -1.52 | -1.53 | 1.000000 35 | 2000 | -1.51 | -1.52 | 1.000000 36 | 1991 | -1.5 | -1.51 | 1.000000 36 | 1992 | -1.49 | -1.5 | 1.000000 36 | 1993 | -1.48 | -1.49 | 1.000000 36 | 1994 | -1.47 | -1.48 | 1.000000 36 | 1995 | -1.46 | -1.47 | 1.000000 36 | 1996 | -1.45 | -1.46 | 1.000000 36 | 1997 | -1.44 | -1.45 | 1.000000 36 | 1998 | -1.43 | -1.44 | 1.000000 36 | 1999 | -1.42 | -1.43 | 1.000000 36 | 2000 | -1.41 | -1.42 | 1.000000 37 | 1991 | -1.4 | -1.41 | 1.000000 37 | 1992 | -1.39 | -1.4 | 1.000000 37 | 1993 | -1.38 | -1.39 | 1.000000 37 | 1994 | -1.37 | -1.38 | 1.000000 37 | 1995 | -1.36 | -1.37 | 1.000000 37 | 1996 | -1.35 | -1.36 | 1.000000 37 | 1997 | -1.34 | -1.35 | 1.000000 37 | 1998 | -1.33 | -1.34 | 1.000000 37 | 1999 | -1.32 | -1.33 | 1.000000 37 | 2000 | -1.31 | -1.32 | 1.000000 38 | 1991 | -1.3 | -1.31 | 1.000000 38 | 1992 | -1.29 | -1.3 | 1.000000 38 | 1993 | -1.28 | -1.29 | 1.000000 38 | 1994 | -1.27 | -1.28 | 1.000000 38 | 1995 | -1.26 | -1.27 | 1.000000 38 | 1996 | -1.25 | -1.26 | 1.000000 38 | 1997 | -1.24 | -1.25 | 1.000000 38 | 1998 | -1.23 | -1.24 | 1.000000 38 | 1999 | -1.22 | -1.23 | 1.000000 38 | 2000 | -1.21 | -1.22 | 1.000000 39 | 1991 | -1.2 | -1.21 | 1.000000 39 | 1992 | -1.19 | -1.2 | 1.000000 39 | 1993 | -1.18 | -1.19 | 1.000000 39 | 1994 | -1.17 | -1.18 | 1.000000 39 | 1995 | -1.16 | -1.17 | 1.000000 39 | 1996 | -1.15 | -1.16 | 1.000000 39 | 1997 | -1.14 | -1.15 | 1.000000 39 | 1998 | -1.13 | -1.14 | 1.000000 39 | 1999 | -1.12 | -1.13 | 1.000000 39 | 2000 | -1.11 | -1.12 | 1.000000 40 | 1991 | -1.1 | -1.11 | 1.000000 40 | 1992 | -1.09 | -1.1 | 1.000000 40 | 1993 | -1.08 | -1.09 | 1.000000 40 | 1994 | -1.07 | -1.08 | 1.000000 40 | 1995 | -1.06 | -1.07 | 1.000000 40 | 1996 | -1.05 | -1.06 | 1.000000 40 | 1997 | -1.04 | -1.05 | 1.000000 40 | 1998 | -1.03 | -1.04 | 1.000000 40 | 1999 | -1.02 | -1.03 | 1.000000 40 | 2000 | -1.01 | -1.02 | 1.000000 41 | 1991 | -1 | -1.01 | 1.000000 41 | 1992 | -0.99 | -1 | 1.000000 41 | 1993 | -0.98 | -0.99 | 1.000000 41 | 1994 | -0.97 | -0.98 | 1.000000 41 | 1995 | -0.96 | -0.97 | 1.000000 41 | 1996 | -0.95 | -0.96 | 1.000000 41 | 1997 | -0.94 | -0.95 | 1.000000 41 | 1998 | -0.93 | -0.94 | 1.000000 41 | 1999 | -0.92 | -0.93 | 1.000000 41 | 2000 | -0.91 | -0.92 | 1.000000 42 | 1991 | -0.9 | -0.91 | 1.000000 42 | 1992 | -0.89 | -0.9 | 1.000000 42 | 1993 | -0.88 | -0.89 | 1.000000 42 | 1994 | -0.87 | -0.88 | 1.000000 42 | 1995 | -0.86 | -0.87 | 1.000000 42 | 1996 | -0.85 | -0.86 | 1.000000 42 | 1997 | -0.84 | -0.85 | 1.000000 42 | 1998 | -0.83 | -0.84 | 1.000000 42 | 1999 | -0.82 | -0.83 | 1.000000 42 | 2000 | -0.81 | -0.82 | 1.000000 43 | 1991 | -0.8 | -0.81 | 1.000000 43 | 1992 | -0.79 | -0.8 | 1.000000 43 | 1993 | -0.78 | -0.79 | 1.000000 43 | 1994 | -0.77 | -0.78 | 1.000000 43 | 1995 | -0.76 | -0.77 | 1.000000 43 | 1996 | -0.75 | -0.76 | 1.000000 43 | 1997 | -0.74 | -0.75 | 1.000000 43 | 1998 | -0.73 | -0.74 | 1.000000 43 | 1999 | -0.72 | -0.73 | 1.000000 43 | 2000 | -0.71 | -0.72 | 1.000000 44 | 1991 | -0.7 | -0.71 | 1.000000 44 | 1992 | -0.69 | -0.7 | 1.000000 44 | 1993 | -0.68 | -0.69 | 1.000000 44 | 1994 | -0.67 | -0.68 | 1.000000 44 | 1995 | -0.66 | -0.67 | 1.000000 44 | 1996 | -0.65 | -0.66 | 1.000000 44 | 1997 | -0.64 | -0.65 | 1.000000 44 | 1998 | -0.63 | -0.64 | 1.000000 44 | 1999 | -0.62 | -0.63 | 1.000000 44 | 2000 | -0.61 | -0.62 | 1.000000 45 | 1991 | -0.6 | -0.61 | 1.000000 45 | 1992 | -0.59 | -0.6 | 1.000000 45 | 1993 | -0.58 | -0.59 | 1.000000 45 | 1994 | -0.57 | -0.58 | 1.000000 45 | 1995 | -0.56 | -0.57 | 1.000000 45 | 1996 | -0.55 | -0.56 | 1.000000 45 | 1997 | -0.54 | -0.55 | 1.000000 45 | 1998 | -0.53 | -0.54 | 1.000000 45 | 1999 | -0.52 | -0.53 | 1.000000 45 | 2000 | -0.51 | -0.52 | 1.000000 46 | 1991 | -0.5 | -0.51 | 1.000000 46 | 1992 | -0.49 | -0.5 | 1.000000 46 | 1993 | -0.48 | -0.49 | 1.000000 46 | 1994 | -0.47 | -0.48 | 1.000000 46 | 1995 | -0.46 | -0.47 | 1.000000 46 | 1996 | -0.45 | -0.46 | 1.000000 46 | 1997 | -0.44 | -0.45 | 1.000000 46 | 1998 | -0.43 | -0.44 | 1.000000 46 | 1999 | -0.42 | -0.43 | 1.000000 46 | 2000 | -0.41 | -0.42 | 1.000000 47 | 1991 | -0.4 | -0.41 | 1.000000 47 | 1992 | -0.39 | -0.4 | 1.000000 47 | 1993 | -0.38 | -0.39 | 1.000000 47 | 1994 | -0.37 | -0.38 | 1.000000 47 | 1995 | -0.36 | -0.37 | 1.000000 47 | 1996 | -0.35 | -0.36 | 1.000000 47 | 1997 | -0.34 | -0.35 | 1.000000 47 | 1998 | -0.33 | -0.34 | 1.000000 47 | 1999 | -0.32 | -0.33 | 1.000000 47 | 2000 | -0.31 | -0.32 | 1.000000 48 | 1991 | -0.3 | -0.31 | 1.000000 48 | 1992 | -0.29 | -0.3 | 1.000000 48 | 1993 | -0.28 | -0.29 | 1.000000 48 | 1994 | -0.27 | -0.28 | 1.000000 48 | 1995 | -0.26 | -0.27 | 1.000000 48 | 1996 | -0.25 | -0.26 | 1.000000 48 | 1997 | -0.24 | -0.25 | 1.000000 48 | 1998 | -0.23 | -0.24 | 1.000000 48 | 1999 | -0.22 | -0.23 | 1.000000 48 | 2000 | -0.21 | -0.22 | 1.000000 49 | 1991 | -0.2 | -0.21 | 1.000000 49 | 1992 | -0.19 | -0.2 | 1.000000 49 | 1993 | -0.18 | -0.19 | 1.000000 49 | 1994 | -0.17 | -0.18 | 1.000000 49 | 1995 | -0.16 | -0.17 | 1.000000 49 | 1996 | -0.15 | -0.16 | 1.000000 49 | 1997 | -0.14 | -0.15 | 1.000000 49 | 1998 | -0.13 | -0.14 | 1.000000 49 | 1999 | -0.12 | -0.13 | 1.000000 49 | 2000 | -0.11 | -0.12 | 1.000000 50 | 1991 | -0.1 | -0.11 | 1.000000 50 | 1992 | -0.09 | -0.1 | 1.000000 50 | 1993 | -0.08 | -0.09 | 1.000000 50 | 1994 | -0.07 | -0.08 | 1.000000 50 | 1995 | -0.06 | -0.07 | 1.000000 50 | 1996 | -0.05 | -0.06 | 1.000000 50 | 1997 | -0.04 | -0.05 | 1.000000 50 | 1998 | -0.03 | -0.04 | 1.000000 50 | 1999 | -0.02 | -0.03 | 1.000000 50 | 2000 | -0.01 | -0.02 | 1.000000 50 | 2001 | 0 | -0.01 | 1.000000 50 | 2002 | 0.01 | 0 | 1.000000 50 | 2003 | 0.02 | 0.01 | 1.000000 50 | 2004 | 0.03 | 0.02 | 1.000000 50 | 2005 | 0.04 | 0.03 | 1.000000 50 | 2006 | 0.05 | 0.04 | 1.000000 50 | 2007 | 0.06 | 0.05 | 1.000000 50 | 2008 | 0.07 | 0.06 | 1.000000 50 | 2009 | 0.08 | 0.07 | 1.000000 51 | 2000 | 0.09 | 0.08 | 1.000000 51 | 2001 | 0.1 | 0.09 | 1.000000 51 | 2002 | 0.11 | 0.1 | 1.000000 51 | 2003 | 0.12 | 0.11 | 1.000000 51 | 2004 | 0.13 | 0.12 | 1.000000 51 | 2005 | 0.14 | 0.13 | 1.000000 51 | 2006 | 0.15 | 0.14 | 1.000000 51 | 2007 | 0.16 | 0.15 | 1.000000 51 | 2008 | 0.17 | 0.16 | 1.000000 51 | 2009 | 0.18 | 0.17 | 1.000000 52 | 2000 | 0.19 | 0.18 | 1.000000 52 | 2001 | 0.2 | 0.19 | 1.000000 52 | 2002 | 0.21 | 0.2 | 1.000000 52 | 2003 | 0.22 | 0.21 | 1.000000 52 | 2004 | 0.23 | 0.22 | 1.000000 52 | 2005 | 0.24 | 0.23 | 1.000000 52 | 2006 | 0.25 | 0.24 | 1.000000 52 | 2007 | 0.26 | 0.25 | 1.000000 52 | 2008 | 0.27 | 0.26 | 1.000000 52 | 2009 | 0.28 | 0.27 | 1.000000 53 | 2000 | 0.29 | 0.28 | 1.000000 53 | 2001 | 0.3 | 0.29 | 1.000000 53 | 2002 | 0.31 | 0.3 | 1.000000 53 | 2003 | 0.32 | 0.31 | 1.000000 53 | 2004 | 0.33 | 0.32 | 1.000000 53 | 2005 | 0.34 | 0.33 | 1.000000 53 | 2006 | 0.35 | 0.34 | 1.000000 53 | 2007 | 0.36 | 0.35 | 1.000000 53 | 2008 | 0.37 | 0.36 | 1.000000 53 | 2009 | 0.38 | 0.37 | 1.000000 54 | 2000 | 0.39 | 0.38 | 1.000000 54 | 2001 | 0.4 | 0.39 | 1.000000 54 | 2002 | 0.41 | 0.4 | 1.000000 54 | 2003 | 0.42 | 0.41 | 1.000000 54 | 2004 | 0.43 | 0.42 | 1.000000 54 | 2005 | 0.44 | 0.43 | 1.000000 54 | 2006 | 0.45 | 0.44 | 1.000000 54 | 2007 | 0.46 | 0.45 | 1.000000 54 | 2008 | 0.47 | 0.46 | 1.000000 54 | 2009 | 0.48 | 0.47 | 1.000000 55 | 2000 | 0.49 | 0.48 | 1.000000 55 | 2001 | 0.5 | 0.49 | 1.000000 55 | 2002 | 0.51 | 0.5 | 1.000000 55 | 2003 | 0.52 | 0.51 | 1.000000 55 | 2004 | 0.53 | 0.52 | 1.000000 55 | 2005 | 0.54 | 0.53 | 1.000000 55 | 2006 | 0.55 | 0.54 | 1.000000 55 | 2007 | 0.56 | 0.55 | 1.000000 55 | 2008 | 0.57 | 0.56 | 1.000000 55 | 2009 | 0.58 | 0.57 | 1.000000 56 | 2000 | 0.59 | 0.58 | 1.000000 56 | 2001 | 0.6 | 0.59 | 1.000000 56 | 2002 | 0.61 | 0.6 | 1.000000 56 | 2003 | 0.62 | 0.61 | 1.000000 56 | 2004 | 0.63 | 0.62 | 1.000000 56 | 2005 | 0.64 | 0.63 | 1.000000 56 | 2006 | 0.65 | 0.64 | 1.000000 56 | 2007 | 0.66 | 0.65 | 1.000000 56 | 2008 | 0.67 | 0.66 | 1.000000 56 | 2009 | 0.68 | 0.67 | 1.000000 57 | 2000 | 0.69 | 0.68 | 1.000000 57 | 2001 | 0.7 | 0.69 | 1.000000 57 | 2002 | 0.71 | 0.7 | 1.000000 57 | 2003 | 0.72 | 0.71 | 1.000000 57 | 2004 | 0.73 | 0.72 | 1.000000 57 | 2005 | 0.74 | 0.73 | 1.000000 57 | 2006 | 0.75 | 0.74 | 1.000000 57 | 2007 | 0.76 | 0.75 | 1.000000 57 | 2008 | 0.77 | 0.76 | 1.000000 57 | 2009 | 0.78 | 0.77 | 1.000000 58 | 2000 | 0.79 | 0.78 | 1.000000 58 | 2001 | 0.8 | 0.79 | 1.000000 58 | 2002 | 0.81 | 0.8 | 1.000000 58 | 2003 | 0.82 | 0.81 | 1.000000 58 | 2004 | 0.83 | 0.82 | 1.000000 58 | 2005 | 0.84 | 0.83 | 1.000000 58 | 2006 | 0.85 | 0.84 | 1.000000 58 | 2007 | 0.86 | 0.85 | 1.000000 58 | 2008 | 0.87 | 0.86 | 1.000000 58 | 2009 | 0.88 | 0.87 | 1.000000 59 | 2000 | 0.89 | 0.88 | 1.000000 59 | 2001 | 0.9 | 0.89 | 1.000000 59 | 2002 | 0.91 | 0.9 | 1.000000 59 | 2003 | 0.92 | 0.91 | 1.000000 59 | 2004 | 0.93 | 0.92 | 1.000000 59 | 2005 | 0.94 | 0.93 | 1.000000 59 | 2006 | 0.95 | 0.94 | 1.000000 59 | 2007 | 0.96 | 0.95 | 1.000000 59 | 2008 | 0.97 | 0.96 | 1.000000 59 | 2009 | 0.98 | 0.97 | 1.000000 60 | 2000 | 0.99 | 0.98 | 1.000000 60 | 2001 | 1 | 0.99 | 1.000000 60 | 2002 | 1.01 | 1 | 1.000000 60 | 2003 | 1.02 | 1.01 | 1.000000 60 | 2004 | 1.03 | 1.02 | 1.000000 60 | 2005 | 1.04 | 1.03 | 1.000000 60 | 2006 | 1.05 | 1.04 | 1.000000 60 | 2007 | 1.06 | 1.05 | 1.000000 60 | 2008 | 1.07 | 1.06 | 1.000000 60 | 2009 | 1.08 | 1.07 | 1.000000 61 | 2000 | 1.09 | 1.08 | 1.000000 61 | 2001 | 1.1 | 1.09 | 1.000000 61 | 2002 | 1.11 | 1.1 | 1.000000 61 | 2003 | 1.12 | 1.11 | 1.000000 61 | 2004 | 1.13 | 1.12 | 1.000000 61 | 2005 | 1.14 | 1.13 | 1.000000 61 | 2006 | 1.15 | 1.14 | 1.000000 61 | 2007 | 1.16 | 1.15 | 1.000000 61 | 2008 | 1.17 | 1.16 | 1.000000 61 | 2009 | 1.18 | 1.17 | 1.000000 62 | 2000 | 1.19 | 1.18 | 1.000000 62 | 2001 | 1.2 | 1.19 | 1.000000 62 | 2002 | 1.21 | 1.2 | 1.000000 62 | 2003 | 1.22 | 1.21 | 1.000000 62 | 2004 | 1.23 | 1.22 | 1.000000 62 | 2005 | 1.24 | 1.23 | 1.000000 62 | 2006 | 1.25 | 1.24 | 1.000000 62 | 2007 | 1.26 | 1.25 | 1.000000 62 | 2008 | 1.27 | 1.26 | 1.000000 62 | 2009 | 1.28 | 1.27 | 1.000000 63 | 2000 | 1.29 | 1.28 | 1.000000 63 | 2001 | 1.3 | 1.29 | 1.000000 63 | 2002 | 1.31 | 1.3 | 1.000000 63 | 2003 | 1.32 | 1.31 | 1.000000 63 | 2004 | 1.33 | 1.32 | 1.000000 63 | 2005 | 1.34 | 1.33 | 1.000000 63 | 2006 | 1.35 | 1.34 | 1.000000 63 | 2007 | 1.36 | 1.35 | 1.000000 63 | 2008 | 1.37 | 1.36 | 1.000000 63 | 2009 | 1.38 | 1.37 | 1.000000 64 | 2000 | 1.39 | 1.38 | 1.000000 64 | 2001 | 1.4 | 1.39 | 1.000000 64 | 2002 | 1.41 | 1.4 | 1.000000 64 | 2003 | 1.42 | 1.41 | 1.000000 64 | 2004 | 1.43 | 1.42 | 1.000000 64 | 2005 | 1.44 | 1.43 | 1.000000 64 | 2006 | 1.45 | 1.44 | 1.000000 64 | 2007 | 1.46 | 1.45 | 1.000000 64 | 2008 | 1.47 | 1.46 | 1.000000 64 | 2009 | 1.48 | 1.47 | 1.000000 65 | 2000 | 1.49 | 1.48 | 1.000000 65 | 2001 | 1.5 | 1.49 | 1.000000 65 | 2002 | 1.51 | 1.5 | 1.000000 65 | 2003 | 1.52 | 1.51 | 1.000000 65 | 2004 | 1.53 | 1.52 | 1.000000 65 | 2005 | 1.54 | 1.53 | 1.000000 65 | 2006 | 1.55 | 1.54 | 1.000000 65 | 2007 | 1.56 | 1.55 | 1.000000 65 | 2008 | 1.57 | 1.56 | 1.000000 65 | 2009 | 1.58 | 1.57 | 1.000000 66 | 2000 | 1.59 | 1.58 | 1.000000 66 | 2001 | 1.6 | 1.59 | 1.000000 66 | 2002 | 1.61 | 1.6 | 1.000000 66 | 2003 | 1.62 | 1.61 | 1.000000 66 | 2004 | 1.63 | 1.62 | 1.000000 66 | 2005 | 1.64 | 1.63 | 1.000000 66 | 2006 | 1.65 | 1.64 | 1.000000 66 | 2007 | 1.66 | 1.65 | 1.000000 66 | 2008 | 1.67 | 1.66 | 1.000000 66 | 2009 | 1.68 | 1.67 | 1.000000 67 | 2000 | 1.69 | 1.68 | 1.000000 67 | 2001 | 1.7 | 1.69 | 1.000000 67 | 2002 | 1.71 | 1.7 | 1.000000 67 | 2003 | 1.72 | 1.71 | 1.000000 67 | 2004 | 1.73 | 1.72 | 1.000000 67 | 2005 | 1.74 | 1.73 | 1.000000 67 | 2006 | 1.75 | 1.74 | 1.000000 67 | 2007 | 1.76 | 1.75 | 1.000000 67 | 2008 | 1.77 | 1.76 | 1.000000 67 | 2009 | 1.78 | 1.77 | 1.000000 68 | 2000 | 1.79 | 1.78 | 1.000000 68 | 2001 | 1.8 | 1.79 | 1.000000 68 | 2002 | 1.81 | 1.8 | 1.000000 68 | 2003 | 1.82 | 1.81 | 1.000000 68 | 2004 | 1.83 | 1.82 | 1.000000 68 | 2005 | 1.84 | 1.83 | 1.000000 68 | 2006 | 1.85 | 1.84 | 1.000000 68 | 2007 | 1.86 | 1.85 | 1.000000 68 | 2008 | 1.87 | 1.86 | 1.000000 68 | 2009 | 1.88 | 1.87 | 1.000000 69 | 2000 | 1.89 | 1.88 | 1.000000 69 | 2001 | 1.9 | 1.89 | 1.000000 69 | 2002 | 1.91 | 1.9 | 1.000000 69 | 2003 | 1.92 | 1.91 | 1.000000 69 | 2004 | 1.93 | 1.92 | 1.000000 69 | 2005 | 1.94 | 1.93 | 1.000000 69 | 2006 | 1.95 | 1.94 | 1.000000 69 | 2007 | 1.96 | 1.95 | 1.000000 69 | 2008 | 1.97 | 1.96 | 1.000000 69 | 2009 | 1.98 | 1.97 | 1.000000 70 | 2000 | 1.99 | 1.98 | 1.000000 (400 rows) plr-REL8_3_0_17/pg_backend_support.c000077500000000000000000000257701277274236600174060ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * pg_backend_support.c - Postgres backend support functions */ #include "plr.h" #ifdef PGDLLIMPORT /* Postgres global */ extern PGDLLIMPORT char my_exec_path[]; #else /* Postgres global */ extern DLLIMPORT char my_exec_path[]; #endif /* PGDLLIMPORT */ /* compiled function hash table */ extern HTAB *plr_HashTable; /* caller's memory context */ extern MemoryContext plr_caller_context; /* * static declarations */ static char *get_lib_pathstr(Oid funcid); static char *expand_dynamic_library_name(const char *name); static char *substitute_libpath_macro(const char *name); static char *find_in_dynamic_libpath(const char *basename); static bool file_exists(const char *name); /* * Compute the hashkey for a given function invocation * * The hashkey is returned into the caller-provided storage at *hashkey. */ void compute_function_hashkey(FunctionCallInfo fcinfo, Form_pg_proc procStruct, plr_func_hashkey *hashkey) { int i; /* Make sure any unused bytes of the struct are zero */ MemSet(hashkey, 0, sizeof(plr_func_hashkey)); /* get function OID */ hashkey->funcOid = fcinfo->flinfo->fn_oid; /* if trigger, get relation OID */ if (CALLED_AS_TRIGGER(fcinfo)) { TriggerData *trigdata = (TriggerData *) fcinfo->context; hashkey->trigrelOid = RelationGetRelid(trigdata->tg_relation); } /* get the argument types */ for (i = 0; i < procStruct->pronargs; i++) { Oid argtypeid = PROARGTYPES(i); /* * Check for polymorphic arguments. If found, use the actual * parameter type from the caller's FuncExpr node, if we have one. * * We can support arguments of type ANY the same way as normal * polymorphic arguments. */ if (argtypeid == ANYARRAYOID || argtypeid == ANYELEMENTOID || argtypeid == ANYOID) { argtypeid = get_fn_expr_argtype(fcinfo->flinfo, i); if (!OidIsValid(argtypeid)) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("could not determine actual argument " "type for polymorphic function \"%s\"", NameStr(procStruct->proname)))); } hashkey->argtypes[i] = argtypeid; } } void plr_HashTableInit(void) { HASHCTL ctl; memset(&ctl, 0, sizeof(ctl)); ctl.keysize = sizeof(plr_func_hashkey); ctl.entrysize = sizeof(plr_HashEnt); ctl.hash = tag_hash; plr_HashTable = hash_create("PLR function cache", FUNCS_PER_USER, &ctl, HASH_ELEM | HASH_FUNCTION); } plr_function * plr_HashTableLookup(plr_func_hashkey *func_key) { plr_HashEnt *hentry; hentry = (plr_HashEnt*) hash_search(plr_HashTable, (void *) func_key, HASH_FIND, NULL); if (hentry) return hentry->function; else return (plr_function *) NULL; } void plr_HashTableInsert(plr_function *function, plr_func_hashkey *func_key) { plr_HashEnt *hentry; bool found; hentry = (plr_HashEnt*) hash_search(plr_HashTable, (void *) func_key, HASH_ENTER, &found); if (hentry == NULL) ereport(ERROR, (errcode(ERRCODE_OUT_OF_MEMORY), errmsg("out of memory"))); if (found) elog(WARNING, "trying to insert a function that exists"); hentry->function = function; /* prepare back link from function to hashtable key */ function->fn_hashkey = &hentry->key; } void plr_HashTableDelete(plr_function *function) { plr_HashEnt *hentry; hentry = (plr_HashEnt*) hash_search(plr_HashTable, (void *) function->fn_hashkey, HASH_REMOVE, NULL); if (hentry == NULL) elog(WARNING, "trying to delete function that does not exist"); } static char * get_lib_pathstr(Oid funcid) { HeapTuple procedureTuple; Form_pg_proc procedureStruct; Oid language; HeapTuple languageTuple; Form_pg_language languageStruct; Oid lang_funcid; Datum tmp; bool isnull; char *raw_path; char *cooked_path; /* get the pg_proc entry */ procedureTuple = SearchSysCache(PROCOID, ObjectIdGetDatum(funcid), 0, 0, 0); if (!HeapTupleIsValid(procedureTuple)) /* internal error */ elog(ERROR, "cache lookup failed for function %u", funcid); procedureStruct = (Form_pg_proc) GETSTRUCT(procedureTuple); /* now get the pg_language entry */ language = procedureStruct->prolang; ReleaseSysCache(procedureTuple); languageTuple = SearchSysCache(LANGOID, ObjectIdGetDatum(language), 0, 0, 0); if (!HeapTupleIsValid(languageTuple)) /* internal error */ elog(ERROR, "cache lookup failed for language %u", language); languageStruct = (Form_pg_language) GETSTRUCT(languageTuple); lang_funcid = languageStruct->lanplcallfoid; ReleaseSysCache(languageTuple); /* finally, get the pg_proc entry for the language handler */ procedureTuple = SearchSysCache(PROCOID, ObjectIdGetDatum(lang_funcid), 0, 0, 0); if (!HeapTupleIsValid(procedureTuple)) /* internal error */ elog(ERROR, "cache lookup failed for function %u", lang_funcid); procedureStruct = (Form_pg_proc) GETSTRUCT(procedureTuple); tmp = SysCacheGetAttr(PROCOID, procedureTuple, Anum_pg_proc_probin, &isnull); raw_path = DatumGetCString(DirectFunctionCall1(byteaout, tmp)); #if PG_VERSION_NUM >= 80500 /* Recognize hex input */ if (raw_path[0] == '\\' && raw_path[1] == 'x') { char *result; int bc; size_t len = strlen(raw_path); bc = (len - 2)/2 + 1; /* maximum possible length */ result = palloc0(bc); bc = hex_decode(raw_path + 2, len - 2, result); cooked_path = expand_dynamic_library_name(result); } else cooked_path = expand_dynamic_library_name(raw_path); #else cooked_path = expand_dynamic_library_name(raw_path); #endif if (!cooked_path) cooked_path = pstrdup(raw_path); ReleaseSysCache(procedureTuple); return cooked_path; } char * get_load_self_ref_cmd(Oid funcid) { char *libstr = get_lib_pathstr(funcid); char *buf = NULL; if (libstr) buf = (char *) palloc(strlen(libstr) + 12 + 1); else ereport(ERROR, (errcode_for_file_access(), errmsg("could not find path to PL/R shared library"))); sprintf(buf, "dyn.load(\"%s\")", libstr); return buf; } void perm_fmgr_info(Oid functionId, FmgrInfo *finfo) { fmgr_info_cxt(functionId, finfo, TopMemoryContext); INIT_AUX_FMGR_ATTS; } static bool file_exists(const char *name) { struct stat st; AssertArg(name != NULL); if (stat(name, &st) == 0) return S_ISDIR(st.st_mode) ? false : true; else if (!(errno == ENOENT || errno == ENOTDIR || errno == EACCES)) ereport(ERROR, (errcode_for_file_access(), errmsg("could not access file \"%s\": %m", name))); return false; } #ifndef DLSUFFIX #error "DLSUFFIX must be defined to compile this file." #endif /* * If name contains a slash, check if the file exists, if so return * the name. Else (no slash) try to expand using search path (see * find_in_dynamic_libpath below); if that works, return the fully * expanded file name. If the previous failed, append DLSUFFIX and * try again. If all fails, return NULL. * * A non-NULL result will always be freshly palloc'd. */ static char * expand_dynamic_library_name(const char *name) { bool have_slash; char *new; char *full; AssertArg(name); have_slash = (strchr(name, '/') != NULL); if (!have_slash) { full = find_in_dynamic_libpath(name); if (full) return full; } else { full = substitute_libpath_macro(name); if (file_exists(full)) return full; pfree(full); } new = palloc(strlen(name) + strlen(DLSUFFIX) + 1); strcpy(new, name); strcat(new, DLSUFFIX); if (!have_slash) { full = find_in_dynamic_libpath(new); pfree(new); if (full) return full; } else { full = substitute_libpath_macro(new); pfree(new); if (file_exists(full)) return full; pfree(full); } return NULL; } /* * Substitute for any macros appearing in the given string. * Result is always freshly palloc'd. */ static char * substitute_libpath_macro(const char *name) { const char *sep_ptr; char *ret; char pkglib_path[MAXPGPATH]; AssertArg(name != NULL); get_pkglib_path(my_exec_path, pkglib_path); if (name[0] != '$') return pstrdup(name); if ((sep_ptr = first_dir_separator(name)) == NULL) sep_ptr = name + strlen(name); if (strlen("$libdir") != sep_ptr - name || strncmp(name, "$libdir", strlen("$libdir")) != 0) ereport(ERROR, (errcode(ERRCODE_INVALID_NAME), errmsg("invalid macro name in dynamic library path: %s", name))); ret = palloc(strlen(pkglib_path) + strlen(sep_ptr) + 1); strcpy(ret, pkglib_path); strcat(ret, sep_ptr); return ret; } /* * Search for a file called 'basename' in the colon-separated search * path Dynamic_library_path. If the file is found, the full file name * is returned in freshly palloc'd memory. If the file is not found, * return NULL. */ static char * find_in_dynamic_libpath(const char *basename) { const char *p; size_t baselen; char *Dynamic_library_path = GetConfigOptionByName("dynamic_library_path", NULL #if PG_VERSION_NUM >= 90600 , false #endif ); AssertArg(basename != NULL); AssertArg(strchr(basename, '/') == NULL); AssertState(Dynamic_library_path != NULL); p = Dynamic_library_path; if (strlen(p) == 0) return NULL; baselen = strlen(basename); for (;;) { size_t len; char *piece; char *mangled; char *full; len = strcspn(p, ":"); if (len == 0) ereport(ERROR, (errcode(ERRCODE_INVALID_NAME), errmsg("zero-length component in DYNAMIC_LIBRARY_PATH"))); piece = palloc(len + 1); strncpy(piece, p, len); piece[len] = '\0'; mangled = substitute_libpath_macro(piece); pfree(piece); /* only absolute paths */ if (mangled[0] != '/') ereport(ERROR, (errcode(ERRCODE_INVALID_NAME), errmsg("DYNAMIC_LIBRARY_PATH component is not absolute"))); full = palloc(strlen(mangled) + 1 + baselen + 1); sprintf(full, "%s/%s", mangled, basename); pfree(mangled); elog(DEBUG2, "find_in_dynamic_libpath: trying %s", full); if (file_exists(full)) return full; pfree(full); if (p[len] == '\0') break; else p += len + 1; } return NULL; } plr-REL8_3_0_17/pg_conversion.c000077500000000000000000001344011277274236600164000ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * pg_conversion.c - functions for converting arguments from pg types to * R types, and for converting return values from R types * to pg types */ #include "plr.h" static void pg_get_one_r(char *value, Oid arg_out_fn_oid, SEXP *obj, int elnum); static SEXP get_r_vector(Oid typtype, int numels); static Datum get_trigger_tuple(SEXP rval, plr_function *function, FunctionCallInfo fcinfo, bool *isnull); static Datum get_tuplestore(SEXP rval, plr_function *function, FunctionCallInfo fcinfo, bool *isnull); static Datum get_simple_array_datum(SEXP rval, Oid typelem, bool *isnull); static Datum get_array_datum(SEXP rval, plr_function *function, int col, bool *isnull); static Datum get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull); static Datum get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *isnull); static Datum get_generic_array_datum(SEXP rval, plr_function *function, int col, bool *isnull); static Tuplestorestate *get_frame_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset); static Tuplestorestate *get_matrix_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset); static Tuplestorestate *get_generic_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset); static SEXP coerce_to_char(SEXP rval); extern char *last_R_error_msg; /* * given a scalar pg value, convert to a one row R vector */ SEXP pg_scalar_get_r(Datum dvalue, Oid arg_typid, FmgrInfo arg_out_func) { SEXP result; /* add our value to it */ if (arg_typid != BYTEAOID) { char *value; value = DatumGetCString(FunctionCall3(&arg_out_func, dvalue, (Datum) 0, Int32GetDatum(-1))); /* get new vector of the appropriate type, length 1 */ PROTECT(result = get_r_vector(arg_typid, 1)); pg_get_one_r(value, arg_typid, &result, 0); UNPROTECT(1); } else { SEXP s, t, obj; int status; Datum dt_dvalue = PointerGetDatum(PG_DETOAST_DATUM(dvalue)); int bsize = VARSIZE((bytea *) dt_dvalue); PROTECT(obj = get_r_vector(arg_typid, bsize)); memcpy((char *) RAW(obj), VARDATA((bytea *) dt_dvalue), bsize); /* * Need to construct a call to * unserialize(rval) */ PROTECT(t = s = allocList(2)); SET_TYPEOF(s, LANGSXP); SETCAR(t, install("unserialize")); t = CDR(t); SETCAR(t, obj); PROTECT(result = R_tryEval(s, R_GlobalEnv, &status)); if(status != 0) { if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("R expression evaluation error caught in \"unserialize\"."))); } UNPROTECT(3); } return result; } /* * Given an array pg value, convert to a multi-row R vector. */ SEXP pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char typalign) { /* * Loop through and convert each scalar value. * Use the converted values to build an R vector. */ SEXP result; ArrayType *v; Oid element_type; int i, j, k, nitems, nr = 1, nc = 1, nz = 1, ndim, *dim; int elem_idx = 0; Datum *elem_values; bool *elem_nulls; bool fast_track_type; /* short-circuit for NULL datums */ if (dvalue == (Datum) NULL) return R_NilValue; v = DatumGetArrayTypeP(dvalue); ndim = ARR_NDIM(v); element_type = ARR_ELEMTYPE(v); dim = ARR_DIMS(v); nitems = ArrayGetNItems(ARR_NDIM(v), ARR_DIMS(v)); switch (element_type) { case INT4OID: case FLOAT8OID: fast_track_type = true; break; default: fast_track_type = false; } /* * Special case for pass-by-value data types, if the following conditions are met: * designated fast_track_type * no NULL elements * 1 dimensional array only * at least one element */ if (fast_track_type && typbyval && !ARR_HASNULL(v) && (ndim == 1) && (nitems > 0)) { char *p = ARR_DATA_PTR(v); /* get new vector of the appropriate type and length */ PROTECT(result = get_r_vector(element_type, nitems)); /* keep this in sync with switch above -- fast_track_type only */ switch (element_type) { case INT4OID: Assert(sizeof(int) == 4); memcpy(INTEGER_DATA(result), p, nitems * sizeof(int)); break; case FLOAT8OID: Assert(sizeof(double) == 8); memcpy(NUMERIC_DATA(result), p, nitems * sizeof(double)); break; default: /* Everything else is error */ ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("direct array passthrough attempted for unsupported type"))); } if (ndim > 1) { SEXP matrix_dims; /* attach dimensions */ PROTECT(matrix_dims = allocVector(INTSXP, ndim)); for (i = 0; i < ndim; i++) INTEGER_DATA(matrix_dims)[i] = dim[i]; setAttrib(result, R_DimSymbol, matrix_dims); UNPROTECT(1); } UNPROTECT(1); /* result */ } else { deconstruct_array(v, element_type, typlen, typbyval, typalign, &elem_values, &elem_nulls, &nitems); /* array is empty */ if (nitems == 0) { PROTECT(result = get_r_vector(element_type, nitems)); UNPROTECT(1); return result; } if (ndim == 1) nr = nitems; else if (ndim == 2) { nr = dim[0]; nc = dim[1]; } else if (ndim == 3) { nr = dim[0]; nc = dim[1]; nz = dim[2]; } else ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("greater than 3-dimensional arrays are not yet supported"))); /* get new vector of the appropriate type and length */ PROTECT(result = get_r_vector(element_type, nitems)); /* Convert all values to their R form and build the vector */ for (i = 0; i < nr; i++) { for (j = 0; j < nc; j++) { for (k = 0; k < nz; k++) { char *value; 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, (Datum) 0, Int32GetDatum(-1))); } else value = NULL; /* * Note that pg_get_one_r() replaces NULL values with * the NA value appropriate for the data type. */ pg_get_one_r(value, element_type, &result, idx); if (value != NULL) pfree(value); } } } pfree(elem_values); pfree(elem_nulls); if (ndim > 1) { SEXP matrix_dims; /* attach dimensions */ PROTECT(matrix_dims = allocVector(INTSXP, ndim)); for (i = 0; i < ndim; i++) INTEGER_DATA(matrix_dims)[i] = dim[i]; setAttrib(result, R_DimSymbol, matrix_dims); UNPROTECT(1); } UNPROTECT(1); /* result */ } return result; } /* * Given an array pg datums, convert to a multi-row R vector. */ SEXP pg_datum_array_get_r(Datum *elem_values, bool *elem_nulls, int numels, bool has_nulls, Oid element_type, FmgrInfo out_func, bool typbyval) { /* * Loop through and convert each scalar value. * Use the converted values to build an R vector. */ SEXP result; int i; bool fast_track_type; switch (element_type) { case INT4OID: case FLOAT8OID: fast_track_type = true; break; default: fast_track_type = false; } /* * Special case for pass-by-value data types, if the following conditions are met: * designated fast_track_type * no NULL elements * 1 dimensional array only * at least one element */ if (fast_track_type && typbyval && !has_nulls && (numels > 0)) { SEXP matrix_dims; /* get new vector of the appropriate type and length */ PROTECT(result = get_r_vector(element_type, numels)); /* keep this in sync with switch above -- fast_track_type only */ switch (element_type) { case INT4OID: Assert(sizeof(int) == 4); memcpy(INTEGER_DATA(result), elem_values, numels * sizeof(int)); break; case FLOAT8OID: Assert(sizeof(double) == 8); memcpy(NUMERIC_DATA(result), elem_values, numels * sizeof(double)); break; default: /* Everything else is error */ ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("direct array passthrough attempted for unsupported type"))); } /* attach dimensions */ PROTECT(matrix_dims = allocVector(INTSXP, 1)); INTEGER_DATA(matrix_dims)[0] = numels; setAttrib(result, R_DimSymbol, matrix_dims); UNPROTECT(1); UNPROTECT(1); /* result */ } else { SEXP matrix_dims; /* array is empty */ if (numels == 0) { PROTECT(result = get_r_vector(element_type, 0)); UNPROTECT(1); return result; } /* get new vector of the appropriate type and length */ PROTECT(result = get_r_vector(element_type, numels)); /* Convert all values to their R form and build the vector */ for (i = 0; i < numels; i++) { char *value; Datum itemvalue; bool isnull; isnull = elem_nulls[i]; itemvalue = elem_values[i]; if (!isnull) { value = DatumGetCString(FunctionCall3(&out_func, itemvalue, (Datum) 0, Int32GetDatum(-1))); } else value = NULL; /* * Note that pg_get_one_r() replaces NULL values with * the NA value appropriate for the data type. */ pg_get_one_r(value, element_type, &result, i); if (value != NULL) pfree(value); } /* attach dimensions */ PROTECT(matrix_dims = allocVector(INTSXP, 1)); INTEGER_DATA(matrix_dims)[0] = numels; setAttrib(result, R_DimSymbol, matrix_dims); UNPROTECT(1); UNPROTECT(1); /* result */ } return result; } /* * Given an array of pg tuples, convert to an R list * the created object is not quite actually a data.frame */ SEXP pg_tuple_get_r_frame(int ntuples, HeapTuple *tuples, TupleDesc tupdesc) { int nr = ntuples; int nc = tupdesc->natts; int nc_non_dropped = 0; int df_colnum = 0; int i = 0; int j = 0; Oid element_type; Oid typelem; SEXP names; SEXP row_names; char buf[256]; SEXP result; SEXP fldvec; if (tuples == NULL || ntuples < 1) return R_NilValue; /* Count non-dropped attributes so we can later ignore the dropped ones */ for (j = 0; j < nc; j++) { if (!tupdesc->attrs[j]->attisdropped) nc_non_dropped++; } /* * Allocate the data.frame initially as a list, * and also allocate a names vector for the column names */ PROTECT(result = NEW_LIST(nc_non_dropped)); PROTECT(names = NEW_CHARACTER(nc_non_dropped)); /* * Loop by columns */ for (j = 0; j < nc; j++) { int16 typlen; bool typbyval; char typdelim; Oid typoutput, typioparam; FmgrInfo outputproc; char typalign; /* ignore dropped attributes */ if (tupdesc->attrs[j]->attisdropped) continue; /* set column name */ SET_COLUMN_NAMES; /* get column datatype oid */ element_type = SPI_gettypeid(tupdesc, j + 1); /* * Check to see if it is an array type. get_element_type will return * InvalidOid instead of actual element type if the type is not a * varlena array. */ typelem = get_element_type(element_type); /* get new vector of the appropriate type and length */ if (typelem == InvalidOid) PROTECT(fldvec = get_r_vector(element_type, nr)); else { PROTECT(fldvec = NEW_LIST(nr)); get_type_io_data(typelem, IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typioparam, &typoutput); fmgr_info(typoutput, &outputproc); } /* loop rows for this column */ for (i = 0; i < nr; i++) { if (typelem == InvalidOid) { /* not an array type */ char *value; value = SPI_getvalue(tuples[i], tupdesc, j + 1); pg_get_one_r(value, element_type, &fldvec, i); } else { /* array type */ Datum dvalue; bool isnull; SEXP fldvec_elem; dvalue = SPI_getbinval(tuples[i], tupdesc, j + 1, &isnull); if (!isnull) PROTECT(fldvec_elem = pg_array_get_r(dvalue, outputproc, typlen, typbyval, typalign)); else PROTECT(fldvec_elem = R_NilValue); SET_VECTOR_ELT(fldvec, i, fldvec_elem); UNPROTECT(1); } } SET_VECTOR_ELT(result, df_colnum, fldvec); UNPROTECT(1); df_colnum++; } /* attach the column 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 use R INTEGER */ PROTECT(result = NEW_INTEGER(numels)); break; case INT8OID: case FLOAT4OID: case FLOAT8OID: case CASHOID: case NUMERICOID: /* * Other numeric types => use R REAL * Note pgsql int8 is mapped to R REAL * because R INTEGER is only 4 byte */ PROTECT(result = NEW_NUMERIC(numels)); break; case BOOLOID: PROTECT(result = NEW_LOGICAL(numels)); break; case BYTEAOID: PROTECT(result = NEW_RAW(numels)); break; default: /* Everything else is defaulted to string */ PROTECT(result = NEW_CHARACTER(numels)); } UNPROTECT(1); return result; } /* * given a single non-array pg value, convert to its R value representation */ static void pg_get_one_r(char *value, Oid typtype, SEXP *obj, int elnum) { switch (typtype) { case OIDOID: case INT2OID: case INT4OID: /* 2 and 4 byte integer pgsql datatype => use R INTEGER */ if (value) INTEGER_DATA(*obj)[elnum] = atoi(value); else INTEGER_DATA(*obj)[elnum] = NA_INTEGER; break; case INT8OID: case FLOAT4OID: case FLOAT8OID: case CASHOID: case NUMERICOID: /* * Other numeric types => use R REAL * Note pgsql int8 is mapped to R REAL * because R INTEGER is only 4 byte */ if (value) NUMERIC_DATA(*obj)[elnum] = atof(value); else NUMERIC_DATA(*obj)[elnum] = NA_REAL; break; case BOOLOID: if (value) LOGICAL_DATA(*obj)[elnum] = ((*value == 't') ? 1 : 0); else LOGICAL_DATA(*obj)[elnum] = NA_LOGICAL; break; default: /* Everything else is defaulted to string */ if (value) SET_STRING_ELT(*obj, elnum, COPY_TO_USER_STRING(value)); else SET_STRING_ELT(*obj, elnum, NA_STRING); } } /* * given an R value, convert to its pg representation */ Datum r_get_pg(SEXP rval, plr_function *function, FunctionCallInfo fcinfo) { bool isnull = false; Datum result; if (function->result_typid != BYTEAOID && (TYPEOF(rval) == CLOSXP || TYPEOF(rval) == PROMSXP || TYPEOF(rval) == LANGSXP || TYPEOF(rval) == ENVSXP)) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("incorrect function return type"), errdetail("R return value type cannot be mapped to PostgreSQL return type."), errhint("Try BYTEA as the PostgreSQL return type."))); if (CALLED_AS_TRIGGER(fcinfo)) result = get_trigger_tuple(rval, function, fcinfo, &isnull); else if (function->result_istuple || fcinfo->flinfo->fn_retset) result = get_tuplestore(rval, function, fcinfo, &isnull); else { /* short circuit if return value is Null */ if (rval == R_NilValue || isNull(rval)) /* probably redundant */ { fcinfo->isnull = true; return (Datum) 0; } if (function->result_elem == 0) result = get_scalar_datum(rval, function->result_typid, function->result_in_func, &isnull); else result = get_array_datum(rval, function, 0, &isnull); } if (isnull) fcinfo->isnull = true; return result; } /* * Similar to r_get_pg, given an R value, convert to its pg representation * Other than scalar, currently only prepared to be used with simple 1D vector */ Datum get_datum(SEXP rval, Oid typid, Oid typelem, FmgrInfo in_func, bool *isnull) { Datum result; /* short circuit if return value is Null */ if (rval == R_NilValue || isNull(rval)) /* probably redundant */ { *isnull = true; return (Datum) 0; } if (typelem == InvalidOid) result = get_scalar_datum(rval, typid, in_func, isnull); else result = get_simple_array_datum(rval, typelem, isnull); return result; } static Datum get_trigger_tuple(SEXP rval, plr_function *function, FunctionCallInfo fcinfo, bool *isnull) { TriggerData *trigdata = (TriggerData *) fcinfo->context; TupleDesc tupdesc = trigdata->tg_relation->rd_att; AttInMetadata *attinmeta; MemoryContext fn_mcxt; MemoryContext oldcontext; int nc; int nr; char **values; HeapTuple tuple = NULL; int i, j; int nc_dropped = 0; int df_colnum = 0; SEXP result; SEXP dfcol; /* short circuit statement level trigger which always returns NULL */ if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event)) { /* special for triggers, don't set isnull flag */ *isnull = false; return (Datum) 0; } /* short circuit if return value is Null */ if (rval == R_NilValue || isNull(rval)) /* probably redundant */ { /* special for triggers, don't set isnull flag */ *isnull = false; return (Datum) 0; } if (isFrame(rval)) nc = length(rval); else if (isMatrix(rval)) nc = ncols(rval); else nc = 1; PROTECT(dfcol = VECTOR_ELT(rval, 0)); nr = length(dfcol); UNPROTECT(1); if (nr != 1) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("incorrect function return type"), errdetail("function return value cannot have more " \ "than one row"))); /* * Count number of dropped attributes so we can add them back to * the return tuple */ for (j = 0; j < nc; j++) { if (tupdesc->attrs[j]->attisdropped) nc_dropped++; } /* * Check to make sure we have the same number of columns * to return as there are attributes in the return tuple. * Note that we have to account for the number of dropped * columns. * * Note we will attempt to coerce the R values into whatever * the return attribute type is and depend on the "in" * function to complain if needed. */ if (nc + nc_dropped != tupdesc->natts) ereport(ERROR, (errcode(ERRCODE_DATATYPE_MISMATCH), errmsg("returned tuple structure does not match table " \ "of trigger event"))); fn_mcxt = fcinfo->flinfo->fn_mcxt; oldcontext = MemoryContextSwitchTo(fn_mcxt); attinmeta = TupleDescGetAttInMetadata(tupdesc); /* coerce columns to character in advance */ PROTECT(result = NEW_LIST(nc)); for (j = 0; j < nc; j++) { PROTECT(dfcol = VECTOR_ELT(rval, j)); if(!isFactor(dfcol)) { SEXP obj; PROTECT(obj = coerce_to_char(dfcol)); SET_VECTOR_ELT(result, j, obj); UNPROTECT(1); } else { SEXP t; for (t = ATTRIB(dfcol); t != R_NilValue; t = CDR(t)) { if(TAG(t) == R_LevelsSymbol) { PROTECT(SETCAR(t, coerce_to_char(CAR(t)))); UNPROTECT(1); break; } } SET_VECTOR_ELT(result, j, dfcol); } UNPROTECT(1); } values = (char **) palloc((nc + nc_dropped) * sizeof(char *)); for(i = 0; i < nr; i++) { for (j = 0; j < nc + nc_dropped; j++) { /* insert NULL for dropped attributes */ if (tupdesc->attrs[j]->attisdropped) values[j] = NULL; else { PROTECT(dfcol = VECTOR_ELT(result, df_colnum)); if(isFactor(dfcol)) { SEXP t; for (t = ATTRIB(dfcol); t != R_NilValue; t = CDR(t)) { if(TAG(t) == R_LevelsSymbol) { SEXP obj; int idx = INTEGER(dfcol)[i] - 1; PROTECT(obj = CAR(t)); values[j] = pstrdup(CHAR(STRING_ELT(obj, idx))); UNPROTECT(1); break; } } } else { if (STRING_ELT(dfcol, 0) != NA_STRING) values[j] = pstrdup(CHAR(STRING_ELT(dfcol, i))); else values[j] = NULL; } UNPROTECT(1); df_colnum++; } } /* construct the tuple */ tuple = BuildTupleFromCStrings(attinmeta, values); for (j = 0; j < nc; j++) if (values[j] != NULL) pfree(values[j]); } UNPROTECT(1); MemoryContextSwitchTo(oldcontext); if (tuple) { *isnull = false; return PointerGetDatum(tuple); } else { /* special for triggers, don't set isnull flag */ *isnull = false; return (Datum) 0; } } static Datum get_tuplestore(SEXP rval, plr_function *function, FunctionCallInfo fcinfo, bool *isnull) { bool retset = fcinfo->flinfo->fn_retset; ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo; TupleDesc tupdesc; AttInMetadata *attinmeta; MemoryContext per_query_ctx; MemoryContext oldcontext; int nc; /* check to see if caller supports us returning a tuplestore */ if (!rsinfo || !(rsinfo->allowedModes & SFRM_Materialize)) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("materialize mode required, but it is not " "allowed in this context"))); if (isFrame(rval)) nc = length(rval); else if (isList(rval) || isNewList(rval)) nc = length(rval); else if (isMatrix(rval)) nc = ncols(rval); else nc = 1; per_query_ctx = rsinfo->econtext->ecxt_per_query_memory; oldcontext = MemoryContextSwitchTo(per_query_ctx); /* get the requested return tuple description */ tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc); /* * Check to make sure we have the same number of columns * to return as there are attributes in the return tuple. * * Note we will attempt to coerce the R values into whatever * the return attribute type is and depend on the "in" * function to complain if needed. */ if (nc != tupdesc->natts) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("query-specified return tuple and " "function returned data.frame are not compatible"))); attinmeta = TupleDescGetAttInMetadata(tupdesc); /* OK, go to work */ rsinfo->returnMode = SFRM_Materialize; if (isFrame(rval)) rsinfo->setResult = get_frame_tuplestore(rval, function, attinmeta, per_query_ctx, retset); else if (isList(rval) || isNewList(rval)) rsinfo->setResult = get_frame_tuplestore(rval, function, attinmeta, per_query_ctx, retset); else if (isMatrix(rval)) rsinfo->setResult = get_matrix_tuplestore(rval, function, attinmeta, per_query_ctx, retset); else rsinfo->setResult = get_generic_tuplestore(rval, function, attinmeta, per_query_ctx, retset); /* * SFRM_Materialize mode expects us to return a NULL Datum. The actual * tuples are in our tuplestore and passed back through * rsinfo->setResult. rsinfo->setDesc is set to the tuple description * that we actually used to build our tuples with, so the caller can * verify we did what it was expecting. */ rsinfo->setDesc = tupdesc; MemoryContextSwitchTo(oldcontext); *isnull = true; return (Datum) 0; } Datum get_scalar_datum(SEXP rval, Oid result_typid, FmgrInfo result_in_func, bool *isnull) { Datum dvalue; SEXP obj; const char *value=NULL; /* * Element type is zero, we don't have an array, so coerce to string * and take the first element as a scalar * * Exception: if result type is BYTEA, we want to return the whole * object in serialized form */ if (result_typid != BYTEAOID) { PROTECT(obj = coerce_to_char(rval)); /* * passing a null into something like * return as.real(NULL) will return numeric(0) * which has a length of 0 */ if ( (isNumeric(rval) && length(rval) == 0) || STRING_ELT(obj, 0) == NA_STRING) { UNPROTECT(1); *isnull = true; dvalue = (Datum) 0; return dvalue; } obj = STRING_ELT(obj, 0); if (TYPEOF(obj) == CHARSXP ) { value = CHAR(obj); } else { ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("return type cannot be coerced to char"))); } UNPROTECT(1); if (value != NULL) { dvalue = FunctionCall3(&result_in_func, CStringGetDatum(value), ObjectIdGetDatum(0), Int32GetDatum(-1)); } else { *isnull = true; dvalue = (Datum) 0; } } else { SEXP s, t; int len, rsize, status; bytea *result; char *rptr; /* * Need to construct a call to * serialize(rval, NULL) */ PROTECT(t = s = allocList(3)); SET_TYPEOF(s, LANGSXP); SETCAR(t, install("serialize")); t = CDR(t); SETCAR(t, rval); t = CDR(t); SETCAR(t, R_NilValue); PROTECT(obj = R_tryEval(s, R_GlobalEnv, &status)); if(status != 0) { if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("R expression evaluation error caught in \"serialize\"."))); } len = LENGTH(obj); rsize = VARHDRSZ + len; result = (bytea *) palloc(rsize); SET_VARSIZE(result, rsize); rptr = VARDATA(result); memcpy(rptr, (char *) RAW(obj), rsize - VARHDRSZ); UNPROTECT(2); dvalue = PointerGetDatum(result); } return dvalue; } static Datum get_array_datum(SEXP rval, plr_function *function, int col, bool *isnull) { SEXP rdims; int ndims; int objlen = length(rval); if (objlen > 0) { /* two supported special cases */ if (isFrame(rval)) return get_frame_array_datum(rval, function, col, isnull); else if (isMatrix(rval)) return get_md_array_datum(rval, 2 /* matrix is 2D */, function, col, isnull); PROTECT(rdims = getAttrib(rval, R_DimSymbol)); ndims = length(rdims); UNPROTECT(1); /* 2D and 3D arrays are specifically supported too */ if (ndims == 2 || ndims == 3) return get_md_array_datum(rval, ndims, function, col, isnull); /* everything else */ return get_generic_array_datum(rval, function, col, isnull); } else { /* create an empty array */ return PointerGetDatum(construct_empty_array(function->result_elem)); } } static Datum get_frame_array_datum(SEXP rval, plr_function *function, int col, bool *isnull) { Datum dvalue; SEXP obj; const char *value; Oid result_elem; FmgrInfo in_func; int typlen; bool typbyval; char typalign; int i; Datum *dvalues = NULL; ArrayType *array; int nr = 0; int nc = length(rval); #define FIXED_NUM_DIMS 2 int ndims = FIXED_NUM_DIMS; int dims[FIXED_NUM_DIMS]; int lbs[FIXED_NUM_DIMS]; #undef FIXED_NUM_DIMS 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) { result_elem = function->result_fld_elem_typid[col]; in_func = function->result_fld_elem_in_func[col]; typlen = function->result_fld_elem_typlen[col]; typbyval = function->result_fld_elem_typbyval[col]; typalign = function->result_fld_elem_typalign[col]; } else { result_elem = function->result_elem; in_func = function->result_elem_in_func; typlen = function->result_elem_typlen; typbyval = function->result_elem_typbyval; typalign = function->result_elem_typalign; } for (j = 0; j < nc; j++) { if (TYPEOF(rval) == VECSXP) PROTECT(dfcol = VECTOR_ELT(rval, j)); else if (TYPEOF(rval) == LISTSXP) { PROTECT(dfcol = CAR(rval)); rval = CDR(rval); } else /* internal error */ elog(ERROR, "plr: bad internal representation of data.frame"); /* * Not sure about this test. Need to reliably detect * factors and do the alternative assignment ONLY for them. * For the moment this locution seems to work correctly. */ if (ATTRIB(dfcol) == R_NilValue || TYPEOF(CAR(ATTRIB(dfcol))) != STRSXP) PROTECT(obj = coerce_to_char(dfcol)); else PROTECT(obj = coerce_to_char(CAR(ATTRIB(dfcol)))); if (j == 0) { nr = length(obj); dvalues = (Datum *) palloc(nr * nc * sizeof(Datum)); nulls = (bool *) palloc(nr * nc * sizeof(bool)); } for(i = 0; i < nr; i++) { value = CHAR(STRING_ELT(obj, i)); idx = ((i * nc) + j); if (STRING_ELT(obj, i) == NA_STRING || value == NULL) { nulls[idx] = TRUE; have_nulls = TRUE; } else { nulls[idx] = FALSE; dvalues[idx] = FunctionCall3(&in_func, CStringGetDatum(value), (Datum) 0, Int32GetDatum(-1)); } } UNPROTECT(2); } dims[0] = nr; dims[1] = nc; 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); dvalue = PointerGetDatum(array); return dvalue; } /* return simple, one dimensional array */ static Datum get_simple_array_datum(SEXP rval, Oid typelem, bool *isnull) { Datum dvalue; SEXP obj; SEXP rdims; const char *value; int16 typlen; bool typbyval; char typdelim; Oid typinput, typioparam; FmgrInfo in_func; char typalign; int i; Datum *dvalues = NULL; ArrayType *array; int nitems; int *dims; int *lbs; bool *nulls; bool have_nulls = FALSE; int ndims = 1; dims = palloc(ndims * sizeof(int)); lbs = palloc(ndims * sizeof(int)); /* * get the element type's in_func */ get_type_io_data(typelem, IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typioparam, &typinput); perm_fmgr_info(typinput, &in_func); PROTECT(rdims = getAttrib(rval, R_DimSymbol)); if (length(rdims) > 1) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("greater than 1-dimensional arrays are " \ "not supported in this context"))); dims[0] = INTEGER(rdims)[0]; lbs[0] = 1; UNPROTECT(1); nitems = dims[0]; if (nitems == 0) { *isnull = true; return (Datum) 0; } dvalues = (Datum *) palloc(nitems * sizeof(Datum)); nulls = (bool *) palloc(nitems * sizeof(bool)); PROTECT(obj = coerce_to_char(rval)); for (i = 0; i < nitems; i++) { value = CHAR(STRING_ELT(obj, i)); if (STRING_ELT(obj, i) == NA_STRING || value == NULL) { nulls[i] = TRUE; have_nulls = TRUE; } else { nulls[i] = FALSE; dvalues[i] = FunctionCall3(&in_func, CStringGetDatum(value), (Datum) 0, Int32GetDatum(-1)); } } UNPROTECT(1); if (!have_nulls) array = construct_md_array(dvalues, NULL, ndims, dims, lbs, typelem, typlen, typbyval, typalign); else array = construct_md_array(dvalues, nulls, ndims, dims, lbs, typelem, typlen, typbyval, typalign); dvalue = PointerGetDatum(array); return dvalue; } static Datum get_md_array_datum(SEXP rval, int ndims, plr_function *function, int col, bool *isnull) { Datum dvalue; SEXP obj; SEXP rdims; const char *value; Oid result_elem; FmgrInfo in_func; int typlen; bool typbyval; char typalign; int i, j, k; Datum *dvalues = NULL; ArrayType *array; int nitems; int nr = 1; int nc = 1; int nz = 1; int *dims; int *lbs; int idx; int cntr = 0; bool *nulls; bool have_nulls = FALSE; if (ndims > 0) { dims = palloc(ndims * sizeof(int)); lbs = palloc(ndims * sizeof(int)); } else { dims = NULL; lbs = NULL; } if (function->result_istuple) { result_elem = function->result_fld_elem_typid[col]; in_func = function->result_fld_elem_in_func[col]; typlen = function->result_fld_elem_typlen[col]; typbyval = function->result_fld_elem_typbyval[col]; typalign = function->result_fld_elem_typalign[col]; } else { result_elem = function->result_elem; in_func = function->result_elem_in_func; typlen = function->result_elem_typlen; typbyval = function->result_elem_typbyval; typalign = function->result_elem_typalign; } PROTECT(rdims = getAttrib(rval, R_DimSymbol)); for(i = 0; i < ndims; i++) { dims[i] = INTEGER(rdims)[i]; lbs[i] = 1; switch (i) { case 0: nr = dims[i]; break; case 1: nc = dims[i]; break; case 2: nz = dims[i]; break; default: /* anything higher is currently unsupported */ ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("greater than 3-dimensional arrays are " \ "not yet supported"))); } } UNPROTECT(1); nitems = nr * nc * nz; dvalues = (Datum *) palloc(nitems * sizeof(Datum)); nulls = (bool *) palloc(nitems * sizeof(bool)); PROTECT(obj = coerce_to_char(rval)); for (i = 0; i < nr; i++) { for (j = 0; j < nc; j++) { 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; } else { nulls[arridx] = FALSE; dvalues[arridx] = 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); dvalue = PointerGetDatum(array); return dvalue; } static Datum get_generic_array_datum(SEXP rval, plr_function *function, int col, bool *isnull) { int objlen = length(rval); Datum dvalue; SEXP obj; const char *value; Oid result_elem; FmgrInfo in_func; int typlen; bool typbyval; char typalign; int i; Datum *dvalues = NULL; ArrayType *array; #define FIXED_NUM_DIMS 1 int ndims = FIXED_NUM_DIMS; int dims[FIXED_NUM_DIMS]; int lbs[FIXED_NUM_DIMS]; #undef FIXED_NUM_DIMS bool *nulls; bool have_nulls = FALSE; bool fast_track_type; bool has_na = false; if (function->result_istuple) { result_elem = function->result_fld_elem_typid[col]; in_func = function->result_fld_elem_in_func[col]; typlen = function->result_fld_elem_typlen[col]; typbyval = function->result_fld_elem_typbyval[col]; typalign = function->result_fld_elem_typalign[col]; } else { result_elem = function->result_elem; in_func = function->result_elem_in_func; typlen = function->result_elem_typlen; typbyval = function->result_elem_typbyval; typalign = function->result_elem_typalign; } /* * Special case for pass-by-value data types, if the following conditions are met: * designated fast_track_type * no NULL/NA elements */ if (TYPEOF(rval) == INTSXP || TYPEOF(rval) == REALSXP) { switch (TYPEOF(rval)) { case INTSXP: if (result_elem == INT4OID) fast_track_type = true; else fast_track_type = false; for (i = 0; i < objlen; i++) { if (INTEGER(rval)[i] == NA_INTEGER) { has_na = true; break; } } break; case REALSXP: if (result_elem == FLOAT8OID) fast_track_type = true; else fast_track_type = false; for (i = 0; i < objlen; i++) { if (ISNAN(REAL(rval)[i])) { has_na = true; break; } } break; default: fast_track_type = false; has_na = true; /* does not really matter in this case */ } } else { fast_track_type = false; has_na = true; /* does not really matter in this case */ } if (fast_track_type && typbyval && !has_na) { int32 nbytes = 0; int32 dataoffset; if (TYPEOF(rval) == INTSXP) { nbytes = objlen * sizeof(INTEGER_DATA(rval)); dvalues = (Datum *) INTEGER_DATA(rval); } else if (TYPEOF(rval) == REALSXP) { nbytes = objlen * sizeof(NUMERIC_DATA(rval)); dvalues = (Datum *) NUMERIC_DATA(rval); } else elog(ERROR, "attempted to passthrough invalid R datatype to Postgresql"); dims[0] = objlen; lbs[0] = 1; dataoffset = 0; /* marker for no null bitmap */ array = (ArrayType *) palloc0(nbytes + ARR_OVERHEAD_NONULLS(ndims)); SET_VARSIZE(array, nbytes + ARR_OVERHEAD_NONULLS(ndims)); array->ndim = ndims; array->dataoffset = dataoffset; array->elemtype = result_elem; memcpy(ARR_DIMS(array), dims, ndims * sizeof(int)); memcpy(ARR_LBOUND(array), lbs, ndims * sizeof(int)); memcpy(ARR_DATA_PTR(array), dvalues, nbytes); dvalue = PointerGetDatum(array); } else { /* original code */ dvalues = (Datum *) palloc(objlen * sizeof(Datum)); nulls = (bool *) palloc(objlen * sizeof(bool)); PROTECT(obj = coerce_to_char(rval)); /* Loop is needed here as result value might be of length > 1 */ for(i = 0; i < objlen; i++) { value = CHAR(STRING_ELT(obj, i)); if (STRING_ELT(obj, i) == NA_STRING || value == NULL) { nulls[i] = TRUE; have_nulls = TRUE; } 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); dvalue = PointerGetDatum(array); } return dvalue; } static Tuplestorestate * get_frame_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset) { Tuplestorestate *tupstore; char **values; HeapTuple tuple; TupleDesc tupdesc = attinmeta->tupdesc; int tupdesc_nc = tupdesc->natts; Form_pg_attribute *attrs = tupdesc->attrs; MemoryContext oldcontext; int i, j; int nr = 0; int nc = length(rval); SEXP dfcol; SEXP result; if (nc != tupdesc_nc) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("actual and requested return type mismatch"), errdetail("Actual return type has %d columns, but " \ "requested return type has %d", nc, tupdesc_nc))); /* switch to appropriate context to create the tuple store */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* initialize our tuplestore */ tupstore = TUPLESTORE_BEGIN_HEAP; MemoryContextSwitchTo(oldcontext); /* * If we return a set, get number of rows by examining the first column. * Otherwise, stop at one row. */ if (retset) { if (isFrame(rval)) { PROTECT(dfcol = VECTOR_ELT(rval, 0)); nr = length(dfcol); UNPROTECT(1); } else if (isList(rval) || isNewList(rval)) nr = 1; } else nr = 1; /* coerce columns to character in advance */ PROTECT(result = NEW_LIST(nc)); for (j = 0; j < nc; j++) { PROTECT(dfcol = VECTOR_ELT(rval, j)); if((!isFactor(dfcol)) && ((attrs[j]->attndims == 0) || (TYPEOF(dfcol) != VECSXP))) { SEXP obj; PROTECT(obj = coerce_to_char(dfcol)); SET_VECTOR_ELT(result, j, obj); UNPROTECT(1); } else if(attrs[j]->attndims != 0) /* array data type */ { SEXP obj; PROTECT(obj = NEW_LIST(nr)); for(i = 0; i < nr; i++) { SEXP dfcolcell; SEXP objcell; PROTECT(dfcolcell = VECTOR_ELT(dfcol, i)); PROTECT(objcell = coerce_to_char(dfcolcell)); SET_VECTOR_ELT(obj, i, objcell); UNPROTECT(2); } SET_VECTOR_ELT(result, j, obj); UNPROTECT(1); } else { SEXP t; for (t = ATTRIB(dfcol); t != R_NilValue; t = CDR(t)) { if(TAG(t) == R_LevelsSymbol) { PROTECT(SETCAR(t, coerce_to_char(CAR(t)))); UNPROTECT(1); break; } } SET_VECTOR_ELT(result, j, dfcol); } UNPROTECT(1); } values = (char **) palloc(nc * sizeof(char *)); for(i = 0; i < nr; i++) { for (j = 0; j < nc; j++) { PROTECT(dfcol = VECTOR_ELT(result, j)); if(isFactor(dfcol)) { SEXP t; /* * a factor is a special type of integer * but must check for NA value first */ if (INTEGER_ELT(dfcol, i) != NA_INTEGER) { for (t = ATTRIB(dfcol); t != R_NilValue; t = CDR(t)) { if(TAG(t) == R_LevelsSymbol) { SEXP obj; int idx = INTEGER(dfcol)[i] - 1; PROTECT(obj = CAR(t)); values[j] = pstrdup(CHAR(STRING_ELT(obj, idx))); UNPROTECT(1); break; } } } else values[j] = NULL; } else { if ((attrs[j]->attndims != 0) || (STRING_ELT(dfcol, i) != NA_STRING)) { if (attrs[j]->attndims == 0) { values[j] = pstrdup(CHAR(STRING_ELT(dfcol, i))); } else /* array data type */ { bool isnull = false; Datum arr_datum; if (TYPEOF(dfcol) != VECSXP) arr_datum = get_array_datum(dfcol, function, j, &isnull); else arr_datum = get_array_datum(VECTOR_ELT(dfcol,i), function, j, &isnull); if (isnull) { values[j] = NULL; } else { FunctionCallInfoData fake_fcinfo; FmgrInfo flinfo; Datum dvalue; MemSet(&fake_fcinfo, 0, sizeof(fake_fcinfo)); MemSet(&flinfo, 0, sizeof(flinfo)); fake_fcinfo.flinfo = &flinfo; flinfo.fn_mcxt = CurrentMemoryContext; fake_fcinfo.context = NULL; fake_fcinfo.resultinfo = NULL; fake_fcinfo.isnull = false; fake_fcinfo.nargs = 1; fake_fcinfo.arg[0] = arr_datum; fake_fcinfo.argnull[0] = false; dvalue = (*array_out)(&fake_fcinfo); if (fake_fcinfo.isnull) values[j] = NULL; else values[j] = DatumGetCString(dvalue); } } } else values[j] = NULL; } UNPROTECT(1); } /* construct the tuple */ tuple = BuildTupleFromCStrings(attinmeta, values); /* switch to appropriate context while storing the tuple */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* now store it */ tuplestore_puttuple(tupstore, tuple); /* now reset the context */ MemoryContextSwitchTo(oldcontext); for (j = 0; j < nc; j++) if (values[j] != NULL) pfree(values[j]); } UNPROTECT(1); oldcontext = MemoryContextSwitchTo(per_query_ctx); tuplestore_donestoring(tupstore); MemoryContextSwitchTo(oldcontext); return tupstore; } static Tuplestorestate * get_matrix_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset) { Tuplestorestate *tupstore; char **values; HeapTuple tuple; MemoryContext oldcontext; SEXP obj; int i, j; int nr; int nc = ncols(rval); /* switch to appropriate context to create the tuple store */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* * If we return a set, get number of rows. * Otherwise, stop at one row. */ if (retset) nr = nrows(rval); else nr = 1; /* initialize our tuplestore */ tupstore = TUPLESTORE_BEGIN_HEAP; MemoryContextSwitchTo(oldcontext); values = (char **) palloc(nc * sizeof(char *)); PROTECT(obj = coerce_to_char(rval)); for(i = 0; i < nr; i++) { for (j = 0; j < nc; j++) { if (STRING_ELT(obj, (j * nr) + i) != NA_STRING) values[j] = (char *) CHAR(STRING_ELT(obj, (j * nr) + i)); else values[j] = (char *) NULL; } /* construct the tuple */ tuple = BuildTupleFromCStrings(attinmeta, values); /* switch to appropriate context while storing the tuple */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* now store it */ tuplestore_puttuple(tupstore, tuple); /* now reset the context */ MemoryContextSwitchTo(oldcontext); } UNPROTECT(1); oldcontext = MemoryContextSwitchTo(per_query_ctx); tuplestore_donestoring(tupstore); MemoryContextSwitchTo(oldcontext); return tupstore; } static Tuplestorestate * get_generic_tuplestore(SEXP rval, plr_function *function, AttInMetadata *attinmeta, MemoryContext per_query_ctx, bool retset) { Tuplestorestate *tupstore; char **values; HeapTuple tuple; MemoryContext oldcontext; int nr; int nc = 1; SEXP obj; int i; /* switch to appropriate context to create the tuple store */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* * If we return a set, get number of rows. * Otherwise, stop at one row. */ if (retset) nr = length(rval); else nr = 1; /* initialize our tuplestore */ tupstore = TUPLESTORE_BEGIN_HEAP; MemoryContextSwitchTo(oldcontext); values = (char **) palloc(nc * sizeof(char *)); PROTECT(obj = coerce_to_char(rval)); for(i = 0; i < nr; i++) { if (STRING_ELT(obj, i) != NA_STRING) values[0] = (char *) CHAR(STRING_ELT(obj, i)); else values[0] = (char *) NULL; /* construct the tuple */ tuple = BuildTupleFromCStrings(attinmeta, values); /* switch to appropriate context while storing the tuple */ oldcontext = MemoryContextSwitchTo(per_query_ctx); /* now store it */ tuplestore_puttuple(tupstore, tuple); /* now reset the context */ MemoryContextSwitchTo(oldcontext); } UNPROTECT(1); oldcontext = MemoryContextSwitchTo(per_query_ctx); tuplestore_donestoring(tupstore); MemoryContextSwitchTo(oldcontext); return tupstore; } static SEXP coerce_to_char(SEXP rval) { SEXP obj = NULL; switch (TYPEOF(rval)) { case LISTSXP: case NILSXP: case SYMSXP: case VECSXP: case EXPRSXP: case LGLSXP: case INTSXP: case REALSXP: case CPLXSXP: case STRSXP: case RAWSXP: PROTECT(obj = AS_CHARACTER(rval)); break; default: ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("data type coercion error"), errdetail("R object is not an expected " \ "data type; examine your R code"))); } UNPROTECT(1); return obj; } plr-REL8_3_0_17/pg_rsupport.c000077500000000000000000000453731277274236600161220ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * pg_rsupport.c - Postgres support for use within plr functions */ #include "plr.h" extern MemoryContext plr_SPI_context; extern char *last_R_error_msg; static SEXP rpgsql_get_results(int ntuples, SPITupleTable *tuptable); static void rsupport_error_callback(void *arg); /* The information we cache prepared plans */ typedef struct saved_plan_desc { void *saved_plan; int nargs; Oid *typeids; Oid *typelems; FmgrInfo *typinfuncs; } saved_plan_desc; /* * Functions used in R *****************************************************************************/ void throw_pg_notice(const char **msg) { /* skip error CONTEXT for explicitly called messages */ SAVE_PLERRCONTEXT; if (msg && *msg) elog(NOTICE, "%s", *msg); else elog(NOTICE, "%s", ""); RESTORE_PLERRCONTEXT; } /* * plr_quote_literal() - quote literal strings that are to * be used in SPI_exec query strings */ SEXP plr_quote_literal(SEXP rval) { const char *value; text *value_text; text *result_text; SEXP result; /* extract the C string */ PROTECT(rval = AS_CHARACTER(rval)); value = CHAR(STRING_ELT(rval, 0)); /* convert using the pgsql quote_literal function */ value_text = PG_STR_GET_TEXT(value); result_text = DatumGetTextP(DirectFunctionCall1(quote_literal, PointerGetDatum(value_text))); /* copy result back into an R object */ PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(PG_TEXT_GET_STR(result_text))); UNPROTECT(2); return result; } /* * plr_quote_literal() - quote identifiers that are to * be used in SPI_exec query strings */ SEXP plr_quote_ident(SEXP rval) { const char *value; text *value_text; text *result_text; SEXP result; /* extract the C string */ PROTECT(rval = AS_CHARACTER(rval)); value = CHAR(STRING_ELT(rval, 0)); /* convert using the pgsql quote_literal function */ value_text = PG_STR_GET_TEXT(value); result_text = DatumGetTextP(DirectFunctionCall1(quote_ident, PointerGetDatum(value_text))); /* copy result back into an R object */ PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(PG_TEXT_GET_STR(result_text))); UNPROTECT(2); return result; } /* * plr_SPI_exec - The builtin SPI_exec command for the R interpreter */ SEXP plr_SPI_exec(SEXP rsql) { int spi_rc = 0; char buf[64]; const char *sql; int count = 0; int ntuples; SEXP result = NULL; MemoryContext oldcontext; PREPARE_PG_TRY; /* set up error context */ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.exec"); PROTECT(rsql = AS_CHARACTER(rsql)); sql = CHAR(STRING_ELT(rsql, 0)); UNPROTECT(1); if (sql == NULL) error("%s", "cannot exec empty query"); /* switch to SPI memory context */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); /* * trap elog/ereport so we can let R finish up gracefully * and generate the error once we exit the interpreter */ PG_TRY(); { /* Execute the query and handle return codes */ spi_rc = SPI_exec(sql, count); } PLR_PG_CATCH(); PLR_PG_END_TRY(); /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); switch (spi_rc) { case SPI_OK_UTILITY: snprintf(buf, sizeof(buf), "%d", 0); SPI_freetuptable(SPI_tuptable); PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf)); UNPROTECT(1); break; case SPI_OK_SELINTO: case SPI_OK_INSERT: case SPI_OK_DELETE: case SPI_OK_UPDATE: #if PG_VERSION_NUM >= 90600 snprintf(buf, sizeof(buf), UINT64_FORMAT, SPI_processed); #else snprintf(buf, sizeof(buf), "%d", SPI_processed); #endif SPI_freetuptable(SPI_tuptable); PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf)); UNPROTECT(1); break; case SPI_OK_SELECT: ntuples = SPI_processed; if (ntuples > 0) { result = rpgsql_get_results(ntuples, SPI_tuptable); SPI_freetuptable(SPI_tuptable); } else result = R_NilValue; break; case SPI_ERROR_ARGUMENT: error("SPI_exec() failed: SPI_ERROR_ARGUMENT"); break; case SPI_ERROR_UNCONNECTED: error("SPI_exec() failed: SPI_ERROR_UNCONNECTED"); break; case SPI_ERROR_COPY: error("SPI_exec() failed: SPI_ERROR_COPY"); break; case SPI_ERROR_CURSOR: error("SPI_exec() failed: SPI_ERROR_CURSOR"); break; case SPI_ERROR_TRANSACTION: error("SPI_exec() failed: SPI_ERROR_TRANSACTION"); break; case SPI_ERROR_OPUNKNOWN: error("SPI_exec() failed: SPI_ERROR_OPUNKNOWN"); break; default: error("SPI_exec() failed: %d", spi_rc); break; } POP_PLERRCONTEXT; return result; } static SEXP rpgsql_get_results(int ntuples, SPITupleTable *tuptable) { SEXP result; ERRORCONTEXTCALLBACK; /* set up error context */ PUSH_PLERRCONTEXT(rsupport_error_callback, "rpgsql_get_results"); if (tuptable != NULL) { HeapTuple *tuples = tuptable->vals; TupleDesc tupdesc = tuptable->tupdesc; result = pg_tuple_get_r_frame(ntuples, tuples, tupdesc); } else result = R_NilValue; POP_PLERRCONTEXT; return result; } /* * plr_SPI_prepare - The builtin SPI_prepare command for the R interpreter */ SEXP plr_SPI_prepare(SEXP rsql, SEXP rargtypes) { const char *sql; int nargs; int i; Oid *typeids = NULL; Oid *typelems = NULL; FmgrInfo *typinfuncs = NULL; void *pplan = NULL; void *saved_plan; saved_plan_desc *plan_desc; SEXP result; MemoryContext oldcontext; PREPARE_PG_TRY; /* set up error context */ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.prepare"); /* switch to long lived context to create plan description */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); plan_desc = (saved_plan_desc *) palloc(sizeof(saved_plan_desc)); MemoryContextSwitchTo(oldcontext); PROTECT(rsql = AS_CHARACTER(rsql)); sql = CHAR(STRING_ELT(rsql, 0)); UNPROTECT(1); if (sql == NULL) error("%s", "cannot prepare empty query"); PROTECT(rargtypes = AS_INTEGER(rargtypes)); if (!isVector(rargtypes) || !isInteger(rargtypes)) error("%s", "second parameter must be a vector of PostgreSQL datatypes"); /* deal with case of no parameters for the prepared query */ if (rargtypes == R_MissingArg || INTEGER(rargtypes)[0] == NA_INTEGER) nargs = 0; else nargs = length(rargtypes); if (nargs < 0) /* can this even happen?? */ error("%s", "second parameter must be a vector of PostgreSQL datatypes"); if (nargs > 0) { /* switch to long lived context to create plan description elements */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); typeids = (Oid *) palloc(nargs * sizeof(Oid)); typelems = (Oid *) palloc(nargs * sizeof(Oid)); typinfuncs = (FmgrInfo *) palloc(nargs * sizeof(FmgrInfo)); MemoryContextSwitchTo(oldcontext); for (i = 0; i < nargs; i++) { int16 typlen; bool typbyval; char typdelim; Oid typinput, typelem; char typalign; FmgrInfo typinfunc; typeids[i] = INTEGER(rargtypes)[i]; /* switch to long lived context to create plan description elements */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); get_type_io_data(typeids[i], IOFunc_input, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typinput); typelems[i] = get_element_type(typeids[i]); MemoryContextSwitchTo(oldcontext); /* perm_fmgr_info already uses TopMemoryContext */ perm_fmgr_info(typinput, &typinfunc); typinfuncs[i] = typinfunc; } } else typeids = NULL; UNPROTECT(1); /* switch to SPI memory context */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); /* * trap elog/ereport so we can let R finish up gracefully * and generate the error once we exit the interpreter */ PG_TRY(); { /* Prepare plan for query */ pplan = SPI_prepare(sql, nargs, typeids); } PLR_PG_CATCH(); PLR_PG_END_TRY(); if (pplan == NULL) { char buf[128]; char *reason; switch (SPI_result) { case SPI_ERROR_ARGUMENT: reason = "SPI_ERROR_ARGUMENT"; break; case SPI_ERROR_UNCONNECTED: reason = "SPI_ERROR_UNCONNECTED"; break; case SPI_ERROR_COPY: reason = "SPI_ERROR_COPY"; break; case SPI_ERROR_CURSOR: reason = "SPI_ERROR_CURSOR"; break; case SPI_ERROR_TRANSACTION: reason = "SPI_ERROR_TRANSACTION"; break; case SPI_ERROR_OPUNKNOWN: reason = "SPI_ERROR_OPUNKNOWN"; break; default: snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result); reason = buf; break; } /* internal error */ error("SPI_prepare() failed: %s", reason); } /* SPI_saveplan already uses TopMemoryContext */ saved_plan = SPI_saveplan(pplan); if (saved_plan == NULL) { char buf[128]; char *reason; switch (SPI_result) { case SPI_ERROR_ARGUMENT: reason = "SPI_ERROR_ARGUMENT"; break; case SPI_ERROR_UNCONNECTED: reason = "SPI_ERROR_UNCONNECTED"; break; default: snprintf(buf, sizeof(buf), "unknown RC %d", SPI_result); reason = buf; break; } /* internal error */ error("SPI_saveplan() failed: %s", reason); } /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); /* no longer need this */ SPI_freeplan(pplan); plan_desc->saved_plan = saved_plan; plan_desc->nargs = nargs; plan_desc->typeids = typeids; plan_desc->typelems = typelems; plan_desc->typinfuncs = typinfuncs; result = R_MakeExternalPtr(plan_desc, R_NilValue, R_NilValue); POP_PLERRCONTEXT; return result; } /* * plr_SPI_execp - The builtin SPI_execp command for the R interpreter */ SEXP plr_SPI_execp(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 *typeids = plan_desc->typeids; Oid *typelems = plan_desc->typelems; FmgrInfo *typinfuncs = plan_desc->typinfuncs; int i; Datum *argvalues = NULL; char *nulls = NULL; bool isnull = false; SEXP obj; int spi_rc = 0; char buf[64]; int count = 0; int ntuples; SEXP result = NULL; MemoryContext oldcontext; PREPARE_PG_TRY; /* set up error context */ PUSH_PLERRCONTEXT(rsupport_error_callback, "pg.spi.execp"); 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_datum(obj, typeids[i], typelems[i], typinfuncs[i], &isnull); if (!isnull) nulls[i] = ' '; else nulls[i] = 'n'; UNPROTECT(1); } /* switch to SPI memory context */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); /* * trap elog/ereport so we can let R finish up gracefully * and generate the error once we exit the interpreter */ PG_TRY(); { /* Execute the plan */ spi_rc = SPI_execp(saved_plan, argvalues, nulls, count); } PLR_PG_CATCH(); PLR_PG_END_TRY(); /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); /* check the result */ switch (spi_rc) { case SPI_OK_UTILITY: snprintf(buf, sizeof(buf), "%d", 0); SPI_freetuptable(SPI_tuptable); PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf)); UNPROTECT(1); break; case SPI_OK_SELINTO: case SPI_OK_INSERT: case SPI_OK_DELETE: case SPI_OK_UPDATE: #if PG_VERSION_NUM >= 90600 snprintf(buf, sizeof(buf), UINT64_FORMAT, SPI_processed); #else snprintf(buf, sizeof(buf), "%d", SPI_processed); #endif SPI_freetuptable(SPI_tuptable); PROTECT(result = NEW_CHARACTER(1)); SET_STRING_ELT(result, 0, COPY_TO_USER_STRING(buf)); UNPROTECT(1); break; case SPI_OK_SELECT: ntuples = SPI_processed; if (ntuples > 0) { result = rpgsql_get_results(ntuples, SPI_tuptable); SPI_freetuptable(SPI_tuptable); } else result = R_NilValue; break; case SPI_ERROR_ARGUMENT: error("SPI_execp() failed: SPI_ERROR_ARGUMENT"); break; case SPI_ERROR_UNCONNECTED: error("SPI_execp() failed: SPI_ERROR_UNCONNECTED"); break; case SPI_ERROR_COPY: error("SPI_execp() failed: SPI_ERROR_COPY"); break; case SPI_ERROR_CURSOR: error("SPI_execp() failed: SPI_ERROR_CURSOR"); break; case SPI_ERROR_TRANSACTION: error("SPI_execp() failed: SPI_ERROR_TRANSACTION"); break; case SPI_ERROR_OPUNKNOWN: error("SPI_execp() failed: SPI_ERROR_OPUNKNOWN"); break; default: error("SPI_execp() failed: %d", spi_rc); break; } POP_PLERRCONTEXT; return result; } /* * plr_SPI_lastoid - return the last oid. To be used after insert queries. */ SEXP plr_SPI_lastoid(void) { SEXP result; PROTECT(result = NEW_INTEGER(1)); INTEGER_DATA(result)[0] = SPI_lastoid; UNPROTECT(1); 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 *typeids = plan_desc->typeids; 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, typeids[i], typinfuncs[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 */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); /* * 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 */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); 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 */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); 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)) { error("pg.spi.cursor_move arg2 must be boolean"); return; } if(!IS_INTEGER(rows_in)) { error("pg.spi.cursor_move arg3 must be an integer"); return; } forward = LOGICAL(forward_in)[0]; rows = INTEGER(rows_in)[0]; /* switch to SPI memory context */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); PG_TRY(); { /* Open the cursor */ SPI_cursor_move(portal, forward, rows); } PLR_PG_CATCH(); PLR_PG_END_TRY(); /* back to caller's memory context */ MemoryContextSwitchTo(oldcontext); } void throw_r_error(const char **msg) { if (msg && *msg) last_R_error_msg = pstrdup(*msg); else last_R_error_msg = pstrdup("caught error calling R function"); } /* * error context callback to let us supply a call-stack traceback */ static void rsupport_error_callback(void *arg) { if (arg) errcontext("In R support function %s", (char *) arg); } plr-REL8_3_0_17/pg_userfuncs.c000077500000000000000000000360121277274236600162270ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * pg_userfuncs.c - User visible PostgreSQL functions */ #include "plr.h" extern MemoryContext plr_SPI_context; #ifndef WIN32 extern char **environ; #endif static ArrayType *plr_array_create(FunctionCallInfo fcinfo, int numelems, int elem_start); /*----------------------------------------------------------------------------- * plr_version : * output PL/R version string *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_version); Datum plr_version(PG_FUNCTION_ARGS) { PG_RETURN_TEXT_P(PG_STR_GET_TEXT(PLR_VERSION)); } /*----------------------------------------------------------------------------- * reload_modules : * interface to allow plr_modules to be reloaded on demand *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(reload_plr_modules); Datum reload_plr_modules(PG_FUNCTION_ARGS) { MemoryContext plr_caller_context = CurrentMemoryContext; if (SPI_connect() != SPI_OK_CONNECT) elog(ERROR, "SPI_connect failed"); plr_SPI_context = CurrentMemoryContext; MemoryContextSwitchTo(plr_caller_context); plr_load_modules(); if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish failed"); PG_RETURN_TEXT_P(PG_STR_GET_TEXT("OK")); } /*----------------------------------------------------------------------------- * install_rcmd : * interface to allow user defined R functions to be called from other * R functions *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(install_rcmd); Datum install_rcmd(PG_FUNCTION_ARGS) { char *cmd = PG_TEXT_GET_STR(PG_GETARG_TEXT_P(0)); load_r_cmd(cmd); PG_RETURN_TEXT_P(PG_STR_GET_TEXT("OK")); } /*----------------------------------------------------------------------------- * array : * form a one-dimensional array given starting elements * FIXME: does not handle NULL array elements * this function should be obsoleted by similar * backend functionality *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_array); Datum plr_array(PG_FUNCTION_ARGS) { ArrayType *result; result = plr_array_create(fcinfo, PG_NARGS(), 0); PG_RETURN_ARRAYTYPE_P(result); } /*----------------------------------------------------------------------------- * array_push : * push an element onto the end of a one-dimensional array * FIXME: does not handle NULL array elements * this function should be obsoleted by similar * backend functionality *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_array_push); Datum plr_array_push(PG_FUNCTION_ARGS) { ArrayType *v; Datum newelem; int *dimv, *lb, ub; ArrayType *result; int indx; Oid element_type; int16 typlen; bool typbyval; char typalign; v = PG_GETARG_ARRAYTYPE_P(0); newelem = PG_GETARG_DATUM(1); /* Sanity check: do we have a one-dimensional array */ if (ARR_NDIM(v) != 1) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("input must be one-dimensional array"))); lb = ARR_LBOUND(v); dimv = ARR_DIMS(v); ub = dimv[0] + lb[0] - 1; indx = ub + 1; element_type = ARR_ELEMTYPE(v); /* Sanity check: do we have a non-zero element type */ if (element_type == 0) /* internal error */ elog(ERROR, "invalid array element type"); get_typlenbyvalalign(element_type, &typlen, &typbyval, &typalign); result = array_set(v, 1, &indx, newelem, FALSE, -1, typlen, typbyval, typalign); PG_RETURN_ARRAYTYPE_P(result); } /*----------------------------------------------------------------------------- * array_accum : * accumulator to build an array from input values -- when used in * conjunction with plr functions that accept an array, and output * a statistic, this can be used to create custom aggregates. * FIXME: does not handle NULL array elements * this function should be obsoleted by similar * backend functionality *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_array_accum); Datum plr_array_accum(PG_FUNCTION_ARGS) { Datum v; Datum newelem; ArrayType *result; /* return NULL if both arguments are NULL */ if (PG_ARGISNULL(0) && PG_ARGISNULL(1)) PG_RETURN_NULL(); /* create a new array from the second argument if first is NULL */ if (PG_ARGISNULL(0)) PG_RETURN_ARRAYTYPE_P(plr_array_create(fcinfo, 1, 1)); /* return the first argument if the second is NULL */ if (PG_ARGISNULL(1)) PG_RETURN_ARRAYTYPE_P(PG_GETARG_ARRAYTYPE_P_COPY(0)); v = PG_GETARG_DATUM(0); newelem = PG_GETARG_DATUM(1); result = DatumGetArrayTypeP(DirectFunctionCall2(plr_array_push, v, newelem)); PG_RETURN_ARRAYTYPE_P(result); } /* * actually does the work for array(), and array_accum() if it is given a null * input array. * * numelems and elem_start allow the function to be shared given the differing * arguments accepted by array() and array_accum(). With array(), all function * arguments are used for array construction -- therefore elem_start is 0 and * numelems is the number of function arguments. With array_accum(), we are * always initializing the array with a single element given to us as argument * number 1 (i.e. the second argument). * */ static ArrayType * plr_array_create(FunctionCallInfo fcinfo, int numelems, int elem_start) { Oid funcid = fcinfo->flinfo->fn_oid; Datum *dvalues = (Datum *) palloc(numelems * sizeof(Datum)); int16 typlen; bool typbyval; Oid typinput; Oid element_type; char typalign; int i; HeapTuple tp; Oid functypeid; Oid *funcargtypes; ArrayType *result; if (numelems == 0) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("at least one value required to construct an array"))); /* * Get the type metadata for the array return type and its elements */ tp = SearchSysCache(PROCOID, ObjectIdGetDatum(funcid), 0, 0, 0); if (!HeapTupleIsValid(tp)) /* internal error */ elog(ERROR, "function OID %u does not exist", funcid); functypeid = ((Form_pg_proc) GETSTRUCT(tp))->prorettype; getTypeInputInfo(functypeid, &typinput, &element_type); get_typlenbyvalalign(element_type, &typlen, &typbyval, &typalign); funcargtypes = FUNCARGTYPES(tp); /* * the first function argument(s) may not be one of our array elements, * but the caller is responsible to ensure we get nothing but array * elements once they start coming */ for (i = elem_start; i < elem_start + numelems; i++) if (funcargtypes[i] != element_type) ereport(ERROR, (errcode(ERRCODE_INVALID_PARAMETER_VALUE), errmsg("argument %d datatype not " \ "compatible with return data type", i + 1))); ReleaseSysCache(tp); for (i = 0; i < numelems; i++) dvalues[i] = PG_GETARG_DATUM(elem_start + i); result = construct_array(dvalues, numelems, element_type, typlen, typbyval, typalign); return result; } /*----------------------------------------------------------------------------- * plr_environ : * utility function to display the environment under which the * postmaster is running. *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_environ); Datum plr_environ(PG_FUNCTION_ARGS) { ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo; Tuplestorestate *tupstore; HeapTuple tuple; TupleDesc tupdesc; AttInMetadata *attinmeta; MemoryContext per_query_ctx; MemoryContext oldcontext; char *var_name; char *var_val; char *values[2]; #ifndef WIN32 char **current_env; #else char *buf; LPTSTR envstr; int count = 0; int i; #endif /* check to see if caller supports us returning a tuplestore */ if (!rsinfo || !(rsinfo->allowedModes & SFRM_Materialize)) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("materialize mode required, but it is not " "allowed in this context"))); per_query_ctx = rsinfo->econtext->ecxt_per_query_memory; oldcontext = MemoryContextSwitchTo(per_query_ctx); /* get the requested return tuple description */ tupdesc = CreateTupleDescCopy(rsinfo->expectedDesc); /* * Check to make sure we have a reasonable tuple descriptor */ if (tupdesc->natts != 2 || tupdesc->attrs[0]->atttypid != TEXTOID || tupdesc->attrs[1]->atttypid != TEXTOID) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("query-specified return tuple and " "function return type are not compatible"))); /* OK to use it */ attinmeta = TupleDescGetAttInMetadata(tupdesc); /* let the caller know we're sending back a tuplestore */ rsinfo->returnMode = SFRM_Materialize; /* initialize our tuplestore */ tupstore = TUPLESTORE_BEGIN_HEAP; #ifndef WIN32 for (current_env = environ; current_env != NULL && *current_env != NULL; current_env++) { Size name_len; var_val = strchr(*current_env, '='); if (!var_val) continue; name_len = var_val - *current_env; var_name = (char *) palloc0(name_len + 1); memcpy(var_name, *current_env, name_len); values[0] = var_name; values[1] = var_val + 1; tuple = BuildTupleFromCStrings(attinmeta, values); tuplestore_puttuple(tupstore, tuple); pfree(var_name); } #else buf = GetEnvironmentStrings(); envstr = buf; while (true) { if (*envstr == 0) break; while (*envstr != 0) envstr++; envstr++; count++; } /* reset pointer to the environment buffer */ envstr = buf; while(*buf == '=') buf++; for (i = 0; i < count; i++) { Size name_len; var_val = strchr(buf, '='); if (!var_val) continue; name_len = var_val - buf; var_name = (char *) palloc0(name_len + 1); memcpy(var_name, buf, name_len); values[0] = var_name; values[1] = var_val + 1; tuple = BuildTupleFromCStrings(attinmeta, values); tuplestore_puttuple(tupstore, tuple); pfree(var_name); while(*buf != '\0') buf++; buf++; } FreeEnvironmentStrings(envstr); #endif /* * no longer need the tuple descriptor reference created by * TupleDescGetAttInMetadata() */ ReleaseTupleDesc(tupdesc); tuplestore_donestoring(tupstore); rsinfo->setResult = tupstore; /* * SFRM_Materialize mode expects us to return a NULL Datum. The actual * tuples are in our tuplestore and passed back through * rsinfo->setResult. rsinfo->setDesc is set to the tuple description * that we actually used to build our tuples with, so the caller can * verify we did what it was expecting. */ rsinfo->setDesc = tupdesc; MemoryContextSwitchTo(oldcontext); return (Datum) 0; } /*----------------------------------------------------------------------------- * plr_set_rhome : * utility function to set the R_HOME environment variable under * which the postmaster is running. *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_set_rhome); Datum plr_set_rhome(PG_FUNCTION_ARGS) { char *rhome = PG_TEXT_GET_STR(PG_GETARG_TEXT_P(0)); size_t rh_len = strlen(rhome); if (rh_len) { char *rhenv; MemoryContext oldcontext; /* Needs to live until/unless we explicitly delete it */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); rhenv = palloc(8 + rh_len); MemoryContextSwitchTo(oldcontext); sprintf(rhenv, "R_HOME=%s", rhome); putenv(rhenv); } PG_RETURN_TEXT_P(PG_STR_GET_TEXT("OK")); } /*----------------------------------------------------------------------------- * plr_unset_rhome : * utility function to unset the R_HOME environment variable under * which the postmaster is running. *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_unset_rhome); Datum plr_unset_rhome(PG_FUNCTION_ARGS) { unsetenv("R_HOME"); PG_RETURN_TEXT_P(PG_STR_GET_TEXT("OK")); } /*----------------------------------------------------------------------------- * plr_set_display : * utility function to set the DISPLAY environment variable under * which the postmaster is running. *---------------------------------------------------------------------------- */ PG_FUNCTION_INFO_V1(plr_set_display); Datum plr_set_display(PG_FUNCTION_ARGS) { char *display = PG_TEXT_GET_STR(PG_GETARG_TEXT_P(0)); size_t d_len = strlen(display); if (d_len) { char *denv; MemoryContext oldcontext; /* Needs to live until/unless we explicitly delete it */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); denv = palloc(9 + d_len); MemoryContextSwitchTo(oldcontext); sprintf(denv, "DISPLAY=%s", display); putenv(denv); } PG_RETURN_TEXT_P(PG_STR_GET_TEXT("OK")); } /*----------------------------------------------------------------------------- * plr_get_raw : * utility function to ... *---------------------------------------------------------------------------- */ extern char *last_R_error_msg; PG_FUNCTION_INFO_V1(plr_get_raw); Datum plr_get_raw(PG_FUNCTION_ARGS) { SEXP result; SEXP s, t, obj; int status; bytea *bvalue = PG_GETARG_BYTEA_P(0); int len, rsize; bytea *bresult; char *brptr; PROTECT(obj = NEW_RAW(VARSIZE(bvalue))); memcpy((char *) RAW(obj), VARDATA(bvalue), VARSIZE(bvalue)); /* * Need to construct a call to * unserialize(rval) */ PROTECT(t = s = allocList(2)); SET_TYPEOF(s, LANGSXP); SETCAR(t, install("unserialize")); t = CDR(t); SETCAR(t, obj); PROTECT(result = R_tryEval(s, R_GlobalEnv, &status)); if(status != 0) { if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("R expression evaluation error caught in \"unserialize\"."))); } len = LENGTH(result); rsize = VARHDRSZ + len; bresult = (bytea *) palloc(rsize); SET_VARSIZE(bresult, rsize); brptr = VARDATA(bresult); memcpy(brptr, (char *) RAW(result), rsize - VARHDRSZ); UNPROTECT(3); PG_RETURN_BYTEA_P(bresult); } plr-REL8_3_0_17/plr--8.3.0.17.sql000066400000000000000000000055151277274236600156460ustar00rootroot00000000000000-- keep this in sync with the plr.sql.in legacy install file CREATE FUNCTION plr_call_handler() RETURNS LANGUAGE_HANDLER AS 'MODULE_PATHNAME' LANGUAGE C; CREATE LANGUAGE plr HANDLER plr_call_handler; CREATE OR REPLACE FUNCTION plr_version () RETURNS text AS 'MODULE_PATHNAME','plr_version' LANGUAGE C; CREATE OR REPLACE FUNCTION reload_plr_modules () RETURNS text AS 'MODULE_PATHNAME','reload_plr_modules' LANGUAGE C; CREATE OR REPLACE FUNCTION install_rcmd (text) RETURNS text AS 'MODULE_PATHNAME','install_rcmd' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION install_rcmd (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_singleton_array (float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array' LANGUAGE C WITH (isstrict); CREATE OR REPLACE FUNCTION plr_array_push (_float8, float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array_push' LANGUAGE C WITH (isstrict); CREATE OR REPLACE FUNCTION plr_array_accum (_float8, float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array_accum' LANGUAGE C; CREATE TYPE plr_environ_type AS (name text, value text); CREATE OR REPLACE FUNCTION plr_environ () RETURNS SETOF plr_environ_type AS 'MODULE_PATHNAME','plr_environ' LANGUAGE C; REVOKE EXECUTE ON FUNCTION plr_environ() FROM PUBLIC; CREATE TYPE r_typename AS (typename text, typeoid oid); CREATE OR REPLACE FUNCTION r_typenames() RETURNS SETOF r_typename AS ' x <- ls(name = .GlobalEnv, pat = "OID") y <- vector() for (i in 1:length(x)) {y[i] <- eval(parse(text = x[i]))} data.frame(typename = x, typeoid = y) ' language 'plr'; CREATE OR REPLACE FUNCTION load_r_typenames() RETURNS text AS ' sql <- "select upper(typname::text) || ''OID'' as typename, oid from pg_catalog.pg_type where typtype = ''b'' order by typname" rs <- pg.spi.exec(sql) for(i in 1:nrow(rs)) { typobj <- rs[i,1] typval <- rs[i,2] if (substr(typobj,1,1) == "_") typobj <- paste("ARRAYOF", substr(typobj,2,nchar(typobj)), sep="") assign(typobj, typval, .GlobalEnv) } return("OK") ' language 'plr'; CREATE TYPE r_version_type AS (name text, value text); CREATE OR REPLACE FUNCTION r_version() RETURNS setof r_version_type as ' cbind(names(version),unlist(version)) ' language 'plr'; CREATE OR REPLACE FUNCTION plr_set_rhome (text) RETURNS text AS 'MODULE_PATHNAME','plr_set_rhome' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION plr_set_rhome (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_unset_rhome () RETURNS text AS 'MODULE_PATHNAME','plr_unset_rhome' LANGUAGE C; REVOKE EXECUTE ON FUNCTION plr_unset_rhome () FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_set_display (text) RETURNS text AS 'MODULE_PATHNAME','plr_set_display' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION plr_set_display (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_get_raw (bytea) RETURNS bytea AS 'MODULE_PATHNAME','plr_get_raw' LANGUAGE C WITH (isstrict); plr-REL8_3_0_17/plr--unpackaged--8.3.0.17.sql000066400000000000000000000020131277274236600200110ustar00rootroot00000000000000/* plr/plr--unpackaged--8.3.0.17.sql */ ALTER EXTENSION plr ADD type plr_environ_type; ALTER EXTENSION plr ADD type r_typename; ALTER EXTENSION plr ADD type r_version_type; ALTER EXTENSION plr ADD function plr_call_handler(); ALTER EXTENSION plr ADD function plr_version(); ALTER EXTENSION plr ADD function reload_plr_modules(); ALTER EXTENSION plr ADD function install_rcmd(text); ALTER EXTENSION plr ADD function plr_singleton_array (float8); ALTER EXTENSION plr ADD function plr_array_push (_float8, float8); ALTER EXTENSION plr ADD function plr_array_accum (_float8, float8); ALTER EXTENSION plr ADD function plr_environ (); ALTER EXTENSION plr ADD function r_typenames(); ALTER EXTENSION plr ADD function load_r_typenames(); ALTER EXTENSION plr ADD function r_version(); ALTER EXTENSION plr ADD function plr_set_rhome (text); ALTER EXTENSION plr ADD function plr_unset_rhome (); ALTER EXTENSION plr ADD function plr_set_display (text); ALTER EXTENSION plr ADD function plr_get_raw (bytea); ALTER EXTENSION plr ADD LANGUAGE plr;plr-REL8_3_0_17/plr.c000077500000000000000000001415531277274236600143300ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * plr.c - Language handler and support functions */ #include "plr.h" PG_MODULE_MAGIC; /* * Global data */ MemoryContext plr_caller_context; MemoryContext plr_SPI_context = NULL; HTAB *plr_HashTable = (HTAB *) NULL; char *last_R_error_msg = NULL; static bool plr_pm_init_done = false; static bool plr_be_init_done = false; /* namespace OID for the PL/R language handler function */ static Oid plr_nspOid = InvalidOid; int R_SignalHandlers = 1; /* Exposed in R_interface.h */ /* * defines */ /* real max is 3 (for "PLR") plus number of characters in an Oid */ #define MAX_PRONAME_LEN NAMEDATALEN #define OPTIONS_NULL_CMD "options(error = expression(NULL))" #define THROWRERROR_CMD \ "pg.throwrerror <-function(msg) " \ "{" \ " msglen <- nchar(msg);" \ " if (substr(msg, msglen, msglen + 1) == \"\\n\")" \ " msg <- substr(msg, 1, msglen - 1);" \ " .C(\"throw_r_error\", as.character(msg));" \ "}" #define OPTIONS_THROWRERROR_CMD \ "options(error = expression(pg.throwrerror(geterrmessage())))" #define THROWNOTICE_CMD \ "pg.thrownotice <-function(msg) " \ "{.C(\"throw_pg_notice\", as.character(msg))}" #define THROWERROR_CMD \ "pg.throwerror <-function(msg) " \ "{stop(msg, call. = FALSE)}" #define OPTIONS_THROWWARN_CMD \ "options(warning.expression = expression(pg.thrownotice(last.warning)))" #define QUOTE_LITERAL_CMD \ "pg.quoteliteral <-function(sql) " \ "{.Call(\"plr_quote_literal\", sql)}" #define QUOTE_IDENT_CMD \ "pg.quoteident <-function(sql) " \ "{.Call(\"plr_quote_ident\", sql)}" #define SPI_EXEC_CMD \ "pg.spi.exec <-function(sql) {.Call(\"plr_SPI_exec\", sql)}" #define SPI_PREPARE_CMD \ "pg.spi.prepare <-function(sql, argtypes = NA) " \ "{.Call(\"plr_SPI_prepare\", sql, argtypes)}" #define SPI_EXECP_CMD \ "pg.spi.execp <-function(sql, argvalues = NA) " \ "{.Call(\"plr_SPI_execp\", sql, argvalues)}" #define SPI_CURSOR_OPEN_CMD \ "pg.spi.cursor_open<-function(cursor_name,plan,argvalues=NA) " \ "{.Call(\"plr_SPI_cursor_open\",cursor_name,plan,argvalues)}" #define SPI_CURSOR_FETCH_CMD \ "pg.spi.cursor_fetch<-function(cursor,forward,rows) " \ "{.Call(\"plr_SPI_cursor_fetch\",cursor,forward,rows)}" #define SPI_CURSOR_MOVE_CMD \ "pg.spi.cursor_move<-function(cursor,forward,rows) " \ "{.Call(\"plr_SPI_cursor_move\",cursor,forward,rows)}" #define SPI_CURSOR_CLOSE_CMD \ "pg.spi.cursor_close<-function(cursor) " \ "{.Call(\"plr_SPI_cursor_close\",cursor)}" #define SPI_LASTOID_CMD \ "pg.spi.lastoid <-function() " \ "{.Call(\"plr_SPI_lastoid\")}" #define SPI_DBDRIVER_CMD \ "dbDriver <-function(db_name)\n" \ "{return(NA)}" #define SPI_DBCONN_CMD \ "dbConnect <- function(drv,user=\"\",password=\"\",host=\"\",dbname=\"\",port=\"\",tty =\"\",options=\"\")\n" \ "{return(NA)}" #define SPI_DBSENDQUERY_CMD \ "dbSendQuery <- function(conn, sql) {\n" \ "plan <- pg.spi.prepare(sql)\n" \ "cursor_obj <- pg.spi.cursor_open(\"plr_cursor\",plan)\n" \ "return(cursor_obj)\n" \ "}" #define SPI_DBFETCH_CMD \ "fetch <- function(rs,n) {\n" \ "data <- pg.spi.cursor_fetch(rs, TRUE, as.integer(n))\n" \ "return(data)\n" \ "}" #define SPI_DBCLEARRESULT_CMD \ "dbClearResult <- function(rs) {\n" \ "pg.spi.cursor_close(rs)\n" \ "}" #define SPI_DBGETQUERY_CMD \ "dbGetQuery <-function(conn, sql) {\n" \ "data <- pg.spi.exec(sql)\n" \ "return(data)\n" \ "}" #define SPI_DBREADTABLE_CMD \ "dbReadTable <- function(con, name, row.names = \"row_names\", check.names = TRUE) {\n" \ "data <- dbGetQuery(con, paste(\"SELECT * from\", name))\n" \ "return(data)\n" \ "}" #define SPI_DBDISCONN_CMD \ "dbDisconnect <- function(con)\n" \ "{return(NA)}" #define SPI_DBUNLOADDRIVER_CMD \ "dbUnloadDriver <-function(drv)\n" \ "{return(NA)}" #define SPI_FACTOR_CMD \ "pg.spi.factor <- function(arg1) {\n" \ " for (col in 1:ncol(arg1)) {\n" \ " if (!is.numeric(arg1[,col])) {\n" \ " arg1[,col] <- factor(arg1[,col])\n" \ " }\n" \ " }\n" \ " return(arg1)\n" \ "}" #define REVAL \ "pg.reval <- function(arg1) {eval(parse(text = arg1))}" #define PG_STATE_FIRSTPASS \ "pg.state.firstpass <- TRUE" #define CurrentTriggerData ((TriggerData *) fcinfo->context) /* * static declarations */ static void plr_atexit(void); static void plr_load_builtins(Oid funcid); static void plr_init_all(Oid funcid); static Datum plr_trigger_handler(PG_FUNCTION_ARGS); static Datum plr_func_handler(PG_FUNCTION_ARGS); static plr_function *compile_plr_function(FunctionCallInfo fcinfo); static plr_function *do_compile(FunctionCallInfo fcinfo, HeapTuple procTup, plr_func_hashkey *hashkey); static SEXP plr_parse_func_body(const char *body); static SEXP plr_convertargs(plr_function *function, Datum *arg, bool *argnull, FunctionCallInfo fcinfo); static void plr_error_callback(void *arg); static Oid getNamespaceOidFromFunctionOid(Oid fnOid); static bool haveModulesTable(Oid nspOid); static char *getModulesSql(Oid nspOid); #ifdef HAVE_WINDOW_FUNCTIONS static void WinGetFrameData(WindowObject winobj, int argno, Datum *dvalues, bool *isnull, int *numels, bool *has_nulls); #endif static void plr_resolve_polymorphic_argtypes(int numargs, Oid *argtypes, char *argmodes, Node *call_expr, bool forValidator, const char *proname); /* * plr_call_handler - This is the only visible function * of the PL interpreter. The PostgreSQL * function manager and trigger manager * call this function for execution of * PL/R procedures. */ PG_FUNCTION_INFO_V1(plr_call_handler); Datum plr_call_handler(PG_FUNCTION_ARGS) { Datum retval; /* save caller's context */ plr_caller_context = CurrentMemoryContext; if (SPI_connect() != SPI_OK_CONNECT) elog(ERROR, "SPI_connect failed"); plr_SPI_context = CurrentMemoryContext; MemoryContextSwitchTo(plr_caller_context); /* initialize R if needed */ plr_init_all(fcinfo->flinfo->fn_oid); if (CALLED_AS_TRIGGER(fcinfo)) retval = plr_trigger_handler(fcinfo); else retval = plr_func_handler(fcinfo); return retval; } void load_r_cmd(const char *cmd) { SEXP cmdSexp, cmdexpr; int i, status; /* * Init if not already done. This can happen when PL/R is not preloaded * and reload_plr_modules() or install_rcmd() is called by the user prior * to any PL/R functions. */ if (!plr_pm_init_done) plr_init(); PROTECT(cmdSexp = NEW_CHARACTER(1)); SET_STRING_ELT(cmdSexp, 0, COPY_TO_USER_STRING(cmd)); PROTECT(cmdexpr = R_PARSEVECTOR(cmdSexp, -1, &status)); if (status != PARSE_OK) { UNPROTECT(2); if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter parse error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter parse error"), errdetail("R parse error caught in \"%s\".", cmd))); } /* Loop is needed here as EXPSEXP may be of length > 1 */ for(i = 0; i < length(cmdexpr); i++) { R_tryEval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv, &status); if(status != 0) { if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("R expression evaluation error caught " \ "in \"%s\".", cmd))); } } UNPROTECT(2); } /* * plr_cleanup() - Let the embedded interpreter clean up after itself * * DO NOT make this static --- it has to be registered as an on_proc_exit() * callback */ void PLR_CLEANUP { char *buf; char *tmpdir = getenv("R_SESSION_TMPDIR"); R_dot_Last(); R_RunExitFinalizers(); KillAllDevices(); if(tmpdir) { int rv; /* * length needed = 'rm -rf ""' == 9 * plus 1 for NULL terminator * plus length of dir string */ buf = (char *) palloc(9 + 1 + strlen(tmpdir)); sprintf(buf, "rm -rf \"%s\"", tmpdir); /* ignoring return value */ rv = system(buf); if (rv != 0) ; /* do nothing */ } } static void plr_atexit(void) { /* only react during plr startup */ if (plr_pm_init_done) return; ereport(ERROR, (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE), errmsg("the R interpreter did not initialize"), errhint("R_HOME must be correct in the environment " \ "of the user that starts the postmaster process."))); } /* * plr_init() - Initialize all that's safe to do in the postmaster * * DO NOT make this static --- it has to be callable by preload */ void plr_init(void) { char *r_home; int rargc; char *rargv[] = {"PL/R", "--slave", "--silent", "--no-save", "--no-restore"}; /* refuse to init more than once */ if (plr_pm_init_done) return; /* refuse to start if R_HOME is not defined */ r_home = getenv("R_HOME"); if (r_home == NULL) { size_t rh_len = strlen(R_HOME_DEFAULT); /* see if there is a compiled in default R_HOME */ if (rh_len) { char *rhenv; MemoryContext oldcontext; /* Needs to live until/unless we explicitly delete it */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); rhenv = palloc(8 + rh_len); MemoryContextSwitchTo(oldcontext); sprintf(rhenv, "R_HOME=%s", R_HOME_DEFAULT); putenv(rhenv); } else ereport(ERROR, (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE), errmsg("environment variable R_HOME not defined"), errhint("R_HOME must be defined in the environment " \ "of the user that starts the postmaster process."))); } rargc = sizeof(rargv)/sizeof(rargv[0]); /* * register an exit callback to handle the case where R does not initialize * and just exits with R_suicide() */ atexit(plr_atexit); /* * Stop R using its own signal handlers */ R_SignalHandlers = 0; /* * When initialization fails, R currently exits. Check the return * value anyway in case this ever gets fixed */ if (!Rf_initEmbeddedR(rargc, rargv)) ereport(ERROR, (errcode(ERRCODE_OBJECT_NOT_IN_PREREQUISITE_STATE), errmsg("the R interpreter did not initialize"), errhint("R_HOME must be correct in the environment " \ "of the user that starts the postmaster process."))); /* arrange for automatic cleanup at proc_exit */ on_proc_exit(plr_cleanup, 0); #ifndef WIN32 /* * Force non-interactive mode since R may not do so. * See comment in Rembedded.c just after R_Interactive = TRUE: * "Rf_initialize_R set this based on isatty" * If Postgres still has the tty attached, R_Interactive remains TRUE */ R_Interactive = false; #endif plr_pm_init_done = true; } /* * plr_load_builtins() - load "builtin" PL/R functions into R interpreter */ static void plr_load_builtins(Oid funcid) { int j; char *cmd; char *cmds[] = { /* first turn off error handling by R */ OPTIONS_NULL_CMD, /* set up the postgres error handler in R */ THROWRERROR_CMD, OPTIONS_THROWRERROR_CMD, THROWNOTICE_CMD, THROWERROR_CMD, OPTIONS_THROWWARN_CMD, /* install the commands for SPI support in the interpreter */ QUOTE_LITERAL_CMD, QUOTE_IDENT_CMD, SPI_EXEC_CMD, SPI_PREPARE_CMD, SPI_EXECP_CMD, SPI_CURSOR_OPEN_CMD, SPI_CURSOR_FETCH_CMD, SPI_CURSOR_MOVE_CMD, SPI_CURSOR_CLOSE_CMD, SPI_LASTOID_CMD, SPI_DBDRIVER_CMD, SPI_DBCONN_CMD, SPI_DBSENDQUERY_CMD, SPI_DBFETCH_CMD, SPI_DBCLEARRESULT_CMD, SPI_DBGETQUERY_CMD, SPI_DBREADTABLE_CMD, SPI_DBDISCONN_CMD, SPI_DBUNLOADDRIVER_CMD, SPI_FACTOR_CMD, /* handy predefined R functions */ REVAL, /* terminate */ NULL }; /* * temporarily turn off R error reporting -- it will be turned back on * once the custom R error handler is installed from the plr library */ load_r_cmd(cmds[0]); /* next load the plr library into R */ load_r_cmd(get_load_self_ref_cmd(funcid)); /* * run the rest of the R bootstrap commands, being careful to start * at cmds[1] since we already executed cmds[0] */ for (j = 1; (cmd = cmds[j]); j++) load_r_cmd(cmds[j]); } /* * plr_load_modules() - Load procedures from * table plr_modules (if it exists) * * The caller is responsible to ensure SPI has already been connected * DO NOT make this static --- it has to be callable by reload_plr_modules() */ void plr_load_modules(void) { int spi_rc; char *cmd; int i; int fno; MemoryContext oldcontext; char *modulesSql; /* switch to SPI memory context */ SWITCHTO_PLR_SPI_CONTEXT(oldcontext); /* * Check if table plr_modules exists */ if (!haveModulesTable(plr_nspOid)) { /* clean up if SPI was used, and regardless restore caller's context */ CLEANUP_PLR_SPI_CONTEXT(oldcontext); return; } /* plr_modules table exists -- get SQL code extract table's contents */ modulesSql = getModulesSql(plr_nspOid); /* Read all the row's from it in the order of modseq */ spi_rc = SPI_exec(modulesSql, 0); /* modulesSql no longer needed -- cleanup */ pfree(modulesSql); if (spi_rc != SPI_OK_SELECT) /* internal error */ elog(ERROR, "plr_init_load_modules: select from plr_modules failed"); /* If there's nothing, no modules exist */ if (SPI_processed == 0) { SPI_freetuptable(SPI_tuptable); /* clean up if SPI was used, and regardless restore caller's context */ CLEANUP_PLR_SPI_CONTEXT(oldcontext); return; } /* * There is at least on module to load. Get the * source from the modsrc load it in the R interpreter */ fno = SPI_fnumber(SPI_tuptable->tupdesc, "modsrc"); for (i = 0; i < SPI_processed; i++) { cmd = SPI_getvalue(SPI_tuptable->vals[i], SPI_tuptable->tupdesc, fno); if (cmd != NULL) { load_r_cmd(cmd); pfree(cmd); } } SPI_freetuptable(SPI_tuptable); /* clean up if SPI was used, and regardless restore caller's context */ CLEANUP_PLR_SPI_CONTEXT(oldcontext); } static void plr_init_all(Oid funcid) { MemoryContext oldcontext; /* everything initialized needs to live until/unless we explicitly delete it */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); /* execute postmaster-startup safe initialization */ if (!plr_pm_init_done) plr_init(); /* * Any other initialization that must be done each time a new * backend starts: */ if (!plr_be_init_done) { /* load "builtin" R functions */ plr_load_builtins(funcid); /* obtain & store namespace OID of PL/R language handler */ plr_nspOid = getNamespaceOidFromFunctionOid(funcid); /* try to load procedures from plr_modules */ plr_load_modules(); plr_be_init_done = true; } /* switch back to caller's context */ MemoryContextSwitchTo(oldcontext); } static Datum plr_trigger_handler(PG_FUNCTION_ARGS) { plr_function *function; SEXP fun; SEXP rargs; SEXP rvalue; Datum retval; Datum arg[FUNC_MAX_ARGS]; bool argnull[FUNC_MAX_ARGS]; TriggerData *trigdata = (TriggerData *) fcinfo->context; TupleDesc tupdesc = trigdata->tg_relation->rd_att; Datum *dvalues; ArrayType *array; #define FIXED_NUM_DIMS 1 int ndims = FIXED_NUM_DIMS; int dims[FIXED_NUM_DIMS]; int lbs[FIXED_NUM_DIMS]; #undef FIXED_NUM_DIMS TRIGGERTUPLEVARS; ERRORCONTEXTCALLBACK; int i; if (trigdata->tg_trigger->tgnargs > 0) dvalues = palloc(trigdata->tg_trigger->tgnargs * sizeof(Datum)); else dvalues = NULL; /* Find or compile the function */ function = compile_plr_function(fcinfo); /* set up error context */ PUSH_PLERRCONTEXT(plr_error_callback, function->proname); /* * Build up arguments for the trigger function. The data types * are mostly hardwired in advance */ /* first is trigger name */ arg[0] = DirectFunctionCall1(textin, CStringGetDatum(trigdata->tg_trigger->tgname)); argnull[0] = false; /* second is trigger relation oid */ arg[1] = ObjectIdGetDatum(trigdata->tg_relation->rd_id); argnull[1] = false; /* third is trigger relation name */ arg[2] = DirectFunctionCall1(textin, CStringGetDatum(get_rel_name(trigdata->tg_relation->rd_id))); argnull[2] = false; /* fourth is when trigger fired, i.e. BEFORE or AFTER */ if (TRIGGER_FIRED_BEFORE(trigdata->tg_event)) arg[3] = DirectFunctionCall1(textin, CStringGetDatum("BEFORE")); else if (TRIGGER_FIRED_AFTER(trigdata->tg_event)) arg[3] = DirectFunctionCall1(textin, CStringGetDatum("AFTER")); else /* internal error */ elog(ERROR, "unrecognized tg_event"); argnull[3] = false; /* * fifth is level trigger fired, i.e. ROW or STATEMENT * sixth is operation that fired trigger, i.e. INSERT, UPDATE, or DELETE * seventh is NEW, eigth is OLD */ if (TRIGGER_FIRED_FOR_STATEMENT(trigdata->tg_event)) { arg[4] = DirectFunctionCall1(textin, CStringGetDatum("STATEMENT")); if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) arg[5] = DirectFunctionCall1(textin, CStringGetDatum("INSERT")); else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) arg[5] = DirectFunctionCall1(textin, CStringGetDatum("DELETE")); else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) arg[5] = DirectFunctionCall1(textin, CStringGetDatum("UPDATE")); else /* internal error */ elog(ERROR, "unrecognized tg_event"); arg[6] = (Datum) 0; argnull[6] = true; arg[7] = (Datum) 0; argnull[7] = true; } else if (TRIGGER_FIRED_FOR_ROW(trigdata->tg_event)) { arg[4] = DirectFunctionCall1(textin, CStringGetDatum("ROW")); if (TRIGGER_FIRED_BY_INSERT(trigdata->tg_event)) SET_INSERT_ARGS_567; else if (TRIGGER_FIRED_BY_DELETE(trigdata->tg_event)) SET_DELETE_ARGS_567; else if (TRIGGER_FIRED_BY_UPDATE(trigdata->tg_event)) SET_UPDATE_ARGS_567; else /* internal error */ elog(ERROR, "unrecognized tg_event"); } else /* internal error */ elog(ERROR, "unrecognized tg_event"); argnull[4] = false; argnull[5] = false; /* * finally, ninth argument is a text array of trigger arguments */ for (i = 0; i < trigdata->tg_trigger->tgnargs; i++) dvalues[i] = DirectFunctionCall1(textin, CStringGetDatum(trigdata->tg_trigger->tgargs[i])); dims[0] = trigdata->tg_trigger->tgnargs; lbs[0] = 1; array = construct_md_array(dvalues, NULL, ndims, dims, lbs, TEXTOID, -1, false, 'i'); arg[8] = PointerGetDatum(array); argnull[8] = false; /* * All done building args; from this point it is just like * calling a non-trigger function, except we need to be careful * that the return value tuple is the same tupdesc as the trigger tuple. */ PROTECT(fun = function->fun); /* Convert all call arguments */ PROTECT(rargs = plr_convertargs(function, arg, argnull, fcinfo)); /* Call the R function */ PROTECT(rvalue = call_r_func(fun, rargs)); /* * Convert the return value from an R object to a Datum. * We expect r_get_pg to do the right thing with missing or empty results. */ if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish failed"); retval = r_get_pg(rvalue, function, fcinfo); POP_PLERRCONTEXT; UNPROTECT(3); return retval; } static Datum plr_func_handler(PG_FUNCTION_ARGS) { plr_function *function; SEXP fun; SEXP rargs; SEXP rvalue; Datum retval; ERRORCONTEXTCALLBACK; /* Find or compile the function */ function = compile_plr_function(fcinfo); /* set up error context */ PUSH_PLERRCONTEXT(plr_error_callback, function->proname); PROTECT(fun = function->fun); /* Convert all call arguments */ PROTECT(rargs = plr_convertargs(function, fcinfo->arg, fcinfo->argnull, fcinfo)); /* Call the R function */ PROTECT(rvalue = call_r_func(fun, rargs)); /* * Convert the return value from an R object to a Datum. * We expect r_get_pg to do the right thing with missing or empty results. */ if (SPI_finish() != SPI_OK_FINISH) elog(ERROR, "SPI_finish failed"); retval = r_get_pg(rvalue, function, fcinfo); POP_PLERRCONTEXT; UNPROTECT(3); return retval; } /* ---------- * compile_plr_function * * Note: it's important for this to fall through quickly if the function * has already been compiled. * ---------- */ plr_function * compile_plr_function(FunctionCallInfo fcinfo) { Oid funcOid = fcinfo->flinfo->fn_oid; HeapTuple procTup; Form_pg_proc procStruct; plr_function *function; plr_func_hashkey hashkey; bool hashkey_valid = false; ERRORCONTEXTCALLBACK; /* * Lookup the pg_proc tuple by Oid; we'll need it in any case */ procTup = SearchSysCache(PROCOID, ObjectIdGetDatum(funcOid), 0, 0, 0); if (!HeapTupleIsValid(procTup)) /* internal error */ elog(ERROR, "cache lookup failed for proc %u", funcOid); procStruct = (Form_pg_proc) GETSTRUCT(procTup); /* set up error context */ PUSH_PLERRCONTEXT(plr_error_callback, NameStr(procStruct->proname)); /* * See if there's already a cache entry for the current FmgrInfo. * If not, try to find one in the hash table. */ function = (plr_function *) fcinfo->flinfo->fn_extra; if (!function) { /* First time through in this backend? If so, init hashtable */ if (!plr_HashTable) plr_HashTableInit(); /* Compute hashkey using function signature and actual arg types */ compute_function_hashkey(fcinfo, procStruct, &hashkey); hashkey_valid = true; /* And do the lookup */ function = plr_HashTableLookup(&hashkey); /* * first time through for this statement, set * firstpass to TRUE */ load_r_cmd(PG_STATE_FIRSTPASS); } if (function) { bool function_valid; /* We have a compiled function, but is it still valid? */ if (function->fn_xmin == HeapTupleHeaderGetXmin(procTup->t_data) && ItemPointerEquals(&function->fn_tid, &procTup->t_self)) function_valid = true; else function_valid = false; if (!function_valid) { /* * Nope, drop the hashtable entry. XXX someday, free all the * subsidiary storage as well. */ plr_HashTableDelete(function); /* free some of the subsidiary storage */ xpfree(function->proname); R_ReleaseObject(function->fun); xpfree(function); function = NULL; } } /* * If the function wasn't found or was out-of-date, we have to compile it */ if (!function) { /* * Calculate hashkey if we didn't already; we'll need it to store * the completed function. */ if (!hashkey_valid) compute_function_hashkey(fcinfo, procStruct, &hashkey); /* * Do the hard part. */ function = do_compile(fcinfo, procTup, &hashkey); } ReleaseSysCache(procTup); /* * Save pointer in FmgrInfo to avoid search on subsequent calls */ fcinfo->flinfo->fn_extra = (void *) function; POP_PLERRCONTEXT; /* * Finally return the compiled function */ return function; } /* * This is the slow part of compile_plr_function(). */ static plr_function * do_compile(FunctionCallInfo fcinfo, HeapTuple procTup, plr_func_hashkey *hashkey) { Form_pg_proc procStruct = (Form_pg_proc) GETSTRUCT(procTup); Datum prosrcdatum; bool isnull; bool is_trigger = CALLED_AS_TRIGGER(fcinfo) ? true : false; plr_function *function = NULL; Oid fn_oid = fcinfo->flinfo->fn_oid; char internal_proname[MAX_PRONAME_LEN]; char *proname; Oid result_typid; HeapTuple langTup; HeapTuple typeTup; Form_pg_language langStruct; Form_pg_type typeStruct; StringInfo proc_internal_def = makeStringInfo(); StringInfo proc_internal_args = makeStringInfo(); char *proc_source; MemoryContext oldcontext; char *p; /* grab the function name */ proname = NameStr(procStruct->proname); /* Build our internal proc name from the functions Oid */ sprintf(internal_proname, "PLR%u", fn_oid); /* * analyze the functions arguments and returntype and store * the in-/out-functions in the function block and create * a new hashtable entry for it. * * Then load the procedure into the R interpreter. */ /* the function structure needs to live until we explicitly delete it */ oldcontext = MemoryContextSwitchTo(TopMemoryContext); /* Allocate a new procedure description block */ function = (plr_function *) palloc(sizeof(plr_function)); if (function == NULL) ereport(ERROR, (errcode(ERRCODE_OUT_OF_MEMORY), errmsg("out of memory"))); MemSet(function, 0, sizeof(plr_function)); function->proname = pstrdup(proname); function->fn_xmin = HeapTupleHeaderGetXmin(procTup->t_data); function->fn_tid = procTup->t_self; #ifdef HAVE_WINDOW_FUNCTIONS /* Flag for window functions */ function->iswindow = procStruct->proiswindow; #endif /* Lookup the pg_language tuple by Oid*/ langTup = SearchSysCache(LANGOID, ObjectIdGetDatum(procStruct->prolang), 0, 0, 0); if (!HeapTupleIsValid(langTup)) { xpfree(function->proname); xpfree(function); /* internal error */ elog(ERROR, "cache lookup failed for language %u", procStruct->prolang); } langStruct = (Form_pg_language) GETSTRUCT(langTup); function->lanpltrusted = langStruct->lanpltrusted; ReleaseSysCache(langTup); /* get the functions return type */ if (procStruct->prorettype == ANYARRAYOID || procStruct->prorettype == ANYELEMENTOID) { result_typid = get_fn_expr_rettype(fcinfo->flinfo); if (result_typid == InvalidOid) result_typid = procStruct->prorettype; } else result_typid = procStruct->prorettype; /* * Get the required information for input conversion of the * return value. */ if (!is_trigger) { function->result_typid = result_typid; typeTup = SearchSysCache(TYPEOID, ObjectIdGetDatum(function->result_typid), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { xpfree(function->proname); xpfree(function); /* internal error */ elog(ERROR, "cache lookup failed for return type %u", procStruct->prorettype); } typeStruct = (Form_pg_type) GETSTRUCT(typeTup); /* Disallow pseudotype return type except VOID or RECORD */ /* (note we already replaced ANYARRAY/ANYELEMENT) */ if (typeStruct->typtype == 'p') { if (procStruct->prorettype == VOIDOID || procStruct->prorettype == RECORDOID) /* okay */ ; else if (procStruct->prorettype == TRIGGEROID) { xpfree(function->proname); xpfree(function); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("trigger functions may only be called as triggers"))); } else { xpfree(function->proname); xpfree(function); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("plr functions cannot return type %s", format_type_be(procStruct->prorettype)))); } } if (typeStruct->typrelid != InvalidOid || procStruct->prorettype == RECORDOID) function->result_istuple = true; perm_fmgr_info(typeStruct->typinput, &(function->result_in_func)); if (function->result_istuple) { int16 typlen; bool typbyval; char typdelim; Oid typinput, typelem; FmgrInfo inputproc; char typalign; TupleDesc tupdesc; int i; ReturnSetInfo *rsinfo = (ReturnSetInfo *) fcinfo->resultinfo; /* check to see if caller supports us returning a tuplestore */ if (!rsinfo || !(rsinfo->allowedModes & SFRM_Materialize) || rsinfo->expectedDesc == NULL) ereport(ERROR, (errcode(ERRCODE_SYNTAX_ERROR), errmsg("materialize mode required, but it is not " "allowed in this context"))); tupdesc = rsinfo->expectedDesc; function->result_natts = tupdesc->natts; function->result_fld_elem_typid = (Oid *) palloc0(function->result_natts * sizeof(Oid)); function->result_fld_elem_in_func = (FmgrInfo *) palloc0(function->result_natts * sizeof(FmgrInfo)); function->result_fld_elem_typlen = (int *) palloc0(function->result_natts * sizeof(int)); function->result_fld_elem_typbyval = (bool *) palloc0(function->result_natts * sizeof(bool)); function->result_fld_elem_typalign = (char *) palloc0(function->result_natts * sizeof(char)); for (i = 0; i < function->result_natts; i++) { function->result_fld_elem_typid[i] = get_element_type(tupdesc->attrs[i]->atttypid); if (OidIsValid(function->result_fld_elem_typid[i])) { get_type_io_data(function->result_fld_elem_typid[i], IOFunc_input, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typinput); perm_fmgr_info(typinput, &inputproc); function->result_fld_elem_in_func[i] = inputproc; function->result_fld_elem_typbyval[i] = typbyval; function->result_fld_elem_typlen[i] = typlen; function->result_fld_elem_typalign[i] = typalign; } } } else { /* * Is return type an array? get_element_type will return InvalidOid * instead of actual element type if the type is not a varlena array. */ if (OidIsValid(get_element_type(function->result_typid))) function->result_elem = typeStruct->typelem; else /* not an array */ function->result_elem = InvalidOid; /* * if we have an array type, get the element type's in_func */ if (function->result_elem != InvalidOid) { int16 typlen; bool typbyval; char typdelim; Oid typinput, typelem; FmgrInfo inputproc; char typalign; get_type_io_data(function->result_elem, IOFunc_input, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typinput); perm_fmgr_info(typinput, &inputproc); function->result_elem_in_func = inputproc; function->result_elem_typbyval = typbyval; function->result_elem_typlen = typlen; function->result_elem_typalign = typalign; } } ReleaseSysCache(typeTup); } else /* trigger */ { function->result_typid = TRIGGEROID; function->result_istuple = true; function->result_elem = InvalidOid; } /* * Get the required information for output conversion * of all procedure arguments */ if (!is_trigger) { int i; bool forValidator = false; int numargs; Oid *argtypes; char **argnames; char *argmodes; numargs = get_func_arg_info(procTup, &argtypes, &argnames, &argmodes); plr_resolve_polymorphic_argtypes(numargs, argtypes, argmodes, fcinfo->flinfo->fn_expr, forValidator, function->proname); function->nargs = procStruct->pronargs; for (i = 0; i < function->nargs; i++) { char argmode = argmodes ? argmodes[i] : PROARGMODE_IN; if (argmode != PROARGMODE_IN && argmode != PROARGMODE_INOUT && argmode != PROARGMODE_VARIADIC) continue; /* * Since we already did the replacement of polymorphic * argument types by actual argument types while computing * the hashkey, we can just use those results. */ function->arg_typid[i] = hashkey->argtypes[i]; typeTup = SearchSysCache(TYPEOID, ObjectIdGetDatum(function->arg_typid[i]), 0, 0, 0); if (!HeapTupleIsValid(typeTup)) { Oid arg_typid = function->arg_typid[i]; xpfree(function->proname); xpfree(function); /* internal error */ elog(ERROR, "cache lookup failed for argument type %u", arg_typid); } typeStruct = (Form_pg_type) GETSTRUCT(typeTup); /* Disallow pseudotype argument * note we already replaced ANYARRAY/ANYELEMENT */ if (typeStruct->typtype == 'p') { Oid arg_typid = function->arg_typid[i]; xpfree(function->proname); xpfree(function); ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("plr functions cannot take type %s", format_type_be(arg_typid)))); } if (typeStruct->typrelid != InvalidOid) function->arg_is_rel[i] = 1; else function->arg_is_rel[i] = 0; perm_fmgr_info(typeStruct->typoutput, &(function->arg_out_func[i])); /* save argument typbyval in case we need for optimization in conversions */ function->arg_typbyval[i] = typeStruct->typbyval; /* * Is argument type an array? get_element_type will return InvalidOid * instead of actual element type if the type is not a varlena array. */ if (OidIsValid(get_element_type(function->arg_typid[i]))) function->arg_elem[i] = typeStruct->typelem; else /* not ant array */ function->arg_elem[i] = InvalidOid; if (i > 0) appendStringInfo(proc_internal_args, ","); SET_ARG_NAME; ReleaseSysCache(typeTup); if (function->arg_elem[i] != InvalidOid) { int16 typlen; bool typbyval; char typdelim; Oid typoutput, typelem; FmgrInfo outputproc; char typalign; get_type_io_data(function->arg_elem[i], IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typoutput); perm_fmgr_info(typoutput, &outputproc); function->arg_elem_out_func[i] = outputproc; function->arg_elem_typbyval[i] = typbyval; function->arg_elem_typlen[i] = typlen; function->arg_elem_typalign[i] = typalign; } } FREE_ARG_NAMES; #ifdef HAVE_WINDOW_FUNCTIONS if (function->iswindow) { for (i = 0; i < function->nargs; i++) { appendStringInfo(proc_internal_args, ","); SET_FRAME_ARG_NAME; } SET_FRAME_XARG_NAMES; } #endif } else { int16 typlen; bool typbyval; char typdelim; Oid typoutput, typelem; FmgrInfo outputproc; char typalign; function->nargs = TRIGGER_NARGS; /* take care of the only non-TEXT first */ get_type_io_data(OIDOID, IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typoutput); function->arg_typid[1] = OIDOID; function->arg_elem[1] = InvalidOid; function->arg_is_rel[1] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[1])); get_type_io_data(TEXTOID, IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typoutput); function->arg_typid[0] = TEXTOID; function->arg_elem[0] = InvalidOid; function->arg_is_rel[0] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[0])); function->arg_typid[2] = TEXTOID; function->arg_elem[2] = InvalidOid; function->arg_is_rel[2] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[2])); function->arg_typid[3] = TEXTOID; function->arg_elem[3] = InvalidOid; function->arg_is_rel[3] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[3])); function->arg_typid[4] = TEXTOID; function->arg_elem[4] = InvalidOid; function->arg_is_rel[4] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[4])); function->arg_typid[5] = TEXTOID; function->arg_elem[5] = InvalidOid; function->arg_is_rel[5] = 0; perm_fmgr_info(typoutput, &(function->arg_out_func[5])); function->arg_typid[6] = RECORDOID; function->arg_elem[6] = InvalidOid; function->arg_is_rel[6] = 1; function->arg_typid[7] = RECORDOID; function->arg_elem[7] = InvalidOid; function->arg_is_rel[7] = 1; function->arg_typid[8] = TEXTARRAYOID; function->arg_elem[8] = TEXTOID; function->arg_is_rel[8] = 0; get_type_io_data(function->arg_elem[8], IOFunc_output, &typlen, &typbyval, &typalign, &typdelim, &typelem, &typoutput); perm_fmgr_info(typoutput, &outputproc); function->arg_elem_out_func[8] = outputproc; function->arg_elem_typbyval[8] = typbyval; function->arg_elem_typlen[8] = typlen; function->arg_elem_typalign[8] = typalign; /* trigger procedure has fixed args */ appendStringInfo(proc_internal_args, "pg.tg.name,pg.tg.relid,pg.tg.relname,pg.tg.when," "pg.tg.level,pg.tg.op,pg.tg.new,pg.tg.old,pg.tg.args"); } /* * Create the R command to define the internal * procedure */ appendStringInfo(proc_internal_def, "%s <- function(%s) {", internal_proname, proc_internal_args->data); /* Add user's function definition to proc body */ prosrcdatum = SysCacheGetAttr(PROCOID, procTup, Anum_pg_proc_prosrc, &isnull); if (isnull) elog(ERROR, "null prosrc"); proc_source = DatumGetCString(DirectFunctionCall1(textout, prosrcdatum)); /* * replace any carriage returns with either a space or a newline, * as appropriate */ p = proc_source; while (*p != '\0') { if (p[0] == '\r') { if (p[1] == '\n') /* for crlf sequence, write over the cr with a space */ *p++ = ' '; else /* otherwise write over the cr with a nl */ *p++ = '\n'; } else p++; } /* parse or find the R function */ if(proc_source && proc_source[0]) appendStringInfo(proc_internal_def, "%s}", proc_source); else appendStringInfo(proc_internal_def, "%s(%s)}", function->proname, proc_internal_args->data); function->fun = plr_parse_func_body(proc_internal_def->data); R_PreserveObject(function->fun); pfree(proc_source); freeStringInfo(proc_internal_def); /* test that this is really a function. */ if(function->fun == R_NilValue) { xpfree(function->proname); xpfree(function); /* internal error */ elog(ERROR, "cannot create internal procedure %s", internal_proname); } /* switch back to the context we were called with */ MemoryContextSwitchTo(oldcontext); /* * add it to the hash table */ plr_HashTableInsert(function, hashkey); return function; } static SEXP plr_parse_func_body(const char *body) { SEXP rbody; SEXP fun; SEXP tmp; int status; PROTECT(rbody = mkString(body)); PROTECT(tmp = R_PARSEVECTOR(rbody, -1, &status)); if (tmp != R_NilValue) PROTECT(fun = VECTOR_ELT(tmp, 0)); else PROTECT(fun = R_NilValue); if (status != PARSE_OK) { UNPROTECT(3); if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter parse error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter parse error"), errdetail("R parse error caught " \ "in \"%s\".", body))); } UNPROTECT(3); return(fun); } SEXP call_r_func(SEXP fun, SEXP rargs) { int i; int errorOccurred; SEXP obj, args, call, ans; long n = length(rargs); if(n > 0) { PROTECT(obj = args = allocList(n)); for (i = 0; i < n; i++) { SETCAR(obj, VECTOR_ELT(rargs, i)); obj = CDR(obj); } UNPROTECT(1); /* * NB: the headers of both R and Postgres define a function * called lcons, so use the full name to be precise about what * function we're calling. */ PROTECT(call = Rf_lcons(fun, args)); } else { PROTECT(call = allocVector(LANGSXP,1)); SETCAR(call, fun); } ans = R_tryEval(call, R_GlobalEnv, &errorOccurred); UNPROTECT(1); if(errorOccurred) { if (last_R_error_msg) ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"), errdetail("%s", last_R_error_msg))); else ereport(ERROR, (errcode(ERRCODE_DATA_EXCEPTION), errmsg("R interpreter expression evaluation error"))); } return ans; } static SEXP plr_convertargs(plr_function *function, Datum *arg, bool *argnull, FunctionCallInfo fcinfo) { int i; int m = 1; int c = 0; SEXP rargs, el; #ifdef HAVE_WINDOW_FUNCTIONS if (function->iswindow) { /* * For WINDOW functions, create an array of R objects with * the number of elements equal to twice the number of arguments. */ m = 2; c = 2; } #endif /* * Create an array of R objects with the number of elements * as a function of the number of arguments. */ PROTECT(rargs = allocVector(VECSXP, c + (m * function->nargs))); /* * iterate over the arguments, convert each of them and put them in * the array. */ for (i = 0; i < function->nargs; i++) { #ifdef HAVE_WINDOW_FUNCTIONS if (!function->iswindow) { #endif if (argnull[i]) { /* fast track for null arguments */ PROTECT(el = R_NilValue); } else if (function->arg_is_rel[i]) { /* for tuple args, convert to a one row data.frame */ CONVERT_TUPLE_TO_DATAFRAME; } else if (function->arg_elem[i] == InvalidOid) { /* for scalar args, convert to a one row vector */ Datum dvalue = arg[i]; Oid arg_typid = function->arg_typid[i]; FmgrInfo arg_out_func = function->arg_out_func[i]; PROTECT(el = pg_scalar_get_r(dvalue, arg_typid, arg_out_func)); } else { /* better be a pg array arg, convert to a multi-row vector */ Datum dvalue = (Datum) PG_DETOAST_DATUM(arg[i]); FmgrInfo out_func = function->arg_elem_out_func[i]; int typlen = function->arg_elem_typlen[i]; bool typbyval = function->arg_elem_typbyval[i]; char typalign = function->arg_elem_typalign[i]; PROTECT(el = pg_array_get_r(dvalue, out_func, typlen, typbyval, typalign)); } SET_VECTOR_ELT(rargs, i, el); UNPROTECT(1); #ifdef HAVE_WINDOW_FUNCTIONS } else { Datum dvalue; bool isnull; WindowObject winobj = PG_WINDOW_OBJECT(); /* get datum for the current row of the window frame */ dvalue = WinGetFuncArgInFrame(winobj, i, 0, WINDOW_SEEK_CURRENT, false, &isnull, NULL); if (isnull) { /* fast track for null arguments */ PROTECT(el = R_NilValue); } else if (function->arg_is_rel[i]) { /* keep compiler quiet */ el = R_NilValue; elog(ERROR, "Tuple arguments not supported in PL/R Window Functions"); } else if (function->arg_elem[i] == InvalidOid) { /* for scalar args, convert to a one row vector */ Oid arg_typid = function->arg_typid[i]; FmgrInfo arg_out_func = function->arg_out_func[i]; PROTECT(el = pg_scalar_get_r(dvalue, arg_typid, arg_out_func)); } else { /* better be a pg array arg, convert to a multi-row vector */ FmgrInfo out_func = function->arg_elem_out_func[i]; int typlen = function->arg_elem_typlen[i]; bool typbyval = function->arg_elem_typbyval[i]; char typalign = function->arg_elem_typalign[i]; dvalue = (Datum) PG_DETOAST_DATUM(dvalue); PROTECT(el = pg_array_get_r(dvalue, out_func, typlen, typbyval, typalign)); } SET_VECTOR_ELT(rargs, i, el); UNPROTECT(1); } #endif } #ifdef HAVE_WINDOW_FUNCTIONS /* now get an array of datums for the entire window frame for each argument */ if (function->iswindow) { WindowObject winobj = PG_WINDOW_OBJECT(); int64 totalrows = WinGetPartitionRowCount(winobj); int numels = 0; for (i = 0; i < function->nargs; i++) { Datum *dvalues = palloc0(totalrows * sizeof(Datum)); bool *isnulls = palloc0(totalrows * sizeof(bool)); Oid datum_typid; FmgrInfo datum_out_func; bool datum_typbyval; bool has_nulls; WinGetFrameData(winobj, i, dvalues, isnulls, &numels, &has_nulls); datum_typid = function->arg_typid[i]; datum_out_func = function->arg_out_func[i]; datum_typbyval = function->arg_typbyval[i]; PROTECT(el = pg_datum_array_get_r(dvalues, isnulls, numels, has_nulls, datum_typid, datum_out_func, datum_typbyval)); /* * We already set function->nargs arguments * so we must start with a function->nargs */ SET_VECTOR_ELT(rargs, function->nargs + i, el); UNPROTECT(1); } /* fnumrows */ PROTECT(el = NEW_NUMERIC(1)); NUMERIC_DATA(el)[0] = (double) numels; SET_VECTOR_ELT(rargs, m * function->nargs + 0, el); UNPROTECT(1); /* prownum */ PROTECT(el = NEW_NUMERIC(1)); NUMERIC_DATA(el)[0] = (double) WinGetCurrentPosition(winobj) + 1;; SET_VECTOR_ELT(rargs, m * function->nargs + 1, el); UNPROTECT(1); } #endif UNPROTECT(1); return(rargs); } /* * error context callback to let us supply a call-stack traceback */ static void plr_error_callback(void *arg) { if (arg) errcontext("In PL/R function %s", (char *) arg); } /* * getNamespaceOidFromFunctionOid - Returns the OID of the namespace for the * language handler function for the postgresql function with the OID equal * to the input argument. */ static Oid getNamespaceOidFromFunctionOid(Oid fnOid) { HeapTuple procTuple; HeapTuple langTuple; Form_pg_proc procStruct; Form_pg_language langStruct; Oid langOid; Oid hfnOid; Oid nspOid; /* Lookup the pg_proc tuple for the called function by OID */ procTuple = SearchSysCache(PROCOID, ObjectIdGetDatum(fnOid), 0, 0, 0); if (!HeapTupleIsValid(procTuple)) /* internal error */ elog(ERROR, "cache lookup failed for function %u", fnOid); procStruct = (Form_pg_proc) GETSTRUCT(procTuple); langOid = procStruct->prolang; ReleaseSysCache(procTuple); /* Lookup the pg_language tuple by OID */ langTuple = SearchSysCache(LANGOID, ObjectIdGetDatum(langOid), 0, 0, 0); if (!HeapTupleIsValid(langTuple)) /* internal error */ elog(ERROR, "cache lookup failed for language %u", langOid); langStruct = (Form_pg_language) GETSTRUCT(langTuple); hfnOid = langStruct->lanplcallfoid; ReleaseSysCache(langTuple); /* Lookup the pg_proc tuple for the language handler by OID */ procTuple = SearchSysCache(PROCOID, ObjectIdGetDatum(hfnOid), 0, 0, 0); if (!HeapTupleIsValid(procTuple)) /* internal error */ elog(ERROR, "cache lookup failed for function %u", hfnOid); procStruct = (Form_pg_proc) GETSTRUCT(procTuple); nspOid = procStruct->pronamespace; ReleaseSysCache(procTuple); return nspOid; } /* * haveModulesTable(Oid) -- Check if table plr_modules exists in the namespace * designated by the OID input argument. */ static bool haveModulesTable(Oid nspOid) { StringInfo sql = makeStringInfo(); char *sql_format = "SELECT NULL " "FROM pg_catalog.pg_class " "WHERE " "relname = 'plr_modules' AND " "relnamespace = %u"; int spiRc; appendStringInfo(sql, sql_format, nspOid); spiRc = SPI_exec(sql->data, 1); if (spiRc != SPI_OK_SELECT) /* internal error */ elog(ERROR, "haveModulesTable: select from pg_class failed"); return SPI_processed == 1; } /* * getModulesSql(Oid) - Builds and returns SQL needed to extract contents from * plr_modules table. The table must exist in the namespace designated by the * OID input argument. Results are ordered by the "modseq" field. * * IMPORTANT: return value must be pfree'd */ static char * getModulesSql(Oid nspOid) { StringInfo sql = makeStringInfo(); char *sql_format = "SELECT modseq, modsrc " "FROM %s " "ORDER BY modseq"; appendStringInfo(sql, sql_format, quote_qualified_identifier(get_namespace_name(nspOid), "plr_modules")); return sql->data; } #ifdef DEBUGPROTECT SEXP pg_protect(SEXP s, char *fn, int ln) { elog(NOTICE, "\tPROTECT\t1\t%s\t%d", fn, ln); return protect(s); } void pg_unprotect(int n, char *fn, int ln) { elog(NOTICE, "\tUNPROTECT\t%d\t%s\t%d", n, fn, ln); unprotect(n); } #endif /* DEBUGPROTECT */ #ifdef HAVE_WINDOW_FUNCTIONS /* * WinGetFrameData * Evaluate a window function's argument expression on a specified * window frame, returning an array of Datums for the frame * * argno: argument number to evaluate (counted from 0) * isnull: output argument, receives isnull status of result */ static void WinGetFrameData(WindowObject winobj, int argno, Datum *dvalues, bool *isnulls, int *numels, bool *has_nulls) { int64 i = 0; *has_nulls = false; for(;;) { Datum lcl_dvalue; bool lcl_isnull; bool isout; bool set_mark; if (i > 0) set_mark = false; else set_mark = true; lcl_dvalue = WinGetFuncArgInFrame(winobj, argno, i, WINDOW_SEEK_HEAD, set_mark, &lcl_isnull, &isout); if (!isout) { dvalues[i] = lcl_dvalue; isnulls[i] = lcl_isnull; if (lcl_isnull) *has_nulls = true; } else { *numels = i; break; } i++; }; } #endif /* * swiped out of plpgsql pl_comp.c * * This is the same as the standard resolve_polymorphic_argtypes() function, * but with a special case for validation: assume that polymorphic arguments * are integer, integer-array or integer-range. Also, we go ahead and report * the error if we can't resolve the types. */ static void plr_resolve_polymorphic_argtypes(int numargs, Oid *argtypes, char *argmodes, Node *call_expr, bool forValidator, const char *proname) { int i; if (!forValidator) { /* normal case, pass to standard routine */ if (!resolve_polymorphic_argtypes(numargs, argtypes, argmodes, call_expr)) ereport(ERROR, (errcode(ERRCODE_FEATURE_NOT_SUPPORTED), errmsg("could not determine actual argument " "type for polymorphic function \"%s\"", proname))); } else { /* special validation case */ for (i = 0; i < numargs; i++) { switch (argtypes[i]) { case ANYELEMENTOID: case ANYNONARRAYOID: case ANYENUMOID: /* XXX dubious */ argtypes[i] = INT4OID; break; case ANYARRAYOID: argtypes[i] = INT4ARRAYOID; break; #ifdef ANYRANGEOID case ANYRANGEOID: argtypes[i] = INT4RANGEOID; break; #endif default: break; } } } } plr-REL8_3_0_17/plr.control000066400000000000000000000002531277274236600155520ustar00rootroot00000000000000# plr extension comment = 'load R interpreter and execute R script from within a database' default_version = '8.3.0.17' module_pathname = '$libdir/plr' relocatable = true plr-REL8_3_0_17/plr.h000077500000000000000000000405441277274236600143330ustar00rootroot00000000000000/* * PL/R - PostgreSQL support for R as a * procedural language (PL) * * Copyright (c) 2003-2015 by Joseph E. Conway * ALL RIGHTS RESERVED * * Joe Conway * * Based on pltcl by Jan Wieck * and inspired by REmbeddedPostgres by * Duncan Temple Lang * http://www.omegahat.org/RSPostgres/ * * License: GPL version 2 or newer. http://www.gnu.org/copyleft/gpl.html * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by * the Free Software Foundation; either version 2 of the License, or * (at your option) any later version. * * This program is distributed in the hope that it will be useful, * but WITHOUT ANY WARRANTY; without even the implied warranty of * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the * GNU General Public License for more details. * * You should have received a copy of the GNU General Public License * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA * * plr.h */ #ifndef PLR_H #define PLR_H #define PLR_VERSION "08.03.00.17" #include "postgres.h" #include "fmgr.h" #include "funcapi.h" #include "miscadmin.h" #if PG_VERSION_NUM >= 80400 #include "windowapi.h" #endif #include "access/heapam.h" #if PG_VERSION_NUM >= 90300 #include "access/htup_details.h" #else #include "access/htup.h" #endif #include "catalog/catversion.h" #include "catalog/pg_language.h" #include "catalog/pg_namespace.h" #include "catalog/pg_proc.h" #include "catalog/pg_type.h" #include "commands/trigger.h" #include "executor/spi.h" #include "lib/stringinfo.h" #include "nodes/makefuncs.h" #include "optimizer/clauses.h" #include "parser/parse_type.h" #include "storage/ipc.h" #include "tcop/tcopprot.h" #include "utils/array.h" #include "utils/builtins.h" #if PG_VERSION_NUM >= 80500 #include "utils/bytea.h" #endif #include "utils/lsyscache.h" #include "utils/memutils.h" #include "utils/rel.h" #include "utils/syscache.h" #include "utils/typcache.h" #include #include #include #include #include /* * The R headers define various symbols that are also defined by the * Postgres headers, so undef them first to avoid conflicts. */ #ifdef ERROR #undef ERROR #endif #ifdef WARNING #undef WARNING #endif #include "R.h" #include "Rversion.h" /* * R version is calculated thus: * Maj * 65536 + Minor * 256 + Build * 1 * So: * version 1.8.0 results in: * (1 * 65536) + (8 * 256) + (0 * 1) == 67584 * version 1.9.0 results in: * (1 * 65536) + (9 * 256) + (0 * 1) == 67840 */ #if (R_VERSION >= 132096) /* R_VERSION >= 2.4.0 */ #include "Rembedded.h" #endif #if !defined(WIN32) && !defined(WIN64) #include "Rinterface.h" #else extern int R_SignalHandlers; #endif #include "Rinternals.h" #include "Rdefines.h" #if (R_VERSION < 133120) /* R_VERSION < 2.8.0 */ #include "Rdevices.h" #endif /* Restore the Postgres headers */ #ifdef ERROR #undef ERROR #endif #ifdef WARNING #undef WARNING #endif #define WARNING 19 #define ERROR 20 /* starting in R-2.7.0 this defn was removed from Rdevices.h */ #ifndef KillAllDevices #define KillAllDevices Rf_KillAllDevices #endif /* for some reason this is not in any R header files, it is locally defined */ #define INTEGER_ELT(x,__i__) INTEGER(x)[__i__] #ifndef R_HOME_DEFAULT #define R_HOME_DEFAULT "" #endif /* working with postgres 7.3 compatible sources */ #if !defined(PG_VERSION_NUM) || PG_VERSION_NUM < 80200 #error "This version of PL/R only builds with PostgreSQL 8.2 or later" #elif PG_VERSION_NUM < 80300 #define PG_VERSION_82_COMPAT #elif PG_VERSION_NUM < 80400 #define PG_VERSION_83_COMPAT #else #define PG_VERSION_84_COMPAT #endif #ifdef PG_VERSION_84_COMPAT #define HAVE_WINDOW_FUNCTIONS #endif #ifdef DEBUGPROTECT #undef PROTECT extern SEXP pg_protect(SEXP s, char *fn, int ln); #define PROTECT(s) pg_protect(s, __FILE__, __LINE__) #undef UNPROTECT extern void pg_unprotect(int n, char *fn, int ln); #define UNPROTECT(n) pg_unprotect(n, __FILE__, __LINE__) #endif /* DEBUGPROTECT */ #define xpfree(var_) \ do { \ if (var_ != NULL) \ { \ pfree(var_); \ var_ = NULL; \ } \ } while (0) #define freeStringInfo(mystr_) \ do { \ xpfree((mystr_)->data); \ xpfree(mystr_); \ } while (0) #define NEXT_STR_ELEMENT " %s" #if (R_VERSION < 67840) /* R_VERSION < 1.9.0 */ #define SET_COLUMN_NAMES \ do { \ int i; \ char *names_buf; \ names_buf = SPI_fname(tupdesc, j + 1); \ for (i = 0; i < strlen(names_buf); i++) { \ if (names_buf[i] == '_') \ names_buf[i] = '.'; \ } \ SET_STRING_ELT(names, df_colnum, mkChar(names_buf)); \ pfree(names_buf); \ } while (0) #else /* R_VERSION >= 1.9.0 */ #define SET_COLUMN_NAMES \ do { \ char *names_buf; \ names_buf = SPI_fname(tupdesc, j + 1); \ SET_STRING_ELT(names, df_colnum, mkChar(names_buf)); \ pfree(names_buf); \ } while (0) #endif #if (R_VERSION < 67584) /* R_VERSION < 1.8.0 */ /* * See the non-exported header file ${R_HOME}/src/include/Parse.h */ extern SEXP R_ParseVector(SEXP, int, int *); #define PARSE_NULL 0 #define PARSE_OK 1 #define PARSE_INCOMPLETE 2 #define PARSE_ERROR 3 #define PARSE_EOF 4 #define R_PARSEVECTOR(a_, b_, c_) R_ParseVector(a_, b_, c_) /* * See the non-exported header file ${R_HOME}/src/include/Defn.h */ extern void R_PreserveObject(SEXP); extern void R_ReleaseObject(SEXP); /* in main.c */ extern void R_dot_Last(void); /* in memory.c */ extern void R_RunExitFinalizers(void); #else /* R_VERSION >= 1.8.0 */ #include "R_ext/Parse.h" #if (R_VERSION >= 132352) /* R_VERSION >= 2.5.0 */ #define R_PARSEVECTOR(a_, b_, c_) R_ParseVector(a_, b_, (ParseStatus *) c_, R_NilValue) #else /* R_VERSION < 2.5.0 */ #define R_PARSEVECTOR(a_, b_, c_) R_ParseVector(a_, b_, (ParseStatus *) c_) #endif /* R_VERSION >= 2.5.0 */ #endif /* R_VERSION >= 1.8.0 */ /* convert C string to text pointer */ #define PG_TEXT_GET_STR(textp_) \ DatumGetCString(DirectFunctionCall1(textout, PointerGetDatum(textp_))) #define PG_STR_GET_TEXT(str_) \ DatumGetTextP(DirectFunctionCall1(textin, CStringGetDatum(str_))) #define PG_REPLACE_STR(str_, substr_, replacestr_) \ PG_TEXT_GET_STR(DirectFunctionCall3(replace_text, \ PG_STR_GET_TEXT(str_), \ PG_STR_GET_TEXT(substr_), \ PG_STR_GET_TEXT(replacestr_))) /* initial number of hash table entries for compiled functions */ #define FUNCS_PER_USER 64 #define ERRORCONTEXTCALLBACK \ ErrorContextCallback plerrcontext #define PUSH_PLERRCONTEXT(_error_callback_, _plr_error_funcname_) \ do { \ plerrcontext.callback = _error_callback_; \ plerrcontext.arg = (void *) pstrdup(_plr_error_funcname_); \ plerrcontext.previous = error_context_stack; \ error_context_stack = &plerrcontext; \ } while (0) #define POP_PLERRCONTEXT \ do { \ pfree(plerrcontext.arg); \ error_context_stack = plerrcontext.previous; \ } while (0) #define SAVE_PLERRCONTEXT \ ErrorContextCallback *ecs_save; \ do { \ ecs_save = error_context_stack; \ error_context_stack = NULL; \ } while (0) #define RESTORE_PLERRCONTEXT \ do { \ error_context_stack = ecs_save; \ } while (0) #ifndef TEXTARRAYOID #define TEXTARRAYOID 1009 #endif #define TRIGGER_NARGS 9 #define TUPLESTORE_BEGIN_HEAP tuplestore_begin_heap(true, false, work_mem) #define INIT_AUX_FMGR_ATTS \ do { \ finfo->fn_mcxt = plr_caller_context; \ finfo->fn_expr = (Node *) NULL; \ } while (0) #define PROARGTYPES(i) \ procStruct->proargtypes.values[i] #define FUNCARGTYPES(_tup_) \ ((Form_pg_proc) GETSTRUCT(_tup_))->proargtypes.values #define PLR_CLEANUP \ plr_cleanup(int code, Datum arg) #define TRIGGERTUPLEVARS \ HeapTuple tup; \ HeapTupleHeader dnewtup; \ HeapTupleHeader dtrigtup #define SET_INSERT_ARGS_567 \ do { \ arg[5] = DirectFunctionCall1(textin, CStringGetDatum("INSERT")); \ tup = trigdata->tg_trigtuple; \ dtrigtup = (HeapTupleHeader) palloc(tup->t_len); \ memcpy((char *) dtrigtup, (char *) tup->t_data, tup->t_len); \ HeapTupleHeaderSetDatumLength(dtrigtup, tup->t_len); \ HeapTupleHeaderSetTypeId(dtrigtup, tupdesc->tdtypeid); \ HeapTupleHeaderSetTypMod(dtrigtup, tupdesc->tdtypmod); \ arg[6] = PointerGetDatum(dtrigtup); \ argnull[6] = false; \ arg[7] = (Datum) 0; \ argnull[7] = true; \ } while (0) #define SET_DELETE_ARGS_567 \ do { \ arg[5] = DirectFunctionCall1(textin, CStringGetDatum("DELETE")); \ arg[6] = (Datum) 0; \ argnull[6] = true; \ tup = trigdata->tg_trigtuple; \ dtrigtup = (HeapTupleHeader) palloc(tup->t_len); \ memcpy((char *) dtrigtup, (char *) tup->t_data, tup->t_len); \ HeapTupleHeaderSetDatumLength(dtrigtup, tup->t_len); \ HeapTupleHeaderSetTypeId(dtrigtup, tupdesc->tdtypeid); \ HeapTupleHeaderSetTypMod(dtrigtup, tupdesc->tdtypmod); \ arg[7] = PointerGetDatum(dtrigtup); \ argnull[7] = false; \ } while (0) #define SET_UPDATE_ARGS_567 \ do { \ arg[5] = DirectFunctionCall1(textin, CStringGetDatum("UPDATE")); \ tup = trigdata->tg_newtuple; \ dnewtup = (HeapTupleHeader) palloc(tup->t_len); \ memcpy((char *) dnewtup, (char *) tup->t_data, tup->t_len); \ HeapTupleHeaderSetDatumLength(dnewtup, tup->t_len); \ HeapTupleHeaderSetTypeId(dnewtup, tupdesc->tdtypeid); \ HeapTupleHeaderSetTypMod(dnewtup, tupdesc->tdtypmod); \ arg[6] = PointerGetDatum(dnewtup); \ argnull[6] = false; \ tup = trigdata->tg_trigtuple; \ dtrigtup = (HeapTupleHeader) palloc(tup->t_len); \ memcpy((char *) dtrigtup, (char *) tup->t_data, tup->t_len); \ HeapTupleHeaderSetDatumLength(dtrigtup, tup->t_len); \ HeapTupleHeaderSetTypeId(dtrigtup, tupdesc->tdtypeid); \ HeapTupleHeaderSetTypMod(dtrigtup, tupdesc->tdtypmod); \ arg[7] = PointerGetDatum(dtrigtup); \ argnull[7] = false; \ } while (0) #define CONVERT_TUPLE_TO_DATAFRAME \ do { \ Oid tupType; \ int32 tupTypmod; \ TupleDesc tupdesc; \ HeapTuple tuple = palloc(sizeof(HeapTupleData)); \ HeapTupleHeader tuple_hdr = DatumGetHeapTupleHeader(arg[i]); \ tupType = HeapTupleHeaderGetTypeId(tuple_hdr); \ tupTypmod = HeapTupleHeaderGetTypMod(tuple_hdr); \ tupdesc = lookup_rowtype_tupdesc(tupType, tupTypmod); \ tuple->t_len = HeapTupleHeaderGetDatumLength(tuple_hdr); \ ItemPointerSetInvalid(&(tuple->t_self)); \ tuple->t_tableOid = InvalidOid; \ tuple->t_data = tuple_hdr; \ PROTECT(el = pg_tuple_get_r_frame(1, &tuple, tupdesc)); \ ReleaseTupleDesc(tupdesc); \ pfree(tuple); \ } while (0) #define GET_ARG_NAMES \ char **argnames; \ argnames = fetchArgNames(procTup, procStruct->pronargs) #define SET_ARG_NAME \ do { \ if (argnames && argnames[i] && argnames[i][0]) \ { \ appendStringInfo(proc_internal_args, "%s", argnames[i]); \ pfree(argnames[i]); \ } \ else \ appendStringInfo(proc_internal_args, "arg%d", i + 1); \ } while (0) #define SET_FRAME_ARG_NAME \ do { \ appendStringInfo(proc_internal_args, "farg%d", i + 1); \ } while (0) #define SET_FRAME_XARG_NAMES \ do { \ appendStringInfo(proc_internal_args, ",fnumrows,prownum"); \ } while (0) #define FREE_ARG_NAMES \ do { \ if (argnames) \ pfree(argnames); \ } while (0) #define PREPARE_PG_TRY \ ERRORCONTEXTCALLBACK #define SWITCHTO_PLR_SPI_CONTEXT(the_caller_context) \ the_caller_context = MemoryContextSwitchTo(plr_SPI_context) #define CLEANUP_PLR_SPI_CONTEXT(the_caller_context) \ MemoryContextSwitchTo(the_caller_context) #define PLR_PG_CATCH() \ PG_CATCH(); \ { \ MemoryContext temp_context; \ ErrorData *edata; \ SWITCHTO_PLR_SPI_CONTEXT(temp_context); \ edata = CopyErrorData(); \ MemoryContextSwitchTo(temp_context); \ error("error in SQL statement : %s", edata->message); \ } #define PLR_PG_END_TRY() \ PG_END_TRY() /* * structs */ typedef struct plr_func_hashkey { /* Hash lookup key for functions */ Oid funcOid; /* * For a trigger function, the OID of the relation triggered on is part * of the hashkey --- we want to compile the trigger separately for each * relation it is used with, in case the rowtype is different. Zero if * not called as a trigger. */ Oid trigrelOid; /* * We include actual argument types in the hash key to support * polymorphic PLpgSQL functions. Be careful that extra positions * are zeroed! */ Oid argtypes[FUNC_MAX_ARGS]; } plr_func_hashkey; /* The information we cache about loaded procedures */ typedef struct plr_function { char *proname; TransactionId fn_xmin; ItemPointerData fn_tid; plr_func_hashkey *fn_hashkey; /* back-link to hashtable key */ bool lanpltrusted; Oid result_typid; bool result_istuple; FmgrInfo result_in_func; Oid result_elem; FmgrInfo result_elem_in_func; int result_elem_typlen; bool result_elem_typbyval; char result_elem_typalign; int result_natts; Oid *result_fld_elem_typid; FmgrInfo *result_fld_elem_in_func; int *result_fld_elem_typlen; bool *result_fld_elem_typbyval; char *result_fld_elem_typalign; int nargs; Oid arg_typid[FUNC_MAX_ARGS]; bool arg_typbyval[FUNC_MAX_ARGS]; FmgrInfo arg_out_func[FUNC_MAX_ARGS]; Oid arg_elem[FUNC_MAX_ARGS]; FmgrInfo arg_elem_out_func[FUNC_MAX_ARGS]; int arg_elem_typlen[FUNC_MAX_ARGS]; bool arg_elem_typbyval[FUNC_MAX_ARGS]; char arg_elem_typalign[FUNC_MAX_ARGS]; int arg_is_rel[FUNC_MAX_ARGS]; SEXP fun; /* compiled R function */ #ifdef HAVE_WINDOW_FUNCTIONS bool iswindow; #endif } plr_function; /* compiled function hash table */ typedef struct plr_hashent { plr_func_hashkey key; plr_function *function; } plr_HashEnt; /* * external declarations */ /* libR interpreter initialization */ extern int Rf_initEmbeddedR(int argc, char **argv); /* PL/R language handler */ extern Datum plr_call_handler(PG_FUNCTION_ARGS); extern void PLR_CLEANUP; extern void plr_init(void); extern void plr_load_modules(void); extern void load_r_cmd(const char *cmd); extern SEXP call_r_func(SEXP fun, SEXP rargs); /* argument and return value conversion functions */ extern SEXP pg_scalar_get_r(Datum dvalue, Oid arg_typid, FmgrInfo arg_out_func); extern SEXP pg_array_get_r(Datum dvalue, FmgrInfo out_func, int typlen, bool typbyval, char typalign); extern SEXP pg_datum_array_get_r(Datum *elem_values, bool *elem_nulls, int numels, bool has_nulls, Oid element_type, FmgrInfo out_func, bool typbyval); extern SEXP pg_tuple_get_r_frame(int ntuples, HeapTuple *tuples, TupleDesc tupdesc); extern Datum r_get_pg(SEXP rval, plr_function *function, FunctionCallInfo fcinfo); extern Datum get_datum(SEXP rval, Oid typid, Oid typelem, FmgrInfo in_func, bool *isnull); extern Datum get_scalar_datum(SEXP rval, Oid result_typ, FmgrInfo result_in_func, bool *isnull); /* Postgres support functions installed into the R interpreter */ extern void throw_pg_notice(const char **msg); extern SEXP plr_quote_literal(SEXP rawstr); extern SEXP plr_quote_ident(SEXP rawstr); extern SEXP plr_SPI_exec(SEXP rsql); extern SEXP plr_SPI_prepare(SEXP rsql, SEXP rargtypes); extern SEXP plr_SPI_execp(SEXP rsaved_plan, SEXP rargvalues); extern SEXP plr_SPI_cursor_open(SEXP cursor_name_arg,SEXP rsaved_plan, SEXP rargvalues); extern SEXP plr_SPI_cursor_fetch(SEXP cursor_in,SEXP forward_in, SEXP rows_in); extern void plr_SPI_cursor_close(SEXP cursor_in); extern void plr_SPI_cursor_move(SEXP cursor_in, SEXP forward_in, SEXP rows_in); extern SEXP plr_SPI_lastoid(void); extern void throw_r_error(const char **msg); /* Postgres callable functions useful in conjunction with PL/R */ extern Datum plr_version(PG_FUNCTION_ARGS); extern Datum reload_plr_modules(PG_FUNCTION_ARGS); extern Datum install_rcmd(PG_FUNCTION_ARGS); extern Datum plr_array_push(PG_FUNCTION_ARGS); extern Datum plr_array(PG_FUNCTION_ARGS); extern Datum plr_array_accum(PG_FUNCTION_ARGS); extern Datum plr_environ(PG_FUNCTION_ARGS); extern Datum plr_set_rhome(PG_FUNCTION_ARGS); extern Datum plr_unset_rhome(PG_FUNCTION_ARGS); extern Datum plr_set_display(PG_FUNCTION_ARGS); extern Datum plr_get_raw(PG_FUNCTION_ARGS); /* Postgres backend support functions */ extern void compute_function_hashkey(FunctionCallInfo fcinfo, Form_pg_proc procStruct, plr_func_hashkey *hashkey); extern void plr_HashTableInit(void); extern plr_function *plr_HashTableLookup(plr_func_hashkey *func_key); extern void plr_HashTableInsert(plr_function *function, plr_func_hashkey *func_key); extern void plr_HashTableDelete(plr_function *function); extern char *get_load_self_ref_cmd(Oid funcid); extern void perm_fmgr_info(Oid functionId, FmgrInfo *finfo); #endif /* PLR_H */ plr-REL8_3_0_17/plr.spec000066400000000000000000000041271277274236600150300ustar00rootroot00000000000000%define pkgdocdir %(pg_config --docdir) %define pkglibdir %(pg_config --pkglibdir) %define pkgsharedir %(pg_config --sharedir) Summary: A loadable procedural language that enables you to write PostgreSQL functions and triggers in the R programming language. Name: plr Version: 8.3.0.17 Release: 1%{?dist} License: BSD Group: Applications/Databases Source: http://www.joeconway.com/plr/plr-%{version}.tar.gz URL: http://www.joeconway.com/plr/ BuildRequires: postgresql-devel >= 8.3 BuildRequires: R-devel Requires: postgresql-server >= 8.3 Requires: R BuildRoot: %{_tmppath}/%{name}-%{version}-%{release}-root-%(%{__id_u} -n) %description PL/R is a loadable procedural language that enables you to write PostgreSQL functions and triggers in the R programming language. PL/R offers most (if not all) of the capabilities a function writer has in the R language. Commands are available to access the database via the PostgreSQL Server Programming Interface (SPI) and to raise messages via elog() . There is no way to access internals of the database backend. However the user is able to gain OS-level access under the permissions of the PostgreSQL user ID, as with a C function. Thus, any unprivileged database user should not be permitted to use this language. It must be installed as an untrusted procedural language so that only database superusers can create functions in it. The writer of a PL/R function must take care that the function cannot be used to do anything unwanted, since it will be able to do anything that could be done by a user logged in as the database administrator. An implementation restriction is that PL/R procedures cannot be used to create input/output functions for new data types. %prep %setup -q -n %{name} %build make USE_PGXS=1 %install rm -rf %{buildroot} make USE_PGXS=1 DESTDIR=%{buildroot}/ install %clean rm -rf %{buildroot} %files %defattr(644,root,root,755) %doc %{pkgdocdir}/extension/README.plr %{pkgsharedir}/extension/plr.sql %{pkgsharedir}/extension/plr.control %{pkgsharedir}/extension/plr--8.3.0.17.sql %{pkgsharedir}/extension/plr--unpackaged--8.3.0.17.sql %{pkglibdir}/plr.so* plr-REL8_3_0_17/plr.sql.in000077500000000000000000000055261277274236600153110ustar00rootroot00000000000000-- keep this in sync with the plr--X.Y.Z.N.sql extension install file CREATE FUNCTION plr_call_handler() RETURNS LANGUAGE_HANDLER AS 'MODULE_PATHNAME' LANGUAGE C; CREATE LANGUAGE plr HANDLER plr_call_handler; CREATE OR REPLACE FUNCTION plr_version () RETURNS text AS 'MODULE_PATHNAME','plr_version' LANGUAGE C; CREATE OR REPLACE FUNCTION reload_plr_modules () RETURNS text AS 'MODULE_PATHNAME','reload_plr_modules' LANGUAGE C; CREATE OR REPLACE FUNCTION install_rcmd (text) RETURNS text AS 'MODULE_PATHNAME','install_rcmd' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION install_rcmd (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_singleton_array (float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array' LANGUAGE C WITH (isstrict); CREATE OR REPLACE FUNCTION plr_array_push (_float8, float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array_push' LANGUAGE C WITH (isstrict); CREATE OR REPLACE FUNCTION plr_array_accum (_float8, float8) RETURNS float8[] AS 'MODULE_PATHNAME','plr_array_accum' LANGUAGE C; CREATE TYPE plr_environ_type AS (name text, value text); CREATE OR REPLACE FUNCTION plr_environ () RETURNS SETOF plr_environ_type AS 'MODULE_PATHNAME','plr_environ' LANGUAGE C; REVOKE EXECUTE ON FUNCTION plr_environ() FROM PUBLIC; CREATE TYPE r_typename AS (typename text, typeoid oid); CREATE OR REPLACE FUNCTION r_typenames() RETURNS SETOF r_typename AS ' x <- ls(name = .GlobalEnv, pat = "OID") y <- vector() for (i in 1:length(x)) {y[i] <- eval(parse(text = x[i]))} data.frame(typename = x, typeoid = y) ' language 'plr'; CREATE OR REPLACE FUNCTION load_r_typenames() RETURNS text AS ' sql <- "select upper(typname::text) || ''OID'' as typename, oid from pg_catalog.pg_type where typtype = ''b'' order by typname" rs <- pg.spi.exec(sql) for(i in 1:nrow(rs)) { typobj <- rs[i,1] typval <- rs[i,2] if (substr(typobj,1,1) == "_") typobj <- paste("ARRAYOF", substr(typobj,2,nchar(typobj)), sep="") assign(typobj, typval, .GlobalEnv) } return("OK") ' language 'plr'; CREATE TYPE r_version_type AS (name text, value text); CREATE OR REPLACE FUNCTION r_version() RETURNS setof r_version_type as ' cbind(names(version),unlist(version)) ' language 'plr'; CREATE OR REPLACE FUNCTION plr_set_rhome (text) RETURNS text AS 'MODULE_PATHNAME','plr_set_rhome' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION plr_set_rhome (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_unset_rhome () RETURNS text AS 'MODULE_PATHNAME','plr_unset_rhome' LANGUAGE C; REVOKE EXECUTE ON FUNCTION plr_unset_rhome () FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_set_display (text) RETURNS text AS 'MODULE_PATHNAME','plr_set_display' LANGUAGE C WITH (isstrict); REVOKE EXECUTE ON FUNCTION plr_set_display (text) FROM PUBLIC; CREATE OR REPLACE FUNCTION plr_get_raw (bytea) RETURNS bytea AS 'MODULE_PATHNAME','plr_get_raw' LANGUAGE C WITH (isstrict); plr-REL8_3_0_17/sql/000077500000000000000000000000001277274236600141525ustar00rootroot00000000000000plr-REL8_3_0_17/sql/plr.sql000077500000000000000000000430171277274236600155000ustar00rootroot00000000000000-- -- first, define the language and functions. Turn off echoing so that expected file -- does not depend on contents of plr.sql. -- \set ECHO none \i plr.sql \set ECHO all -- check version SELECT plr_version(); -- make typenames available in the global namespace select load_r_typenames(); 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(); -- -- 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'); -- -- user defined R function test -- select install_rcmd('pg.test.install <-function(msg) {print(msg)}'); create or replace function pg_test_install(text) returns text as 'pg.test.install(arg1)' language 'plr'; select pg_test_install('hello world'); -- -- test simple input/output types -- CREATE OR REPLACE FUNCTION rint2(i int2) RETURNS int2 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint2(1::int2); select rint2(NULL); CREATE OR REPLACE FUNCTION rint4(i int4) RETURNS int4 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint4(1::int4); select rint4(NULL); CREATE OR REPLACE FUNCTION rint8(i int8) RETURNS int8 AS $$ return (as.integer(i)) $$ LANGUAGE plr; select rint8(1::int8); select rint8(NULL); CREATE OR REPLACE FUNCTION rbool(b bool) RETURNS bool AS $$ return (as.logical(b)) $$ LANGUAGE plr; select rbool('t'); select rbool('f'); select rbool(NULL); CREATE OR REPLACE FUNCTION rfloat4(f float4) RETURNS float4 AS $$ return (as.numeric(f)) $$ LANGUAGE plr; select rfloat4(1::int4); select rfloat4(NULL); CREATE OR REPLACE FUNCTION rfloat8(f float8) RETURNS float8 AS $$ return (as.numeric(f)) $$ LANGUAGE plr; select rfloat8(1::float8); select rfloat8(NULL); -- -- a variety of plr functions -- create or replace function throw_notice(text) returns text as 'pg.thrownotice(arg1)' language 'plr'; select throw_notice('hello'); create or replace function paste(_text,_text,text) returns text[] as 'paste(arg1,arg2, sep = arg3)' language 'plr'; select paste('{hello, happy}','{world, birthday}',' '); create or replace function vec(_float8) returns _float8 as 'arg1' language 'plr'; select vec('{1.23, 1.32}'::float8[]); create or replace function vec(float, float) returns _float8 as 'c(arg1,arg2)' language 'plr'; select vec(1.23, 1.32); create or replace function echo(text) returns text as 'print(arg1)' language 'plr'; select echo('hello'); 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'); create or replace function "commandArgs"() returns text[] as '' language 'plr'; select "commandArgs"(); create or replace function vec(float) returns text as 'c(arg1)' language 'plr'; select vec(1.23); 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); create or replace function print(text) returns text as '' language 'plr'; select print('hello'); create or replace function cube(int) returns float as 'sq <- function(x) {return(x * x)}; return(arg1 * sq(arg1))' language 'plr'; select cube(3); 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); 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); create or replace function mean(_float8) returns float as '' language 'plr'; select mean('{1.23,1.31,1.42,1.27}'::_float8); 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'); -- -- 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); 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; 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); 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; -- -- 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(); create or replace function test_vi() returns int as 'array(1:10,c(2,5))' language 'plr'; select test_vi(); create or replace function test_mt() returns text as 'as.matrix(array(1:10,c(2,5)))' language 'plr'; select test_mt(); create or replace function test_mi() returns int as 'as.matrix(array(1:10,c(2,5)))' language 'plr'; select test_mi(); create or replace function test_dt() returns text as 'as.data.frame(array(1:10,c(2,5)))[[1]]' language 'plr'; select test_dt(); 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; create or replace function test_vta() returns text[] as 'array(1:10,c(2,5))' language 'plr'; select test_vta(); create or replace function test_via() returns int[] as 'array(1:10,c(2,5))' language 'plr'; select test_via(); create or replace function test_mta() returns text[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr'; select test_mta(); create or replace function test_mia() returns int[] as 'as.matrix(array(1:10,c(2,5)))' language 'plr'; select test_mia(); create or replace function test_dia() returns int[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr'; select test_dia(); create or replace function test_dta() returns text[] as 'as.data.frame(array(1:10,c(2,5)))' language 'plr'; select test_dta(); create or replace function test_dta1() returns text[] as 'as.data.frame(array(letters[1:10], c(2,5)))' language 'plr'; select test_dta1(); create or replace function test_dta2() returns text[] as 'as.data.frame(data.frame(letters[1:10],1:10))' language 'plr'; select test_dta2(); -- 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; 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); 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); 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); create or replace function test_vint() returns setof int as 'as.vector(array(1:15,c(5,3)))' language 'plr'; select * from test_vint(); -- -- 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(); 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(); create or replace function test_mtup1() returns setof mtup as 'as.matrix(array(1:15,c(5,3)))' language 'plr'; select * from test_mtup1(); create or replace function test_vtup1() returns setof vtup as 'as.vector(array(1:15,c(5,3)))' language 'plr'; select * from test_vtup1(); -- -- 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'); create or replace function pg_quote_literal(text) returns text as 'pg.quoteliteral(arg1)' language 'plr'; select pg_quote_literal('Hello''World'); 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'''); 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'''); 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); create or replace function fetch_pgoid(text) returns int as 'pg.reval(arg1)' language 'plr'; select fetch_pgoid('BYTEAOID'); 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'); 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); 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"; -- -- test NULL handling -- CREATE OR REPLACE FUNCTION r_test (float8) RETURNS float8 AS 'arg1' LANGUAGE 'plr'; select r_test(null) is null as "NULL"; 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"; select r_max(null,2) as "TWO"; select r_max(1,null) as "ONE"; select r_max(null,null) is null as "NULL"; -- -- 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)); -- -- 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); -- -- 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"; -- 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; -- 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"; 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; select arr3d('{{{111,112},{121,122},{131,132}},{{211,212},{221,222},{231,232}}}',0,1,1) is null as "NULL"; 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; -- -- 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}}}'); -- -- 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; insert into foo values(11,'cat99',1.89); select count(*) from foo; update foo set f1 = 'zzz'; select count(*) from foo; delete from foo; select count(*) from foo; 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; insert into foo values(11,'cat99',1.89); select count(*) from foo; update foo set f1 = 'zzz' where f0 = 11; select * from foo where f0 = 11; delete from foo where f0 = 11; select count(*) from foo; 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; insert into foo values(11,'cat99',1.89); select * from foo where f0 = 11; update foo set f1 = 'zzz' where f0 = 11; select * from foo where f0 = 11; delete from foo where f0 = 11; select count(*) from foo; 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; insert into foo values(11,'cat99',1.89); select count(*) from foo; update foo set f1 = 'zzz' where f0 = 11; select * from foo where f0 = 11; delete from foo where f0 = 11; select count(*) from foo; 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; insert into foo values(11,'cat99',1.89); select count(*) from foo; update foo set f1 = 'zzz' where f0 = 11; select * from foo where f0 = 11; delete from foo where f0 = 11; select count(*) from foo; 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); SELECT * FROM cursor_fetch_test(2,true); SELECT * FROM cursor_fetch_test(20,true); --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(); --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); --Test bytea arguments and return values: serialize/unserialize create or replace function test_serialize(text) returns bytea as ' mydf <- pg.spi.exec(arg1) return (mydf) ' language 'plr'; create or replace function restore_df(bytea) returns setof record as ' return (arg1) ' language 'plr'; select * from restore_df((select test_serialize('select oid, typname from pg_type where typname in (''oid'',''name'',''int4'')'))) as t(oid oid, typname name); --Test WINDOW functions -- create test table CREATE TABLE test_data ( fyear integer, firm float8, eps float8 ); -- insert data for test INSERT INTO test_data SELECT (b.f + 1) % 10 + 2000 AS fyear, floor((b.f+1)/10) + 50 AS firm, f::float8/100 AS eps FROM generate_series(-200,199,1) b(f); CREATE OR REPLACE FUNCTION r_regr_slope(float8, float8) RETURNS float8 AS $BODY$ slope <- NA y <- farg1 x <- farg2 if (fnumrows==9) try (slope <- lm(y ~ x)$coefficients[2]) return(slope) $BODY$ LANGUAGE plr WINDOW; SELECT *, round((r_regr_slope(eps, lag_eps) OVER w)::numeric,6) AS slope_R FROM (SELECT firm, fyear, eps, lag(eps) OVER (ORDER BY firm, fyear) AS lag_eps FROM test_data) AS a WHERE eps IS NOT NULL WINDOW w AS (ORDER BY firm, fyear ROWS 8 PRECEDING);