LCOV - code coverage report
Current view: top level - src/pl/plperl - plperl_helpers.h (source / functions) Hit Total Coverage
Test: PostgreSQL 13devel Lines: 33 35 94.3 %
Date: 2019-11-13 23:06:49 Functions: 5 5 100.0 %
Legend: Lines: hit not hit

          Line data    Source code
       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        2140 : utf_u2e(char *utf8_str, size_t len)
      16             : {
      17             :     char       *ret;
      18             : 
      19        2140 :     ret = pg_any_to_server(utf8_str, len, PG_UTF8);
      20             : 
      21             :     /* ensure we have a copy even if no conversion happened */
      22        2138 :     if (ret == utf8_str)
      23        2138 :         ret = pstrdup(ret);
      24             : 
      25        2138 :     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        2462 : utf_e2u(const char *str)
      35             : {
      36             :     char       *ret;
      37             : 
      38        2462 :     ret = pg_server_to_any(str, strlen(str), PG_UTF8);
      39             : 
      40             :     /* ensure we have a copy even if no conversion happened */
      41        2462 :     if (ret == str)
      42        2462 :         ret = pstrdup(ret);
      43             : 
      44        2462 :     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        2140 : sv2cstr(SV *sv)
      55             : {
      56        2140 :     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        4146 :     if (SvREADONLY(sv) ||
      73        4012 :         isGV_with_GP(sv) ||
      74        2006 :         (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
      75         134 :         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        2006 :         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        2140 :     if (GetDatabaseEncoding() == PG_SQL_ASCII)
      91           0 :         val = SvPV(sv, len);
      92             :     else
      93        2140 :         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        2140 :     res = utf_u2e(val, len);
     100             : 
     101             :     /* safe now to garbage collect the new SV */
     102        2138 :     SvREFCNT_dec(sv);
     103             : 
     104        2138 :     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        2462 : cstr2sv(const char *str)
     113             : {
     114        2462 :     dTHX;
     115             :     SV         *sv;
     116             :     char       *utf8_str;
     117             : 
     118             :     /* no conversion when SQL_ASCII */
     119        2462 :     if (GetDatabaseEncoding() == PG_SQL_ASCII)
     120           0 :         return newSVpv(str, 0);
     121             : 
     122        2462 :     utf8_str = utf_e2u(str);
     123             : 
     124        2462 :     sv = newSVpv(utf8_str, 0);
     125        2462 :     SvUTF8_on(sv);
     126        2462 :     pfree(utf8_str);
     127             : 
     128        2462 :     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          22 : croak_cstr(const char *str)
     141             : {
     142          22 :     dTHX;
     143             : 
     144             : #ifdef croak_sv
     145             :     /* Use sv_2mortal() to be sure the transient SV gets freed */
     146          22 :     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 */

Generated by: LCOV version 1.13