File Coverage

Pro.xs
Criterion Covered Total %
statement 293 360 81.3
branch 154 384 40.1
condition n/a
subroutine n/a
pod n/a
total 447 744 60.0


line stmt bran cond sub pod time code
1             #define PERLIO_NOT_STDIO 0 /* For co-existence with stdio only */
2             #define PERL_NO_GET_CONTEXT /* we want efficiency */
3              
4             #ifdef __cplusplus
5             extern "C" {
6             #endif
7             #include "EXTERN.h"
8             #include "perl.h"
9             #include "XSUB.h"
10             #ifdef __cplusplus
11             }
12             #endif
13              
14             #include
15             #include
16              
17             #include "ppport.h"
18              
19             #ifdef USE_SYSTEM_HTP_HEADER
20             #include
21             #else
22             #include "tmplpro.h"
23             #endif
24              
25             typedef PerlIO * OutputStream;
26              
27             struct perl_callback_state {
28             SV* perl_obj_self_ptr;
29             AV* filtered_tmpl_array;
30             AV* pool_for_perl_vars;
31             int force_untaint;
32             };
33              
34             static
35             int debuglevel=0;
36              
37 449           static struct perl_callback_state new_callback_state (SV* self_ptr) {
38             dTHX; /* fetch context */
39             struct perl_callback_state cs;
40 449           cs.perl_obj_self_ptr = self_ptr;
41 449           cs.filtered_tmpl_array = newAV();
42 449           cs.pool_for_perl_vars = newAV();
43 449           cs.force_untaint = 0;
44 449           return cs;
45             }
46              
47             /* endnext points on next character to end of interval as in c++ */
48 1297           static void write_chars_to_file (ABSTRACT_WRITER* OutputFile, const char* begin, const char* endnext) {
49             dTHX; /* fetch context */
50 1297           PerlIO_write((PerlIO*)OutputFile,begin, endnext-begin);
51 1297           }
52              
53             /* endnext points on next to end character of the interval */
54 2759           static void write_chars_to_string (ABSTRACT_WRITER* OutputString, const char* begin, const char* endnext) {
55             dTHX; /* fetch context */
56 2759           sv_catpvn((SV*)OutputString, begin, endnext-begin);
57 2759           }
58              
59             static
60 1476           ABSTRACT_VALUE* get_ABSTRACT_VALUE_impl (ABSTRACT_DATASTATE* none, ABSTRACT_MAP* ptr_HV, PSTRING name) {
61             dTHX; /* fetch context */
62             /*if (debuglevel>1) warn ("Pro.xs: get_ABSTRACT_VALUE_impl: ptr_HV=%p",ptr_HV);*/
63 1476           return hv_fetch((HV*) ptr_HV,name.begin, name.endnext-name.begin, 0);
64             }
65              
66             static
67             SV*
68 209           call_coderef (SV* coderef) {
69             SV* SVretval;
70             I32 count;
71             dTHX; /* fetch context */
72             /* TODO: G_EVAL and error handler */
73 209           dSP;
74              
75             /* let perl clean up mortals after the end of output() call
76             ENTER;
77             SAVETMPS;*/
78              
79 209 50         PUSHMARK(SP);
80 209           PUTBACK; /* in fact, isn't needed -- nothing is pushed and G_NOARGS is used */
81              
82 209           count = call_sv(coderef, G_EVAL|G_SCALAR|G_NOARGS);
83 209           SPAGAIN;
84              
85             /* Check the eval first */
86 209 50         if (SvTRUE(ERRSV))
    50          
    50          
    50          
    0          
    0          
    50          
    50          
    0          
    0          
    0          
    0          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    50          
    0          
    0          
    50          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
    0          
87 0           {
88             STRLEN n_a;
89 0 0         printf ("Pro.xs: param tree code reference exited abnormally - %s\n", SvPV(ERRSV, n_a));
    0          
    0          
    0          
    0          
90 0           SVretval=POPs; /* undef */
91             }
92             else
93             {
94 209 50         if (count != 1)
95 0           croak("Pro.xs: internal context error (got %d) while calling CODE reference\n", (int)count);
96 209           SVretval=POPs;
97             }
98              
99 209           PUTBACK;
100             /* let perl clean up mortals after the end of output() call
101             FREETMPS;
102             LEAVE;*/
103 209           return SVretval;
104             }
105              
106             static
107 731           PSTRING ABSTRACT_VALUE2PSTRING_impl (ABSTRACT_DATASTATE* callback_state, ABSTRACT_VALUE* valptr) {
108 731           STRLEN len=0;
109 731           PSTRING retval={NULL,NULL};
110             SV* SVval;
111             dTHX; /* fetch context */
112 731 50         if (valptr==NULL) return retval;
113 731           SVval = *((SV**) valptr);
114             /*if (debuglevel>1) warn ("Pro.xs: ABSTRACT_VALUE2PSTRING_impl: SVval=%p valptr=%p",SVval,valptr);*/
115 731 100         SvGETMAGIC(SVval);
    50          
116 731 50         if (SvOK(SVval) && SvROK(SVval)) {
    0          
    0          
    100          
117 12 100         if (SvTYPE(SvRV(SVval))==SVt_PVCV) {
118 7           SVval = call_coderef(SVval);
119 5 50         } else if(SvTYPE(SvRV(SVval))==SVt_PV) {
120 0           SVval = SvRV(SVval);
121             }
122 12 50         SvGETMAGIC(SVval);
    0          
123             }
124 731 50         if (!SvOK(SVval)) return retval;
    0          
    0          
125             /* TODO param resource deallocation */
126 731 50         if (((struct perl_callback_state*) callback_state)->force_untaint && SVval && SvTAINTED(SVval))
    0          
    0          
    0          
127 0           croak("force_untaint: got tainted value %" SVf, SVval);
128              
129 731 100         retval.begin=SvPV(SVval, len);
130 731           retval.endnext=retval.begin+len;
131 731           return retval;
132             }
133              
134             static
135 304           int is_ABSTRACT_VALUE_true_impl (ABSTRACT_DATASTATE* none, ABSTRACT_VALUE* valptr) {
136             SV* SVval;
137             dTHX; /* fetch context */
138 304 50         if (valptr==NULL) return 0;
139 304           SVval = *((SV**) valptr);
140 304 100         if (SvROK(SVval)) {
141 208 100         if ((SvTYPE(SvRV(SVval)) == SVt_PVCV)) {
142 202           SVval = call_coderef(SVval);
143             } else
144             /* arrayptr : in HTML::Template, true if len(array)>0 */
145 6 50         if ((SvTYPE(SvRV(SVval)) == SVt_PVAV)
146 6 50         && (av_len((AV *)SvRV(SVval))<0)) {
147 0           return 0;
148 6           } else return 1;
149             }
150             /* in any place where I receive a value of which I don't know the origin,
151             I should call SvGETMAGIC first. */
152 298 50         SvGETMAGIC(SVval);
    0          
153 298 50         if(SvTRUE(SVval)) return 1;
    50          
    50          
    0          
    0          
    100          
    50          
    50          
    0          
    0          
    50          
    50          
    100          
    50          
    0          
    100          
154 106           return 0;
155             }
156              
157             static
158 75           ABSTRACT_ARRAY* ABSTRACT_VALUE2ABSTRACT_ARRAY_impl (ABSTRACT_DATASTATE* none, ABSTRACT_VALUE* abstrvalptr) {
159 75           SV* val = *((SV**) abstrvalptr);
160             dTHX; /* fetch context */
161 75 50         SvGETMAGIC(val);
    0          
162 75 50         if ((!SvROK(val)) || (SvTYPE(SvRV(val)) != SVt_PVAV)) return 0;
    50          
163 75           return (ABSTRACT_ARRAY*) SvRV(val);
164             }
165              
166             static
167 75           int get_ABSTRACT_ARRAY_length_impl (ABSTRACT_DATASTATE* none, ABSTRACT_ARRAY* loops_AV) {
168             dTHX; /* fetch context */
169 75 50         SvGETMAGIC((SV *)loops_AV);
    0          
170 75           return av_len((AV *)loops_AV)+1;
171             }
172              
173             static
174 187           ABSTRACT_MAP* get_ABSTRACT_MAP_impl (ABSTRACT_DATASTATE* none, ABSTRACT_ARRAY* loops_AV, int loop) {
175             dTHX; /* fetch context */
176             SV* val;
177 187           SV** arrayvalptr = av_fetch((AV*)loops_AV, loop, 0);
178 187 50         if (arrayvalptr==NULL) return NULL;
179 187           val = *arrayvalptr;
180 187 100         SvGETMAGIC(val);
    50          
181 187 50         if ((!SvROK(val)) || (SvTYPE(SvRV(val)) != SVt_PVHV)) {
    50          
182 0           return NULL;
183             } else {
184 187           return (ABSTRACT_MAP *)SvRV(*arrayvalptr);
185             }
186             }
187              
188             static
189 0           const char* get_filepath (ABSTRACT_FINDFILE* callback_state, const char* filename, const char* prevfilename) {
190             dTHX; /* fetch context */
191 0           dSP ;
192             int count ;
193             STRLEN len;
194             char* filepath;
195             SV* perlprevfile;
196 0           SV* PerlSelfHTMLTemplatePro = ((struct perl_callback_state*)callback_state)->perl_obj_self_ptr;
197 0           SV* perlretval = sv_2mortal(newSVpv(filename,0));
198 0 0         if (prevfilename) {
199 0           perlprevfile=sv_2mortal(newSVpv(prevfilename,0));
200             } else {
201 0           perlprevfile=sv_2mortal(newSV(0));
202             }
203             /*if (debuglevel>1) warn ("Pro.xs: get_filepath: self=%p prevfile=%p retval=%p",PerlSelfHTMLTemplatePro,perlprevfile,perlretval);*/
204 0           ENTER ;
205 0           SAVETMPS;
206 0 0         PUSHMARK(SP) ;
207 0 0         XPUSHs((SV*)PerlSelfHTMLTemplatePro);
208 0 0         XPUSHs(perlretval);
209 0 0         XPUSHs(perlprevfile);
210 0           PUTBACK ;
211 0           count = call_pv("_get_filepath", G_SCALAR);
212 0           SPAGAIN ;
213 0 0         if (count != 1) croak("Big troublen") ;
214 0           perlretval=POPs;
215             /* any memory leaks??? */
216 0 0         if (SvOK(perlretval)) {
    0          
    0          
217 0 0         filepath = SvPV(perlretval, len);
218 0           av_push(((struct perl_callback_state*)callback_state)->pool_for_perl_vars,perlretval);
219 0           SvREFCNT_inc(perlretval);
220             } else {
221 0           filepath = NULL;
222             }
223 0           PUTBACK ;
224 0 0         FREETMPS ;
225 0           LEAVE ;
226 0           return filepath;
227             }
228              
229             static
230 9           PSTRING load_file (ABSTRACT_FILTER* callback_state, const char* filepath) {
231             dTHX; /* fetch context */
232 9           dSP ;
233             int count ;
234             STRLEN len;
235             PSTRING tmpl;
236             SV* templateptr;
237 9           SV* perlretval = sv_2mortal(newSVpv(filepath,0));
238 9           ENTER ;
239 9           SAVETMPS;
240 9 50         PUSHMARK(SP) ;
241 9 50         XPUSHs(((struct perl_callback_state*)callback_state)->perl_obj_self_ptr);
242 9 50         XPUSHs(perlretval);
243 9           PUTBACK ;
244 9           count = call_pv("_load_template", G_SCALAR);
245 9           SPAGAIN ;
246 9 50         if (count != 1) croak("Big troublen") ;
247 9           templateptr=POPs;
248             /* any memory leaks??? */
249 9 50         if (SvOK(templateptr) && SvROK(templateptr)) {
    0          
    0          
    50          
250 9 50         tmpl.begin = SvPV(SvRV(templateptr), len);
251 9           tmpl.endnext=tmpl.begin+len;
252 9           av_push(((struct perl_callback_state*)callback_state)->filtered_tmpl_array,templateptr);
253 9           SvREFCNT_inc(templateptr);
254             } else {
255 0           croak("Big trouble! _load_template internal fatal error\n") ;
256             }
257 9           PUTBACK ;
258 9 50         FREETMPS ;
259 9           LEAVE ;
260 9           return tmpl;
261             }
262              
263             static
264 9           int unload_file(ABSTRACT_FILTER* callback_state, PSTRING memarea) {
265             dTHX; /* fetch context */
266 9           SvREFCNT_dec(av_pop(((struct perl_callback_state*)callback_state)->filtered_tmpl_array));
267 9           return 0;
268             }
269              
270             static
271 135           ABSTRACT_USERFUNC* is_expr_userfnc (ABSTRACT_FUNCMAP* FuncHash, PSTRING name) {
272             dTHX; /* fetch context */
273 135           SV** hashvalptr=hv_fetch((HV *) FuncHash, name.begin, name.endnext-name.begin, 0);
274 135           return hashvalptr;
275             }
276              
277             static
278 70           void free_expr_arglist(ABSTRACT_ARGLIST* arglist)
279             {
280             dTHX; /* fetch context */
281 70 50         if (NULL!=arglist) {
282 70           av_undef((AV*) arglist);
283 70           SvREFCNT_dec(arglist);
284             }
285 70           }
286              
287             static
288 70           ABSTRACT_ARGLIST* init_expr_arglist(ABSTRACT_CALLER* none)
289             {
290             dTHX; /* fetch context */
291 70           return newAV();
292             }
293              
294             static
295 88           void push_expr_arglist(ABSTRACT_ARGLIST* arglist, ABSTRACT_EXPRVAL* exprval)
296             {
297             dTHX; /* fetch context */
298 88           SV* val=NULL;
299 88           int exprval_type=tmplpro_get_expr_type(exprval);
300             PSTRING parg;
301 88           switch (exprval_type) {
302 0           case EXPR_TYPE_NULL: val=newSV(0);break;
303 8           case EXPR_TYPE_INT: val=newSViv(tmplpro_get_expr_as_int64(exprval));break;
304 1           case EXPR_TYPE_DBL: val=newSVnv(tmplpro_get_expr_as_double(exprval));break;
305 79           case EXPR_TYPE_PSTR: parg=tmplpro_get_expr_as_pstring(exprval);
306 79           val=newSVpvn(parg.begin, parg.endnext-parg.begin);break;
307 0           default: die ("Perl wrapper: FATAL INTERNAL ERROR:Unsupported type %d in exprval", exprval_type);
308             }
309 88           av_push ((AV*) arglist, val);
310 88           }
311              
312             static
313 70           void call_expr_userfnc (ABSTRACT_CALLER* callback_state, ABSTRACT_ARGLIST* arglist, ABSTRACT_USERFUNC* hashvalptr, ABSTRACT_EXPRVAL* exprval) {
314             dTHX; /* fetch context */
315 70           dSP ;
316 70           char* empty="";
317             char* strval;
318             SV ** arrval;
319             SV * svretval;
320             I32 i;
321             I32 numretval;
322 70           I32 arrlen=av_len((AV *) arglist);
323 70           PSTRING retvalpstr = { empty, empty };
324 70           retvalpstr.begin=empty;
325 70           retvalpstr.endnext=empty;
326 70 50         if (hashvalptr==NULL) {
327 0           die ("FATAL INTERNAL ERROR:Call_EXPR:function called but not exists");
328             tmplpro_set_expr_as_pstring(exprval,retvalpstr);
329             return;
330 70 50         } else if (! SvROK(*((SV**) hashvalptr)) || (SvTYPE(SvRV(*((SV**) hashvalptr))) != SVt_PVCV)) {
    50          
331 0           die ("FATAL INTERNAL ERROR:Call_EXPR:not a function reference");
332             tmplpro_set_expr_as_pstring(exprval,retvalpstr);
333             return;
334             }
335              
336 70           ENTER ;
337 70           SAVETMPS ;
338              
339 70 50         PUSHMARK(SP) ;
340 158 100         for (i=0;i<=arrlen;i++) {
341 88           arrval=av_fetch((AV *) arglist,i,0);
342 88 50         if (arrval) XPUSHs(*arrval);
    50          
343 0           else warn("INTERNAL: call: strange arrval");
344             }
345 70           PUTBACK ;
346 70           numretval=call_sv(*((SV**) hashvalptr), G_SCALAR);
347 70           SPAGAIN ;
348 70 50         if (numretval) {
349 70           svretval=POPs;
350 70 50         SvGETMAGIC(svretval);
    0          
351 70 100         if (SvOK(svretval)) {
    50          
    50          
352 132 100         if (SvIOK(svretval)) {
353 1 50         tmplpro_set_expr_as_int64(exprval,SvIV(svretval));
354 65 50         } else if (SvNOK(svretval)) {
355 0 0         tmplpro_set_expr_as_double(exprval,SvNV(svretval));
356             } else {
357 65           STRLEN len=0;
358 65 50         strval =SvPV(svretval, len);
359             /* hack !!! */
360 65           av_push(((struct perl_callback_state*)callback_state)->pool_for_perl_vars,svretval);
361 65           SvREFCNT_inc(svretval);
362 65           retvalpstr.begin=strval;
363 65           retvalpstr.endnext=strval +len;
364 65           tmplpro_set_expr_as_pstring(exprval,retvalpstr);
365             }
366             } else {
367 70 50         if (debuglevel>1) warn ("user defined function returned undef\n");
368             }
369             } else {
370 0 0         if (debuglevel) warn ("user defined function returned nothing\n");
371             }
372              
373 70 50         FREETMPS ;
374 70           LEAVE ;
375              
376 70           return;
377             }
378              
379             typedef void (*set_int_option_functype) (struct tmplpro_param*, int);
380              
381             static
382 4041           void set_integer_from_hash(pTHX_ HV* TheHash, char* key, struct tmplpro_param* param, set_int_option_functype setfunc) {
383 4041           SV** hashvalptr=hv_fetch(TheHash, key, strlen(key), 0);
384 4041 100         if (hashvalptr==NULL) return;
385 3214 50         setfunc(param,SvIV(*hashvalptr));
386             }
387              
388             static
389 1347           int get_integer_from_hash(pTHX_ HV* TheHash, char* key) {
390 1347           SV** hashvalptr=hv_fetch(TheHash, key, strlen(key), 0);
391 1347 100         if (hashvalptr==NULL) return 0;
392 898 50         return SvIV(*hashvalptr);
393             }
394              
395             static
396 1347           PSTRING get_string_from_hash(pTHX_ HV* TheHash, char* key) {
397 1347           SV** hashvalptr=hv_fetch(TheHash, key, strlen(key), 0);
398 1347           STRLEN len=0;
399             char * begin;
400 1347           PSTRING retval={NULL,NULL};
401 1347 100         if (hashvalptr==NULL) return retval;
402 451 100         if (SvROK(*hashvalptr)) {
403             /* if (SvTYPE(SvRV(*hashvalptr))!=SVt_PV) return (PSTRING) {NULL,NULL}; */
404 216 50         begin=SvPV(SvRV(*hashvalptr),len);
405             } else {
406 235 50         if (! SvPOK(*hashvalptr)) return retval;
407 235 50         begin=SvPV(*hashvalptr,len);
408             }
409 451           retval.begin=begin;
410 451           retval.endnext=begin+len;
411 1347           return retval;
412             }
413              
414              
415             static
416 449           char** get_array_of_strings_from_hash(pTHX_ HV* TheHash, char* key, struct perl_callback_state* callback_state) {
417 449           SV** valptr=hv_fetch(TheHash, key, strlen(key), 0);
418             int amax;
419 449           char** path=NULL;
420             AV* pathAV;
421 449           int i =0;
422             char** j;
423             SV* store;
424 449 50         if (valptr!=NULL && SvROK(*valptr) && (SvTYPE(SvRV(*valptr)) == SVt_PVAV) ) {
    50          
    50          
425 449           pathAV=(AV *)SvRV(*valptr);
426 449           amax=av_len(pathAV);
427 508 100         if (amax<0) {
428 390           return NULL;
429             } else {
430 59           store = newSV(sizeof(char*)*(amax+2));
431             /*if (debuglevel>1) warn ("Pro.xs: get_array_of_strings_from_hash: store=%p",store);*/
432 59 50         path = (char**) SvGROW(store, sizeof(char*)*(amax+2));
    50          
433 59           av_push(((struct perl_callback_state*)callback_state)->pool_for_perl_vars,store);
434             //path=(char**) malloc(sizeof(char*)*(amax+2));
435 59           j=path;
436 127 100         for (i=0; i<=amax;i++) {
437 68           valptr = av_fetch(pathAV,i,0);
438 68 50         if (valptr!=NULL) {
439 68 50         *j=SvPV_nolen(*valptr);
440 68           j++;
441             }
442 68           *j=NULL;
443             }
444             }
445             } else {
446 0           warn ("get_array_of_strings:option %s not found :(\n", key);
447             }
448 59           return path;
449             }
450              
451             static
452 449           struct tmplpro_param* process_tmplpro_options (struct perl_callback_state* callback_state) {
453             dTHX; /* fetch context */
454             HV* SelfHash;
455             SV** hashvalptr;
456             const char* tmpstring;
457 449           SV* PerlSelfPtr=callback_state->perl_obj_self_ptr;
458 449           int default_escape=HTML_TEMPLATE_OPT_ESCAPE_NO;
459              
460             /* main arguments */
461             PSTRING filename;
462             PSTRING scalarref;
463              
464             /* internal initialization */
465 449           struct tmplpro_param* param=tmplpro_param_init();
466              
467             /* setting initial hooks */
468 449           tmplpro_set_option_WriterFuncPtr(param, &write_chars_to_string);
469 449           tmplpro_set_option_GetAbstractValFuncPtr(param, &get_ABSTRACT_VALUE_impl);
470 449           tmplpro_set_option_AbstractVal2pstringFuncPtr(param, &ABSTRACT_VALUE2PSTRING_impl);
471 449           tmplpro_set_option_AbstractVal2abstractArrayFuncPtr(param, &ABSTRACT_VALUE2ABSTRACT_ARRAY_impl);
472 449           tmplpro_set_option_GetAbstractArrayLengthFuncPtr(param, &get_ABSTRACT_ARRAY_length_impl);
473 449           tmplpro_set_option_IsAbstractValTrueFuncPtr(param, &is_ABSTRACT_VALUE_true_impl);
474 449           tmplpro_set_option_GetAbstractMapFuncPtr(param, &get_ABSTRACT_MAP_impl);
475 449           tmplpro_set_option_LoadFileFuncPtr(param, &load_file);
476 449           tmplpro_set_option_UnloadFileFuncPtr(param, &unload_file);
477              
478             /* setting initial Expr hooks */
479 449           tmplpro_set_option_InitExprArglistFuncPtr(param, &init_expr_arglist);
480 449           tmplpro_set_option_FreeExprArglistFuncPtr(param, &free_expr_arglist);
481 449           tmplpro_set_option_PushExprArglistFuncPtr(param, &push_expr_arglist);
482 449           tmplpro_set_option_CallExprUserfncFuncPtr(param, &call_expr_userfnc);
483 449           tmplpro_set_option_IsExprUserfncFuncPtr(param, &is_expr_userfnc);
484             /* end setting initial hooks */
485              
486             /* setting perl globals */
487 449           tmplpro_set_option_ext_findfile_state(param,callback_state);
488 449           tmplpro_set_option_ext_filter_state(param,callback_state);
489 449           tmplpro_set_option_ext_calluserfunc_state(param,callback_state);
490 449           tmplpro_set_option_ext_data_state(param,callback_state);
491             /* end setting perl globals */
492              
493 449 50         if ((!SvROK(PerlSelfPtr)) || (SvTYPE(SvRV(PerlSelfPtr)) != SVt_PVHV))
    50          
494             {
495 0           die("FATAL:SELF:hash pointer was expected but not found");
496             }
497 449           SelfHash=(HV *)SvRV(PerlSelfPtr);
498              
499             /* checking main arguments */
500 449           filename=get_string_from_hash(aTHX_ SelfHash,"filename");
501 449           scalarref=get_string_from_hash(aTHX_ SelfHash,"scalarref");
502 449           tmplpro_set_option_filename(param, filename.begin);
503 449           tmplpro_set_option_scalarref(param, scalarref);
504 449 100         if (filename.begin==NULL && scalarref.begin==NULL) {
    50          
505 0           die ("bad arguments: expected filename or scalarref");
506             }
507              
508             /* setting expr_func */
509 449           hashvalptr=hv_fetch(SelfHash, "expr_func", 9, 0); /* 9=strlen("expr_func") */
510 449 50         if (!hashvalptr || !SvROK(*hashvalptr) || (SvTYPE(SvRV(*hashvalptr)) != SVt_PVHV))
    50          
    50          
511 0           die("FATAL:output:EXPR user functions not found");
512 449           tmplpro_set_option_expr_func_map(param, (HV *) SvRV(*hashvalptr));
513             /* end setting expr_func */
514              
515             /* setting param_map */
516 449           tmplpro_clear_option_param_map(param);
517 449           hashvalptr=hv_fetch(SelfHash, "associate", 9, 0); /* 9=strlen("associate") */
518 449 50         if (hashvalptr!=NULL && SvROK(*hashvalptr) && (SvTYPE(SvRV(*hashvalptr)) == SVt_PVAV)) {
    50          
    50          
519 449           AV* associate = (AV*) SvRV(*hashvalptr);
520 449           I32 i = av_len(associate);
521             SV** arrayvalptr;
522 451 100         while (i>=0) {
523 2           arrayvalptr = av_fetch(associate, i, 0);
524 2 50         if (arrayvalptr!=NULL && SvROK(*arrayvalptr))
    50          
525 2           tmplpro_push_option_param_map(param, (ABSTRACT_MAP *)SvRV(*arrayvalptr), 0);
526 2           i--;
527             }
528             }
529 449           hashvalptr=hv_fetch(SelfHash, "param_map", 9, 0); /* 9=strlen("param_map") */
530             /* TODO param deallocation on warn/die */
531 449 50         if (!hashvalptr || !SvROK(*hashvalptr) || (SvTYPE(SvRV(*hashvalptr)) != SVt_PVHV))
    50          
    50          
532 0           die("FATAL:output:param_map not found");
533 449           tmplpro_push_option_param_map(param, (ABSTRACT_MAP *)SvRV(*hashvalptr), 0);
534             /* end setting param_map */
535              
536             /* setting filter */
537 449           hashvalptr=hv_fetch(SelfHash, "filter", 6, 0); /* 6=strlen("filter") */
538 449 50         if (!hashvalptr || !SvROK(*hashvalptr) || (SvTYPE(SvRV(*hashvalptr)) != SVt_PVAV))
    50          
    50          
539 0           die("FATAL:output:filter not found");
540 449 100         if (av_len((AV*)SvRV(*hashvalptr))>=0) tmplpro_set_option_filters(param, 1);
541             /* end setting param_map */
542              
543 449 100         if (!get_integer_from_hash(aTHX_ SelfHash,"case_sensitive")) {
544 375           tmplpro_set_option_tmpl_var_case(param, ASK_NAME_LOWERCASE);
545             }
546              
547 449           set_integer_from_hash(aTHX_ SelfHash,"tmpl_var_case",param,tmplpro_set_option_tmpl_var_case);
548 449           set_integer_from_hash(aTHX_ SelfHash,"max_includes",param,tmplpro_set_option_max_includes);
549 449           set_integer_from_hash(aTHX_ SelfHash,"no_includes",param,tmplpro_set_option_no_includes);
550 449           set_integer_from_hash(aTHX_ SelfHash,"search_path_on_include",param,tmplpro_set_option_search_path_on_include);
551 449           set_integer_from_hash(aTHX_ SelfHash,"global_vars",param,tmplpro_set_option_global_vars);
552 449           set_integer_from_hash(aTHX_ SelfHash,"debug",param,tmplpro_set_option_debug);
553 449           debuglevel = tmplpro_get_option_debug(param);
554 449           set_integer_from_hash(aTHX_ SelfHash,"loop_context_vars",param,tmplpro_set_option_loop_context_vars);
555 449           set_integer_from_hash(aTHX_ SelfHash,"path_like_variable_scope",param,tmplpro_set_option_path_like_variable_scope);
556             /* still unsupported */
557 449           set_integer_from_hash(aTHX_ SelfHash,"strict",param,tmplpro_set_option_strict);
558              
559 449           tmpstring=get_string_from_hash(aTHX_ SelfHash,"default_escape").begin;
560 449 100         if (tmpstring && *tmpstring) {
    50          
561 2           switch (*tmpstring) {
562             case '1': case 'H': case 'h': /* HTML*/
563 1           default_escape = HTML_TEMPLATE_OPT_ESCAPE_HTML;
564 1           break;
565             case 'U': case 'u': /* URL */
566 1           default_escape = HTML_TEMPLATE_OPT_ESCAPE_URL;
567 1           break;
568             case 'J': case 'j': /* JS */
569 0           default_escape = HTML_TEMPLATE_OPT_ESCAPE_JS;
570 0           break;
571             case '0': case 'N': case 'n': /* 0 or NONE */
572 0           default_escape = HTML_TEMPLATE_OPT_ESCAPE_NO;
573 0           break;
574             default:
575 0           warn("unsupported value of default_escape=%s. Valid values are HTML, URL or JS.\n",tmpstring);
576             }
577 2           tmplpro_set_option_default_escape(param, default_escape);
578              
579             }
580              
581             /* setting callback_state */
582 449           callback_state->force_untaint=get_integer_from_hash(aTHX_ SelfHash,"force_untaint");
583             /* end setting callback_state */
584              
585 449 50         if (get_integer_from_hash(aTHX_ SelfHash,"__use_perl_find_file")) {
586 0           tmplpro_set_option_FindFileFuncPtr(param, &get_filepath);
587             } else {
588 449           tmplpro_set_option_path(param, get_array_of_strings_from_hash(aTHX_ SelfHash, "path", callback_state));
589 449           tmplpro_set_option_FindFileFuncPtr(param, NULL);
590             }
591              
592             #if defined _WIN32
593             /* hack; see https://rt.cpan.org/Public/Bug/Display.html?id=51218 */
594             tmplpro_set_option_template_root(param, getenv("HTML_TEMPLATE_ROOT"));
595             #endif
596 449           return param;
597             }
598              
599             static void
600 449           release_tmplpro_options(struct tmplpro_param* param, struct perl_callback_state callback_state)
601             {
602             dTHX; /* fetch context */
603 449           av_undef(callback_state.filtered_tmpl_array);
604 449           av_undef(callback_state.pool_for_perl_vars);
605 449           SvREFCNT_dec(callback_state.filtered_tmpl_array);
606 449           SvREFCNT_dec(callback_state.pool_for_perl_vars);
607 449           tmplpro_param_free(param);
608 449           }
609              
610              
611              
612             MODULE = HTML::Template::Pro PACKAGE = HTML::Template::Pro
613              
614             void
615             _init()
616             CODE:
617 14           tmplpro_procore_init();
618              
619             void
620             _done()
621             CODE:
622 0           tmplpro_procore_done();
623              
624              
625             int
626             exec_tmpl(self_ptr,possible_output)
627             SV* self_ptr;
628             SV* possible_output;
629             PREINIT:
630 71           struct perl_callback_state callback_state = new_callback_state(self_ptr);
631 71           struct tmplpro_param* proparam=process_tmplpro_options(&callback_state);
632             CODE:
633 71 50         if (debuglevel>0) warn ("Pro.xs: entered exec_tmpl self=%p",self_ptr);
634             OutputStream output_stream;
635 71 50         SvGETMAGIC(possible_output);
    0          
636 71 50         if (!SvOK(possible_output)) {
    0          
    0          
637 0           tmplpro_set_option_WriterFuncPtr(proparam,NULL);
638             } else {
639 71           output_stream = IoOFP(sv_2io(possible_output));
640 71 50         if (output_stream == NULL){
641 0           warn("Pro.xs:output: bad file descriptor in print_to option. Use stdout\n");
642 0           tmplpro_set_option_WriterFuncPtr(proparam,NULL);
643             } else {
644 71           tmplpro_set_option_ext_writer_state(proparam,output_stream);
645 71           tmplpro_set_option_WriterFuncPtr(proparam,&write_chars_to_file);
646             }
647             }
648 71           RETVAL = tmplpro_exec_tmpl(proparam);
649 71           release_tmplpro_options(proparam,callback_state);
650 71 50         if (RETVAL!=0) warn ("Pro.xs: non-zero exit code %d",RETVAL);
651             OUTPUT:
652             RETVAL
653              
654              
655             SV*
656             exec_tmpl_string(self_ptr)
657             SV* self_ptr;
658             PREINIT:
659             int retstate;
660             /* made mortal automatically */
661             SV* outputString;
662 378           struct perl_callback_state callback_state = new_callback_state(self_ptr);
663 378           struct tmplpro_param* proparam=process_tmplpro_options(&callback_state);
664             CODE:
665 378 50         if (debuglevel>0) warn ("Pro.xs: entered exec_tmpl_string self=%p",self_ptr);
666 378           outputString=newSV(4000); /* 4000 allocated bytes -- should be approx. filesize*/
667 378           sv_setpvn(outputString, "", 0);
668 378           tmplpro_set_option_WriterFuncPtr(proparam,&write_chars_to_string);
669 378           tmplpro_set_option_ext_writer_state(proparam,outputString);
670 378           retstate = tmplpro_exec_tmpl(proparam);
671 378           release_tmplpro_options(proparam,callback_state);
672 378 50         if (retstate!=0) warn ("Pro.xs: non-zero exit code %d",retstate);
673 378           RETVAL = outputString;
674             OUTPUT:
675             RETVAL
676              
677              
678             SV*
679             exec_tmpl_string_builtin(self_ptr)
680             SV* self_ptr;
681             PREINIT:
682             int retstate;
683             SV* outputString;
684             PSTRING inString;
685 0           struct perl_callback_state callback_state = new_callback_state(self_ptr);
686 0           struct tmplpro_param* proparam=process_tmplpro_options(&callback_state);
687             CODE:
688 0           inString = tmplpro_tmpl2pstring(proparam, &retstate);
689 0           outputString=newSV(inString.endnext-inString.begin+2);
690 0           sv_setpvn(outputString, inString.begin, inString.endnext-inString.begin);
691 0           release_tmplpro_options(proparam,callback_state);
692 0 0         if (retstate!=0) warn ("Pro.xs: non-zero exit code %d",retstate);
693 0           RETVAL = outputString;
694             OUTPUT:
695             RETVAL
696