- /************************************************************
- * 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 = SearchSysCacheTuple(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;
- 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);
- }
-
- /************************************************************
- * 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] = (Datum) (*fmgr_faddr(&qdesc->arginfuncs[j]))
- (callargs[j],
- qdesc->argtypelems[j],
- 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 = SearchSysCacheTuple(TYPEOID,
- ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
- 0, 0, 0);
- if (!HeapTupleIsValid(typeTup))
- {
- elog(ERROR, "plperl: Cache lookup for attribute '%s' type %ld failed",
- attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid));
- }
-
- typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
- typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
-
- /************************************************************
- * 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))
- {
- FmgrInfo finfo;
-
- fmgr_info(typoutput, &finfo);
-
- outputstr = (*fmgr_faddr(&finfo))
- (attr, typelem,
- 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
- **********************************************************************/
-static SV *
-plperl_build_tuple_argument(HeapTuple tuple, TupleDesc tupdesc)
-{
- int i;
- SV *output;
- Datum attr;
- bool isnull;
-
- char *attname;
- char *outputstr;
- HeapTuple typeTup;
- Oid typoutput;
- Oid typelem;
-
- output = sv_2mortal(newSVpv("{", 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 = SearchSysCacheTuple(TYPEOID,
- ObjectIdGetDatum(tupdesc->attrs[i]->atttypid),
- 0, 0, 0);
- if (!HeapTupleIsValid(typeTup))
- {
- elog(ERROR, "plperl: Cache lookup for attribute '%s' type %ld failed",
- attname, ObjectIdGetDatum(tupdesc->attrs[i]->atttypid));
- }
-
- typoutput = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typoutput);
- typelem = (Oid) (((Form_pg_type) GETSTRUCT(typeTup))->typelem);
-
- /************************************************************
- * 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.
- ************************************************************/
- if (!isnull && OidIsValid(typoutput))
- {
- FmgrInfo finfo;
-
- fmgr_info(typoutput, &finfo);
-
- outputstr = (*fmgr_faddr(&finfo))
- (attr, typelem,
- tupdesc->attrs[i]->attlen);
-
- sv_catpvf(output, "'%s' => '%s',", attname, outputstr);
- pfree(outputstr);
- }
- else
- sv_catpvf(output, "'%s' => undef,", attname);
- }
- sv_catpv(output, "}");
- output = perl_eval_pv(SvPV(output, na), TRUE);
- return output;