1 /* On Win32 without PERL_IMPLICIT_SYS, PerlLIO_link is #defined as
2  * link, which in turn is #defined as win32_link, but mp2's
3  * modperl_perl_unembed.h #undefs link, leaving link as an unresolved
4  * symbol when linking Param.dll.
5  */
6 #ifdef WIN32
7 #ifndef PERL_IMPLICIT_SYS
8 #undef PerlLIO_link
9 #define PerlLIO_link(oldname, newname) win32_link(oldname, newname)
10 #endif
11 #endif
12 
13 MODULE = APR::Request::Param      PACKAGE = APR::Request::Param
14 
15 SV *
16 value(obj, p1=NULL, p2=NULL)
17     APR::Request::Param obj
18     SV *p1
19     SV *p2
20   PREINIT:
21     /*nada*/
22 
23   CODE:
24     RETVAL = apreq_xs_param2sv(aTHX_ obj, NULL, NULL);
25 
26   OUTPUT:
27     RETVAL
28 
29 SV *
30 upload_filename(obj)
31     APR::Request::Param obj
32   PREINIT:
33 
34   CODE:
35     if (obj->upload != NULL)
36         RETVAL = apreq_xs_param2sv(aTHX_ obj, NULL, NULL);
37     else
38         RETVAL = &PL_sv_undef;
39 
40   OUTPUT:
41     RETVAL
42 
43 
44 
45 BOOT:
46     {
47         apr_version_t version;
48         apr_version(&version);
49         if (version.major != APR_MAJOR_VERSION)
50             Perl_croak(aTHX_ "Can't load module APR::Request::Param : "
51                              "wrong libapr major version "
52                              "(expected %d, saw %d)",
53                               APR_MAJOR_VERSION, version.major);
54     }
55 
56     /* register the overloading (type 'A') magic */
57     PL_amagic_generation++;
58     /* The magic for overload gets a GV* via gv_fetchmeth as */
59     /* mentioned above, and looks in the SV* slot of it for */
60     /* the "fallback" status. */
61     sv_setsv(
62         get_sv( "APR::Request::Param::()", TRUE ),
63         &PL_sv_yes
64     );
65     newXS("APR::Request::Param::()", XS_APR__Request__Param_nil, file);
66     newXS("APR::Request::Param::(\"\"", XS_APR__Request__Param_value, file);
67 
68 
69 MODULE = APR::Request::Param   PACKAGE = APR::Request::Param
70 
71 SV *
72 name(obj)
73     APR::Request::Param obj
74 
75   CODE:
76     RETVAL = newSVpvn(obj->v.name, obj->v.nlen);
77     if (apreq_param_is_tainted(obj))
78         SvTAINTED_on(RETVAL);
79 
80   OUTPUT:
81     RETVAL
82 
83 
84 IV
85 is_tainted(obj, val=NULL)
86     APR::Request::Param obj
87     SV *val
88   PREINIT:
89     /*nada*/
90 
91   CODE:
92     RETVAL = apreq_param_is_tainted(obj);
93 
94     if (items == 2) {
95         if (SvTRUE(val))
96            apreq_param_tainted_on(obj);
97         else
98            apreq_param_tainted_off(obj);
99     }
100 
101   OUTPUT:
102     RETVAL
103 
104 IV
105 charset(obj, val=NULL)
106     APR::Request::Param obj
107     SV *val
108   PREINIT:
109     /*nada*/
110 
111   CODE:
112     if (items == 2)
113         RETVAL = apreq_param_charset_set(obj, SvIV(val));
114     else
115         RETVAL = apreq_param_charset_get(obj);
116 
117   OUTPUT:
118     RETVAL
119 
120 APR::Request::Param
121 make(class, pool, name, val)
122     apreq_xs_subclass_t class
123     APR::Pool pool
124     SV *name
125     SV *val
126   PREINIT:
127     STRLEN nlen, vlen;
128     const char *n, *v;
129     SV *parent = SvRV(ST(1));
130 
131   CODE:
132     n = SvPV(name, nlen);
133     v = SvPV(val, vlen);
134     RETVAL = apreq_param_make(pool, n, nlen, v, vlen);
135     if (SvTAINTED(name) || SvTAINTED(val))
136         apreq_param_tainted_on(RETVAL);
137 
138   OUTPUT:
139     RETVAL
140 
141 
142 MODULE = APR::Request::Param PACKAGE = APR::Request::Param
143 
144 SV *
145 upload_link(param, path)
146     APR::Request::Param param
147     const char *path
148   PREINIT:
149     apr_file_t *f;
150     const char *fname;
151     apr_status_t s;
152 
153   CODE:
154     if (param->upload == NULL)
155         Perl_croak(aTHX_ "$param->upload_link($file): param has no upload brigade");
156     f = apreq_brigade_spoolfile(param->upload);
157     if (f == NULL) {
158         apr_off_t len;
159         s = apr_file_open(&f, path, APR_CREATE | APR_EXCL | APR_WRITE |
160                           APR_READ | APR_BINARY,
161                           APR_OS_DEFAULT,
162                           param->upload->p);
163         if (s == APR_SUCCESS) {
164             s = apreq_brigade_fwrite(f, &len, param->upload);
165             if (s == APR_SUCCESS)
166                 XSRETURN_YES;
167         }
168     }
169     else {
170         s = apr_file_name_get(&fname, f);
171         if (s != APR_SUCCESS)
172             Perl_croak(aTHX_ "$param->upload_link($file): can't get spoolfile name");
173         if (PerlLIO_link(fname, path) >= 0)
174             XSRETURN_YES;
175         else {
176             s = apr_file_copy(fname, path, APR_OS_DEFAULT, param->upload->p);
177             if (s == APR_SUCCESS)
178                 XSRETURN_YES;
179         }
180     }
181     RETVAL = &PL_sv_undef;
182 
183   OUTPUT:
184     RETVAL
185 
186 apr_size_t
187 upload_slurp(param, buffer)
188     APR::Request::Param param
189     SV *buffer
190   PREINIT:
191     apr_off_t len;
192     apr_status_t s;
193     char *data;
194 
195   CODE:
196     if (param->upload == NULL)
197         Perl_croak(aTHX_ "$param->upload_slurp($data): param has no upload brigade");
198 
199     s = apr_brigade_length(param->upload, 0, &len);
200     if (s != APR_SUCCESS)
201         Perl_croak(aTHX_ "$param->upload_slurp($data): can't get upload length");
202 
203     RETVAL = len;
204     (void)SvUPGRADE(buffer, SVt_PV);
205     data = SvGROW(buffer, RETVAL + 1);
206     data[RETVAL] = 0;
207     SvCUR_set(buffer, RETVAL);
208     SvPOK_only(buffer);
209     s = apr_brigade_flatten(param->upload, data, &RETVAL);
210     if (s != APR_SUCCESS)
211         Perl_croak(aTHX_ "$param->upload_slurp($data): can't flatten upload");
212 
213     if (apreq_param_is_tainted(param))
214         SvTAINTED_on(buffer);
215 
216     SvSETMAGIC(buffer);
217 
218   OUTPUT:
219     RETVAL
220 
221 UV
222 upload_size(param)
223     APR::Request::Param param
224   PREINIT:
225     apr_off_t len;
226     apr_status_t s;
227 
228   CODE:
229     if (param->upload == NULL)
230         Perl_croak(aTHX_ "$param->upload_size(): param has no upload brigade");
231 
232     s = apr_brigade_length(param->upload, 0, &len);
233     if (s != APR_SUCCESS)
234         Perl_croak(aTHX_ "$param->upload_size(): can't get upload length");
235 
236     RETVAL = len;
237 
238   OUTPUT:
239     RETVAL
240 
241 SV *
242 upload_type(param)
243     APR::Request::Param param
244   PREINIT:
245     const char *ct, *sc;
246     STRLEN len;
247   CODE:
248     if (param->info == NULL)
249         Perl_croak(aTHX_ "$param->upload_type(): param has no info table");
250 
251     ct = apr_table_get(param->info, "Content-Type");
252     if (ct == NULL)
253         Perl_croak(aTHX_ "$param->upload_type: can't find Content-Type header");
254 
255     if ((sc = strchr(ct, ';')))
256         len = sc - ct;
257     else
258         len = strlen(ct);
259 
260     RETVAL = newSVpvn(ct, len);
261     if (apreq_param_is_tainted(param))
262         SvTAINTED_on(RETVAL);
263 
264   OUTPUT:
265     RETVAL
266 
267 
268 const char *
269 upload_tempname(param, req=apreq_xs_sv2handle(aTHX_ ST(0)))
270     APR::Request::Param param
271     APR::Request req
272 
273   PREINIT:
274     apr_file_t *f;
275     apr_status_t s;
276 
277   CODE:
278     if (param->upload == NULL)
279       Perl_croak(aTHX_
280                  "$param->upload_tempname($req): param has no upload brigade"
281                  );
282     f = apreq_brigade_spoolfile(param->upload);
283     if (f == NULL) {
284         const char *path;
285         s = apreq_temp_dir_get(req, &path);
286         if (s != APR_SUCCESS)
287             Perl_croak(aTHX_
288                        "$param->upload_tempname($req): can't get temp_dir"
289                        );
290         s = apreq_brigade_concat(param->upload->p, path, 0,
291                                  param->upload, param->upload);
292         if (s != APR_SUCCESS)
293             Perl_croak(aTHX_
294                        "$param->upload_tempname($req): can't make spool bucket"
295                        );
296         f = apreq_brigade_spoolfile(param->upload);
297     }
298     s = apr_file_name_get(&RETVAL, f);
299     if (s != APR_SUCCESS)
300         Perl_croak(aTHX_
301                    "$param->upload_link($file): can't get spool file name"
302                    );
303 
304   OUTPUT:
305     RETVAL
306 
307 
308 
309