src/pl/plperl/plperl.h

   1 /*-------------------------------------------------------------------------
   2  *
   3  * plperl.h
   4  *        Common include file for PL/Perl files
   5  *
   6  * This should be included _AFTER_ postgres.h and system include files, as
   7  * well as headers that could in turn include system headers.
   8  *
   9  * Portions Copyright (c) 1996-2024, PostgreSQL Global Development Group
  10  * Portions Copyright (c) 1995, Regents of the University of California
  11  *
  12  * src/pl/plperl/plperl.h
  13  */
  14
  15 #ifndef PL_PERL_H
  16 #define PL_PERL_H
  17
  18 /* defines free() by way of system headers, so must be included before perl.h */
  19 #include "mb/pg_wchar.h"
  20
  21 /*
  22  * Pull in Perl headers via a wrapper header, to control the scope of
  23  * the system_header pragma therein.
  24  */
  25 #include "plperl_system.h"
  26
  27 /* declare routines from plperl.c for access by .xs files */
  28 HV                 *plperl_spi_exec(char *, int);
  29 void            plperl_return_next(SV *);
  30 SV                 *plperl_spi_query(char *);
  31 SV                 *plperl_spi_fetchrow(char *);
  32 SV                 *plperl_spi_prepare(char *, int, SV **);
  33 HV                 *plperl_spi_exec_prepared(char *, HV *, int, SV **);
  34 SV                 *plperl_spi_query_prepared(char *, int, SV **);
  35 void            plperl_spi_freeplan(char *);
  36 void            plperl_spi_cursor_close(char *);
  37 void            plperl_spi_commit(void);
  38 void            plperl_spi_rollback(void);
  39 char       *plperl_sv_to_literal(SV *, char *);
  40 void            plperl_util_elog(int level, SV *msg);
  41
  42
  43 /* helper functions */
  44
  45 /*
  46  * convert from utf8 to database encoding
  47  *
  48  * Returns a palloc'ed copy of the original string
  49  */
  50 static inline char *
  51 utf_u2e(char *utf8_str, size_t len)
  52 {
  53         char       *ret;
  54
  55         ret = pg_any_to_server(utf8_str, len, PG_UTF8);
  56
  57         /* ensure we have a copy even if no conversion happened */
  58         if (ret == utf8_str)
  59                 ret = pstrdup(ret);
  60
  61         return ret;
  62 }
  63
  64 /*
  65  * convert from database encoding to utf8
  66  *
  67  * Returns a palloc'ed copy of the original string
  68  */
  69 static inline char *
  70 utf_e2u(const char *str)
  71 {
  72         char       *ret;
  73
  74         ret = pg_server_to_any(str, strlen(str), PG_UTF8);
  75
  76         /* ensure we have a copy even if no conversion happened */
  77         if (ret == str)
  78                 ret = pstrdup(ret);
  79
  80         return ret;
  81 }
  82
  83 /*
  84  * Convert an SV to a char * in the current database encoding
  85  *
  86  * Returns a palloc'ed copy of the original string
  87  */
  88 static inline char *
  89 sv2cstr(SV *sv)
  90 {
  91         dTHX;
  92         char       *val,
  93                            *res;
  94         STRLEN          len;
  95
  96         /*
  97          * get a utf8 encoded char * out of perl. *note* it may not be valid utf8!
  98          */
  99
 100         /*
 101          * SvPVutf8() croaks nastily on certain things, like typeglobs and
 102          * readonly objects such as $^V. That's a perl bug - it's not supposed to
 103          * happen. To avoid crashing the backend, we make a copy of the sv before
 104          * passing it to SvPVutf8(). The copy is garbage collected when we're done
 105          * with it.
 106          */
 107         if (SvREADONLY(sv) ||
 108                 isGV_with_GP(sv) ||
 109                 (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
 110                 sv = newSVsv(sv);
 111         else
 112         {
 113                 /*
 114                  * increase the reference count so we can just SvREFCNT_dec() it when
 115                  * we are done
 116                  */
 117                 SvREFCNT_inc_simple_void(sv);
 118         }
 119
 120         /*
 121          * Request the string from Perl, in UTF-8 encoding; but if we're in a
 122          * SQL_ASCII database, just request the byte soup without trying to make
 123          * it UTF8, because that might fail.
 124          */
 125         if (GetDatabaseEncoding() == PG_SQL_ASCII)
 126                 val = SvPV(sv, len);
 127         else
 128                 val = SvPVutf8(sv, len);
 129
 130         /*
 131          * Now convert to database encoding.  We use perl's length in the event we
 132          * had an embedded null byte to ensure we error out properly.
 133          */
 134         res = utf_u2e(val, len);
 135
 136         /* safe now to garbage collect the new SV */
 137         SvREFCNT_dec(sv);
 138
 139         return res;
 140 }
 141
 142 /*
 143  * Create a new SV from a string assumed to be in the current database's
 144  * encoding.
 145  */
 146 static inline SV *
 147 cstr2sv(const char *str)
 148 {
 149         dTHX;
 150         SV                 *sv;
 151         char       *utf8_str;
 152
 153         /* no conversion when SQL_ASCII */
 154         if (GetDatabaseEncoding() == PG_SQL_ASCII)
 155                 return newSVpv(str, 0);
 156
 157         utf8_str = utf_e2u(str);
 158
 159         sv = newSVpv(utf8_str, 0);
 160         SvUTF8_on(sv);
 161         pfree(utf8_str);
 162
 163         return sv;
 164 }
 165
 166 /*
 167  * croak() with specified message, which is given in the database encoding.
 168  *
 169  * Ideally we'd just write croak("%s", str), but plain croak() does not play
 170  * nice with non-ASCII data.  In modern Perl versions we can call cstr2sv()
 171  * and pass the result to croak_sv(); in versions that don't have croak_sv(),
 172  * we have to work harder.
 173  */
 174 static inline void
 175 croak_cstr(const char *str)
 176 {
 177         dTHX;
 178
 179 #ifdef croak_sv
 180         /* Use sv_2mortal() to be sure the transient SV gets freed */
 181         croak_sv(sv_2mortal(cstr2sv(str)));
 182 #else
 183
 184         /*
 185          * The older way to do this is to assign a UTF8-marked value to ERRSV and
 186          * then call croak(NULL).  But if we leave it to croak() to append the
 187          * error location, it does so too late (only after popping the stack) in
 188          * some Perl versions.  Hence, use mess() to create an SV with the error
 189          * location info already appended.
 190          */
 191         SV                 *errsv = get_sv("@", GV_ADD);
 192         char       *utf8_str = utf_e2u(str);
 193         SV                 *ssv;
 194
 195         ssv = mess("%s", utf8_str);
 196         SvUTF8_on(ssv);
 197
 198         pfree(utf8_str);
 199
 200         sv_setsv(errsv, ssv);
 201
 202         croak(NULL);
 203 #endif                                                  /* croak_sv */
 204 }
 205
 206 #endif                                                  /* PL_PERL_H */