Skip to content
体验新版
项目
组织
正在加载...
登录
切换导航
打开侧边栏
Greenplum
Gpdb
提交
3a484d9e
G
Gpdb
项目概览
Greenplum
/
Gpdb
通知
7
Star
1
Fork
0
代码
文件
提交
分支
Tags
贡献者
分支图
Diff
Issue
0
列表
看板
标记
里程碑
合并请求
0
DevOps
流水线
流水线任务
计划
Wiki
0
Wiki
分析
仓库
DevOps
项目成员
Pages
G
Gpdb
项目概览
项目概览
详情
发布
仓库
仓库
文件
提交
分支
标签
贡献者
分支图
比较
Issue
0
Issue
0
列表
看板
标记
里程碑
合并请求
0
合并请求
0
Pages
DevOps
DevOps
流水线
流水线任务
计划
分析
分析
仓库分析
DevOps
Wiki
0
Wiki
成员
成员
收起侧边栏
关闭侧边栏
动态
分支图
创建新Issue
流水线任务
提交
Issue看板
体验新版 GitCode,发现更多精彩内容 >>
提交
3a484d9e
编写于
10月 19, 2001
作者:
T
Tom Lane
浏览文件
操作
浏览文件
下载
电子邮件补丁
差异文件
Fix plperl to discard cached function definition after CREATE OR
REPLACE FUNCTION. Clean up typlen/typmod errors inherited from pltcl.
上级
379268aa
变更
1
隐藏空白更改
内联
并排
Showing
1 changed file
with
186 addition
and
1643 deletion
+186
-1643
src/pl/plperl/plperl.c
src/pl/plperl/plperl.c
+186
-1643
未找到文件。
src/pl/plperl/plperl.c
浏览文件 @
3a484d9e
...
...
@@ -33,10 +33,11 @@
* ENHANCEMENTS, OR MODIFICATIONS.
*
* IDENTIFICATION
* $Header: /cvsroot/pgsql/src/pl/plperl/plperl.c,v 1.2
3 2001/10/06 23:21:44
tgl Exp $
* $Header: /cvsroot/pgsql/src/pl/plperl/plperl.c,v 1.2
4 2001/10/19 22:43:49
tgl Exp $
*
**********************************************************************/
#include "postgres.h"
/* system stuff */
#include <stdio.h>
...
...
@@ -56,6 +57,7 @@
#include "tcop/tcopprot.h"
#include "utils/syscache.h"
#include "catalog/pg_language.h"
#include "catalog/pg_proc.h"
#include "catalog/pg_type.h"
...
...
@@ -87,35 +89,19 @@
typedef
struct
plperl_proc_desc
{
char
*
proname
;
TransactionId
fn_xmin
;
CommandId
fn_cmin
;
bool
lanpltrusted
;
FmgrInfo
result_in_func
;
Oid
result_in_elem
;
int
result_in_len
;
int
nargs
;
FmgrInfo
arg_out_func
[
FUNC_MAX_ARGS
];
Oid
arg_out_elem
[
FUNC_MAX_ARGS
];
int
arg_out_len
[
FUNC_MAX_ARGS
];
int
arg_is_rel
[
FUNC_MAX_ARGS
];
bool
lanpltrusted
;
SV
*
reference
;
}
plperl_proc_desc
;
/**********************************************************************
* The information we cache about prepared and saved plans
**********************************************************************/
typedef
struct
plperl_query_desc
{
char
qname
[
20
];
void
*
plan
;
int
nargs
;
Oid
*
argtypes
;
FmgrInfo
*
arginfuncs
;
Oid
*
argtypelems
;
Datum
*
argvalues
;
int
*
arglen
;
}
plperl_query_desc
;
/**********************************************************************
* Global data
**********************************************************************/
...
...
@@ -125,11 +111,6 @@ static int plperl_restart_in_progress = 0;
static
PerlInterpreter
*
plperl_interp
=
NULL
;
static
HV
*
plperl_proc_hash
=
NULL
;
#if REALLYHAVEITONTHEBALL
static
Tcl_HashTable
*
plperl_query_hash
=
NULL
;
#endif
/**********************************************************************
* Forward declarations
**********************************************************************/
...
...
@@ -140,29 +121,11 @@ Datum plperl_call_handler(PG_FUNCTION_ARGS);
static
Datum
plperl_func_handler
(
PG_FUNCTION_ARGS
);
static
plperl_proc_desc
*
compile_plperl_function
(
Oid
fn_oid
,
bool
is_trigger
);
static
SV
*
plperl_build_tuple_argument
(
HeapTuple
tuple
,
TupleDesc
tupdesc
);
static
void
plperl_init_shared_libs
(
void
);
#ifdef REALLYHAVEITONTHEBALL
static
HeapTuple
plperl_trigger_handler
(
PG_FUNCTION_ARGS
);
static
int
plperl_elog
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[]);
static
int
plperl_quote
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[]);
static
int
plperl_SPI_exec
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[]);
static
int
plperl_SPI_prepare
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[]);
static
int
plperl_SPI_execp
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[]);
static
void
plperl_set_tuple_values
(
Tcl_Interp
*
interp
,
char
*
arrayname
,
int
tupno
,
HeapTuple
tuple
,
TupleDesc
tupdesc
);
#endif
/*
* This routine is a crock, and so is everyplace that calls it. The problem
...
...
@@ -196,7 +159,7 @@ plperl_init_all(void)
/************************************************************
* Destroy the existing
safe
interpreter
* Destroy the existing
Perl
interpreter
************************************************************/
if
(
plperl_interp
!=
NULL
)
{
...
...
@@ -216,25 +179,16 @@ plperl_init_all(void)
}
/************************************************************
* Free the prepared query hash table
************************************************************/
/*
* if (plperl_query_hash != NULL) { }
*/
/************************************************************
* Now recreate a new safe interpreter
* Now recreate a new Perl interpreter
************************************************************/
plperl_init_interp
();
plperl_firstcall
=
0
;
return
;
}
/**********************************************************************
* plperl_init_interp() - Create the
safe
Perl interpreter
* plperl_init_interp() - Create the Perl interpreter
**********************************************************************/
static
void
plperl_init_interp
(
void
)
...
...
@@ -266,7 +220,7 @@ plperl_init_interp(void)
/************************************************************
* Initialize the proc and query hash tables
*************************
***********************************/
************************************************************/
plperl_proc_hash
=
newHV
();
}
...
...
@@ -300,7 +254,7 @@ plperl_call_handler(PG_FUNCTION_ARGS)
if
(
SPI_connect
()
!=
SPI_OK_CONNECT
)
elog
(
ERROR
,
"plperl: cannot connect to SPI manager"
);
/************************************************************
* Keep track about the nesting of
Tcl-SPI-Tc
l-... calls
* Keep track about the nesting of
Perl-SPI-Per
l-... calls
************************************************************/
plperl_call_level
++
;
...
...
@@ -454,7 +408,7 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
tmp
=
DatumGetCString
(
FunctionCall3
(
&
(
desc
->
arg_out_func
[
i
]),
fcinfo
->
arg
[
i
],
ObjectIdGetDatum
(
desc
->
arg_out_elem
[
i
]),
Int32GetDatum
(
desc
->
arg_out_len
[
i
]
)));
Int32GetDatum
(
-
1
)));
XPUSHs
(
sv_2mortal
(
newSVpv
(
tmp
,
0
)));
pfree
(
tmp
);
}
...
...
@@ -500,188 +454,15 @@ plperl_call_perl_func(plperl_proc_desc * desc, FunctionCallInfo fcinfo)
static
Datum
plperl_func_handler
(
PG_FUNCTION_ARGS
)
{
int
i
;
char
internal_proname
[
512
];
int
proname_len
;
plperl_proc_desc
*
prodesc
;
SV
*
perlret
;
Datum
retval
;
sigjmp_buf
save_restart
;
/************************************************************
* Build our internal proc name from the functions Oid
************************************************************/
sprintf
(
internal_proname
,
"__PLPerl_proc_%u"
,
fcinfo
->
flinfo
->
fn_oid
);
proname_len
=
strlen
(
internal_proname
);
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
if
(
!
hv_exists
(
plperl_proc_hash
,
internal_proname
,
proname_len
))
{
/************************************************************
* If we haven't found it in the hashtable, we analyze
* the functions arguments and returntype and store
* the in-/out-functions in the prodesc block and create
* a new hashtable entry for it.
*
* Then we load the procedure into the safe interpreter.
************************************************************/
HeapTuple
procTup
;
HeapTuple
langTup
;
HeapTuple
typeTup
;
Form_pg_proc
procStruct
;
Form_pg_language
langStruct
;
Form_pg_type
typeStruct
;
char
*
proc_source
;
/************************************************************
* Allocate a new procedure description block
************************************************************/
prodesc
=
(
plperl_proc_desc
*
)
malloc
(
sizeof
(
plperl_proc_desc
));
prodesc
->
proname
=
malloc
(
strlen
(
internal_proname
)
+
1
);
strcpy
(
prodesc
->
proname
,
internal_proname
);
/************************************************************
* Lookup the pg_proc tuple by Oid
************************************************************/
procTup
=
SearchSysCache
(
PROCOID
,
ObjectIdGetDatum
(
fcinfo
->
flinfo
->
fn_oid
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
procTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: cache lookup for proc %u failed"
,
fcinfo
->
flinfo
->
fn_oid
);
}
procStruct
=
(
Form_pg_proc
)
GETSTRUCT
(
procTup
);
/************************************************************
* Lookup the pg_language tuple by Oid
************************************************************/
langTup
=
SearchSysCache
(
LANGOID
,
ObjectIdGetDatum
(
procStruct
->
prolang
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
langTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: cache lookup for language %u failed"
,
procStruct
->
prolang
);
}
langStruct
=
(
Form_pg_language
)
GETSTRUCT
(
langTup
);
prodesc
->
lanpltrusted
=
langStruct
->
lanpltrusted
;
ReleaseSysCache
(
langTup
);
/************************************************************
* Get the required information for input conversion of the
* return value.
************************************************************/
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
procStruct
->
prorettype
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
if
(
!
OidIsValid
(
procStruct
->
prorettype
))
elog
(
ERROR
,
"plperl functions cannot return type
\"
opaque
\"
"
"
\n\t
except when used as triggers"
);
else
elog
(
ERROR
,
"plperl: cache lookup for return type %u failed"
,
procStruct
->
prorettype
);
}
typeStruct
=
(
Form_pg_type
)
GETSTRUCT
(
typeTup
);
if
(
typeStruct
->
typrelid
!=
InvalidOid
)
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: return types of tuples not supported yet"
);
}
perm_fmgr_info
(
typeStruct
->
typinput
,
&
(
prodesc
->
result_in_func
));
prodesc
->
result_in_elem
=
(
Oid
)
(
typeStruct
->
typelem
);
prodesc
->
result_in_len
=
typeStruct
->
typlen
;
ReleaseSysCache
(
typeTup
);
/************************************************************
* Get the required information for output conversion
* of all procedure arguments
************************************************************/
prodesc
->
nargs
=
procStruct
->
pronargs
;
for
(
i
=
0
;
i
<
prodesc
->
nargs
;
i
++
)
{
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
procStruct
->
proargtypes
[
i
]),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
if
(
!
OidIsValid
(
procStruct
->
proargtypes
[
i
]))
elog
(
ERROR
,
"plperl functions cannot take type
\"
opaque
\"
"
);
else
elog
(
ERROR
,
"plperl: cache lookup for argument type %u failed"
,
procStruct
->
proargtypes
[
i
]);
}
typeStruct
=
(
Form_pg_type
)
GETSTRUCT
(
typeTup
);
if
(
typeStruct
->
typrelid
!=
InvalidOid
)
prodesc
->
arg_is_rel
[
i
]
=
1
;
else
prodesc
->
arg_is_rel
[
i
]
=
0
;
perm_fmgr_info
(
typeStruct
->
typoutput
,
&
(
prodesc
->
arg_out_func
[
i
]));
prodesc
->
arg_out_elem
[
i
]
=
(
Oid
)
(
typeStruct
->
typelem
);
prodesc
->
arg_out_len
[
i
]
=
typeStruct
->
typlen
;
ReleaseSysCache
(
typeTup
);
}
/************************************************************
* create the text of the anonymous subroutine.
* we do not use a named subroutine so that we can call directly
* through the reference.
*
************************************************************/
proc_source
=
DatumGetCString
(
DirectFunctionCall1
(
textout
,
PointerGetDatum
(
&
procStruct
->
prosrc
)));
/************************************************************
* Create the procedure in the interpreter
************************************************************/
prodesc
->
reference
=
plperl_create_sub
(
proc_source
,
prodesc
->
lanpltrusted
);
pfree
(
proc_source
);
if
(
!
prodesc
->
reference
)
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: cannot create internal procedure %s"
,
internal_proname
);
}
/************************************************************
* Add the proc description block to the hashtable
************************************************************/
hv_store
(
plperl_proc_hash
,
internal_proname
,
proname_len
,
newSViv
((
IV
)
prodesc
),
0
);
ReleaseSysCache
(
procTup
);
}
else
{
/************************************************************
* Found the proc description block in the hashtable
************************************************************/
prodesc
=
(
plperl_proc_desc
*
)
SvIV
(
*
hv_fetch
(
plperl_proc_hash
,
internal_proname
,
proname_len
,
0
));
}
/* Find or compile the function */
prodesc
=
compile_plperl_function
(
fcinfo
->
flinfo
->
fn_oid
,
false
);
/* Set up error handling */
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
...
...
@@ -693,7 +474,6 @@ plperl_func_handler(PG_FUNCTION_ARGS)
siglongjmp
(
Warn_restart
,
1
);
}
/************************************************************
* Call the Perl function
************************************************************/
...
...
@@ -719,7 +499,7 @@ plperl_func_handler(PG_FUNCTION_ARGS)
retval
=
FunctionCall3
(
&
prodesc
->
result_in_func
,
PointerGetDatum
(
SvPV
(
perlret
,
PL_na
)),
ObjectIdGetDatum
(
prodesc
->
result_in_elem
),
Int32GetDatum
(
prodesc
->
result_in_len
));
Int32GetDatum
(
-
1
));
}
SvREFCNT_dec
(
perlret
);
...
...
@@ -736,1447 +516,210 @@ plperl_func_handler(PG_FUNCTION_ARGS)
}
#ifdef REALLYHAVEITONTHEBALL
/**********************************************************************
*
plperl_trigger_handler() - Handler for trigger calls
*
compile_plperl_function - compile (or hopefully just look up) function
**********************************************************************/
static
HeapTuple
plperl_trigger_handler
(
PG_FUNCTION_ARGS
)
static
plperl_proc_desc
*
compile_plperl_function
(
Oid
fn_oid
,
bool
is_trigger
)
{
TriggerData
*
trigdata
=
(
TriggerData
*
)
fcinfo
->
context
;
char
internal_proname
[
512
];
char
*
stroid
;
Tcl_HashEntry
*
hashent
;
int
hashnew
;
plperl_proc_desc
*
prodesc
;
TupleDesc
tupdesc
;
HeapTuple
rettup
;
Tcl_DString
tcl_cmd
;
Tcl_DString
tcl_trigtup
;
Tcl_DString
tcl_newtup
;
int
tcl_rc
;
HeapTuple
procTup
;
Form_pg_proc
procStruct
;
char
internal_proname
[
64
];
int
proname_len
;
plperl_proc_desc
*
prodesc
=
NULL
;
int
i
;
int
*
modattrs
;
Datum
*
modvalues
;
char
*
modnulls
;
int
ret_numvals
;
char
**
ret_values
;
sigjmp_buf
save_restart
;
/* We'll need the pg_proc tuple in any case... */
procTup
=
SearchSysCache
(
PROCOID
,
ObjectIdGetDatum
(
fn_oid
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
procTup
))
elog
(
ERROR
,
"plperl: cache lookup for proc %u failed"
,
fn_oid
);
procStruct
=
(
Form_pg_proc
)
GETSTRUCT
(
procTup
);
/************************************************************
* Build our internal proc name from the functions Oid
************************************************************/
sprintf
(
internal_proname
,
"__PLPerl_proc_%u"
,
fcinfo
->
flinfo
->
fn_oid
);
if
(
!
is_trigger
)
sprintf
(
internal_proname
,
"__PLPerl_proc_%u"
,
fn_oid
);
else
sprintf
(
internal_proname
,
"__PLPerl_proc_%u_trigger"
,
fn_oid
);
proname_len
=
strlen
(
internal_proname
);
/************************************************************
* Lookup the internal proc name in the hashtable
************************************************************/
hashent
=
Tcl_FindHashEntry
(
plperl_proc_hash
,
internal_proname
);
if
(
hashent
==
NULL
)
if
(
hv_exists
(
plperl_proc_hash
,
internal_proname
,
proname_len
))
{
bool
uptodate
;
prodesc
=
(
plperl_proc_desc
*
)
SvIV
(
*
hv_fetch
(
plperl_proc_hash
,
internal_proname
,
proname_len
,
0
));
/************************************************************
* If we haven't found it in the hashtable,
* we load the procedure into the safe interpreter.
* If it's present, must check whether it's still up to date.
* This is needed because CREATE OR REPLACE FUNCTION can modify the
* function's pg_proc entry without changing its OID.
************************************************************/
Tcl_DString
proc_internal_def
;
Tcl_DString
proc_internal_body
;
HeapTuple
procTup
;
Form_pg_proc
procStruct
;
uptodate
=
(
prodesc
->
fn_xmin
==
procTup
->
t_data
->
t_xmin
&&
prodesc
->
fn_cmin
==
procTup
->
t_data
->
t_cmin
);
if
(
!
uptodate
)
{
/* need we delete old entry? */
prodesc
=
NULL
;
}
}
/************************************************************
* If we haven't found it in the hashtable, we analyze
* the functions arguments and returntype and store
* the in-/out-functions in the prodesc block and create
* a new hashtable entry for it.
*
* Then we load the procedure into the Perl interpreter.
************************************************************/
if
(
prodesc
==
NULL
)
{
HeapTuple
langTup
;
HeapTuple
typeTup
;
Form_pg_language
langStruct
;
Form_pg_type
typeStruct
;
char
*
proc_source
;
/************************************************************
* Allocate a new procedure description block
************************************************************/
prodesc
=
(
plperl_proc_desc
*
)
malloc
(
sizeof
(
plperl_proc_desc
));
memset
(
prodesc
,
0
,
sizeof
(
plperl_proc_desc
));
prodesc
->
proname
=
malloc
(
strlen
(
internal_proname
)
+
1
);
strcpy
(
prodesc
->
proname
,
internal_proname
);
if
(
prodesc
==
NULL
)
elog
(
ERROR
,
"plperl: out of memory"
);
MemSet
(
prodesc
,
0
,
sizeof
(
plperl_proc_desc
));
prodesc
->
proname
=
strdup
(
internal_proname
);
prodesc
->
fn_xmin
=
procTup
->
t_data
->
t_xmin
;
prodesc
->
fn_cmin
=
procTup
->
t_data
->
t_cmin
;
/************************************************************
* Lookup the pg_
proc
tuple by Oid
* Lookup the pg_
language
tuple by Oid
************************************************************/
procTup
=
SearchSysCache
(
PROC
OID
,
ObjectIdGetDatum
(
fcinfo
->
flinfo
->
fn_oid
),
langTup
=
SearchSysCache
(
LANG
OID
,
ObjectIdGetDatum
(
procStruct
->
prolang
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
proc
Tup
))
if
(
!
HeapTupleIsValid
(
lang
Tup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: cache lookup for
proc
%u failed"
,
fcinfo
->
flinfo
->
fn_oid
);
elog
(
ERROR
,
"plperl: cache lookup for
language
%u failed"
,
procStruct
->
prolang
);
}
procStruct
=
(
Form_pg_proc
)
GETSTRUCT
(
procTup
);
langStruct
=
(
Form_pg_language
)
GETSTRUCT
(
langTup
);
prodesc
->
lanpltrusted
=
langStruct
->
lanpltrusted
;
ReleaseSysCache
(
langTup
);
/************************************************************
*
Create the tcl command to define the internal
*
procedure
*
Get the required information for input conversion of the
*
return value.
************************************************************/
Tcl_DStringInit
(
&
proc_internal_def
);
Tcl_DStringInit
(
&
proc_internal_body
);
Tcl_DStringAppendElement
(
&
proc_internal_def
,
"proc"
);
Tcl_DStringAppendElement
(
&
proc_internal_def
,
internal_proname
);
Tcl_DStringAppendElement
(
&
proc_internal_def
,
"TG_name TG_relid TG_relatts TG_when TG_level TG_op __PLTcl_Tup_NEW __PLTcl_Tup_OLD args"
);
if
(
!
is_trigger
)
{
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
procStruct
->
prorettype
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
if
(
!
OidIsValid
(
procStruct
->
prorettype
))
elog
(
ERROR
,
"plperl functions cannot return type
\"
opaque
\"
"
"
\n\t
except when used as triggers"
);
else
elog
(
ERROR
,
"plperl: cache lookup for return type %u failed"
,
procStruct
->
prorettype
);
}
typeStruct
=
(
Form_pg_type
)
GETSTRUCT
(
typeTup
);
if
(
typeStruct
->
typrelid
!=
InvalidOid
)
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: return types of tuples not supported yet"
);
}
perm_fmgr_info
(
typeStruct
->
typinput
,
&
(
prodesc
->
result_in_func
));
prodesc
->
result_in_elem
=
typeStruct
->
typelem
;
ReleaseSysCache
(
typeTup
);
}
/************************************************************
* prefix procedure body with
* upvar #0 <internal_procname> GD
* and with appropriate setting of NEW, OLD,
* and the arguments as numerical variables.
* Get the required information for output conversion
* of all procedure arguments
************************************************************/
Tcl_DStringAppend
(
&
proc_internal_body
,
"upvar #0 "
,
-
1
);
Tcl_DStringAppend
(
&
proc_internal_body
,
internal_proname
,
-
1
);
Tcl_DStringAppend
(
&
proc_internal_body
,
" GD
\n
"
,
-
1
);
Tcl_DStringAppend
(
&
proc_internal_body
,
"array set NEW $__PLTcl_Tup_NEW
\n
"
,
-
1
);
Tcl_DStringAppend
(
&
proc_internal_body
,
"array set OLD $__PLTcl_Tup_OLD
\n
"
,
-
1
);
Tcl_DStringAppend
(
&
proc_internal_body
,
"set i 0
\n
"
"set v 0
\n
"
"foreach v $args {
\n
"
" incr i
\n
"
" set $i $v
\n
"
"}
\n
"
"unset i v
\n\n
"
,
-
1
);
if
(
!
is_trigger
)
{
prodesc
->
nargs
=
procStruct
->
pronargs
;
for
(
i
=
0
;
i
<
prodesc
->
nargs
;
i
++
)
{
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
procStruct
->
proargtypes
[
i
]),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
if
(
!
OidIsValid
(
procStruct
->
proargtypes
[
i
]))
elog
(
ERROR
,
"plperl functions cannot take type
\"
opaque
\"
"
);
else
elog
(
ERROR
,
"plperl: cache lookup for argument type %u failed"
,
procStruct
->
proargtypes
[
i
]);
}
typeStruct
=
(
Form_pg_type
)
GETSTRUCT
(
typeTup
);
if
(
typeStruct
->
typrelid
!=
InvalidOid
)
prodesc
->
arg_is_rel
[
i
]
=
1
;
else
prodesc
->
arg_is_rel
[
i
]
=
0
;
perm_fmgr_info
(
typeStruct
->
typoutput
,
&
(
prodesc
->
arg_out_func
[
i
]));
prodesc
->
arg_out_elem
[
i
]
=
typeStruct
->
typelem
;
ReleaseSysCache
(
typeTup
);
}
}
/************************************************************
* create the text of the anonymous subroutine.
* we do not use a named subroutine so that we can call directly
* through the reference.
*
************************************************************/
proc_source
=
DatumGetCString
(
DirectFunctionCall1
(
textout
,
PointerGetDatum
(
&
procStruct
->
prosrc
)));
Tcl_DStringAppend
(
&
proc_internal_body
,
proc_source
,
-
1
);
pfree
(
proc_source
);
Tcl_DStringAppendElement
(
&
proc_internal_def
,
Tcl_DStringValue
(
&
proc_internal_body
));
Tcl_DStringFree
(
&
proc_internal_body
);
/************************************************************
* Create the procedure in the
safe
interpreter
* Create the procedure in the interpreter
************************************************************/
tcl_rc
=
Tcl_GlobalEval
(
plperl_safe_interp
,
Tcl_DStringValue
(
&
proc_internal_def
));
Tcl_DStringFree
(
&
proc_internal_def
);
if
(
tcl_rc
!=
TCL_OK
)
prodesc
->
reference
=
plperl_create_sub
(
proc_source
,
prodesc
->
lanpltrusted
);
pfree
(
proc_source
);
if
(
!
prodesc
->
reference
)
{
free
(
prodesc
->
proname
);
free
(
prodesc
);
elog
(
ERROR
,
"plperl: cannot create internal procedure %s
- %s
"
,
internal_proname
,
plperl_safe_interp
->
result
);
elog
(
ERROR
,
"plperl: cannot create internal procedure %s"
,
internal_proname
);
}
/************************************************************
* Add the proc description block to the hashtable
************************************************************/
hashent
=
Tcl_CreateHashEntry
(
plperl_proc_hash
,
prodesc
->
proname
,
&
hashnew
);
Tcl_SetHashValue
(
hashent
,
(
ClientData
)
prodesc
);
ReleaseSysCache
(
procTup
);
}
else
{
/************************************************************
* Found the proc description block in the hashtable
************************************************************/
prodesc
=
(
plperl_proc_desc
*
)
Tcl_GetHashValue
(
hashent
);
}
tupdesc
=
trigdata
->
tg_relation
->
rd_att
;
/************************************************************
* Create the tcl command to call the internal
* proc in the safe interpreter
************************************************************/
Tcl_DStringInit
(
&
tcl_cmd
);
Tcl_DStringInit
(
&
tcl_trigtup
);
Tcl_DStringInit
(
&
tcl_newtup
);
/************************************************************
* We call external functions below - care for elog(ERROR)
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
Tcl_DStringFree
(
&
tcl_cmd
);
Tcl_DStringFree
(
&
tcl_trigtup
);
Tcl_DStringFree
(
&
tcl_newtup
);
plperl_restart_in_progress
=
1
;
if
(
--
plperl_call_level
==
0
)
plperl_restart_in_progress
=
0
;
siglongjmp
(
Warn_restart
,
1
);
hv_store
(
plperl_proc_hash
,
internal_proname
,
proname_len
,
newSViv
((
IV
)
prodesc
),
0
);
}
/* The procedure name */
Tcl_DStringAppendElement
(
&
tcl_cmd
,
internal_proname
);
/* The trigger name for argument TG_name */
Tcl_DStringAppendElement
(
&
tcl_cmd
,
trigdata
->
tg_trigger
->
tgname
);
/* The oid of the trigger relation for argument TG_relid */
stroid
=
DatumGetCString
(
DirectFunctionCall1
(
oidout
,
ObjectIdGetDatum
(
trigdata
->
tg_relation
->
rd_id
)));
Tcl_DStringAppendElement
(
&
tcl_cmd
,
stroid
);
pfree
(
stroid
);
/* A list of attribute names for argument TG_relatts */
Tcl_DStringAppendElement
(
&
tcl_trigtup
,
""
);
for
(
i
=
0
;
i
<
tupdesc
->
natts
;
i
++
)
Tcl_DStringAppendElement
(
&
tcl_trigtup
,
tupdesc
->
attrs
[
i
]
->
attname
.
data
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
Tcl_DStringFree
(
&
tcl_trigtup
);
Tcl_DStringInit
(
&
tcl_trigtup
);
/* The when part of the event for TG_when */
if
(
TRIGGER_FIRED_BEFORE
(
trigdata
->
tg_event
))
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"BEFORE"
);
else
if
(
TRIGGER_FIRED_AFTER
(
trigdata
->
tg_event
))
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"AFTER"
);
else
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"UNKNOWN"
);
ReleaseSysCache
(
procTup
);
/* The level part of the event for TG_level */
if
(
TRIGGER_FIRED_FOR_ROW
(
trigdata
->
tg_event
))
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"ROW"
);
else
if
(
TRIGGER_FIRED_FOR_STATEMENT
(
trigdata
->
tg_event
))
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"STATEMENT"
);
else
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"UNKNOWN"
);
return
prodesc
;
}
/* Build the data list for the trigtuple */
plperl_build_tuple_argument
(
trigdata
->
tg_trigtuple
,
tupdesc
,
&
tcl_trigtup
);
/*
* Now the command part of the event for TG_op and data for NEW and
* OLD
*/
if
(
TRIGGER_FIRED_BY_INSERT
(
trigdata
->
tg_event
))
{
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"INSERT"
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
Tcl_DStringAppendElement
(
&
tcl_cmd
,
""
);
rettup
=
trigdata
->
tg_trigtuple
;
}
else
if
(
TRIGGER_FIRED_BY_DELETE
(
trigdata
->
tg_event
))
{
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"DELETE"
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
""
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
rettup
=
trigdata
->
tg_trigtuple
;
}
else
if
(
TRIGGER_FIRED_BY_UPDATE
(
trigdata
->
tg_event
))
{
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"UPDATE"
);
plperl_build_tuple_argument
(
trigdata
->
tg_newtuple
,
tupdesc
,
&
tcl_newtup
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_newtup
));
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
rettup
=
trigdata
->
tg_newtuple
;
}
else
{
Tcl_DStringAppendElement
(
&
tcl_cmd
,
"UNKNOWN"
);
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
Tcl_DStringAppendElement
(
&
tcl_cmd
,
Tcl_DStringValue
(
&
tcl_trigtup
));
rettup
=
trigdata
->
tg_trigtuple
;
}
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
Tcl_DStringFree
(
&
tcl_trigtup
);
Tcl_DStringFree
(
&
tcl_newtup
);
/************************************************************
* Finally append the arguments from CREATE TRIGGER
************************************************************/
for
(
i
=
0
;
i
<
trigdata
->
tg_trigger
->
tgnargs
;
i
++
)
Tcl_DStringAppendElement
(
&
tcl_cmd
,
trigdata
->
tg_trigger
->
tgargs
[
i
]);
/************************************************************
* Call the Tcl function
************************************************************/
tcl_rc
=
Tcl_GlobalEval
(
plperl_safe_interp
,
Tcl_DStringValue
(
&
tcl_cmd
));
Tcl_DStringFree
(
&
tcl_cmd
);
/************************************************************
* Check the return code from Tcl and handle
* our special restart mechanism to get rid
* of all nested call levels on transaction
* abort.
************************************************************/
if
(
tcl_rc
==
TCL_ERROR
||
plperl_restart_in_progress
)
{
if
(
!
plperl_restart_in_progress
)
{
plperl_restart_in_progress
=
1
;
if
(
--
plperl_call_level
==
0
)
plperl_restart_in_progress
=
0
;
elog
(
ERROR
,
"plperl: %s"
,
plperl_safe_interp
->
result
);
}
if
(
--
plperl_call_level
==
0
)
plperl_restart_in_progress
=
0
;
siglongjmp
(
Warn_restart
,
1
);
}
switch
(
tcl_rc
)
{
case
TCL_OK
:
break
;
default:
elog
(
ERROR
,
"plperl: unsupported TCL return code %d"
,
tcl_rc
);
}
/************************************************************
* The return value from the procedure might be one of
* the magic strings OK or SKIP or a list from array get
************************************************************/
if
(
SPI_finish
()
!=
SPI_OK_FINISH
)
elog
(
ERROR
,
"plperl: SPI_finish() failed"
);
if
(
strcmp
(
plperl_safe_interp
->
result
,
"OK"
)
==
0
)
return
rettup
;
if
(
strcmp
(
plperl_safe_interp
->
result
,
"SKIP"
)
==
0
)
{
return
(
HeapTuple
)
NULL
;;
}
/************************************************************
* Convert the result value from the safe interpreter
* and setup structures for SPI_modifytuple();
************************************************************/
if
(
Tcl_SplitList
(
plperl_safe_interp
,
plperl_safe_interp
->
result
,
&
ret_numvals
,
&
ret_values
)
!=
TCL_OK
)
{
elog
(
NOTICE
,
"plperl: cannot split return value from trigger"
);
elog
(
ERROR
,
"plperl: %s"
,
plperl_safe_interp
->
result
);
}
if
(
ret_numvals
%
2
!=
0
)
{
ckfree
(
ret_values
);
elog
(
ERROR
,
"plperl: invalid return list from trigger - must have even # of elements"
);
}
modattrs
=
(
int
*
)
palloc
(
tupdesc
->
natts
*
sizeof
(
int
));
modvalues
=
(
Datum
*
)
palloc
(
tupdesc
->
natts
*
sizeof
(
Datum
));
for
(
i
=
0
;
i
<
tupdesc
->
natts
;
i
++
)
{
modattrs
[
i
]
=
i
+
1
;
modvalues
[
i
]
=
(
Datum
)
NULL
;
}
modnulls
=
palloc
(
tupdesc
->
natts
+
1
);
memset
(
modnulls
,
'n'
,
tupdesc
->
natts
);
modnulls
[
tupdesc
->
natts
]
=
'\0'
;
/************************************************************
* Care for possible elog(ERROR)'s below
************************************************************/
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
ckfree
(
ret_values
);
plperl_restart_in_progress
=
1
;
if
(
--
plperl_call_level
==
0
)
plperl_restart_in_progress
=
0
;
siglongjmp
(
Warn_restart
,
1
);
}
i
=
0
;
while
(
i
<
ret_numvals
)
{
int
attnum
;
HeapTuple
typeTup
;
Oid
typinput
;
Oid
typelem
;
FmgrInfo
finfo
;
/************************************************************
* Ignore pseudo elements with a dot name
************************************************************/
if
(
*
(
ret_values
[
i
])
==
'.'
)
{
i
+=
2
;
continue
;
}
/************************************************************
* Get the attribute number
************************************************************/
attnum
=
SPI_fnumber
(
tupdesc
,
ret_values
[
i
++
]);
if
(
attnum
==
SPI_ERROR_NOATTRIBUTE
)
elog
(
ERROR
,
"plperl: invalid attribute '%s'"
,
ret_values
[
--
i
]);
/************************************************************
* Lookup the attribute type in the syscache
* for the input function
************************************************************/
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
tupdesc
->
attrs
[
attnum
-
1
]
->
atttypid
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
elog
(
ERROR
,
"plperl: Cache lookup for attribute '%s' type %u failed"
,
ret_values
[
--
i
],
tupdesc
->
attrs
[
attnum
-
1
]
->
atttypid
);
}
typinput
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typinput
);
typelem
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typelem
);
ReleaseSysCache
(
typeTup
);
/************************************************************
* Set the attribute to NOT NULL and convert the contents
************************************************************/
modnulls
[
attnum
-
1
]
=
' '
;
fmgr_info
(
typinput
,
&
finfo
);
modvalues
[
attnum
-
1
]
=
FunctionCall3
(
&
finfo
,
CStringGetDatum
(
ret_values
[
i
++
]),
ObjectIdGetDatum
(
typelem
),
Int32GetDatum
(
tupdesc
->
attrs
[
attnum
-
1
]
->
atttypmod
));
}
rettup
=
SPI_modifytuple
(
trigdata
->
tg_relation
,
rettup
,
tupdesc
->
natts
,
modattrs
,
modvalues
,
modnulls
);
pfree
(
modattrs
);
pfree
(
modvalues
);
pfree
(
modnulls
);
if
(
rettup
==
NULL
)
elog
(
ERROR
,
"plperl: SPI_modifytuple() failed - RC = %d
\n
"
,
SPI_result
);
ckfree
(
ret_values
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
rettup
;
}
/**********************************************************************
* plperl_elog() - elog() support for PLTcl
**********************************************************************/
static
int
plperl_elog
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[])
{
int
level
;
sigjmp_buf
save_restart
;
/************************************************************
* Suppress messages during the restart process
************************************************************/
if
(
plperl_restart_in_progress
)
return
TCL_ERROR
;
/************************************************************
* Catch the restart longjmp and begin a controlled
* return though all interpreter levels if it happens
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
plperl_restart_in_progress
=
1
;
return
TCL_ERROR
;
}
if
(
argc
!=
3
)
{
Tcl_SetResult
(
interp
,
"syntax error - 'elog level msg'"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
if
(
strcmp
(
argv
[
1
],
"NOTICE"
)
==
0
)
level
=
NOTICE
;
else
if
(
strcmp
(
argv
[
1
],
"WARN"
)
==
0
)
level
=
ERROR
;
else
if
(
strcmp
(
argv
[
1
],
"ERROR"
)
==
0
)
level
=
ERROR
;
else
if
(
strcmp
(
argv
[
1
],
"FATAL"
)
==
0
)
level
=
FATAL
;
else
if
(
strcmp
(
argv
[
1
],
"DEBUG"
)
==
0
)
level
=
DEBUG
;
else
{
Tcl_AppendResult
(
interp
,
"Unknown elog level '"
,
argv
[
1
],
"'"
,
NULL
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_ERROR
;
}
/************************************************************
* Call elog(), restore the original restart address
* and return to the caller (if not catched)
************************************************************/
elog
(
level
,
argv
[
2
]);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_OK
;
}
/**********************************************************************
* plperl_quote() - quote literal strings that are to
* be used in SPI_exec query strings
**********************************************************************/
static
int
plperl_quote
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[])
{
char
*
tmp
;
char
*
cp1
;
char
*
cp2
;
/************************************************************
* Check call syntax
************************************************************/
if
(
argc
!=
2
)
{
Tcl_SetResult
(
interp
,
"syntax error - 'quote string'"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Allocate space for the maximum the string can
* grow to and initialize pointers
************************************************************/
tmp
=
palloc
(
strlen
(
argv
[
1
])
*
2
+
1
);
cp1
=
argv
[
1
];
cp2
=
tmp
;
/************************************************************
* Walk through string and double every quote and backslash
************************************************************/
while
(
*
cp1
)
{
if
(
*
cp1
==
'\''
)
*
cp2
++
=
'\''
;
else
{
if
(
*
cp1
==
'\\'
)
*
cp2
++
=
'\\'
;
}
*
cp2
++
=
*
cp1
++
;
}
/************************************************************
* Terminate the string and set it as result
************************************************************/
*
cp2
=
'\0'
;
Tcl_SetResult
(
interp
,
tmp
,
TCL_VOLATILE
);
pfree
(
tmp
);
return
TCL_OK
;
}
/**********************************************************************
* plperl_SPI_exec() - The builtin SPI_exec command
* for the safe interpreter
**********************************************************************/
static
int
plperl_SPI_exec
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[])
{
int
spi_rc
;
char
buf
[
64
];
int
count
=
0
;
char
*
arrayname
=
NULL
;
int
query_idx
;
int
i
;
int
loop_rc
;
int
ntuples
;
HeapTuple
*
tuples
;
TupleDesc
tupdesc
=
NULL
;
sigjmp_buf
save_restart
;
char
*
usage
=
"syntax error - 'SPI_exec "
"?-count n? "
"?-array name? query ?loop body?"
;
/************************************************************
* Don't do anything if we are already in restart mode
************************************************************/
if
(
plperl_restart_in_progress
)
return
TCL_ERROR
;
/************************************************************
* Check the call syntax and get the count option
************************************************************/
if
(
argc
<
2
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
i
=
1
;
while
(
i
<
argc
)
{
if
(
strcmp
(
argv
[
i
],
"-array"
)
==
0
)
{
if
(
++
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
arrayname
=
argv
[
i
++
];
continue
;
}
if
(
strcmp
(
argv
[
i
],
"-count"
)
==
0
)
{
if
(
++
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
if
(
Tcl_GetInt
(
interp
,
argv
[
i
++
],
&
count
)
!=
TCL_OK
)
return
TCL_ERROR
;
continue
;
}
break
;
}
query_idx
=
i
;
if
(
query_idx
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Prepare to start a controlled return through all
* interpreter levels on transaction abort
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
plperl_restart_in_progress
=
1
;
Tcl_SetResult
(
interp
,
"Transaction abort"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Execute the query and handle return codes
************************************************************/
spi_rc
=
SPI_exec
(
argv
[
query_idx
],
count
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
switch
(
spi_rc
)
{
case
SPI_OK_UTILITY
:
Tcl_SetResult
(
interp
,
"0"
,
TCL_VOLATILE
);
return
TCL_OK
;
case
SPI_OK_SELINTO
:
case
SPI_OK_INSERT
:
case
SPI_OK_DELETE
:
case
SPI_OK_UPDATE
:
sprintf
(
buf
,
"%d"
,
SPI_processed
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
return
TCL_OK
;
case
SPI_OK_SELECT
:
break
;
case
SPI_ERROR_ARGUMENT
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_UNCONNECTED
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_COPY
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_COPY"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_CURSOR
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_CURSOR"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_TRANSACTION
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_OPUNKNOWN
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
default:
sprintf
(
buf
,
"%d"
,
spi_rc
);
Tcl_AppendResult
(
interp
,
"plperl: SPI_exec() failed - "
,
"unknown RC "
,
buf
,
NULL
);
return
TCL_ERROR
;
}
/************************************************************
* Only SELECT queries fall through to here - remember the
* tuples we got
************************************************************/
ntuples
=
SPI_processed
;
if
(
ntuples
>
0
)
{
tuples
=
SPI_tuptable
->
vals
;
tupdesc
=
SPI_tuptable
->
tupdesc
;
}
/************************************************************
* Again prepare for elog(ERROR)
************************************************************/
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
plperl_restart_in_progress
=
1
;
Tcl_SetResult
(
interp
,
"Transaction abort"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* If there is no loop body given, just set the variables
* from the first tuple (if any) and return the number of
* tuples selected
************************************************************/
if
(
argc
==
query_idx
+
1
)
{
if
(
ntuples
>
0
)
plperl_set_tuple_values
(
interp
,
arrayname
,
0
,
tuples
[
0
],
tupdesc
);
sprintf
(
buf
,
"%d"
,
ntuples
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_OK
;
}
/************************************************************
* There is a loop body - process all tuples and evaluate
* the body on each
************************************************************/
query_idx
++
;
for
(
i
=
0
;
i
<
ntuples
;
i
++
)
{
plperl_set_tuple_values
(
interp
,
arrayname
,
i
,
tuples
[
i
],
tupdesc
);
loop_rc
=
Tcl_Eval
(
interp
,
argv
[
query_idx
]);
if
(
loop_rc
==
TCL_OK
)
continue
;
if
(
loop_rc
==
TCL_CONTINUE
)
continue
;
if
(
loop_rc
==
TCL_RETURN
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_RETURN
;
}
if
(
loop_rc
==
TCL_BREAK
)
break
;
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_ERROR
;
}
/************************************************************
* Finally return the number of tuples
************************************************************/
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
sprintf
(
buf
,
"%d"
,
ntuples
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
return
TCL_OK
;
}
/**********************************************************************
* plperl_SPI_prepare() - Builtin support for prepared plans
* The Tcl command SPI_prepare
* allways saves the plan using
* SPI_saveplan and returns a key for
* access. There is no chance to prepare
* and not save the plan currently.
**********************************************************************/
static
int
plperl_SPI_prepare
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[])
{
int
nargs
;
char
**
args
;
plperl_query_desc
*
qdesc
;
void
*
plan
;
int
i
;
HeapTuple
typeTup
;
Tcl_HashEntry
*
hashent
;
int
hashnew
;
sigjmp_buf
save_restart
;
/************************************************************
* Don't do anything if we are already in restart mode
************************************************************/
if
(
plperl_restart_in_progress
)
return
TCL_ERROR
;
/************************************************************
* Check the call syntax
************************************************************/
if
(
argc
!=
3
)
{
Tcl_SetResult
(
interp
,
"syntax error - 'SPI_prepare query argtypes'"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Split the argument type list
************************************************************/
if
(
Tcl_SplitList
(
interp
,
argv
[
2
],
&
nargs
,
&
args
)
!=
TCL_OK
)
return
TCL_ERROR
;
/************************************************************
* Allocate the new querydesc structure
************************************************************/
qdesc
=
(
plperl_query_desc
*
)
malloc
(
sizeof
(
plperl_query_desc
));
sprintf
(
qdesc
->
qname
,
"%lx"
,
(
long
)
qdesc
);
qdesc
->
nargs
=
nargs
;
qdesc
->
argtypes
=
(
Oid
*
)
malloc
(
nargs
*
sizeof
(
Oid
));
qdesc
->
arginfuncs
=
(
FmgrInfo
*
)
malloc
(
nargs
*
sizeof
(
FmgrInfo
));
qdesc
->
argtypelems
=
(
Oid
*
)
malloc
(
nargs
*
sizeof
(
Oid
));
qdesc
->
argvalues
=
(
Datum
*
)
malloc
(
nargs
*
sizeof
(
Datum
));
qdesc
->
arglen
=
(
int
*
)
malloc
(
nargs
*
sizeof
(
int
));
/************************************************************
* Prepare to start a controlled return through all
* interpreter levels on transaction abort
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
plperl_restart_in_progress
=
1
;
free
(
qdesc
->
argtypes
);
free
(
qdesc
->
arginfuncs
);
free
(
qdesc
->
argtypelems
);
free
(
qdesc
->
argvalues
);
free
(
qdesc
->
arglen
);
free
(
qdesc
);
ckfree
(
args
);
return
TCL_ERROR
;
}
/************************************************************
* Lookup the argument types by name in the system cache
* and remember the required information for input conversion
************************************************************/
for
(
i
=
0
;
i
<
nargs
;
i
++
)
{
typeTup
=
SearchSysCache
(
TYPNAME
,
PointerGetDatum
(
args
[
i
]),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
elog
(
ERROR
,
"plperl: Cache lookup of type %s failed"
,
args
[
i
]);
qdesc
->
argtypes
[
i
]
=
typeTup
->
t_data
->
t_oid
;
perm_fmgr_info
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typinput
,
&
(
qdesc
->
arginfuncs
[
i
]));
qdesc
->
argtypelems
[
i
]
=
((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typelem
;
qdesc
->
argvalues
[
i
]
=
(
Datum
)
NULL
;
qdesc
->
arglen
[
i
]
=
(
int
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typlen
);
ReleaseSysCache
(
typeTup
);
}
/************************************************************
* Prepare the plan and check for errors
************************************************************/
plan
=
SPI_prepare
(
argv
[
1
],
nargs
,
qdesc
->
argtypes
);
if
(
plan
==
NULL
)
{
char
buf
[
128
];
char
*
reason
;
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
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:
sprintf
(
buf
,
"unknown RC %d"
,
SPI_result
);
reason
=
buf
;
break
;
}
elog
(
ERROR
,
"plperl: SPI_prepare() failed - %s"
,
reason
);
}
/************************************************************
* Save the plan
************************************************************/
qdesc
->
plan
=
SPI_saveplan
(
plan
);
if
(
qdesc
->
plan
==
NULL
)
{
char
buf
[
128
];
char
*
reason
;
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
switch
(
SPI_result
)
{
case
SPI_ERROR_ARGUMENT
:
reason
=
"SPI_ERROR_ARGUMENT"
;
break
;
case
SPI_ERROR_UNCONNECTED
:
reason
=
"SPI_ERROR_UNCONNECTED"
;
break
;
default:
sprintf
(
buf
,
"unknown RC %d"
,
SPI_result
);
reason
=
buf
;
break
;
}
elog
(
ERROR
,
"plperl: SPI_saveplan() failed - %s"
,
reason
);
}
/************************************************************
* Insert a hashtable entry for the plan and return
* the key to the caller
************************************************************/
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
hashent
=
Tcl_CreateHashEntry
(
plperl_query_hash
,
qdesc
->
qname
,
&
hashnew
);
Tcl_SetHashValue
(
hashent
,
(
ClientData
)
qdesc
);
Tcl_SetResult
(
interp
,
qdesc
->
qname
,
TCL_VOLATILE
);
return
TCL_OK
;
}
/**********************************************************************
* plperl_SPI_execp() - Execute a prepared plan
**********************************************************************/
static
int
plperl_SPI_execp
(
ClientData
cdata
,
Tcl_Interp
*
interp
,
int
argc
,
char
*
argv
[])
{
int
spi_rc
;
char
buf
[
64
];
int
i
,
j
;
int
loop_body
;
Tcl_HashEntry
*
hashent
;
plperl_query_desc
*
qdesc
;
char
*
nulls
=
NULL
;
char
*
arrayname
=
NULL
;
int
count
=
0
;
int
callnargs
;
static
char
**
callargs
=
NULL
;
int
loop_rc
;
int
ntuples
;
HeapTuple
*
tuples
=
NULL
;
TupleDesc
tupdesc
=
NULL
;
sigjmp_buf
save_restart
;
char
*
usage
=
"syntax error - 'SPI_execp "
"?-nulls string? ?-count n? "
"?-array name? query ?args? ?loop body?"
;
/************************************************************
* Tidy up from an earlier abort
************************************************************/
if
(
callargs
!=
NULL
)
{
ckfree
(
callargs
);
callargs
=
NULL
;
}
/************************************************************
* Don't do anything if we are already in restart mode
************************************************************/
if
(
plperl_restart_in_progress
)
return
TCL_ERROR
;
/************************************************************
* Get the options and check syntax
************************************************************/
i
=
1
;
while
(
i
<
argc
)
{
if
(
strcmp
(
argv
[
i
],
"-array"
)
==
0
)
{
if
(
++
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
arrayname
=
argv
[
i
++
];
continue
;
}
if
(
strcmp
(
argv
[
i
],
"-nulls"
)
==
0
)
{
if
(
++
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
nulls
=
argv
[
i
++
];
continue
;
}
if
(
strcmp
(
argv
[
i
],
"-count"
)
==
0
)
{
if
(
++
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
if
(
Tcl_GetInt
(
interp
,
argv
[
i
++
],
&
count
)
!=
TCL_OK
)
return
TCL_ERROR
;
continue
;
}
break
;
}
/************************************************************
* Check minimum call arguments
************************************************************/
if
(
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
usage
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Get the prepared plan descriptor by it's key
************************************************************/
hashent
=
Tcl_FindHashEntry
(
plperl_query_hash
,
argv
[
i
++
]);
if
(
hashent
==
NULL
)
{
Tcl_AppendResult
(
interp
,
"invalid queryid '"
,
argv
[
--
i
],
"'"
,
NULL
);
return
TCL_ERROR
;
}
qdesc
=
(
plperl_query_desc
*
)
Tcl_GetHashValue
(
hashent
);
/************************************************************
* If a nulls string is given, check for correct length
************************************************************/
if
(
nulls
!=
NULL
)
{
if
(
strlen
(
nulls
)
!=
qdesc
->
nargs
)
{
Tcl_SetResult
(
interp
,
"length of nulls string doesn't match # of arguments"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
}
/************************************************************
* If there was a argtype list on preparation, we need
* an argument value list now
************************************************************/
if
(
qdesc
->
nargs
>
0
)
{
if
(
i
>=
argc
)
{
Tcl_SetResult
(
interp
,
"missing argument list"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Split the argument values
************************************************************/
if
(
Tcl_SplitList
(
interp
,
argv
[
i
++
],
&
callnargs
,
&
callargs
)
!=
TCL_OK
)
return
TCL_ERROR
;
/************************************************************
* Check that the # of arguments matches
************************************************************/
if
(
callnargs
!=
qdesc
->
nargs
)
{
Tcl_SetResult
(
interp
,
"argument list length doesn't match # of arguments for query"
,
TCL_VOLATILE
);
if
(
callargs
!=
NULL
)
{
ckfree
(
callargs
);
callargs
=
NULL
;
}
return
TCL_ERROR
;
}
/************************************************************
* Prepare to start a controlled return through all
* interpreter levels on transaction abort during the
* parse of the arguments
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
for
(
j
=
0
;
j
<
callnargs
;
j
++
)
{
if
(
qdesc
->
arglen
[
j
]
<
0
&&
qdesc
->
argvalues
[
j
]
!=
(
Datum
)
NULL
)
{
pfree
((
char
*
)
(
qdesc
->
argvalues
[
j
]));
qdesc
->
argvalues
[
j
]
=
(
Datum
)
NULL
;
}
}
ckfree
(
callargs
);
callargs
=
NULL
;
plperl_restart_in_progress
=
1
;
Tcl_SetResult
(
interp
,
"Transaction abort"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Setup the value array for the SPI_execp() using
* the type specific input functions
************************************************************/
for
(
j
=
0
;
j
<
callnargs
;
j
++
)
{
qdesc
->
argvalues
[
j
]
=
FunctionCall3
(
&
qdesc
->
arginfuncs
[
j
],
CStringGetDatum
(
callargs
[
j
]),
ObjectIdGetDatum
(
qdesc
->
argtypelems
[
j
]),
Int32GetDatum
(
qdesc
->
arglen
[
j
]));
}
/************************************************************
* Free the splitted argument value list
************************************************************/
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
ckfree
(
callargs
);
callargs
=
NULL
;
}
else
callnargs
=
0
;
/************************************************************
* Remember the index of the last processed call
* argument - a loop body for SELECT might follow
************************************************************/
loop_body
=
i
;
/************************************************************
* Prepare to start a controlled return through all
* interpreter levels on transaction abort
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
for
(
j
=
0
;
j
<
callnargs
;
j
++
)
{
if
(
qdesc
->
arglen
[
j
]
<
0
&&
qdesc
->
argvalues
[
j
]
!=
(
Datum
)
NULL
)
{
pfree
((
char
*
)
(
qdesc
->
argvalues
[
j
]));
qdesc
->
argvalues
[
j
]
=
(
Datum
)
NULL
;
}
}
plperl_restart_in_progress
=
1
;
Tcl_SetResult
(
interp
,
"Transaction abort"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* Execute the plan
************************************************************/
spi_rc
=
SPI_execp
(
qdesc
->
plan
,
qdesc
->
argvalues
,
nulls
,
count
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
/************************************************************
* For varlena data types, free the argument values
************************************************************/
for
(
j
=
0
;
j
<
callnargs
;
j
++
)
{
if
(
qdesc
->
arglen
[
j
]
<
0
&&
qdesc
->
argvalues
[
j
]
!=
(
Datum
)
NULL
)
{
pfree
((
char
*
)
(
qdesc
->
argvalues
[
j
]));
qdesc
->
argvalues
[
j
]
=
(
Datum
)
NULL
;
}
}
/************************************************************
* Check the return code from SPI_execp()
************************************************************/
switch
(
spi_rc
)
{
case
SPI_OK_UTILITY
:
Tcl_SetResult
(
interp
,
"0"
,
TCL_VOLATILE
);
return
TCL_OK
;
case
SPI_OK_SELINTO
:
case
SPI_OK_INSERT
:
case
SPI_OK_DELETE
:
case
SPI_OK_UPDATE
:
sprintf
(
buf
,
"%d"
,
SPI_processed
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
return
TCL_OK
;
case
SPI_OK_SELECT
:
break
;
case
SPI_ERROR_ARGUMENT
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_ARGUMENT"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_UNCONNECTED
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_UNCONNECTED"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_COPY
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_COPY"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_CURSOR
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_CURSOR"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_TRANSACTION
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_TRANSACTION"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
case
SPI_ERROR_OPUNKNOWN
:
Tcl_SetResult
(
interp
,
"plperl: SPI_exec() failed - SPI_ERROR_OPUNKNOWN"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
default:
sprintf
(
buf
,
"%d"
,
spi_rc
);
Tcl_AppendResult
(
interp
,
"plperl: SPI_exec() failed - "
,
"unknown RC "
,
buf
,
NULL
);
return
TCL_ERROR
;
}
/************************************************************
* Only SELECT queries fall through to here - remember the
* tuples we got
************************************************************/
ntuples
=
SPI_processed
;
if
(
ntuples
>
0
)
{
tuples
=
SPI_tuptable
->
vals
;
tupdesc
=
SPI_tuptable
->
tupdesc
;
}
/************************************************************
* Prepare to start a controlled return through all
* interpreter levels on transaction abort during
* the ouput conversions of the results
************************************************************/
memcpy
(
&
save_restart
,
&
Warn_restart
,
sizeof
(
save_restart
));
if
(
sigsetjmp
(
Warn_restart
,
1
)
!=
0
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
plperl_restart_in_progress
=
1
;
Tcl_SetResult
(
interp
,
"Transaction abort"
,
TCL_VOLATILE
);
return
TCL_ERROR
;
}
/************************************************************
* If there is no loop body given, just set the variables
* from the first tuple (if any) and return the number of
* tuples selected
************************************************************/
if
(
loop_body
>=
argc
)
{
if
(
ntuples
>
0
)
plperl_set_tuple_values
(
interp
,
arrayname
,
0
,
tuples
[
0
],
tupdesc
);
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
sprintf
(
buf
,
"%d"
,
ntuples
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
return
TCL_OK
;
}
/************************************************************
* There is a loop body - process all tuples and evaluate
* the body on each
************************************************************/
for
(
i
=
0
;
i
<
ntuples
;
i
++
)
{
plperl_set_tuple_values
(
interp
,
arrayname
,
i
,
tuples
[
i
],
tupdesc
);
loop_rc
=
Tcl_Eval
(
interp
,
argv
[
loop_body
]);
if
(
loop_rc
==
TCL_OK
)
continue
;
if
(
loop_rc
==
TCL_CONTINUE
)
continue
;
if
(
loop_rc
==
TCL_RETURN
)
{
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_RETURN
;
}
if
(
loop_rc
==
TCL_BREAK
)
break
;
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
return
TCL_ERROR
;
}
/************************************************************
* Finally return the number of tuples
************************************************************/
memcpy
(
&
Warn_restart
,
&
save_restart
,
sizeof
(
Warn_restart
));
sprintf
(
buf
,
"%d"
,
ntuples
);
Tcl_SetResult
(
interp
,
buf
,
TCL_VOLATILE
);
return
TCL_OK
;
}
/**********************************************************************
* plperl_set_tuple_values() - Set variables for all attributes
* of a given tuple
**********************************************************************/
static
void
plperl_set_tuple_values
(
Tcl_Interp
*
interp
,
char
*
arrayname
,
int
tupno
,
HeapTuple
tuple
,
TupleDesc
tupdesc
)
{
int
i
;
char
*
outputstr
;
char
buf
[
64
];
Datum
attr
;
bool
isnull
;
char
*
attname
;
HeapTuple
typeTup
;
Oid
typoutput
;
Oid
typelem
;
char
**
arrptr
;
char
**
nameptr
;
char
*
nullname
=
NULL
;
/************************************************************
* Prepare pointers for Tcl_SetVar2() below and in array
* mode set the .tupno element
************************************************************/
if
(
arrayname
==
NULL
)
{
arrptr
=
&
attname
;
nameptr
=
&
nullname
;
}
else
{
arrptr
=
&
arrayname
;
nameptr
=
&
attname
;
sprintf
(
buf
,
"%d"
,
tupno
);
Tcl_SetVar2
(
interp
,
arrayname
,
".tupno"
,
buf
,
0
);
}
for
(
i
=
0
;
i
<
tupdesc
->
natts
;
i
++
)
{
/************************************************************
* Get the attribute name
************************************************************/
attname
=
tupdesc
->
attrs
[
i
]
->
attname
.
data
;
/************************************************************
* Get the attributes value
************************************************************/
attr
=
heap_getattr
(
tuple
,
i
+
1
,
tupdesc
,
&
isnull
);
/************************************************************
* Lookup the attribute type in the syscache
* for the output function
************************************************************/
typeTup
=
SearchSysCache
(
TYPEOID
,
ObjectIdGetDatum
(
tupdesc
->
attrs
[
i
]
->
atttypid
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
elog
(
ERROR
,
"plperl: Cache lookup for attribute '%s' type %u failed"
,
attname
,
tupdesc
->
attrs
[
i
]
->
atttypid
);
}
typoutput
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typoutput
);
typelem
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typelem
);
ReleaseSysCache
(
typeTup
);
/************************************************************
* If there is a value, set the variable
* If not, unset it
*
* Hmmm - Null attributes will cause functions to
* crash if they don't expect them - need something
* smarter here.
************************************************************/
if
(
!
isnull
&&
OidIsValid
(
typoutput
))
{
outputstr
=
DatumGetCString
(
OidFunctionCall3
(
typoutput
,
attr
,
ObjectIdGetDatum
(
typelem
),
Int32GetDatum
(
tupdesc
->
attrs
[
i
]
->
attlen
)));
Tcl_SetVar2
(
interp
,
*
arrptr
,
*
nameptr
,
outputstr
,
0
);
pfree
(
outputstr
);
}
else
Tcl_UnsetVar2
(
interp
,
*
arrptr
,
*
nameptr
,
0
);
}
}
#endif
/**********************************************************************
* plperl_build_tuple_argument() - Build a string for a ref to a hash
* from all attributes of a given tuple
...
...
@@ -2188,7 +731,6 @@ plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
SV
*
output
;
Datum
attr
;
bool
isnull
;
char
*
attname
;
char
*
outputstr
;
HeapTuple
typeTup
;
...
...
@@ -2209,6 +751,15 @@ plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
************************************************************/
attr
=
heap_getattr
(
tuple
,
i
+
1
,
tupdesc
,
&
isnull
);
/************************************************************
* If it is null it will be set to undef in the hash.
************************************************************/
if
(
isnull
)
{
sv_catpvf
(
output
,
"'%s' => undef,"
,
attname
);
continue
;
}
/************************************************************
* Lookup the attribute type in the syscache
* for the output function
...
...
@@ -2217,32 +768,24 @@ plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
ObjectIdGetDatum
(
tupdesc
->
attrs
[
i
]
->
atttypid
),
0
,
0
,
0
);
if
(
!
HeapTupleIsValid
(
typeTup
))
{
elog
(
ERROR
,
"plperl: Cache lookup for attribute '%s' type %u failed"
,
attname
,
tupdesc
->
attrs
[
i
]
->
atttypid
);
}
typoutput
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typoutput
)
;
typelem
=
(
Oid
)
(((
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typelem
)
;
typoutput
=
(
(
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typoutput
;
typelem
=
(
(
Form_pg_type
)
GETSTRUCT
(
typeTup
))
->
typelem
;
ReleaseSysCache
(
typeTup
);
/************************************************************
* If there is a value, append the attribute name and the
* value to the list.
* If it is null it will be set to undef.
* Append the attribute name and the value to the list.
************************************************************/
if
(
!
isnull
&&
OidIsValid
(
typoutput
))
{
outputstr
=
DatumGetCString
(
OidFunctionCall3
(
typoutput
,
attr
,
ObjectIdGetDatum
(
typelem
),
Int32GetDatum
(
tupdesc
->
attrs
[
i
]
->
attlen
)));
sv_catpvf
(
output
,
"'%s' => '%s',"
,
attname
,
outputstr
);
pfree
(
outputstr
);
}
else
sv_catpvf
(
output
,
"'%s' => undef,"
,
attname
);
outputstr
=
DatumGetCString
(
OidFunctionCall3
(
typoutput
,
attr
,
ObjectIdGetDatum
(
typelem
),
Int32GetDatum
(
tupdesc
->
attrs
[
i
]
->
atttypmod
)));
sv_catpvf
(
output
,
"'%s' => '%s',"
,
attname
,
outputstr
);
pfree
(
outputstr
);
}
sv_catpv
(
output
,
"}"
);
output
=
perl_eval_pv
(
SvPV
(
output
,
PL_na
),
TRUE
);
return
output
;
...
...
编辑
预览
Markdown
is supported
0%
请重试
或
添加新附件
.
添加附件
取消
You are about to add
0
people
to the discussion. Proceed with caution.
先完成此消息的编辑!
取消
想要评论请
注册
或
登录