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