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