src/pl/plperl/plperl_helpers.h

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