Line data Source code
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 2184 : utf_u2e(char *utf8_str, size_t len)
52 : {
53 : char *ret;
54 :
55 2184 : ret = pg_any_to_server(utf8_str, len, PG_UTF8);
56 :
57 : /* ensure we have a copy even if no conversion happened */
58 2182 : if (ret == utf8_str)
59 2182 : ret = pstrdup(ret);
60 :
61 2182 : 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 2714 : utf_e2u(const char *str)
71 : {
72 : char *ret;
73 :
74 2714 : ret = pg_server_to_any(str, strlen(str), PG_UTF8);
75 :
76 : /* ensure we have a copy even if no conversion happened */
77 2714 : if (ret == str)
78 2714 : ret = pstrdup(ret);
79 :
80 2714 : 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 2184 : sv2cstr(SV *sv)
90 : {
91 2184 : 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 2184 : if (SvREADONLY(sv) ||
108 2034 : isGV_with_GP(sv) ||
109 2034 : (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM))
110 150 : 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 2034 : 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 2184 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
126 0 : val = SvPV(sv, len);
127 : else
128 2184 : 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 2184 : res = utf_u2e(val, len);
135 :
136 : /* safe now to garbage collect the new SV */
137 2182 : SvREFCNT_dec(sv);
138 :
139 2182 : 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 2714 : cstr2sv(const char *str)
148 : {
149 2714 : dTHX;
150 : SV *sv;
151 : char *utf8_str;
152 :
153 : /* no conversion when SQL_ASCII */
154 2714 : if (GetDatabaseEncoding() == PG_SQL_ASCII)
155 0 : return newSVpv(str, 0);
156 :
157 2714 : utf8_str = utf_e2u(str);
158 :
159 2714 : sv = newSVpv(utf8_str, 0);
160 2714 : SvUTF8_on(sv);
161 2714 : pfree(utf8_str);
162 :
163 2714 : 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 26 : croak_cstr(const char *str)
176 : {
177 26 : dTHX;
178 :
179 : #ifdef croak_sv
180 : /* Use sv_2mortal() to be sure the transient SV gets freed */
181 26 : 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 */
|
