source: rdnap/lib/Params/Validate.xs@ 203

Last change on this file since 203 was 203, checked in by Rick van der Zwet, 14 years ago

Little wrapper, as, the orginal one is gone.
File size: 46.0 KB
RevLine 
[203]1/* Copyright (c) 2000-2009 Dave Rolsky
2 All rights reserved.
3 This program is free software; you can redistribute it and/or
4 modify it under the same terms as Perl itself. See the LICENSE
5 file that comes with this distribution for more details. */
6
7#include "EXTERN.h"
8#include "perl.h"
9#include "XSUB.h"
10#define NEED_eval_pv
11#define NEED_sv_2pv_nolen
12#define NEED_newCONSTSUB
13#include "ppport.h"
14
15#ifdef __GNUC__
16#define INLINE inline
17#else
18#define INLINE
19#endif
20
21/* type constants */
22#define SCALAR 1
23#define ARRAYREF 2
24#define HASHREF 4
25#define CODEREF 8
26#define GLOB 16
27#define GLOBREF 32
28#define SCALARREF 64
29#define UNKNOWN 128
30#define UNDEF 256
31#define OBJECT 512
32
33#define HANDLE (GLOB | GLOBREF)
34#define BOOLEAN (SCALAR | UNDEF)
35
36/* return data macros */
37#define RETURN_ARRAY(ret) \
38 STMT_START \
39 { \
40 I32 i; \
41 switch(GIMME_V) \
42 { \
43 case G_VOID: \
44 return; \
45 case G_ARRAY: \
46 EXTEND(SP, av_len(ret) + 1); \
47 for(i = 0; i <= av_len(ret); i++) \
48 { \
49 PUSHs(*av_fetch(ret, i, 1)); \
50 } \
51 break; \
52 case G_SCALAR: \
53 XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \
54 break; \
55 } \
56 } STMT_END \
57
58#define RETURN_HASH(ret) \
59 STMT_START \
60 { \
61 HE* he; \
62 I32 keys; \
63 switch(GIMME_V) \
64 { \
65 case G_VOID: \
66 return; \
67 case G_ARRAY: \
68 keys = hv_iterinit(ret); \
69 EXTEND(SP, keys * 2); \
70 while ((he = hv_iternext(ret))) \
71 { \
72 PUSHs(HeSVKEY_force(he)); \
73 PUSHs(HeVAL(he)); \
74 } \
75 break; \
76 case G_SCALAR: \
77 XPUSHs(sv_2mortal(newRV_inc((SV*) ret))); \
78 break; \
79 } \
80 } STMT_END
81
82 /* These macros are used because Perl 5.6.1 (and presumably 5.6.0)
83 have problems if we try to die directly from XS code. So instead,
84 we just set some global variables and return 0. For 5.6.0,
85 validate(), validate_pos(), and validate_with() are thin Perl level
86 wrappers which localize these globals, call the XS sub, and then
87 check the globals afterwards. */
88
89#if (PERL_VERSION == 6) /* 5.6.0 or 5.6.1 */
90#define FAIL(message, options) \
91 { \
92 SV* perl_error; \
93 SV* perl_on_fail; \
94 SV* on_fail; \
95 perl_error = get_sv("Params::Validate::ERROR", 0); \
96 if (! perl_error) \
97 croak("Cannot retrieve $Params::Validate::ERROR\n"); \
98 perl_on_fail = get_sv("Params::Validate::ON_FAIL", 0); \
99 if (! perl_on_fail) \
100 croak("Cannot retrieve $Params::Validate::ON_FAIL\n"); \
101 SvSetSV(perl_error, message); \
102 on_fail = get_on_fail(options); \
103 SvSetSV(perl_on_fail, on_fail); \
104 return 0; \
105 }
106#else /* any other version*/
107#define FAIL(message, options) \
108 validation_failure(message, options);
109#endif /* PERL_VERSION */
110
111/* module initialization */
112static void
113bootinit() {
114 HV* stash;
115
116 /* define constants */
117 stash = gv_stashpv("Params::Validate", 1);
118 newCONSTSUB(stash, "SCALAR", newSViv(SCALAR));
119 newCONSTSUB(stash, "ARRAYREF", newSViv(ARRAYREF));
120 newCONSTSUB(stash, "HASHREF", newSViv(HASHREF));
121 newCONSTSUB(stash, "CODEREF", newSViv(CODEREF));
122 newCONSTSUB(stash, "GLOB", newSViv(GLOB));
123 newCONSTSUB(stash, "GLOBREF", newSViv(GLOBREF));
124 newCONSTSUB(stash, "SCALARREF", newSViv(SCALARREF));
125 newCONSTSUB(stash, "UNKNOWN", newSViv(UNKNOWN));
126 newCONSTSUB(stash, "UNDEF", newSViv(UNDEF));
127 newCONSTSUB(stash, "OBJECT", newSViv(OBJECT));
128 newCONSTSUB(stash, "HANDLE", newSViv(HANDLE));
129 newCONSTSUB(stash, "BOOLEAN", newSViv(BOOLEAN));
130}
131
132
133INLINE static bool
134no_validation() {
135 SV* no_v;
136
137 no_v = perl_get_sv("Params::Validate::NO_VALIDATION", 0);
138 if (! no_v)
139 croak("Cannot retrieve $Params::Validate::NO_VALIDATION\n");
140
141 return SvTRUE(no_v);
142}
143
144
145/* return type string that corresponds to typemask */
146INLINE static SV*
147typemask_to_string(IV mask) {
148 SV* buffer;
149 IV empty = 1;
150
151 buffer = sv_2mortal(newSVpv("", 0));
152
153 if (mask & SCALAR) {
154 sv_catpv(buffer, "scalar");
155 empty = 0;
156 }
157 if (mask & ARRAYREF) {
158 sv_catpv(buffer, empty ? "arrayref" : " arrayref");
159 empty = 0;
160 }
161 if (mask & HASHREF) {
162 sv_catpv(buffer, empty ? "hashref" : " hashref");
163 empty = 0;
164 }
165 if (mask & CODEREF) {
166 sv_catpv(buffer, empty ? "coderef" : " coderef");
167 empty = 0;
168 }
169 if (mask & GLOB) {
170 sv_catpv(buffer, empty ? "glob" : " glob");
171 empty = 0;
172 }
173 if (mask & GLOBREF) {
174 sv_catpv(buffer, empty ? "globref" : " globref");
175 empty = 0;
176 }
177 if (mask & SCALARREF) {
178 sv_catpv(buffer, empty ? "scalarref" : " scalarref");
179 empty = 0;
180 }
181 if (mask & UNDEF) {
182 sv_catpv(buffer, empty ? "undef" : " undef");
183 empty = 0;
184 }
185 if (mask & OBJECT) {
186 sv_catpv(buffer, empty ? "object" : " object");
187 empty = 0;
188 }
189 if (mask & UNKNOWN) {
190 sv_catpv(buffer, empty ? "unknown" : " unknown");
191 empty = 0;
192 }
193
194 return buffer;
195}
196
197
198/* compute numberic datatype for variable */
199INLINE static IV
200get_type(SV* sv) {
201 IV type = 0;
202
203 if (SvTYPE(sv) == SVt_PVGV) {
204 return GLOB;
205 }
206 if (!SvOK(sv)) {
207 return UNDEF;
208 }
209 if (!SvROK(sv)) {
210 return SCALAR;
211 }
212
213 switch (SvTYPE(SvRV(sv))) {
214 case SVt_NULL:
215 case SVt_IV:
216 case SVt_NV:
217 case SVt_PV:
218 #if PERL_VERSION <= 10
219 case SVt_RV:
220 #endif
221 case SVt_PVMG:
222 case SVt_PVIV:
223 case SVt_PVNV:
224 #if PERL_VERSION <= 8
225 case SVt_PVBM:
226 #elif PERL_VERSION >= 11
227 case SVt_REGEXP:
228 #endif
229 type = SCALARREF;
230 break;
231 case SVt_PVAV:
232 type = ARRAYREF;
233 break;
234 case SVt_PVHV:
235 type = HASHREF;
236 break;
237 case SVt_PVCV:
238 type = CODEREF;
239 break;
240 case SVt_PVGV:
241 type = GLOBREF;
242 break;
243 /* Perl 5.10 has a bunch of new types that I don't think will ever
244 actually show up here (I hope), but not handling them makes the
245 C compiler cranky. */
246 default:
247 type = UNKNOWN;
248 break;
249 }
250
251 if (type) {
252 if (sv_isobject(sv)) return type | OBJECT;
253 return type;
254 }
255
256 /* Getting here should not be possible */
257 return UNKNOWN;
258}
259
260
261/* get an article for given string */
262INLINE
263#if (PERL_VERSION >= 6) /* Perl 5.6.0+ */
264static const char*
265#else
266static char*
267#endif
268article(SV* string) {
269 STRLEN len;
270 char* rawstr;
271
272 rawstr = SvPV(string, len);
273 if (len) {
274 switch(rawstr[0]) {
275 case 'a':
276 case 'e':
277 case 'i':
278 case 'o':
279 case 'u':
280 return "an";
281 }
282 }
283
284 return "a";
285}
286
287
288#if (PERL_VERSION == 6) /* 5.6.0 or 5.6.1 */
289static SV*
290get_on_fail(HV* options) {
291 SV** temp;
292
293 if ((temp = hv_fetch(options, "on_fail", 7, 0))) {
294 SvGETMAGIC(*temp);
295 return *temp;
296 }
297 else {
298 return &PL_sv_undef;
299 }
300}
301#endif /* PERL_VERSION */
302
303#if (PERL_VERSION != 6) /* not used with 5.6.0 or 5.6.1 */
304/* raises exception either using user-defined callback or using
305 built-in method */
306static void
307validation_failure(SV* message, HV* options) {
308 SV** temp;
309 SV* on_fail;
310
311 if ((temp = hv_fetch(options, "on_fail", 7, 0))) {
312 SvGETMAGIC(*temp);
313 on_fail = *temp;
314 }
315 else {
316 on_fail = NULL;
317 }
318
319 /* use user defined callback if available */
320 if (on_fail) {
321 dSP;
322 PUSHMARK(SP);
323 XPUSHs(message);
324 PUTBACK;
325 call_sv(on_fail, G_DISCARD);
326 }
327
328 /* by default resort to Carp::confess for error reporting */
329 {
330 dSP;
331 perl_require_pv("Carp.pm");
332 PUSHMARK(SP);
333 XPUSHs(message);
334 PUTBACK;
335 call_pv("Carp::confess", G_DISCARD);
336 }
337
338 return;
339}
340#endif /* PERL_VERSION */
341
342/* get called subroutine fully qualified name */
343static SV*
344get_called(HV* options) {
345 SV** temp;
346
347 if ((temp = hv_fetch(options, "called", 6, 0))) {
348 SvGETMAGIC(*temp);
349 return *temp;
350 }
351 else {
352 IV frame;
353 SV* buffer;
354 SV* caller;
355
356 if ((temp = hv_fetch(options, "stack_skip", 10, 0))) {
357 SvGETMAGIC(*temp);
358 frame = SvIV(*temp);
359 }
360 else {
361 frame = 1;
362 }
363
364 /* With 5.6.0 & 5.6.1 there is an extra wrapper around the
365 validation subs which we want to ignore */
366 #if (PERL_VERSION == 6)
367 frame++;
368 #endif
369
370 buffer = sv_2mortal(newSVpvf("(caller(%d))[3]", (int) frame));
371 SvTAINTED_off(buffer);
372
373 caller = eval_pv(SvPV_nolen(buffer), 1);
374 if (SvTYPE(caller) == SVt_NULL) {
375 sv_setpv(caller, "N/A");
376 }
377
378 return caller;
379 }
380}
381
382
383/* $value->isa alike validation */
384static IV
385validate_isa(SV* value, SV* package, SV* id, HV* options) {
386 SV* buffer;
387 IV ok = 1;
388
389 SvGETMAGIC(value);
390 if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) {
391 dSP;
392
393 SV* ret;
394 IV count;
395
396 ENTER;
397 SAVETMPS;
398
399 PUSHMARK(SP);
400 EXTEND(SP, 2);
401 PUSHs(value);
402 PUSHs(package);
403 PUTBACK;
404
405 count = call_method("isa", G_SCALAR);
406
407 if (! count)
408 croak("Calling isa did not return a value");
409
410 SPAGAIN;
411
412 ret = POPs;
413 SvGETMAGIC(ret);
414
415 ok = SvTRUE(ret);
416
417 PUTBACK;
418 FREETMPS;
419 LEAVE;
420 }
421 else {
422 ok = 0;
423 }
424
425 if (! ok) {
426 buffer = sv_2mortal(newSVsv(id));
427 sv_catpv(buffer, " to ");
428 sv_catsv(buffer, get_called(options));
429 sv_catpv(buffer, " was not ");
430 sv_catpv(buffer, article(package));
431 sv_catpv(buffer, " '");
432 sv_catsv(buffer, package);
433 sv_catpv(buffer, "' (it is ");
434 if ( SvOK(value) ) {
435 sv_catpv(buffer, article(value));
436 sv_catpv(buffer, " ");
437 sv_catsv(buffer, value);
438 }
439 else {
440 sv_catpv(buffer, "undef");
441 }
442 sv_catpv(buffer, ")\n");
443 FAIL(buffer, options);
444 }
445
446 return 1;
447}
448
449
450static IV
451validate_can(SV* value, SV* method, SV* id, HV* options) {
452 IV ok = 1;
453
454 SvGETMAGIC(value);
455 if (SvOK(value) && (sv_isobject(value) || (SvPOK(value) && ! looks_like_number(value)))) {
456 dSP;
457
458 SV* ret;
459 IV count;
460
461 ENTER;
462 SAVETMPS;
463
464 PUSHMARK(SP);
465 EXTEND(SP, 2);
466 PUSHs(value);
467 PUSHs(method);
468 PUTBACK;
469
470 count = call_method("can", G_SCALAR);
471
472 if (! count)
473 croak("Calling can did not return a value");
474
475 SPAGAIN;
476
477 ret = POPs;
478 SvGETMAGIC(ret);
479
480 ok = SvTRUE(ret);
481
482 PUTBACK;
483 FREETMPS;
484 LEAVE;
485 }
486 else {
487 ok = 0;
488 }
489
490 if (! ok) {
491 SV* buffer;
492
493 buffer = sv_2mortal(newSVsv(id));
494 sv_catpv(buffer, " to ");
495 sv_catsv(buffer, get_called(options));
496 sv_catpv(buffer, " does not have the method: '");
497 sv_catsv(buffer, method);
498 sv_catpv(buffer, "'\n");
499 FAIL(buffer, options);
500 }
501
502 return 1;
503}
504
505
506/* validates specific parameter using supplied parameter specification */
507static IV
508validate_one_param(SV* value, SV* params, HV* spec, SV* id, HV* options, IV* untaint) {
509 SV** temp;
510 IV i;
511
512 /* check type */
513 if ((temp = hv_fetch(spec, "type", 4, 0))) {
514 IV type;
515
516 if ( ! ( SvOK(*temp)
517 && looks_like_number(*temp)
518 && SvIV(*temp) > 0 ) ) {
519 SV* buffer;
520
521 buffer = sv_2mortal(newSVsv(id));
522 sv_catpv( buffer, " has a type specification which is not a number. It is ");
523 if ( SvOK(*temp) ) {
524 sv_catpv( buffer, "a string - " );
525 sv_catsv( buffer, *temp );
526 }
527 else {
528 sv_catpv( buffer, "undef");
529 }
530 sv_catpv( buffer, ".\n Use the constants exported by Params::Validate to declare types." );
531
532 FAIL(buffer, options);
533 }
534
535 SvGETMAGIC(*temp);
536 type = get_type(value);
537 if (! (type & SvIV(*temp))) {
538 SV* buffer;
539 SV* is;
540 SV* allowed;
541
542 buffer = sv_2mortal(newSVsv(id));
543 sv_catpv(buffer, " to ");
544 sv_catsv(buffer, get_called(options));
545 sv_catpv(buffer, " was ");
546 is = typemask_to_string(type);
547 allowed = typemask_to_string(SvIV(*temp));
548 sv_catpv(buffer, article(is));
549 sv_catpv(buffer, " '");
550 sv_catsv(buffer, is);
551 sv_catpv(buffer, "', which is not one of the allowed types: ");
552 sv_catsv(buffer, allowed);
553 sv_catpv(buffer, "\n");
554 FAIL(buffer, options);
555 }
556 }
557
558 /* check isa */
559 if ((temp = hv_fetch(spec, "isa", 3, 0))) {
560 SvGETMAGIC(*temp);
561
562 if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) {
563 AV* array = (AV*) SvRV(*temp);
564
565 for(i = 0; i <= av_len(array); i++) {
566 SV* package;
567
568 package = *av_fetch(array, i, 1);
569 SvGETMAGIC(package);
570 if (! validate_isa(value, package, id, options)) {
571 return 0;
572 }
573 }
574 }
575 else {
576 if (! validate_isa(value, *temp, id, options)) {
577 return 0;
578 }
579 }
580 }
581
582 /* check can */
583 if ((temp = hv_fetch(spec, "can", 3, 0))) {
584 SvGETMAGIC(*temp);
585 if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVAV) {
586 AV* array = (AV*) SvRV(*temp);
587
588 for (i = 0; i <= av_len(array); i++) {
589 SV* method;
590
591 method = *av_fetch(array, i, 1);
592 SvGETMAGIC(method);
593
594 if (! validate_can(value, method, id, options)) {
595 return 0;
596 }
597 }
598 }
599 else {
600 if (! validate_can(value, *temp, id, options)) {
601 return 0;
602 }
603 }
604 }
605
606 /* let callbacks to do their tests */
607 if ((temp = hv_fetch(spec, "callbacks", 9, 0))) {
608 SvGETMAGIC(*temp);
609 if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVHV) {
610 HE* he;
611
612 hv_iterinit((HV*) SvRV(*temp));
613 while ((he = hv_iternext((HV*) SvRV(*temp)))) {
614 if (SvROK(HeVAL(he)) && SvTYPE(SvRV(HeVAL(he))) == SVt_PVCV) {
615 dSP;
616
617 SV* ret;
618 IV ok;
619 IV count;
620
621 ENTER;
622 SAVETMPS;
623
624 PUSHMARK(SP);
625 EXTEND(SP, 2);
626 PUSHs(value);
627 PUSHs(sv_2mortal(newRV_inc(params)));
628 PUTBACK;
629
630 count = call_sv(SvRV(HeVAL(he)), G_SCALAR);
631
632 SPAGAIN;
633
634 if (! count)
635 croak("Validation callback did not return anything");
636
637 ret = POPs;
638 SvGETMAGIC(ret);
639 ok = SvTRUE(ret);
640
641 PUTBACK;
642 FREETMPS;
643 LEAVE;
644
645 if (! ok) {
646 SV* buffer;
647
648 buffer = sv_2mortal(newSVsv(id));
649 sv_catpv(buffer, " to ");
650 sv_catsv(buffer, get_called(options));
651 sv_catpv(buffer, " did not pass the '");
652 sv_catsv(buffer, HeSVKEY_force(he));
653 sv_catpv(buffer, "' callback\n");
654 FAIL(buffer, options);
655 }
656 }
657 else {
658 SV* buffer;
659
660 buffer = sv_2mortal(newSVpv("callback '", 0));
661 sv_catsv(buffer, HeSVKEY_force(he));
662 sv_catpv(buffer, "' for ");
663 sv_catsv(buffer, get_called(options));
664 sv_catpv(buffer, " is not a subroutine reference\n");
665 FAIL(buffer, options);
666 }
667 }
668 }
669 else {
670 SV* buffer;
671
672 buffer = sv_2mortal(newSVpv("'callbacks' validation parameter for '", 0));
673 sv_catsv(buffer, get_called(options));
674 sv_catpv(buffer, " must be a hash reference\n");
675 FAIL(buffer, options);
676 }
677 }
678
679 if ((temp = hv_fetch(spec, "regex", 5, 0))) {
680 dSP;
681
682 IV has_regex = 0;
683 IV ok;
684
685 SvGETMAGIC(*temp);
686 if (SvPOK(*temp)) {
687 has_regex = 1;
688 }
689 else if (SvROK(*temp)) {
690 SV* svp;
691
692 svp = (SV*)SvRV(*temp);
693
694 #if PERL_VERSION <= 10
695 if (SvMAGICAL(svp) && mg_find(svp, PERL_MAGIC_qr)) {
696 has_regex = 1;
697 }
698 #else
699 if (SvTYPE(svp) == SVt_REGEXP) {
700 has_regex = 1;
701 }
702 #endif
703 }
704
705 if (!has_regex) {
706 SV* buffer;
707
708 buffer = sv_2mortal(newSVpv("'regex' validation parameter for '", 0));
709 sv_catsv(buffer, get_called(options));
710 sv_catpv(buffer, " must be a string or qr// regex\n");
711 FAIL(buffer, options);
712 }
713
714 PUSHMARK(SP);
715 EXTEND(SP, 2);
716 PUSHs(value);
717 PUSHs(*temp);
718 PUTBACK;
719 call_pv("Params::Validate::_check_regex_from_xs", G_SCALAR);
720 SPAGAIN;
721 ok = POPi;
722 PUTBACK;
723
724 if (!ok) {
725 SV* buffer;
726
727 buffer = sv_2mortal(newSVsv(id));
728 sv_catpv(buffer, " to ");
729 sv_catsv(buffer, get_called(options));
730 sv_catpv(buffer, " did not pass regex check\n");
731 FAIL(buffer, options);
732 }
733 }
734
735 if ((temp = hv_fetch(spec, "untaint", 7, 0))) {
736 if (SvTRUE(*temp)) {
737 *untaint = 1;
738 }
739 }
740
741 return 1;
742}
743
744
745/* merges one hash into another (not deep copy) */
746static void
747merge_hashes(HV* in, HV* out) {
748 HE* he;
749
750 hv_iterinit(in);
751 while ((he = hv_iternext(in))) {
752 if (!hv_store_ent(out, HeSVKEY_force(he),
753 SvREFCNT_inc(HeVAL(he)), HeHASH(he))) {
754 SvREFCNT_dec(HeVAL(he));
755 croak("Cannot add new key to hash");
756 }
757 }
758}
759
760
761/* convert array to hash */
762static IV
763convert_array2hash(AV* in, HV* options, HV* out) {
764 IV i;
765 I32 len;
766
767 len = av_len(in);
768 if (len > -1 && len % 2 != 1) {
769 SV* buffer;
770 buffer = sv_2mortal(newSVpv("Odd number of parameters in call to ", 0));
771 sv_catsv(buffer, get_called(options));
772 sv_catpv(buffer, " when named parameters were expected\n");
773
774 FAIL(buffer, options);
775 }
776
777 for(i = 0; i <= av_len(in); i += 2) {
778 SV* key;
779 SV* value;
780
781 key = *av_fetch(in, i, 1);
782 SvGETMAGIC(key);
783
784 /* We need to make a copy because if the array was @_, then the
785 values in the array are marked as readonly, which causes
786 problems when the hash being made gets returned to the
787 caller. */
788 value = sv_2mortal( newSVsv( *av_fetch(in, i + 1, 1) ) );
789 SvGETMAGIC(value);
790
791 if (! hv_store_ent(out, key, SvREFCNT_inc(value), 0)) {
792 SvREFCNT_dec(value);
793 croak("Cannot add new key to hash");
794 }
795 }
796
797 return 1;
798}
799
800
801/* get current Params::Validate options */
802static HV*
803get_options(HV* options) {
804 HV* OPTIONS;
805 HV* ret;
806 SV** temp;
807 char* pkg;
808 #if (PERL_VERSION != 6)
809 SV* buffer;
810 SV* caller;
811 #endif
812
813 ret = (HV*) sv_2mortal((SV*) newHV());
814
815 #if (PERL_VERSION == 6)
816 pkg = SvPV_nolen(get_sv("Params::Validate::CALLER", 0));
817 #else
818 buffer = sv_2mortal(newSVpv("caller(0)", 0));
819 SvTAINTED_off(buffer);
820
821 caller = eval_pv(SvPV_nolen(buffer), 1);
822 if (SvTYPE(caller) == SVt_NULL) {
823 pkg = "main";
824 }
825 else {
826 pkg = SvPV_nolen(caller);
827 }
828 #endif
829 /* get package specific options */
830 OPTIONS = get_hv("Params::Validate::OPTIONS", 1);
831 if ((temp = hv_fetch(OPTIONS, pkg, strlen(pkg), 0))) {
832 SvGETMAGIC(*temp);
833 if (SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVHV) {
834 if (options) {
835 merge_hashes((HV*) SvRV(*temp), ret);
836 }
837 else {
838 return (HV*) SvRV(*temp);
839 }
840 }
841 }
842 if (options) {
843 merge_hashes(options, ret);
844 }
845
846 return ret;
847}
848
849
850static SV*
851normalize_one_key(SV* key, SV* normalize_func, SV* strip_leading, IV ignore_case) {
852 SV* copy;
853 STRLEN len_sl;
854 STRLEN len;
855 char *rawstr_sl;
856 char *rawstr;
857
858 copy = sv_2mortal(newSVsv(key));
859
860 /* if normalize_func is provided, ignore the other options */
861 if (normalize_func) {
862 dSP;
863
864 SV* normalized;
865
866 PUSHMARK(SP);
867 XPUSHs(copy);
868 PUTBACK;
869 if (! call_sv(SvRV(normalize_func), G_SCALAR)) {
870 croak("The normalize_keys callback did not return anything");
871 }
872 SPAGAIN;
873 normalized = POPs;
874 PUTBACK;
875
876 if (! SvOK(normalized)) {
877 croak("The normalize_keys callback did not return a defined value when normalizing the key '%s'", SvPV_nolen(copy));
878 }
879
880 return normalized;
881 }
882 else if (ignore_case || strip_leading) {
883 if (ignore_case) {
884 STRLEN i;
885
886 rawstr = SvPV(copy, len);
887 for (i = 0; i < len; i++) {
888 /* should this account for UTF8 strings? */
889 *(rawstr + i) = toLOWER(*(rawstr + i));
890 }
891 }
892
893 if (strip_leading) {
894 rawstr_sl = SvPV(strip_leading, len_sl);
895 rawstr = SvPV(copy, len);
896
897 if (len > len_sl && strnEQ(rawstr_sl, rawstr, len_sl)) {
898 copy = sv_2mortal(newSVpvn(rawstr + len_sl, len - len_sl));
899 }
900 }
901 }
902
903 return copy;
904}
905
906
907static HV*
908normalize_hash_keys(HV* p, SV* normalize_func, SV* strip_leading, IV ignore_case) {
909 SV* normalized;
910 HE* he;
911 HV* norm_p;
912
913 if (!normalize_func && !ignore_case && !strip_leading) {
914 return p;
915 }
916
917 norm_p = (HV*) sv_2mortal((SV*) newHV());
918 hv_iterinit(p);
919 while ((he = hv_iternext(p))) {
920 normalized =
921 normalize_one_key(HeSVKEY_force(he), normalize_func, strip_leading, ignore_case);
922
923 if (hv_fetch_ent(norm_p, normalized, 0, 0)) {
924 croak("The normalize_keys callback returned a key that already exists, '%s', when normalizing the key '%s'",
925 SvPV_nolen(normalized), SvPV_nolen(HeSVKEY_force(he)));
926 }
927
928 if (! hv_store_ent(norm_p, normalized, SvREFCNT_inc(HeVAL(he)), 0)) {
929 SvREFCNT_dec(HeVAL(he));
930 croak("Cannot add new key to hash");
931 }
932 }
933 return norm_p;
934}
935
936
937static IV
938validate_pos_depends(AV* p, AV* specs, HV* options) {
939 IV p_idx;
940 SV** depends;
941 SV** p_spec;
942 SV* buffer;
943
944 for (p_idx = 0; p_idx <= av_len(p); p_idx++) {
945 p_spec = av_fetch(specs, p_idx, 0);
946
947 if (p_spec != NULL && SvROK(*p_spec) &&
948 SvTYPE(SvRV(*p_spec)) == SVt_PVHV) {
949
950 depends = hv_fetch((HV*) SvRV(*p_spec), "depends", 7, 0);
951
952 if (! depends) {
953 return 1;
954 }
955
956 if (SvROK(*depends)) {
957 croak("Arguments to 'depends' for validate_pos() must be a scalar");
958 }
959
960 if (av_len(p) < SvIV(*depends) -1) {
961
962 buffer =
963 sv_2mortal(newSVpvf("Parameter #%d depends on parameter #%d, which was not given",
964 (int) p_idx + 1,
965 (int) SvIV(*depends)));
966
967 FAIL(buffer, options);
968 }
969 }
970 }
971 return 1;
972}
973
974
975static IV
976validate_named_depends(HV* p, HV* specs, HV* options) {
977 HE* he;
978 HE* he1;
979 SV* buffer;
980 SV** depends_value;
981 AV* depends_list;
982 SV* depend_name;
983 SV* temp;
984 I32 d_idx;
985
986 /* the basic idea here is to iterate through the parameters
987 * (which we assumed to have already gone through validation
988 * via validate_one_param()), and the check to see if that
989 * parameter contains a "depends" spec. If it does, we'll
990 * check if that parameter specified by depends exists in p
991 */
992 hv_iterinit(p);
993 while ((he = hv_iternext(p))) {
994 he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he));
995
996 if (he1 && SvROK(HeVAL(he1)) &&
997 SvTYPE(SvRV(HeVAL(he1))) == SVt_PVHV) {
998
999 if (hv_exists((HV*) SvRV(HeVAL(he1)), "depends", 7)) {
1000
1001 depends_value = hv_fetch((HV*) SvRV(HeVAL(he1)), "depends", 7, 0);
1002
1003 if (! depends_value) {
1004 return 1;
1005 }
1006
1007 if (! SvROK(*depends_value)) {
1008 depends_list = (AV*) sv_2mortal((SV*) newAV());
1009 temp = sv_2mortal(newSVsv(*depends_value));
1010 av_push(depends_list,SvREFCNT_inc(temp));
1011 }
1012 else if (SvTYPE(SvRV(*depends_value)) == SVt_PVAV) {
1013 depends_list = (AV*) SvRV(*depends_value);
1014 }
1015 else {
1016 croak("Arguments to 'depends' must be a scalar or arrayref");
1017 }
1018
1019 for (d_idx =0; d_idx <= av_len(depends_list); d_idx++) {
1020
1021 depend_name = *av_fetch(depends_list, d_idx, 0);
1022
1023 /* first check if the parameter to which this
1024 * depends on was given to us
1025 */
1026 if (!hv_exists(p, SvPV_nolen(depend_name),
1027 SvCUR(depend_name))) {
1028 /* oh-oh, the parameter that this parameter
1029 * depends on is not available. Let's first check
1030 * if this is even valid in the spec (i.e., the
1031 * spec actually contains a spec for such parameter)
1032 */
1033 if (!hv_exists(specs, SvPV_nolen(depend_name),
1034 SvCUR(depend_name))) {
1035
1036 buffer =
1037 sv_2mortal(newSVpv("Following parameter specified in depends for '", 0));
1038
1039 sv_catsv(buffer, HeSVKEY_force(he1));
1040 sv_catpv(buffer, "' does not exist in spec: ");
1041 sv_catsv(buffer, depend_name);
1042
1043 croak(SvPV_nolen(buffer));
1044 }
1045 /* if we got here, the spec was correct. we just
1046 * need to issue a regular validation failure
1047 */
1048 buffer = sv_2mortal(newSVpv( "Parameter '", 0));
1049 sv_catsv(buffer, HeSVKEY_force(he1));
1050 sv_catpv(buffer, "' depends on parameter '");
1051 sv_catsv(buffer, depend_name);
1052 sv_catpv(buffer, "', which was not given");
1053 FAIL(buffer, options);
1054 }
1055 }
1056 }
1057 }
1058 }
1059 return 1;
1060}
1061
1062
1063void
1064cat_string_representation(SV* buffer, SV* value) {
1065 if(SvOK(value)) {
1066 sv_catpv(buffer, "\"");
1067 sv_catpv(buffer, SvPV_nolen(value));
1068 sv_catpv(buffer, "\"");
1069 }
1070 else {
1071 sv_catpv(buffer, "undef");
1072 }
1073}
1074
1075
1076void
1077apply_defaults(HV *ret, HV *p, HV *specs, AV *missing) {
1078 HE* he;
1079 SV** temp;
1080
1081 hv_iterinit(specs);
1082 while ((he = hv_iternext(specs))) {
1083 HV* spec;
1084 SV* val;
1085
1086 val = HeVAL(he);
1087
1088 /* get extended param spec if available */
1089 if (SvROK(val) && SvTYPE(SvRV(val)) == SVt_PVHV) {
1090 spec = (HV*) SvRV(val);
1091 }
1092 else {
1093 spec = NULL;
1094 }
1095
1096 /* test for parameter existence */
1097 if (hv_exists_ent(p, HeSVKEY_force(he), HeHASH(he))) {
1098 continue;
1099 }
1100
1101 /* parameter may not be defined but we may have default */
1102 if (spec && (temp = hv_fetch(spec, "default", 7, 0))) {
1103 SV* value;
1104
1105 SvGETMAGIC(*temp);
1106 value = sv_2mortal(newSVsv(*temp));
1107
1108 /* make sure that parameter is put into return hash */
1109 if (GIMME_V != G_VOID) {
1110 if (!hv_store_ent(ret, HeSVKEY_force(he),
1111 SvREFCNT_inc(value), HeHASH(he))) {
1112 SvREFCNT_dec(value);
1113 croak("Cannot add new key to hash");
1114 }
1115 }
1116
1117 continue;
1118 }
1119
1120 /* find if missing parameter is mandatory */
1121 if (! no_validation()) {
1122 SV** temp;
1123
1124 if (spec) {
1125 if ((temp = hv_fetch(spec, "optional", 8, 0))) {
1126 SvGETMAGIC(*temp);
1127
1128 if (SvTRUE(*temp)) continue;
1129 }
1130 }
1131 else if (!SvTRUE(HeVAL(he))) {
1132 continue;
1133 }
1134 av_push(missing, SvREFCNT_inc(HeSVKEY_force(he)));
1135 }
1136 }
1137}
1138
1139
1140static IV
1141validate(HV* p, HV* specs, HV* options, HV* ret) {
1142 AV* missing;
1143 AV* unmentioned;
1144 HE* he;
1145 HE* he1;
1146 SV* hv;
1147 SV* hv1;
1148 IV ignore_case = 0;
1149 SV* strip_leading = NULL;
1150 IV allow_extra = 0;
1151 SV** temp;
1152 SV* normalize_func = NULL;
1153 AV* untaint_keys = (AV*) sv_2mortal((SV*) newAV());
1154 IV i;
1155
1156 if ((temp = hv_fetch(options, "ignore_case", 11, 0))) {
1157 SvGETMAGIC(*temp);
1158 ignore_case = SvTRUE(*temp);
1159 }
1160
1161 if ((temp = hv_fetch(options, "strip_leading", 13, 0))) {
1162 SvGETMAGIC(*temp);
1163 if (SvOK(*temp)) strip_leading = *temp;
1164 }
1165
1166 if ((temp = hv_fetch(options, "normalize_keys", 14, 0))) {
1167 SvGETMAGIC(*temp);
1168 if(SvROK(*temp) && SvTYPE(SvRV(*temp)) == SVt_PVCV) {
1169 normalize_func = *temp;
1170 }
1171 }
1172
1173 if (normalize_func || ignore_case || strip_leading) {
1174 p = normalize_hash_keys(p, normalize_func, strip_leading, ignore_case);
1175 specs = normalize_hash_keys(specs, normalize_func, strip_leading, ignore_case);
1176 }
1177
1178 /* short-circuit everything else when no_validation is true */
1179 if (no_validation()) {
1180 if (GIMME_V != G_VOID) {
1181 while ((he = hv_iternext(p))) {
1182 hv = HeVAL(he);
1183 SvGETMAGIC(hv);
1184
1185 /* put the parameter into return hash */
1186 if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv),
1187 HeHASH(he))) {
1188 SvREFCNT_dec(hv);
1189 croak("Cannot add new key to hash");
1190 }
1191 }
1192 apply_defaults(ret, p, specs, NULL);
1193 }
1194
1195 return 1;
1196 }
1197
1198 if ((temp = hv_fetch(options, "allow_extra", 11, 0))) {
1199 SvGETMAGIC(*temp);
1200 allow_extra = SvTRUE(*temp);
1201 }
1202
1203 /* find extra parameters and validate good parameters */
1204 unmentioned = (AV*) sv_2mortal((SV*) newAV());
1205
1206 hv_iterinit(p);
1207 while ((he = hv_iternext(p))) {
1208 hv = HeVAL(he);
1209 SvGETMAGIC(hv);
1210
1211 /* put the parameter into return hash */
1212 if (GIMME_V != G_VOID) {
1213 if (!hv_store_ent(ret, HeSVKEY_force(he), SvREFCNT_inc(hv),
1214 HeHASH(he))) {
1215 SvREFCNT_dec(hv);
1216 croak("Cannot add new key to hash");
1217 }
1218 }
1219
1220 /* check if this parameter is defined in spec and if it is
1221 then validate it using spec */
1222 he1 = hv_fetch_ent(specs, HeSVKEY_force(he), 0, HeHASH(he));
1223 if(he1) {
1224 hv1 = HeVAL(he1);
1225 if (SvROK(hv1) && SvTYPE(SvRV(hv1)) == SVt_PVHV) {
1226 SV* buffer;
1227 HV* spec;
1228 IV untaint = 0;
1229
1230 spec = (HV*) SvRV(hv1);
1231 buffer = sv_2mortal(newSVpv("The '", 0));
1232 sv_catsv(buffer, HeSVKEY_force(he));
1233 sv_catpv(buffer, "' parameter (");
1234 cat_string_representation(buffer, hv);
1235 sv_catpv(buffer, ")");
1236
1237 if (! validate_one_param(hv, (SV*) p, spec, buffer, options, &untaint))
1238 return 0;
1239
1240 /* The value stored here is meaningless, we're just tracking
1241 keys to untaint later */
1242 if (untaint) {
1243 av_push(untaint_keys, SvREFCNT_inc(HeSVKEY_force(he1)));
1244 }
1245 }
1246 }
1247 else if (! allow_extra) {
1248 av_push(unmentioned, SvREFCNT_inc(HeSVKEY_force(he)));
1249 }
1250
1251 if (av_len(unmentioned) > -1) {
1252 SV* buffer;
1253
1254 buffer = sv_2mortal(newSVpv("The following parameter", 0));
1255 if (av_len(unmentioned) != 0) {
1256 sv_catpv(buffer, "s were ");
1257 }
1258 else {
1259 sv_catpv(buffer, " was ");
1260 }
1261 sv_catpv(buffer, "passed in the call to ");
1262 sv_catsv(buffer, get_called(options));
1263 sv_catpv(buffer, " but ");
1264 if (av_len(unmentioned) != 0) {
1265 sv_catpv(buffer, "were ");
1266 }
1267 else {
1268 sv_catpv(buffer, "was ");
1269 }
1270 sv_catpv(buffer, "not listed in the validation options: ");
1271 for(i = 0; i <= av_len(unmentioned); i++) {
1272 sv_catsv(buffer, *av_fetch(unmentioned, i, 1));
1273 if (i < av_len(unmentioned)) {
1274 sv_catpv(buffer, " ");
1275 }
1276 }
1277 sv_catpv(buffer, "\n");
1278
1279 FAIL(buffer, options);
1280 }
1281 }
1282
1283 validate_named_depends(p, specs, options);
1284
1285 /* find missing parameters */
1286 missing = (AV*) sv_2mortal((SV*) newAV());
1287
1288 apply_defaults(ret, p, specs, missing);
1289
1290 if (av_len(missing) > -1) {
1291 SV* buffer;
1292
1293 buffer = sv_2mortal(newSVpv("Mandatory parameter", 0));
1294 if (av_len(missing) > 0) {
1295 sv_catpv(buffer, "s ");
1296 }
1297 else {
1298 sv_catpv(buffer, " ");
1299 }
1300
1301 for(i = 0; i <= av_len(missing); i++) {
1302 sv_catpvf(buffer, "'%s'",
1303 SvPV_nolen(*av_fetch(missing, i, 0)));
1304 if (i < av_len(missing)) {
1305 sv_catpv(buffer, ", ");
1306 }
1307 }
1308 sv_catpv(buffer, " missing in call to ");
1309 sv_catsv(buffer, get_called(options));
1310 sv_catpv(buffer, "\n");
1311
1312 FAIL(buffer, options);
1313 }
1314
1315 if (GIMME_V != G_VOID) {
1316 for (i = 0; i <= av_len(untaint_keys); i++) {
1317 SvTAINTED_off(HeVAL(hv_fetch_ent(p, *av_fetch(untaint_keys, i, 0), 0, 0)));
1318 }
1319 }
1320
1321 return 1;
1322}
1323
1324
1325static SV*
1326validate_pos_failure(IV pnum, IV min, IV max, HV* options) {
1327 SV* buffer;
1328 SV** temp;
1329 IV allow_extra;
1330
1331 if ((temp = hv_fetch(options, "allow_extra", 11, 0))) {
1332 SvGETMAGIC(*temp);
1333 allow_extra = SvTRUE(*temp);
1334 }
1335 else {
1336 allow_extra = 0;
1337 }
1338
1339 buffer = sv_2mortal(newSViv(pnum + 1));
1340 if (pnum != 0) {
1341 sv_catpv(buffer, " parameters were passed to ");
1342 }
1343 else {
1344 sv_catpv(buffer, " parameter was passed to ");
1345 }
1346 sv_catsv(buffer, get_called(options));
1347 sv_catpv(buffer, " but ");
1348 if (!allow_extra) {
1349 if (min != max) {
1350 sv_catpvf(buffer, "%d - %d", (int) min + 1, (int) max + 1);
1351 }
1352 else {
1353 sv_catpvf(buffer, "%d", (int) max + 1);
1354 }
1355 }
1356 else {
1357 sv_catpvf(buffer, "at least %d", (int) min + 1);
1358 }
1359 if ((allow_extra ? min : max) != 0) {
1360 sv_catpv(buffer, " were expected\n");
1361 }
1362 else {
1363 sv_catpv(buffer, " was expected\n");
1364 }
1365
1366 return buffer;
1367}
1368
1369
1370/* Given a single parameter spec and a corresponding complex spec form
1371 of it (which must be false if the spec is not complex), return true
1372 says that the parameter is options. */
1373static bool
1374spec_says_optional(SV* spec, IV complex_spec) {
1375 SV** temp;
1376
1377 if (complex_spec) {
1378 if ((temp = hv_fetch((HV*) SvRV(spec), "optional", 8, 0))) {
1379 SvGETMAGIC(*temp);
1380 if (!SvTRUE(*temp))
1381 return FALSE;
1382 }
1383 else {
1384 return FALSE;
1385 }
1386 }
1387 else {
1388 if (SvTRUE(spec)) {
1389 return FALSE;
1390 }
1391 }
1392 return TRUE;
1393}
1394
1395
1396static IV
1397validate_pos(AV* p, AV* specs, HV* options, AV* ret) {
1398 SV* buffer;
1399 SV* value;
1400 SV* spec = NULL;
1401 SV** temp;
1402 IV i;
1403 IV complex_spec = 0;
1404 IV allow_extra;
1405 /* Index of highest-indexed required parameter known so far, or -1
1406 if no required parameters are known yet. */
1407 IV min = -1;
1408 AV* untaint_indexes = (AV*) sv_2mortal((SV*) newAV());
1409
1410 if (no_validation()) {
1411 IV spec_count = av_len(specs);
1412 IV p_count = av_len(p);
1413 IV max = spec_count > p_count ? spec_count : p_count;
1414
1415 if (GIMME_V == G_VOID) {
1416 return 1;
1417 }
1418
1419 for (i = 0; i <= max; i++) {
1420 if (i <= spec_count) {
1421 spec = *av_fetch(specs, i, 1);
1422 SvGETMAGIC(spec);
1423 complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV);
1424 }
1425
1426 if (i <= av_len(p)) {
1427 value = *av_fetch(p, i, 1);
1428 SvGETMAGIC(value);
1429 av_push(ret, SvREFCNT_inc(value));
1430 } else if (complex_spec &&
1431 (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) {
1432 SvGETMAGIC(*temp);
1433 av_push(ret, SvREFCNT_inc(*temp));
1434 }
1435 }
1436 return 1;
1437 }
1438
1439 /* iterate through all parameters and validate them */
1440 for (i = 0; i <= av_len(specs); i++) {
1441 spec = *av_fetch(specs, i, 1);
1442 SvGETMAGIC(spec);
1443 complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV);
1444
1445 /* Unless the current spec refers to an optional argument, update
1446 our notion of the index of the highest-idexed required
1447 parameter. */
1448 if (! spec_says_optional(spec, complex_spec) ) {
1449 min = i;
1450 }
1451
1452 if (i <= av_len(p)) {
1453 value = *av_fetch(p, i, 1);
1454 SvGETMAGIC(value);
1455
1456 if (complex_spec) {
1457 IV untaint = 0;
1458
1459 buffer = sv_2mortal(newSVpvf("Parameter #%d (", (int) i + 1));
1460 cat_string_representation(buffer, value);
1461 sv_catpv(buffer, ")");
1462
1463 if (! validate_one_param(value, (SV*) p, (HV*) SvRV(spec),
1464 buffer, options, &untaint)) {
1465 return 0;
1466 }
1467
1468 if (untaint) {
1469 av_push(untaint_indexes, newSViv(i));
1470 }
1471 }
1472
1473 if (GIMME_V != G_VOID) {
1474 av_push(ret, SvREFCNT_inc(value));
1475 }
1476
1477 } else if (complex_spec &&
1478 (temp = hv_fetch((HV*) SvRV(spec), "default", 7, 0))) {
1479 SvGETMAGIC(*temp);
1480
1481 if (GIMME_V != G_VOID) {
1482 av_push(ret, SvREFCNT_inc(*temp));
1483 }
1484
1485 }
1486 else {
1487 if (i == min) {
1488 /* We don't have as many arguments as the arg spec requires. */
1489 SV* buffer;
1490
1491 /* Look forward through remaining argument specifications to
1492 find the last non-optional one, so we can correctly report the
1493 number of arguments required. */
1494 for (i++ ; i <= av_len(specs); i++) {
1495 spec = *av_fetch(specs, i, 1);
1496 SvGETMAGIC(spec);
1497 complex_spec = (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV);
1498 if (! spec_says_optional(spec, complex_spec)) {
1499 min = i;
1500 }
1501 if (min != i)
1502 break;
1503 }
1504
1505 buffer = validate_pos_failure(av_len(p), min, av_len(specs), options);
1506
1507 FAIL(buffer, options);
1508 }
1509 }
1510 }
1511
1512 validate_pos_depends(p, specs, options);
1513
1514 /* test for extra parameters */
1515 if (av_len(p) > av_len(specs)) {
1516 if ((temp = hv_fetch(options, "allow_extra", 11, 0))) {
1517 SvGETMAGIC(*temp);
1518 allow_extra = SvTRUE(*temp);
1519 }
1520 else {
1521 allow_extra = 0;
1522 }
1523 if (allow_extra) {
1524 /* put all additional parameters into return array */
1525 if (GIMME_V != G_VOID) {
1526 for(i = av_len(specs) + 1; i <= av_len(p); i++) {
1527 value = *av_fetch(p, i, 1);
1528 SvGETMAGIC(value);
1529
1530 av_push(ret, SvREFCNT_inc(value));
1531 }
1532 }
1533 }
1534 else {
1535 SV* buffer;
1536
1537 buffer = validate_pos_failure(av_len(p), min, av_len(specs), options);
1538
1539 FAIL(buffer, options);
1540 }
1541 }
1542
1543 if (GIMME_V != G_VOID) {
1544 for (i = 0; i <= av_len(untaint_indexes); i++) {
1545 SvTAINTED_off(*av_fetch(p, SvIV(*av_fetch(untaint_indexes, i, 0)), 0));
1546 }
1547 }
1548
1549 return 1;
1550}
1551
1552
1553MODULE = Params::Validate PACKAGE = Params::Validate
1554
1555BOOT:
1556 bootinit();
1557
1558void
1559_validate(p, specs)
1560 SV* p
1561 SV* specs
1562
1563 PROTOTYPE: \@$
1564
1565 PPCODE:
1566
1567 HV* ret = NULL;
1568 AV* pa;
1569 HV* ph;
1570 HV* options;
1571
1572 if (no_validation() && GIMME_V == G_VOID) {
1573 XSRETURN(0);
1574 }
1575
1576 SvGETMAGIC(p);
1577 if (! (SvROK(p) && SvTYPE(SvRV(p)) == SVt_PVAV)) {
1578 croak("Expecting array reference as first parameter");
1579 }
1580
1581 SvGETMAGIC(specs);
1582 if (! (SvROK(specs) && SvTYPE(SvRV(specs)) == SVt_PVHV)) {
1583 croak("Expecting hash reference as second parameter");
1584 }
1585
1586 pa = (AV*) SvRV(p);
1587 ph = NULL;
1588 if (av_len(pa) == 0) {
1589 /* we were called as validate( @_, ... ) where @_ has a
1590 single element, a hash reference */
1591 SV* value;
1592
1593 value = *av_fetch(pa, 0, 1);
1594 SvGETMAGIC(value);
1595 if (SvROK(value) && SvTYPE(SvRV(value)) == SVt_PVHV) {
1596 ph = (HV*) SvRV(value);
1597 }
1598 }
1599
1600 options = get_options(NULL);
1601
1602 if (! ph) {
1603 ph = (HV*) sv_2mortal((SV*) newHV());
1604
1605 if (! convert_array2hash(pa, options, ph) ) {
1606 XSRETURN(0);
1607 }
1608 }
1609 if (GIMME_V != G_VOID) {
1610 ret = (HV*) sv_2mortal((SV*) newHV());
1611 }
1612 if (! validate(ph, (HV*) SvRV(specs), options, ret)) {
1613 XSRETURN(0);
1614 }
1615 RETURN_HASH(ret);
1616
1617void
1618_validate_pos(p, ...)
1619SV* p
1620
1621 PROTOTYPE: \@@
1622
1623 PPCODE:
1624
1625 AV* specs;
1626 AV* ret = NULL;
1627 IV i;
1628
1629 if (no_validation() && GIMME_V == G_VOID) {
1630 XSRETURN(0);
1631 }
1632
1633
1634 SvGETMAGIC(p);
1635 if (!SvROK(p) || !(SvTYPE(SvRV(p)) == SVt_PVAV)) {
1636 croak("Expecting array reference as first parameter");
1637 }
1638
1639
1640 specs = (AV*) sv_2mortal((SV*) newAV());
1641 av_extend(specs, items);
1642 for(i = 1; i < items; i++) {
1643 if (!av_store(specs, i - 1, SvREFCNT_inc(ST(i)))) {
1644 SvREFCNT_dec(ST(i));
1645 croak("Cannot store value in array");
1646 }
1647 }
1648
1649
1650 if (GIMME_V != G_VOID) {
1651 ret = (AV*) sv_2mortal((SV*) newAV());
1652 }
1653
1654
1655 if (! validate_pos((AV*) SvRV(p), specs, get_options(NULL), ret)) {
1656 XSRETURN(0);
1657 }
1658
1659
1660 RETURN_ARRAY(ret);
1661
1662void
1663_validate_with(...)
1664
1665 PPCODE:
1666
1667 HV* p;
1668 SV* params;
1669 SV* spec;
1670 IV i;
1671
1672 if (no_validation() && GIMME_V == G_VOID) XSRETURN(0);
1673
1674 /* put input list into hash */
1675 p = (HV*) sv_2mortal((SV*) newHV());
1676 for(i = 0; i < items; i += 2) {
1677 SV* key;
1678 SV* value;
1679
1680 key = ST(i);
1681 if (i + 1 < items) {
1682 value = ST(i + 1);
1683 }
1684 else {
1685 value = &PL_sv_undef;
1686 }
1687 if (! hv_store_ent(p, key, SvREFCNT_inc(value), 0)) {
1688 SvREFCNT_dec(value);
1689 croak("Cannot add new key to hash");
1690 }
1691 }
1692
1693 params = *hv_fetch(p, "params", 6, 1);
1694 SvGETMAGIC(params);
1695 spec = *hv_fetch(p, "spec", 4, 1);
1696 SvGETMAGIC(spec);
1697
1698 if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVAV) {
1699 if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) {
1700 AV* ret = NULL;
1701
1702 if (GIMME_V != G_VOID) {
1703 ret = (AV*) sv_2mortal((SV*) newAV());
1704 }
1705
1706 if (! validate_pos((AV*) SvRV(params), (AV*) SvRV(spec),
1707 get_options(p), ret)) {
1708 XSRETURN(0);
1709 }
1710
1711 RETURN_ARRAY(ret);
1712 }
1713 else {
1714 croak("Expecting array reference in 'params'");
1715 }
1716 }
1717 else if (SvROK(spec) && SvTYPE(SvRV(spec)) == SVt_PVHV) {
1718 HV* hv;
1719 HV* ret = NULL;
1720 HV* options;
1721
1722 options = get_options(p);
1723
1724 if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVHV) {
1725 hv = (HV*) SvRV(params);
1726 }
1727 else if (SvROK(params) && SvTYPE(SvRV(params)) == SVt_PVAV) {
1728 I32 hv_set = 0;
1729
1730 /* Check to see if we have a one element array
1731 containing a hash reference */
1732 if (av_len((AV*) SvRV(params)) == 0) {
1733 SV** first_elem;
1734
1735 first_elem = av_fetch((AV*) SvRV(params), 0, 0);
1736
1737 if (first_elem && SvROK(*first_elem) &&
1738 SvTYPE(SvRV(*first_elem)) == SVt_PVHV) {
1739
1740 hv = (HV*) SvRV(*first_elem);
1741 hv_set = 1;
1742 }
1743 }
1744
1745 if (! hv_set) {
1746 hv = (HV*) sv_2mortal((SV*) newHV());
1747
1748 if (! convert_array2hash((AV*) SvRV(params), options, hv))
1749 XSRETURN(0);
1750 }
1751 }
1752 else {
1753 croak("Expecting array or hash reference in 'params'");
1754 }
1755
1756 if (GIMME_V != G_VOID) {
1757 ret = (HV*) sv_2mortal((SV*) newHV());
1758 }
1759
1760 if (! validate(hv, (HV*) SvRV(spec), options, ret)) {
1761 XSRETURN(0);
1762 }
1763
1764 RETURN_HASH(ret);
1765 }
1766 else {
1767 croak("Expecting array or hash reference in 'spec'");
1768 }
Note: See TracBrowser for help on using the repository browser.