TER1 (Statement): 100.00%
TER2 (Branch): 100.00%
TER3 (LCSAJ): 100.0% (1/1)
Approximate LCSAJ segments: 3
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package App::Test::Generator::Template; 2: 3: use strict; 4: use warnings; 5: use autodie qw(:all); 6: 7: use utf8; 8: use Data::Section::Simple; 9: 10: our $VERSION = '0.46'; 11: 12: =head1 NAME 13: 14: App::Test::Generator::Template - Template for the test files generated by App::Test::Generator 15: 16: =head1 VERSION 17: 18: Version 0.46 19: 20: =head1 SYNOPSIS 21: 22: The template for the test files generated by App::Test::Generator. 23: 24: =head1 METHODS 25: 26: =head2 get_data_section 27: 28: Returns a reference to the named template, read from this module's 29: C<__DATA__> section via L<Data::Section::Simple>. 30: 31: my $template_ref = App::Test::Generator::Template->get_data_section('test.tt'); 32: my $template_ref = App::Test::Generator::Template::get_data_section('test.tt'); 33: 34: =head3 Arguments 35: 36: =over 4 37: 38: =item * C<$template_file> 39: 40: The name of the C<@@>-delimited section to retrieve. The only value 41: currently defined in this module's C<__DATA__> section is C<test.tt>. 42: May be called either as a class method (C<< Template->get_data_section(...) >>, 43: in which case the leading class-name argument is stripped before lookup) 44: or as a plain function. 45: 46: =back 47: 48: =head3 Returns 49: 50: A scalar reference to the template content. If C<$template_file> does 51: not match a defined C<@@> section, returns a reference to C<undef>. 52: 53: =head3 Side Effects 54: 55: None. Does not write to disk or modify any global state. 56: 57: =head3 API specification 58: 59: =head4 input 60: 61: { 62: template_file => { type => SCALAR, optional => 1 }, 63: } 64: 65: =head4 output 66: 67: { type => SCALARREF } 68: 69: =cut 70: 71: sub get_data_section 72: { ●73 → 73 → 77 73: if($_[0] && ($_[0] eq __PACKAGE__)) {Mutants (Total: 1, Killed: 1, Survived: 0)
74: shift; 75: } 76: 77: return \Data::Section::Simple::get_data_section($_[0]);
Mutants (Total: 2, Killed: 2, Survived: 0)
78: } 79: 80: 1; 81: 82: =head1 AUTHOR 83: 84: Nigel Horne, C<< <njh at nigelhorne.com> >> 85: 86: Portions of this module's initial design and documentation were created with the 87: assistance of L<ChatGPT|https://openai.com/> (GPT-5), with final curation 88: and authorship by Nigel Horne. 89: 90: =cut 91: 92: __DATA__ 93: 94: @@ test.tt 95: #!/usr/bin/env perl 96: 97: use strict; 98: use warnings; 99: 100: use utf8; 101: use open qw(:std :encoding(UTF-8)); # https://github.com/nigelhorne/App-Test-Generator/issues/1 102: 103: use Carp; 104: use Data::Dumper; 105: use Data::Random qw(:all); 106: use Data::Random::String; 107: use Data::Random::String::Matches 0.02; 108: use Data::Random::Structure; 109: use Encode qw(decode_utf8); 110: use Unicode::Normalize (); 111: use Test::Most; 112: use Test::Returns 0.02; 113: use Unicode::GCString; 114: 115: [% setup_code %] 116: 117: [% IF module %] 118: diag('[% module %]->[% function %] test case created by https://github.com/nigelhorne/App-Test-Generator'); 119: [% ELSE %] 120: diag('[% function %] test case created by https://github.com/nigelhorne/App-Test-Generator'); 121: [% END %] 122: 123: die_on_fail if($ENV{'DIE_ON_FAIL'}); 124: 125: # Edge-case maps injected from config (optional) 126: my %edge_cases = ( 127: [% edge_cases_code %] 128: ); 129: my @edge_case_array = ( 130: [% edge_case_array_code %] 131: ); 132: my %type_edge_cases = ( 133: [% type_edge_cases_code %] 134: ); 135: my %config = ( 136: [% config_code %] 137: ); 138: 139: if($^O ne 'MSWin32' && $config{close_stdin}) { 140: 141: close(STDIN); 142: open(STDIN, '<', '/dev/null'); 143: } 144: 145: # TODO: add more, and remove magic numbers 146: use constant { 147: PROB_LOWERCASE => $config{prob_lowercase} // 0.72, 148: PROB_EDGE_CASE => $config{prob_edge_case} // 0.4, 149: }; 150: 151: # Seed for reproducible fuzzing (if provided) 152: [% seed_code %] 153: 154: my %input = ( 155: [% input_code %] 156: ); 157: 158: my %output = ( 159: [% output_code %] 160: ); 161: 162: my %transforms = ( 163: [% transforms_code %] 164: ); 165: 166: my @relationships = ( 167: [% relationships_code %] 168: ); 169: 170: # Candidates for regex comparisons 171: my @candidate_good = ('123', 'abc', 'A1B2', '0'); 172: my @candidate_bad = ( 173: "😊", # emoji 174: "１２３", # full-width digits 175: "١٢٣", # Arabic digits 176: '..', # regex metachars 177: "a\nb", # newline in middle 178: "é", # E acute 179: 'x' x 5000, # huge string 180: *STDOUT, 181: ' ', # space 182: "\t", # tab 183: "\r", # carriage return 184: 185: # Added later if the configuration says so 186: # '', # empty 187: # undef, # undefined 188: # "\0", # null byte 189: ); 190: my $positions = populate_positions(\%input); 191: 192: # --- Fuzzer helpers --- 193: sub _pick_from { 194: my $arrayref = $_[0]; 195: return undef unless $arrayref && ref $arrayref eq 'ARRAY' && @{$arrayref}; 196: return $arrayref->[ int(rand(scalar @$arrayref)) ]; 197: } 198: 199: sub rand_ascii_str { 200: my $len = shift // int(rand(10)) + 1; 201: # join '', map { chr(97 + int(rand(26))) } 1..$len; 202: return Data::Random::String->create_random_string(length => $len, contains => 'alphanumeric'); 203: } 204: 205: my @unicode_codepoints = ( 206: 0x00A9, # © 207: 0x00AE, # ® 208: 0x03A9, # Ω 209: 0x20AC, # € 210: 0x2013, # – (en-dash) 211: 0x0301, # combining acute accent 212: 0x0308, # combining diaeresis 213: 0x1F600, # 😀 (emoji) 214: 0x1F62E, # 😮 215: 0x1F4A9, # 💩 (yes) 216: ); 217: 218: # Tests for matches or nomatch 219: my @regex_tests = ( 220: 'match123', 221: 'nope', 222: '/fullpath', 223: '/', 224: '/etc/passwd', 225: '../../etc/passwd', 226: "/etc/passwd\0", 227: "D:\\dos_path", 228: "I:\\", 229: '/(?{ exit 1 })/', 230: ); 231: 232: # unified generator to randomly produces codepoint strings, 233: # grapheme clusters, ZWJ emoji sequences, or aggressive Unicode fuzz strings 234: sub rand_str 235: { 236: my $len = $_[0]; 237: if(!defined($len)) { 238: $len = int(rand(10)) + 1; # length random number between 1 and 10 239: } 240: 241: return '' if($len == 0); 242: 243: if(!($config{'test_non_ascii'} // 0)) { 244: return rand_ascii_str($len); 245: } 246: 247: # my $rc = _rand_str_basic($len); 248: # $rc = _rand_unicode_fuzzer($len); 249: # my $l = Unicode::GCString->new($rc)->length(); 250: # if($len > $l) { 251: # $rc .= 'a' x ($len - $l); # Why is this needed? 252: # } 253: 254: # return $rc; 255: 256: # TODO: length issues at the moment 257: my $mode = int(rand(5)); # 0..4 258: 259: my $rc = _rand_str_basic($len); 260: 261: $rc = _rand_str_basic($len) if $mode == 0; 262: $rc = _rand_codepoint_exact($len) if $mode == 1; 263: $rc = _rand_grapheme_exact($len) if $mode == 2; 264: $rc = _rand_unicode_fuzzer($len) if $mode == 3; 265: $rc = rand_ascii_str($len) if($mode == 4); 266: 267: my $rc_len = Unicode::GCString->new($rc)->length(); 268: if($rc_len > $len) { 269: my $gcstr = Unicode::GCString->new($rc); 270: $rc = $gcstr->substr(0, $len)->as_string(); 271: $rc_len = Unicode::GCString->new($rc)->length(); 272: } 273: if($len > $rc_len) { 274: $rc .= 'a' x ($len - $rc_len); 275: $rc_len = Unicode::GCString->new($rc)->length(); 276: } 277: 278: fail("BUG $rc_len != $len (mode == $mode)") if($rc_len != $len); 279: 280: return $rc; 281: } 282: 283: ##################################################### 284: # 1. EXACT-LENGTH CODEPOINT MODE 285: # Generate a random string: mostly ASCII, sometimes unicode, sometimes nul bytes or combining marks 286: ##################################################### 287: sub _rand_str_basic 288: { 289: my $len = $_[0]; 290: 291: my @chars; 292: for (1..$len) { 293: my $r = rand(); 294: if ($r < PROB_LOWERCASE) { 295: push @chars, chr(97 + int(rand(26))); # a-z 296: } elsif ($r < 0.88) { 297: push @chars, chr(65 + int(rand(26))); # A-Z 298: } elsif ($r < 0.95) { 299: push @chars, chr(48 + int(rand(10))); # 0-9 300: } elsif($r < 0.975) { 301: push @chars, _rand_unicode_char(); # occasional emoji/marks 302: } elsif($config{'test_nuls'}) { 303: push @chars, chr(0); # nul byte injection 304: } else { 305: push @chars, chr(97 + int(rand(26))); # a-z 306: } 307: } 308: 309: if (rand() < 0.08) { 310: # 8% chance to prepend combining acute accent (0301) 311: $chars[-1] = chr(0x0301); 312: } elsif (rand() < 0.08) { 313: # 8% chance to append combining diaeresis (0308) 314: $chars[-1] .= chr(0x0308); 315: } 316: return join('', @chars); 317: } 318: 319: ##################################################### 320: # 2. EXACT-LENGTH CODEPOINT MODE 321: # combining marks decorate characters 322: ##################################################### 323: sub _rand_codepoint_exact { 324: my $len = $_[0]; 325: my @chars; 326: 327: for (1..$len) { 328: my $c = _rand_base_char(); 329: if(rand() < 0.08) { 330: # prepend combining acute 331: $c = chr(0x0301) 332: } elsif(rand() < 0.08) { 333: # append combining dieresis 334: $c = chr(0x0308); 335: } 336: push @chars, $c; 337: } 338: 339: return join('', @chars); 340: } 341: 342: # helper for codepoint mode 343: sub _rand_base_char { 344: my $r = rand(); 345: 346: if ($r < 0.70) { return chr(97 + int(rand(26))); } 347: if ($r < 0.88) { return chr(65 + int(rand(26))); } 348: if ($r < 0.95) { return chr(48 + int(rand(10))); } 349: return _rand_unicode_char(); 350: } 351: 352: ##################################################### 353: # 3. EXACT-LENGTH GRAPHEME-CLUSTER MODE 354: # each "character" is a whole grapheme cluster: 355: # - emoji with ZWJ sequences 356: # - flags 357: # - skin-tone variants 358: # - accented characters 359: ##################################################### 360: sub _rand_grapheme_exact { 361: my $len = $_[0]; 362: my @clusters; 363: 364: my @emoji_base = qw( 365: 😀 😠😂 🤣 😅 😊 😎 😠😡 🥳 366: 👠👎 👋 🖠🙠💩 🧠â¤ï¸ 🫠367: ); 368: 369: my @skin_tones = ( 370: "\x{1F3FB}", "\x{1F3FC}", "\x{1F3FD}", "\x{1F3FE}", "\x{1F3FF}" 371: ); 372: 373: my @zwj_parts = ( 374: "\x{200D}\x{1F33A}", # ZWJ + Flower 375: "\x{200D}\x{1F4BB}", # ZWJ + Laptop 376: "\x{200D}\x{1F9D1}", # ZWJ + person 377: ); 378: 379: my @flags = ( 380: "\x{1F1FA}\x{1F1F8}", # US 381: "\x{1F1EC}\x{1F1E7}", # UK 382: "\x{1F1E8}\x{1F1E6}", # CA 383: "\x{1F1E6}\x{1F1FA}", # AU 384: ); 385: 386: for (1..$len) { 387: my $type = rand(); 388: 389: if ($type < 0.4) { 390: # base emoji 391: my $e = $emoji_base[ rand @emoji_base ]; 392: 393: # TODO 394: # maybe add skin tone 395: # $e .= $skin_tones[rand @skin_tones] if rand() < 0.3; 396: 397: # TODO 398: # maybe add zwj sequence 399: # $e .= $zwj_parts[rand @zwj_parts] if rand() < 0.15; 400: 401: push @clusters, $e; 402: } elsif ($type < 0.55) { 403: # flag (always 1 grapheme cluster) 404: push @clusters, $flags[rand @flags]; 405: } elsif ($type < 0.75) { 406: # accented letter (composed or decomposed) 407: my $base = chr(97 + int(rand(26))); # a-z 408: my $accented = $base . chr(0x0301); 409: $accented = Unicode::Normalize::NFC($accented) if rand() < 0.5; 410: push @clusters, $accented; 411: } else { 412: # fallback ASCII 413: push @clusters, chr(97 + int(rand(26))); 414: } 415: } 416: 417: return join('', @clusters); 418: } 419: 420: #################################################### 421: # 4. UNICODE FUZZER MODE 422: # Extremely aggressive: invalid sequences, NULs, bidirectional markers, Zalgo 423: # Exclude unpaired surrogates for now, since TAP::Harness complains about that 424: #################################################### 425: sub _rand_unicode_fuzzer { 426: my $len = $_[0]; 427: my @out; 428: 429: my @zalgo_up = map { chr($_) } (0x030D..0x036F); 430: my @bidi = ("\x{202A}", "\x{202B}", "\x{202D}", "\x{202E}", "\x{2066}", "\x{2067}"); 431: my @weird = $config{'test_nuls'} ? ("\x{0000}", "\x{FFFD}", "\x{FEFF}") : ("\x{FFFD}", "\x{FEFF}"); 432: 433: for (1..$len) { 434: my $r = rand(); 435: 436: if ($r < 0.25) { 437: # push @out, chr( int(rand(0x10FFFF)) ); # random codepoint will include surragates 438: # Generate random codepoint, excluding surrogate range 439: my $cp; 440: do { 441: $cp = int(rand(0x10FFFF)); 442: } while ($cp >= 0xD800 && $cp <= 0xDFFF); 443: push @out, chr($cp); 444: } elsif ($r < 0.40) { 445: push @out, chr(65 + int(rand(26))) . $zalgo_up[rand @zalgo_up]; # Zalgo 446: } elsif ($r < 0.55) { 447: push @out, $bidi[rand @bidi]; 448: } elsif ($r < 0.70) { 449: push @out, $weird[rand @weird]; 450: } else { 451: push @out, _rand_unicode_char(); 452: } 453: } 454: 455: return join('', @out); 456: } 457: 458: ################################################### 459: # Random Unicode character helper 460: ################################################### 461: sub _rand_unicode_char 462: { 463: if(rand() < 0.5) { 464: my $cp = $unicode_codepoints[ int(rand(@unicode_codepoints)) ]; 465: return chr($cp); 466: } 467: 468: my @pool = ( 469: 0x00A9, 0x00AE, 0x2600, 0x2601, 470: 0x1F600 + int(rand(200)), # emoji block 471: 0x0300 + int(rand(80)), # combining marks 472: ); 473: return chr( $pool[int rand @pool] ); 474: } 475: 476: # Random character either upper or lower case 477: # sub rand_char 478: # { 479: # return rand_chars(set => 'all', min => 1, max => 1); 480: 481: # my $char = ''; 482: # my $upper_chars = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'; 483: # my $lower_chars = 'abcdefghijklmnopqrstuvwxyz'; 484: # my $combined_chars = $upper_chars . $lower_chars; 485: 486: # # Generate a random index between 0 and the length of the string minus 1 487: # my $rand_index = int(rand(length($combined_chars))); 488: 489: # # Get the character at that index 490: # return substr($combined_chars, $rand_index, 1); 491: # } 492: 493: # Integer generator: mix typical small ints with large limits 494: sub rand_int { 495: my $r = rand(); 496: if ($r < 0.75) { 497: return int(rand(200)) - 100; # -100 .. 100 (usual) 498: } elsif ($r < 0.9) { 499: return int(rand(2**31)) - 2**30; # 32-bit-ish 500: } elsif ($r < 0.98) { 501: return (int(rand(2**63)) - 2**62); # 64-bit-ish 502: } else { 503: # very large/suspicious values 504: return 2**63 - 1; 505: } 506: } 507: sub rand_bool { rand() > 0.5 ? 1 : 0 } 508: 509: # Number generator (floating), includes tiny/huge floats 510: sub rand_num { 511: my $r = rand(); 512: if ($r < 0.7) { 513: return (rand() * 200 - 100); # -100 .. 100 514: } elsif ($r < 0.9) { 515: return (rand() * 1e12) - 5e11; # large-ish 516: } elsif ($r < 0.95) { 517: return -0.0; # Negative 0 518: } elsif ($r < 0.96) { 519: return (rand() * 1e308) - 5e307; # very large floats 520: } elsif($r < 0.97) { 521: return 9**9**9; # Infinity 522: } else { 523: return 1e-308 * (rand() * 1000); # tiny float, subnormal-like 524: } 525: } 526: 527: sub rand_arrayref { 528: my $len = shift || int(rand(3)) + 1; # small arrays 529: 530: return Data::Random::Structure->new(max_elements => $len, max_depth => 1)->generate_array(); 531: 532: # return [ map { rand_str() } 1..$len ]; 533: } 534: 535: sub rand_hashref { 536: my $len = shift || int(rand(3)) + 1; # small hashes 537: 538: return Data::Random::Structure->new(max_elements => $len, max_depth => 1)->generate_hash(); 539: 540: # my %h; 541: # for (1..$len) { 542: # $h{rand_str(3)} = rand_str(5); 543: # } 544: # return \%h; 545: } 546: 547: sub rand_email 548: { 549: my $len = shift || int(rand(10)); 550: my $l; 551: my @name; 552: my @tlds = qw(com org net edu gov io co uk de fr); 553: 554: for($l = 0; $l < $len; $l++) { 555: push @name, pack('c', (int(rand 26))+97); 556: } 557: push @name, '@'; 558: $len = rand(10); 559: for($l = 0; $l < $len; $l++) { 560: push @name, pack('c', (int(rand 26))+97); 561: } 562: push @name, '.'; 563: $len = rand($#tlds+1); 564: push @name, $tlds[$len]; 565: return join('', @name); 566: } 567: 568: sub fuzz_inputs 569: { 570: my @cases; 571: 572: # Are any options mandatory? 573: my $all_optional = 1; 574: my %mandatory_strings; # List of mandatory strings to be added to all tests, always put at start so it can be overwritten 575: my %mandatory_objects; 576: my %mandatory_numbers; 577: my $class_simple_loaded; 578: 579: # Create a hash ref of the mandatory args 580: foreach my $field (keys %input) { 581: my $spec = $input{$field} || {}; 582: if((ref($spec) eq 'HASH') && (!$spec->{optional})) { 583: $all_optional = 0; 584: if($spec->{'type'} eq 'string') { 585: local $config{'test_undef'} = 0; 586: local $config{'test_nuls'} = 0; 587: local $config{'test_empty'} = 0; 588: if($spec->{'matches'}) { 589: $mandatory_strings{$field} = Data::Random::String::Matches->create_random_string({ regex => $spec->{'matches'} }); 590: } elsif(defined $spec->{memberof}) { 591: my @set = @{$spec->{memberof}}; 592: $mandatory_strings{$field} = $set[-1]; 593: } else { 594: $mandatory_strings{$field} = rand_ascii_str($spec->{max} // $spec->{min}); 595: } 596: } elsif($spec->{'type'} eq 'object') { 597: my $method = $spec->{'can'}; 598: if(!defined($method)) { 599: die "$field: type is object, but 'can' is not specified which is needed to mock the object"; 600: } 601: if(!$class_simple_loaded) { 602: require_ok('Class::Simple'); 603: eval { 604: Class::Simple->import(); 605: $class_simple_loaded = 1; 606: }; 607: } 608: my $simple_obj = new_ok('Class::Simple'); 609: $simple_obj->$method(1); 610: $mandatory_objects{$field} = $simple_obj; 611: } elsif(($spec->{'type'} eq 'float') || ($spec->{'type'} eq 'number') || ($spec->{'type'} eq 'integer')) { 612: my $number; 613: if(defined(my $min = $spec->{min})) { 614: $number = rand($min); 615: } else { 616: $number = rand(100000); 617: } 618: if(defined(my $max = $spec->{max})) { 619: if($number > $max) { 620: $number = $max; 621: } 622: } 623: if($spec->{'type'} eq 'integer') { 624: $number = int($number); 625: } 626: $mandatory_numbers{$field} = $number; 627: } elsif($spec->{type} eq 'hashref') { 628: if(defined($spec->{schema})) { 629: die __PACKAGE__, ': TODO: add schema support to hashref'; 630: } elsif($spec->{max} || $spec->{min}) { 631: die __PACKAGE__, ': TODO: add size support to hashref'; 632: } 633: $mandatory_objects{$field} = { 'line' => __LINE__ }; 634: } elsif(($spec->{type} eq 'arrayref') || ($spec->{type} eq 'array')) { 635: $mandatory_objects{$field} = []; 636: } elsif($spec->{type} eq 'any') { 637: $mandatory_strings{$field} = rand_ascii_str(8); 638: } else { 639: die __PACKAGE__, ': TODO: type = ', $spec->{'type'}; 640: } 641: } 642: } 643: 644: # Don't do for now, until transform object code is added 645: # my %mandatory_args; 646: # if(my $foundation = _fill_foundation()) { 647: # %mandatory_args = %{$foundation}; 648: # } 649: my %mandatory_args = (%mandatory_strings, %mandatory_objects, %mandatory_numbers); 650: 651: if(($all_optional) || ((scalar keys %input) > 1)) { 652: # Basic test cases 653: if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) { 654: # our %input = ( type => 'string' ); 655: my $type = $input{'type'}; 656: 657: if($input{'enum'}) { 658: if($input{'memberof'}) { 659: die 'input has both enum and memberof'; 660: } 661: $input{'memberof'} = delete $input{'enum'}; 662: } 663: foreach my $field(keys %input) { 664: next if($field =~ /^_/); # Ignore comments 665: if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'memberof', 'position'))) { 666: die("TODO: handle schema keyword '$field'"); 667: } 668: } 669: 670: if ($type eq 'string') { 671: push @cases, @{_generate_string_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 672: # push @cases, { '_input' => "emoji \x{1F600}" }; 673: } else { 674: die "TODO: type $type"; 675: } 676: } else { 677: # our %input = ( str => { type => 'string' } ); 678: 679: foreach my $arg_name (keys %input) { 680: my $spec = $input{$arg_name} || {}; 681: my $type = lc((!ref($spec)) ? $spec : $spec->{type}) || 'string'; 682: 683: if(ref($spec) && $spec->{'enum'}) { 684: if($spec->{'memberof'}) { 685: die "$arg_name has both enum and memberof"; 686: } 687: $spec->{'memberof'} = delete $spec->{'enum'}; 688: } 689: foreach my $field(keys %{$spec}) { 690: next if($field =~ /^_/); # Ignore comments 691: if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'memberof', 'position', 'isa'))) { 692: diag(__LINE__, ": TODO: handle schema keyword '$field'"); 693: } 694: } 695: 696: # --- Type-based seeds --- 697: if(($type eq 'number') || ($type eq 'float')) { 698: push @cases, @{_generate_float_cases($arg_name, $spec, \%mandatory_args, _LINE => __LINE__)}; 699: } elsif ($type eq 'integer') { 700: # Probably duplicated below, but here as well just in case 701: push @cases, @{_generate_integer_cases($arg_name, $spec, \%mandatory_args, _LINE => __LINE__)}; 702: } elsif ($type eq 'string') { 703: push @cases, @{_generate_string_cases($arg_name, $spec, \%mandatory_args, _LINE => __LINE__)}; 704: } elsif ($type eq 'boolean') { 705: push @cases, @{_generate_boolean_cases($arg_name, $spec, \%mandatory_args, _LINE => __LINE__)}; 706: } elsif ($type eq 'hashref') { 707: push @cases, 708: { %mandatory_args, $arg_name => { a => 1 } }, 709: { %mandatory_args, $arg_name => [], _STATUS => 'DIES' }, 710: { %mandatory_args, $arg_name => 66, _STATUS => 'DIES' }, 711: { %mandatory_args, $arg_name => sub { die 'fail' }, _STATUS => 'DIES' }, 712: { %mandatory_args, $arg_name => 'scalar when hashref is needed', _STATUS => 'DIES' }, 713: { %mandatory_args, $arg_name => \'scalarref when hashref is needed', _STATUS => 'DIES' }; 714: if($config{test_undef}) { 715: push @cases, 716: { %mandatory_args, $arg_name => { nested => { 'first', undef, 'third' } }, _DESCRIPTION => 'nested hash with undef' } if($config{test_undef}); 717: } 718: } elsif ($type eq 'arrayref') { 719: my $circular_ref = []; 720: push @{$circular_ref}, $circular_ref; 721: 722: push @cases, 723: { %mandatory_args, $arg_name => [1,2] }, 724: { %mandatory_args, $arg_name => $circular_ref, _STATUS => 'DIES', _DESCRIPTION => 'circular ref is caught' }, 725: { %mandatory_args, $arg_name => { a => 1 }, _STATUS => 'DIES' }; 726: } elsif($type eq 'object') { 727: if($spec->{'isa'}) { 728: push @cases, { $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ }; 729: push @cases, { $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ }; 730: 731: # Test dies when given the wrong type of object 732: push @cases, { $arg_name => new_ok('MyTestPackage'), _STATUS => 'DIES', _LINE => __LINE__ }; 733: 734: use_ok($spec->{isa}); 735: push @cases, { $arg_name => new_ok($spec->{isa}) }; 736: } elsif(!$spec->{can}) { 737: Carp::carp("neither 'isa' nor 'can' is defined - what type of object should be sent?"); 738: } 739: } elsif($type eq 'any') { 740: push @cases, 741: { %mandatory_args, $arg_name => 'string_value' }, 742: { %mandatory_args, $arg_name => 42 }, 743: { %mandatory_args, $arg_name => 3.14 }, 744: { %mandatory_args, $arg_name => [] }, 745: { %mandatory_args, $arg_name => {} }; 746: if($config{test_undef}) { 747: push @cases, { %mandatory_args, $arg_name => undef }; 748: } 749: } 750: 751: # --- matches (regex) --- 752: if (defined $spec->{matches}) { 753: my $regex = $spec->{matches}; 754: for my $string(@regex_tests) { 755: if($string =~ $regex) { 756: push @cases, { %mandatory_args, ( $arg_name => $string ) }; 757: } else { 758: push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) }; 759: } 760: } 761: } 762: 763: # --- nomatch (regex) --- 764: if (defined $spec->{nomatch}) { 765: my $regex = $spec->{nomatch}; 766: for my $string(@regex_tests) { 767: if($string =~ $regex) { 768: push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) }; 769: } else { 770: push @cases, { %mandatory_args, ( $arg_name => $string ) }; 771: } 772: } 773: } 774: 775: # --- memberof --- 776: if (defined $spec->{memberof}) { 777: my @set = @{ $spec->{memberof} }; 778: push @cases, { %mandatory_args, ( $arg_name => $set[0] ) } if @set; 779: push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_', _STATUS => 'DIES' ) }; 780: } 781: 782: # --- notmemberof --- 783: if (defined $spec->{notmemberof}) { 784: my @set = @{ $spec->{notmemberof} }; 785: push @cases, { %mandatory_args, ( $arg_name => $set[0], _STATUS => 'DIES' ) } if @set; 786: push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_' ) }; 787: } 788: 789: # --- semantic --- 790: if(defined(my $semantic = $spec->{'semantic'})) { 791: if(defined(my $semantic = $spec->{'semantic'})) { 792: push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) }, 793: { %mandatory_args, ( $arg_name => 0 ) }, 794: { %mandatory_args, ( $arg_name => 1 ) }, 795: { %mandatory_args, ( $arg_name => time ) }, 796: { %mandatory_args, ( $arg_name => 2147483647 ) }, 797: { %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) }, 798: { %mandatory_args, ( $arg_name => 2147483648, _STATUS => 'DIES' ) }; 799: } elsif($semantic eq 'email') { 800: push @cases, 801: { %mandatory_args, ( $arg_name => 'user@example.com' ) }, 802: { %mandatory_args, ( $arg_name => 'user+tag@sub.example.co.uk' ) }, 803: { %mandatory_args, ( $arg_name => '@nodomain', _STATUS => 'DIES' ) }, 804: { %mandatory_args, ( $arg_name => 'noatsign', _STATUS => 'DIES' ) }, 805: { %mandatory_args, ( $arg_name => 'user@', _STATUS => 'DIES' ) }, 806: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }, 807: { %mandatory_args, ( $arg_name => 'user@' . ('a' x 256) . '.com', _STATUS => 'DIES' ) }; 808: } elsif($semantic eq 'filepath') { 809: push @cases, 810: { %mandatory_args, ( $arg_name => '/tmp/test.txt' ) }, 811: { %mandatory_args, ( $arg_name => 'relative/path.txt' ) }, 812: { %mandatory_args, ( $arg_name => '.' ) }, 813: { %mandatory_args, ( $arg_name => '..' ) }, 814: { %mandatory_args, ( $arg_name => '../../etc/passwd', _STATUS => 'DIES' ) }, 815: { %mandatory_args, ( $arg_name => '/etc/passwd' . "\0", _STATUS => 'DIES' ) }, 816: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }, 817: { %mandatory_args, ( $arg_name => '/' . ('a' x 4096), _STATUS => 'DIES' ) }; 818: if($^O eq 'MSWin32') { 819: push @cases, 820: { %mandatory_args, ( $arg_name => 'C:\\Users\\test\\file.txt' ) }, 821: { %mandatory_args, ( $arg_name => 'D:\\' ) }, 822: { %mandatory_args, ( $arg_name => 'relative\\path.txt' ) }, 823: { %mandatory_args, ( $arg_name => 'C:\\..\\..\\Windows\\System32', _STATUS => 'DIES' ) }, 824: { %mandatory_args, ( $arg_name => 'C:\\path\\' . "\0" . 'file', _STATUS => 'DIES' ) }, 825: { %mandatory_args, ( $arg_name => 'COM1', _STATUS => 'DIES' ) }, # reserved device name 826: { %mandatory_args, ( $arg_name => 'NUL', _STATUS => 'DIES' ) }, # reserved device name 827: { %mandatory_args, ( $arg_name => 'C:\\path\\file?.txt', _STATUS => 'DIES' ) }, # wildcard 828: { %mandatory_args, ( $arg_name => 'C:\\path\\file*.txt', _STATUS => 'DIES' ) }, # wildcard 829: { %mandatory_args, ( $arg_name => '\\\\server\\share\\file.txt' ) }; # UNC path 830: } 831: } elsif($semantic eq 'date_string') { 832: push @cases, 833: { %mandatory_args, ( $arg_name => '2024-01-01' ) }, 834: { %mandatory_args, ( $arg_name => '1970-01-01' ) }, 835: { %mandatory_args, ( $arg_name => '2024-02-29' ) }, # leap day 836: { %mandatory_args, ( $arg_name => '2023-02-29', _STATUS => 'DIES' ) }, # not a leap year 837: { %mandatory_args, ( $arg_name => '2024-13-01', _STATUS => 'DIES' ) }, # month 13 838: { %mandatory_args, ( $arg_name => '2024-00-01', _STATUS => 'DIES' ) }, # month 0 839: { %mandatory_args, ( $arg_name => '01-01-2024', _STATUS => 'DIES' ) }, # wrong order 840: { %mandatory_args, ( $arg_name => '2024/01/01', _STATUS => 'DIES' ) }, # wrong separator 841: { %mandatory_args, ( $arg_name => 'not-a-date', _STATUS => 'DIES' ) }, 842: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }; 843: } elsif($semantic eq 'iso8601_string') { 844: push @cases, 845: { %mandatory_args, ( $arg_name => '2024-01-01T00:00:00Z' ) }, 846: { %mandatory_args, ( $arg_name => '2024-06-15T12:30:45Z' ) }, 847: { %mandatory_args, ( $arg_name => '2024-01-01T00:00:00+05:30' ) }, 848: { %mandatory_args, ( $arg_name => '2024-01-01' ) }, # date only - check if accepted 849: { %mandatory_args, ( $arg_name => '2024-01-01T25:00:00Z', _STATUS => 'DIES' ) }, # hour 25 850: { %mandatory_args, ( $arg_name => '2024-01-01T00:61:00Z', _STATUS => 'DIES' ) }, # minute 61 851: { %mandatory_args, ( $arg_name => 'not-a-datetime', _STATUS => 'DIES' ) }, 852: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }; 853: } else { 854: diag("semantic type $semantic is not yet supported"); 855: } 856: } 857: } 858: } 859: } 860: 861: # Optional deduplication 862: # my %seen; 863: # @cases = grep { !$seen{join '|', %$_}++ } @cases; 864: 865: # Random data test cases 866: # Uses type_edge_cases sometimes 867: if(scalar keys %input) { 868: if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) { 869: # our %input = ( type => 'string' ); 870: my $type = $input{'type'}; 871: for (1..[% iterations_code %]) { 872: my $case_input; 873: if (@edge_case_array && rand() < PROB_EDGE_CASE) { 874: # Sometimes pick a field-specific edge-case 875: $case_input = _pick_from(\@edge_case_array); 876: } elsif(exists $type_edge_cases{$type} && rand() < 0.3) { 877: # Sometimes pick a type-level edge-case 878: $case_input = _pick_from($type_edge_cases{$type}); 879: } elsif($type eq 'string') { 880: if($input{matches}) { 881: $case_input = Data::Random::String::Matches->create_random_string({ regex => $input{'matches'} }); 882: } else { 883: $case_input = rand_str(); 884: } 885: } elsif($type eq 'integer') { 886: my $min = $input{'min'} // 0; 887: 888: $case_input = int(rand_int() + $min); 889: # If it's takes an integer, a float should die 890: push @cases, { _input => $case_input + 0.1, _STATUS => 'DIES', _LINE => __LINE__ }; 891: } elsif(($type eq 'number') || ($type eq 'float')) { 892: $case_input = abs(rand_num()) + $input{'min'}; 893: } elsif($type eq 'boolean') { 894: $case_input = rand_bool(); 895: } else { 896: die "TODO: type $type"; 897: } 898: push @cases, { _input => $case_input, _STATUS => 'OK', _LINE => __LINE__ } if($case_input); 899: } 900: } else { 901: # our %input = ( str => { type => 'string' } ); 902: push @cases, @{generate_tests(\%input, \%mandatory_args, _LINE => __LINE__)}; 903: 904: } 905: } 906: 907: # edge-cases 908: if($config{'test_undef'}) { 909: if($all_optional) { 910: push @cases, { '_DESCRIPTION' => 'No args since all are optional' }; 911: } else { 912: # Note that this is set on the input rather than output 913: push @cases, { '_STATUS' => 'DIES' }; # At least one argument is needed 914: } 915: } 916: 917: if(scalar keys %input) { 918: push @cases, { '_STATUS' => 'DIES', map { $_ => undef } keys %input } if($config{'test_undef'}); 919: } else { 920: push @cases, { '_DESCRIPTION' => 'Takes no input' }; # Takes no input 921: } 922: 923: # If it's not in mandatory_strings it sets to 'undef' which is the idea, to test { value => undef } in the args 924: # _LINE has to go first or else the undef in there mucks up the hash format 925: push @cases, { _LINE => __LINE__, map { $_ => $mandatory_strings{$_} } keys %input, %mandatory_objects } if($config{'test_undef'} && !$positions); 926: 927: push @candidate_bad, '' if($config{'test_empty'}); 928: push @candidate_bad, undef if($config{'test_undef'}); 929: push @candidate_bad, "\0" if($config{'test_nuls'}); 930: 931: # generate numeric, string, hashref and arrayref min/max edge cases 932: # TODO: For hashref and arrayref, if there's a $spec->{schema} field, use that for the data that's being generated 933: if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) { 934: # our %input = ( type => 'string' ); 935: my $type = $input{type}; 936: if (exists $input{memberof} && ref $input{memberof} eq 'ARRAY' && @{$input{memberof}}) { 937: # Generate edge cases for memberof inside values 938: foreach my $val (@{$input{memberof}}) { 939: push @cases, 940: { _input => $val, _LINE => __LINE__ }, 941: { _input => " $val", _LINE => __LINE__, _STATUS => 'DIES' }, 942: { _input => "$val ", _LINE => __LINE__, _STATUS => 'DIES' }, 943: { _input => substr($val, 0, -1), _LINE => __LINE__, _STATUS => 'DIES' }; 944: if($val =~ /[A-Z]/) { 945: push @cases, { _input => lc($val), _LINE => __LINE__, _STATUS => 'DIES' }; 946: } 947: if($val =~ /[a-z]/) { 948: push @cases, { _input => uc($val), _LINE => __LINE__, _STATUS => 'DIES' }; 949: } 950: } 951: # outside value 952: my $outside; 953: if(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) { 954: $outside = (sort { $a <=> $b } @{$input{memberof}})[-1] + 1; 955: } else { 956: $outside = 'INVALID_MEMBEROF'; 957: } 958: push @cases, { _input => $outside, _STATUS => 'DIES' }; 959: } else { 960: # Generate edge cases for min/max 961: if($type eq 'integer') { 962: push @cases, @{_generate_integer_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 963: } elsif(($type eq 'number') || ($type eq 'float')) { 964: push @cases, @{_generate_float_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 965: } elsif ($type eq 'string') { 966: push @cases, @{_generate_string_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 967: } elsif ($type eq 'arrayref') { 968: if (defined $input{min}) { 969: my $len = $input{min}; 970: push @cases, { _input => [ (1) x ($len + 1) ] }; # just inside 971: push @cases, { _input => [ (1) x $len ] }; # border 972: push @cases, { _input => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside 973: } else { 974: push @cases, { _input => [] } if($config{'test_empty'}); # No min, empty array should be allowable 975: } 976: if (defined $input{max}) { 977: my $len = $input{max}; 978: push @cases, { _input => [ (1) x ($len - 1) ] }; # just inside 979: push @cases, { _input => [ (1) x $len ] }; # border 980: push @cases, { _input => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside 981: } 982: } elsif ($type eq 'hashref') { 983: if (defined $input{min}) { 984: my $len = $input{min}; 985: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) } }; 986: push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } }; 987: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0; 988: } else { 989: push @cases, { _input => {} } if($config{'test_empty'}); # No min, empty hash should be allowable 990: } 991: if (defined $input{max}) { 992: my $len = $input{max}; 993: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) } }; 994: push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } }; 995: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' }; 996: } 997: } elsif ($type eq 'boolean') { 998: push @cases, @{_generate_boolean_cases('_input', \%input, \%mandatory_args)}; 999: } 1000: 1001: # Test all edge cases 1002: foreach my $edge(@edge_case_array) { 1003: push @cases, { _input => $edge, _DESCRIPTION => 'edge case' }; 1004: } 1005: } 1006: } else { 1007: # our %input = ( str => { type => 'string' } ); 1008: push @cases, @{generate_tests(\%input, \%mandatory_args)}; 1009: } 1010: 1011: # fuzzing can easily generate repeats 1012: if($config{'dedup'}) { 1013: return _dedup_cases(\@cases); 1014: } 1015: 1016: # use Data::Dumper; 1017: # die(Dumper(@cases)); 1018: 1019: return \@cases; 1020: } 1021: 1022: # Functions to generate test cases 1023: sub _generate_integer_cases { 1024: my ($arg_name, $spec, $mandatory_args) = @_; 1025: my @cases; 1026: 1027: foreach my $i (-42, -1, 42) { 1028: if(((!defined $spec->{min}) || ($spec->{min} <= $i)) && ((!defined($spec->{max})) || ($spec->{max} >= $i))) { 1029: push @cases, { %{$mandatory_args}, ( $arg_name => $i ) }; 1030: } else { 1031: push @cases, { %{$mandatory_args}, ( $arg_name => $i, _STATUS => 'DIES' ) }; 1032: } 1033: } 1034: 1035: [% IF module %] 1036: # Send wrong data type - builtins aren't good at checking this 1037: push @cases, 1038: { %{$mandatory_args}, ( $arg_name => "test string in integer field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) }, 1039: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1040: { %{$mandatory_args}, ( $arg_name => 3.14, _STATUS => 'DIES' ) }, # Float 1041: { %{$mandatory_args}, ( $arg_name => 'xyz', _STATUS => 'DIES' ) }, 1042: { %{$mandatory_args}, ( $arg_name => \42, _STATUS => 'DIES' ) }, # Scalar ref 1043: { %{$mandatory_args}, ( $arg_name => *STDOUT, _STATUS => 'DIES' ) }, # Global variable 1044: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }; 1045: [% END %] 1046: 1047: # min/max numeric boundaries 1048: if (defined $spec->{min}) { 1049: my $min = $spec->{min}; 1050: push @cases, 1051: { %{$mandatory_args}, ( $arg_name => $min - 1, _STATUS => 'DIES' ) }, 1052: { %{$mandatory_args}, ( $arg_name => " $min ", _LINE => __LINE__ ) }, # border, padded integer 1053: { %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ) }, # border 1054: { %{$mandatory_args}, ( $arg_name => $min + 1 ) }; # just inside 1055: 1056: if(!defined $spec->{max}) { 1057: push @cases, { %{$mandatory_args}, ( $arg_name => int($min + abs(rand_int())) ), _LINE => __LINE__ }; 1058: } 1059: if($min <= 0) { 1060: push @cases, { %{$mandatory_args}, ( $arg_name => -0.0, _STATUS => 'OK' ) }; # Negative 0 1061: } 1062: } else { 1063: push @cases, 1064: { %{$mandatory_args}, ( $arg_name => 1e5, _STATUS => 'OK' ) }, # Scientific notation 1065: { %{$mandatory_args}, ( $arg_name => 1_000, _STATUS => 'OK' ) }, # Underscored 1066: { %{$mandatory_args}, ( $arg_name => ' 42 ', _STATUS => 'OK' ) }; # Padded integer 1067: } 1068: 1069: if (defined $spec->{max}) { 1070: my $max = $spec->{max}; 1071: push @cases, 1072: { %{$mandatory_args}, ( $arg_name => $max - 1 ) }, 1073: { %{$mandatory_args}, ( $arg_name => $max ) }, 1074: { %{$mandatory_args}, ( $arg_name => $max + 1, _STATUS => 'DIES' ) }; 1075: 1076: if(defined $spec->{min}) { 1077: # Test 0 if it's in range 1078: push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0); 1079: } else { 1080: push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_int() ), _DESCRIPTION => 'max is defined but min is not' }; 1081: if($max >= 0) { 1082: push @cases, { %{$mandatory_args}, ( $arg_name => -0.0, _STATUS => 'OK' ) }; # Negative 0 1083: if($max == 0) { 1084: push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_int()) * -1 ), _LINE => __LINE__ }; # Any negative integer 1085: } 1086: } 1087: } 1088: } elsif(!defined $spec->{min}) { 1089: # Can take any number, so give it one 1090: push @cases, 1091: { %{$mandatory_args}, ( $arg_name => rand_int() ), _LINE => __LINE__ }, 1092: { %{$mandatory_args}, ( $arg_name => 0) }; # 0 is in range 1093: } 1094: 1095: return \@cases; 1096: } 1097: 1098: sub _generate_float_cases { 1099: my ($arg_name, $spec, $mandatory_args) = @_; 1100: my @cases; 1101: 1102: if((!defined $spec->{min}) || ($spec->{min} <= -0.1)) { 1103: push @cases, { %{$mandatory_args}, ( $arg_name => -0.1, _LINE => __LINE__ ) }; 1104: } 1105: if((!defined $spec->{min}) || ($spec->{min} <= 43.56)) { 1106: push @cases, { %{$mandatory_args}, ( $arg_name => 43.56 ) }; 1107: } 1108: 1109: [% IF module %] 1110: # Send wrong data type - builtins aren't good at checking this 1111: push @cases, 1112: { %{$mandatory_args}, ( $arg_name => "test string in float field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) }, 1113: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1114: { %{$mandatory_args}, ( $arg_name => \42.1, _STATUS => 'DIES' ) }, # Scalar ref 1115: # NaN and Inf are valid according to looks_like_number() so we 1116: # cannot assume they die 1117: # { %{$mandatory_args}, ( $arg_name => "NaN", _STATUS => 'DIES' ) }, 1118: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }; 1119: [% END %] 1120: 1121: # min/max numeric boundaries 1122: if (defined $spec->{min}) { 1123: my $min = $spec->{min}; 1124: push @cases, 1125: { %{$mandatory_args}, ( $arg_name => $min - 0.001, _STATUS => 'DIES' ), _DESCRIPTION => 'float below minimum value is denied' }, 1126: { %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ), _DESCRIPTION => 'float minimum value is allowed' }, # border 1127: { %{$mandatory_args}, ( $arg_name => $min + 0.001 ), _DESCRIPTION => 'float above minimum value is allowed' }; # just inside 1128: 1129: [% IF module %] 1130: push @cases, { %{$mandatory_args}, ( $arg_name => "-inf", _STATUS => 'DIES' ) }; 1131: [% END %] 1132: 1133: if(!defined $spec->{max}) { 1134: if($min <= 0) { 1135: push @cases, { %{$mandatory_args}, ( $arg_name => $min + abs(rand_num()) ), _LINE => __LINE__ }; # Any positive number 1136: } else { 1137: push @cases, { %{$mandatory_args}, ( $arg_name => $min + rand_num() ), _DESCRIPTION => 'min is defined but max is not' }; 1138: } 1139: } 1140: } 1141: if (defined $spec->{max}) { 1142: my $max = $spec->{max}; 1143: push @cases, 1144: { %{$mandatory_args}, ( $arg_name => $max - 0.000001 ) }, 1145: { %{$mandatory_args}, ( $arg_name => $max ) }, 1146: { %{$mandatory_args}, ( $arg_name => $max + 0.000001, _STATUS => 'DIES' ) }; 1147: 1148: [% IF module %] 1149: push @cases, 1150: { %{$mandatory_args}, ( $arg_name => "inf", _STATUS => 'DIES' ) }, 1151: { %{$mandatory_args}, ( $arg_name => 9**9**9, _STATUS => 'DIES' ) }; 1152: [% END %] 1153: 1154: if(defined $spec->{min}) { 1155: # Test 0 if it's in range 1156: push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0); 1157: } else { 1158: push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_num() ), _LINE => __LINE__ }; 1159: if($max == 0) { 1160: push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_num()) * -0.00000001 ) }; # Any negative number 1161: } 1162: } 1163: } elsif(!defined $spec->{min}) { 1164: # Can take any number, so give it some 1165: push @cases, 1166: { %{$mandatory_args}, ( $arg_name => rand_num(), _LINE => __LINE__ ) }, 1167: { %{$mandatory_args}, ( $arg_name => 1.23 ) }, 1168: { %{$mandatory_args}, ( $arg_name => -42.1 ) }, 1169: { %{$mandatory_args}, ( $arg_name => -0.0 ) }, # -0 is in range 1170: { %{$mandatory_args}, ( $arg_name => 0 ) }; # 0 is in range 1171: } 1172: 1173: return \@cases; 1174: } 1175: 1176: # basic boolean edge cases 1177: sub _generate_boolean_cases { 1178: my ($arg_name, $spec, $mandatory_args) = @_; 1179: 1180: my @cases; 1181: 1182: if(exists($spec->{'memberof'}) && (ref($spec->{'memberof'} eq 'ARRAY'))) { 1183: # memberof already defines allowed booleans 1184: foreach my $val (@{$spec->{memberof}}) { 1185: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1186: } 1187: } else { 1188: @cases = ( 1189: { %{$mandatory_args}, ( $arg_name => 0 ) }, 1190: { %{$mandatory_args}, ( $arg_name => 1 ) }, 1191: { %{$mandatory_args}, ( $arg_name => 'true' ) }, 1192: { %{$mandatory_args}, ( $arg_name => 'false' ) }, 1193: { %{$mandatory_args}, ( $arg_name => 'off' ) }, 1194: { %{$mandatory_args}, ( $arg_name => 'on' ) }, 1195: { %{$mandatory_args}, ( $arg_name => 'yes' ) }, 1196: { %{$mandatory_args}, ( $arg_name => 'no' ) }, 1197: { %{$mandatory_args}, ( $arg_name => 'xyzzy', _STATUS => 'DIES' ) }, # invalid boolean 1198: { %{$mandatory_args}, ( $arg_name => -1, _STATUS => 'DIES' ) }, # invalid boolean 1199: { %{$mandatory_args}, ( $arg_name => 2, _STATUS => 'DIES' ) }, # invalid boolean 1200: { %{$mandatory_args}, ( $arg_name => bless({}, 'Evil::Class'), _STATUS => 'DIES', _LINE => __LINE__ ) }, 1201: { %{$mandatory_args}, ( $arg_name => [ 1 ], _STATUS => 'DIES' ) } # invalid boolean 1202: ); 1203: } 1204: 1205: push @cases, { %{$mandatory_args}, ( $arg_name => undef, _STATUS => 'DIES' ) } if($config{'test_undef'}); 1206: push @cases, { %{$mandatory_args}, ( $arg_name => "\0", _STATUS => 'DIES' ) } if($config{'test_nuls'}); 1207: 1208: return \@cases; 1209: } 1210: 1211: sub _generate_string_cases 1212: { 1213: my ($arg_name, $spec, $mandatory_args, $properties_array_ref) = @_; 1214: 1215: my @cases; 1216: 1217: if (defined $spec->{min}) { 1218: my $len = $spec->{min}; 1219: if(my $re = $spec->{matches}) { 1220: if(ref($re) ne 'Regexp') { 1221: $re = qr/$re/; 1222: } 1223: my $random_string; 1224: if($spec->{'max'}) { 1225: $random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re }); 1226: } elsif($spec->{'min'}) { 1227: $random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re }); 1228: } else { 1229: $random_string = Data::Random::String::Matches->create_random_string({ regex => $re }); 1230: } 1231: # Is hello allowed? 1232: foreach my $str('hello', $random_string) { 1233: if($str =~ $re) { 1234: if(!defined($spec->{'memberof'}) || (grep { $_ eq $str } @{$spec->{'memberof'}})) { 1235: if(defined($spec->{'notmemberof'}) && (grep { $_ eq $str } @{$spec->{'notmemberof'}})) { 1236: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1237: } else { 1238: push @cases, { %{$mandatory_args}, ( $arg_name => $str ) }; 1239: } 1240: } elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) { 1241: # Data::Random 1242: push @cases, { %{$mandatory_args}, ( _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] ) } 1243: } else { 1244: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1245: } 1246: } else { 1247: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1248: } 1249: } 1250: for my $count ($len + 1, $len, $len - 1) { 1251: next if ($count < 0); 1252: my $str = rand_str($count); 1253: if($str =~ $re) { 1254: push @cases, { %{$mandatory_args}, ( $arg_name => $str ) }; 1255: } else { 1256: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1257: } 1258: } 1259: } else { 1260: # matches is not defined 1261: if(!defined($spec->{'memberof'}) || (grep { $_ eq 'hello' } @{$spec->{'memberof'}})) { 1262: if(defined($spec->{'notmemberof'}) && (grep { $_ eq 'hello' } @{$spec->{'notmemberof'}})) { 1263: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1264: } elsif((!defined($spec->{max})) || ($spec->{max} >= 5)) { 1265: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'OK' ) }; 1266: } else { 1267: push @cases, 1268: { %{$mandatory_args}, ( $arg_name => 'plugh', _LINE => __LINE__, _STATUS => 'DIES' ) }, 1269: { %{$mandatory_args}, ( $arg_name => ' ', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1270: } 1271: # Check that trimmed strings work 1272: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len, _LINE => __LINE__, _STATUS => 'OK' ) }; 1273: } else { 1274: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1275: } 1276: if(!defined($spec->{'memberof'})) { 1277: push @cases, { %{$mandatory_args}, ( $arg_name => "he\nlo", _LINE => __LINE__, _STATUS => 'OK' ) }, 1278: { %{$mandatory_args}, ( $arg_name => "\nhell", _LINE => __LINE__, _STATUS => 'OK' ) }, 1279: { %{$mandatory_args}, ( $arg_name => "hell\n", _LINE => __LINE__, _STATUS => 'OK' ) }, 1280: { %{$mandatory_args}, ( $arg_name => ' hell', _LINE => __LINE__, _STATUS => 'OK' ) }, 1281: { %{$mandatory_args}, ( $arg_name => rand_str($len) . "\n" . rand_str($len), _LINE => __LINE__, _STATUS => 'OK' ) }; 1282: } 1283: 1284: if($len <= 0) { 1285: push @cases, { %{$mandatory_args}, ( $arg_name => '', _LINE => __LINE__, _DESCRIPTION => 'min == 0 so empty should be allowed' ) } if($config{'test_empty'}); # min == 0, empty string should be allowable 1286: push @cases, 1287: { %{$mandatory_args}, ( $arg_name => ' ', _LINE => __LINE__ ) }, 1288: { %{$mandatory_args}, ( $arg_name => "\n", _LINE => __LINE__ ) }, 1289: # Don't confuse if() with if(defined()) 1290: { %{$mandatory_args}, ( $arg_name => '0', _STATUS => 'DIES' ) }; 1291: 1292: if($config{'test_security'}) { 1293: push @cases, 1294: { %{$mandatory_args}, ( $arg_name => '<script>alert(1)</script>', _LINE => __LINE__ ) }, 1295: { %{$mandatory_args}, ( $arg_name => "'; DROP TABLE foo --", _LINE => __LINE__ ) }; 1296: } 1297: } 1298: } 1299: } elsif($config{'test_empty'}) { 1300: # No min, empty string should be allowable 1301: if(defined($spec->{'memberof'}) && (!grep { $_ eq '' } @{$spec->{'memberof'}})) { 1302: push @cases, { %{$mandatory_args}, ( $arg_name => '', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1303: } else { 1304: push @cases, { %{$mandatory_args}, ( $arg_name => '', _LINE => __LINE__ ) }; 1305: } 1306: } 1307: if (defined $spec->{max}) { 1308: my $len = $spec->{max}; 1309: if((!defined($spec->{min})) || ($spec->{min} != $len)) { 1310: if(my $re = $spec->{matches}) { 1311: for my $count ($len - 1, $len, $len + 1) { 1312: my $str = rand_str($count); 1313: if($str =~ $re) { 1314: if($count > $len) { 1315: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _LINE => __LINE__, _STATUS => 'DIES' ) }; 1316: } else { 1317: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _LINE => __LINE__ ) }; 1318: } 1319: } else { 1320: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1321: } 1322: } 1323: } else { 1324: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _LINE => __LINE__ ) }; # just inside 1325: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len), _LINE => __LINE__ ) }; # border 1326: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len + 1), _LINE => __LINE__, _STATUS => 'DIES' ) }; # outside 1327: } 1328: } elsif(defined($spec->{min}) && ($spec->{min} == $len)) { 1329: if($len >= 2) { 1330: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len - 1, _LINE => __LINE__, _DESCRIPTION => 'max == min', _STATUS => 'DIES' ) }; 1331: } 1332: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len, _LINE => __LINE__, _DESCRIPTION => 'max == min' ) }; 1333: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len + 1, _LINE => __LINE__, _DESCRIPTION => 'max == min', _STATUS => 'DIES' ) }; 1334: } 1335: } elsif((!$spec->{matches}) && (!$spec->{memberof})) { 1336: # TODO: send them if they match the regex 1337: if(exists($spec->{'min'})) { 1338: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(($spec->{'min'} + 1) * 1_000), _LINE => __LINE__ ) }; 1339: } else { 1340: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(65535), _LINE => __LINE__, _DESCRIPTION => 'Long string nearly 64K characters' ) }; 1341: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(65536), _LINE => __LINE__, _DESCRIPTION => 'Long string 64K characters' ) }; 1342: } 1343: if((!exists($spec->{min})) || ($spec->{min} <= 1)) { 1344: push @cases, { %{$mandatory_args}, ( $arg_name => "\x{FEFF}", _STATUS => 'OK', _LINE => __LINE__, _DESCRIPTION => 'Byte order marker' ) }; 1345: } else { 1346: push @cases, { %{$mandatory_args}, ( $arg_name => "\x{FEFF}", _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'Byte order marker' ) }; 1347: } 1348: } 1349: 1350: if((!exists($spec->{min})) || ($spec->{min} == 0)) { 1351: # '' should die unless it's in the memberof list 1352: if(defined($spec->{'memberof'}) && (!grep { $_ eq '' } @{$spec->{'memberof'}})) { 1353: push @cases, { %{$mandatory_args}, ( $arg_name => '', _NAME => $arg_name, _STATUS => 'DIES', _LINE => __LINE__ ) } 1354: } elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) { 1355: # Data::Random 1356: push @cases, { %{$mandatory_args}, _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] } 1357: } elsif($config{'test_empty'} && !$spec->{'memberof'}) { 1358: push @cases, { %{$mandatory_args}, ( $arg_name => '', _NAME => $arg_name, _LINE => __LINE__ ) }; 1359: } 1360: } 1361: # push @cases, { $arg_name => "emoji \x{1F600}" }; 1362: 1363: unless(defined($spec->{memberof}) || defined($spec->{matches})) { 1364: # --- min/max string/array boundaries --- 1365: if(defined $spec->{min}) { 1366: my $len = $spec->{min}; 1367: if($len == 1) { 1368: if($config{'test_empty'}) { 1369: push @cases, { %{$mandatory_args}, ( $arg_name => '', _STATUS => 'DIES', _LINE => __LINE__ ) }; 1370: } 1371: } elsif($len > 0) { 1372: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _STATUS => 'DIES' ) }; 1373: } 1374: if((!defined($spec->{max})) || ($spec->{max} >= $len + 1)) { 1375: push @cases, 1376: { %{$mandatory_args}, ( $arg_name => rand_str($len) ) }, 1377: { %{$mandatory_args}, ( $arg_name => rand_str($len + 1) ) }; 1378: } 1379: if($len <= 1) { 1380: push @cases, 1381: { %{$mandatory_args}, ( $arg_name => "\n" ) }, # new lines are fun 1382: { %{$mandatory_args}, ( $arg_name => ' ' ) }, 1383: { %{$mandatory_args}, ( $arg_name => " \n " ) }; 1384: } 1385: } else { 1386: push @cases, 1387: { %{$mandatory_args}, ( $arg_name => "\n" ) }, # new lines are fun 1388: { %{$mandatory_args}, ( $arg_name => ' ' ) }, 1389: { %{$mandatory_args}, ( $arg_name => " \n " ) }; 1390: } 1391: if (defined $spec->{max}) { 1392: my $len = $spec->{max}; 1393: if((!defined($spec->{min})) || ($spec->{min} < ($len - 1))) { 1394: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1) ) }; 1395: } else { 1396: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _STATUS => 'DIES' ) }; 1397: } 1398: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len) ) }; 1399: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len + 1), _STATUS => 'DIES' ) }; 1400: } 1401: } 1402: 1403: if(defined $spec->{matches}) { 1404: my $re = $spec->{matches}; 1405: 1406: # --- Positive controls --- 1407: foreach my $val (@candidate_good) { 1408: if ($val =~ $re) { 1409: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1410: last; # one good match is enough 1411: } 1412: } 1413: 1414: # --- Negative controls --- 1415: foreach my $val (@candidate_bad) { 1416: if(!defined($val)) { 1417: push @cases, { _input => undef, _STATUS => 'DIES', _LINE => __LINE__ } if($config{'test_undef'}); 1418: } elsif ($val !~ $re) { 1419: push @cases, { _input => $val, _STATUS => 'DIES', _LINE => __LINE__ }; 1420: } 1421: } 1422: push @cases, { $arg_name => undef, _STATUS => 'DIES' } if($config{'test_undef'}); 1423: } 1424: if(defined $spec->{nomatch}) { 1425: my $re = $spec->{nomatch}; 1426: 1427: # --- Positive controls --- 1428: foreach my $val (@candidate_good) { 1429: if ($val !~ $re) { 1430: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1431: last; # one good match is enough 1432: } 1433: } 1434: 1435: # --- Negative controls --- 1436: foreach my $val (@candidate_bad) { 1437: if ($val =~ $re) { 1438: push @cases, { $arg_name => $val, _STATUS => 'DIES' }; 1439: } 1440: } 1441: } 1442: 1443: [% IF module %] 1444: # Send wrong data type - builtins aren't good at checking this 1445: if($config{'test_nuls'}) { 1446: push @cases, 1447: { %{$mandatory_args}, $arg_name => "\0", _STATUS => 'DIES', _LINE => __LINE__ }, 1448: { %{$mandatory_args}, $arg_name => "nul\0", _STATUS => 'DIES', _LINE => __LINE__ }, 1449: { %{$mandatory_args}, $arg_name => "\0nul", _STATUS => 'DIES', _LINE => __LINE__ }; 1450: if(defined($spec->{matches})) { 1451: my $re = $spec->{matches}; 1452: foreach my $val (@candidate_good) { 1453: $val = "$val\0"; 1454: if ($val !~ $re) { 1455: push @cases, { %{$mandatory_args}, ( $arg_name => $val, _STATUS => 'DIES', _DESCRIPTION => 'Nul byte after regex' ) }; 1456: } 1457: $val = "\0$val"; 1458: if ($val !~ $re) { 1459: push @cases, { %{$mandatory_args}, ( $arg_name => $val, _STATUS => 'DIES', _DESCRIPTION => 'Nul byte before regex' ) }; 1460: } 1461: } 1462: } 1463: } 1464: if($config{'test_empty'}) { 1465: push @cases, 1466: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }, 1467: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1468: } 1469: push @cases, 1470: { %{$mandatory_args}, ( $arg_name => \'ref to scalar', _STATUS => 'DIES', _LINE => __LINE__ ) }, 1471: { %{$mandatory_args}, ( $arg_name => sub { die 'boom' }, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1472: { %{$mandatory_args}, ( $arg_name => bless({}, 'Evil::Class'), _STATUS => 'DIES', _LINE => __LINE__ ) }, 1473: # { %{$mandatory_args}, ( $arg_name => [1, 2, 3], _STATUS => 'DIES', _LINE => __LINE__ ) }, # Generates false positives. Why? 1474: { %{$mandatory_args}, ( $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1475: [% END %] 1476: 1477: return \@cases; 1478: } 1479: 1480: # dedup, fuzzing can easily generate repeats 1481: # FIXME: I don't think this catches them all 1482: # FIXME: Handle cases with Class::Simple calls 1483: # FIXME: The JSON encoding fails on various data types that are sent (e.g. scalar refs, objects) so don't bother 1484: sub _dedup_cases 1485: { 1486: my $cases = shift; 1487: 1488: # Do not use JSON::MaybeXS because it will fail on non utf-8 characters 1489: require JSON::PP; 1490: JSON::PP->import(); 1491: 1492: # return inside eval{} returns from the eval block, not from 1493: # _dedup_cases — the deduped result must be captured here, or 1494: # this always falls through to the unduplicated $cases below. 1495: # 1496: # encode_json() does not sort hash keys, so two structurally 1497: # identical case hashrefs can serialize with different key order 1498: # (Perl's per-hash iteration order randomisation) and dodge the 1499: # %seen check below — use ->canonical to make the dump order-stable. 1500: my $rc = eval { 1501: my $json = JSON::PP->new->canonical; 1502: my %seen; 1503: my @rc = grep { 1504: my $dump = $json->encode($_); 1505: !$seen{$dump}++ 1506: } @{$cases}; 1507: 1508: return \@rc; 1509: }; 1510: # Carp::carp(__PACKAGE__, ": disabling deduping: $@"); 1511: 1512: return $@ ? $cases : $rc; 1513: } 1514: 1515: sub generate_tests 1516: { 1517: my $input = $_[0]; 1518: my %mandatory_args = %{$_[1]}; 1519: 1520: my @cases; 1521: 1522: foreach my $field (keys %input) { 1523: my $spec = $input{$field} || {}; 1524: foreach my $field(keys %{$spec}) { 1525: next if($field =~ /^_/); # Ignore comments 1526: if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'position', 'memberof', 'semantic', 'isa'))) { 1527: die("TODO: handle schema keyword '$field'"); 1528: } 1529: } 1530: } 1531: 1532: # Build a test of the mandatory args 1533: push @cases, { _input => \%mandatory_args, status => 'OK' } if(keys %mandatory_args); 1534: 1535: for (1..[% iterations_code %]) { 1536: # One by one change each of the mandatory fields 1537: foreach my $field (keys %input) { 1538: my $spec = $input{$field} || {}; 1539: next if $spec->{'memberof'}; # Memberof data is created below 1540: my $type = $spec->{type} || 'string'; 1541: 1542: my %case_input = (%mandatory_args); 1543: # 1) Sometimes pick a field-specific edge-case 1544: if (exists $edge_cases{$field} && rand() < PROB_EDGE_CASE) { 1545: push @cases, { _input => {%case_input}, status => 'OK' } if(keys %case_input); 1546: $case_input{$field} = _pick_from($edge_cases{$field}); 1547: next; 1548: } 1549: 1550: # 2) Sometimes pick a type-level edge-case 1551: if (exists $type_edge_cases{$type} && rand() < 0.3) { 1552: $case_input{$field} = _pick_from($type_edge_cases{$type}); 1553: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1554: next; 1555: } 1556: 1557: # 3) Sormal random generation by type 1558: if ($type eq 'string') { 1559: if(my $re = $spec->{matches}) { 1560: if(ref($re) ne 'Regexp') { 1561: $re = qr/$re/; 1562: } 1563: if($spec->{'max'}) { 1564: $case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re }); 1565: } elsif($spec->{'min'}) { 1566: $case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re }); 1567: } else { 1568: $case_input{$field} = Data::Random::String::Matches->create_random_string({ regex => $re }); 1569: } 1570: } elsif(my $semantic = $spec->{'semantic'}) { 1571: if($semantic eq 'email') { 1572: $case_input{$field} = rand_email($spec->{'max'} // $spec->{'min'}); 1573: } else { 1574: diag(__LINE__, ": TODO: handle semantic type '$semantic'"); 1575: } 1576: } elsif(!$spec->{'memberof'}) { 1577: if(my $min = $spec->{min}) { 1578: $case_input{$field} = rand_str($min); 1579: if($config{'test_empty'} && ($min == 0)) { 1580: push @cases, { _input => {%case_input}, status => 'OK' } if(keys %case_input); 1581: $case_input{$field} = ''; 1582: } 1583: } else { 1584: $case_input{$field} = rand_str(); 1585: if($config{'test_empty'}) { 1586: push @cases, { _input => {%case_input}, status => 'OK' } if(keys %case_input); 1587: $case_input{$field} = ''; 1588: } 1589: } 1590: } 1591: } elsif ($type eq 'integer') { 1592: if(my $min = $spec->{min}) { 1593: if(my $max = $spec->{'max'}) { 1594: $case_input{$field} = int(rand($max - $min + 1)) + $min; 1595: } else { 1596: $case_input{$field} = rand_int() + $min; 1597: } 1598: } elsif(exists($spec->{min})) { 1599: # min == 0 1600: if(my $max = $spec->{'max'}) { 1601: $case_input{$field} = int(rand($max + 1)); 1602: } else { 1603: $case_input{$field} = int(abs(rand_int())); 1604: } 1605: } else { 1606: push @cases, 1607: # If it's takes an integer, a float should die 1608: { _input => rand_int() + 0.2, _STATUS => 'DIES', _LINE => __LINE__ }, 1609: # Integers passed as a string 1610: { _input => "007", _STATUS => 'OK', _LINE => __LINE__ }, 1611: { _input => "0x10", _STATUS => 'OK', _LINE => __LINE__ }, 1612: { _input => "1_000", _STATUS => 'OK', _LINE => __LINE__ }; 1613: $case_input{$field} = rand_int(); 1614: } 1615: } elsif ($type eq 'boolean') { 1616: $case_input{$field} = rand_bool(); 1617: } elsif ($type eq 'number') { 1618: if(defined(my $min = $spec->{min})) { 1619: $case_input{$field} = abs(rand_num()) + $min; 1620: } else { 1621: $case_input{$field} = rand_num(); 1622: } 1623: } elsif ($type eq 'arrayref') { 1624: my $circular_ref = []; 1625: push @{$circular_ref}, $circular_ref; 1626: 1627: push @cases, { %mandatory_args, ($field => $circular_ref, _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => "Don't accept array ref with circular references") }; 1628: 1629: if(my $element_type = $input{element_type}) { 1630: if($element_type eq 'integer') { 1631: push @cases, 1632: { %mandatory_args, ($field => '0.3', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'float in list of integers') }, 1633: { %mandatory_args, ($field => 'string in array of ints', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'string in list of integers') }; 1634: } elsif($element_type eq 'boolean') { 1635: push @cases, 1636: { %mandatory_args, ($field => 2, _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => '2 list of booleans') }, 1637: { %mandatory_args, ($field => '0.3', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'float in list of booleans') }, 1638: { %mandatory_args, ($field => 'string in array of bools', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'string in list of booleans') }; 1639: } 1640: } 1641: 1642: push @cases, { %mandatory_args, (field => [ 'fred', undef, 'wilma' ], _LINE => __LINE__, _DESCRIPTION => 'undef element in array') } if($config{test_undef}); 1643: $case_input{$field} = rand_arrayref(); 1644: } elsif ($type eq 'hashref') { 1645: if($config{test_undef}) { 1646: push @cases, { %mandatory_args, (field => { 'fred' => 'wilma', 'undef' => undef, 'foo' => 'bar' }, _LINE => __LINE__, _DESCRIPTION => 'undef element in hashref') }; 1647: push @cases, { %mandatory_args, (field => { 'fred' => 'wilma', 'nested' => { 'first' => 'one', 'undef' => undef, 'third' => 'three' }, 'foo' => 'bar' }, _LINE => __LINE__, _DESCRIPTION => 'undef element in nested hashref') }; 1648: } 1649: $case_input{$field} = rand_hashref(); 1650: } elsif($config{'test_undef'}) { 1651: $case_input{$field} = undef; 1652: } 1653: 1654: # 4) occasionally drop optional fields 1655: if ($spec->{optional} && rand() < 0.25) { 1656: delete $case_input{$field}; 1657: } 1658: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1659: 1660: ##################### 1661: # FIXME: Start of duplicated code from the above part of the loop. 1662: # Go through and remove duplications then remove this code 1663: if (exists $spec->{memberof} && ref $spec->{memberof} eq 'ARRAY' && @{$spec->{memberof}}) { 1664: # Generate edge cases for memberof 1665: # inside values 1666: foreach my $val (@{$input{memberof}}) { 1667: push @cases, 1668: { %mandatory_args, ( $field => $val ) }, 1669: { %mandatory_args, ( $field => " $val", _LINE => __LINE__, _STATUS => 'DIES' ) }, 1670: { %mandatory_args, ( $field => "$val ", _LINE => __LINE__, _STATUS => 'DIES' ) }, 1671: { %mandatory_args, ( $field => substr($val, 0, -1), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1672: if($val =~ /[A-Z]/) { 1673: push @cases, { %mandatory_args, ( $field => lc($val), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1674: } 1675: if($val =~ /[a-z]/) { 1676: push @cases, { %mandatory_args, ( $field => uc($val), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1677: } 1678: } 1679: # outside value 1680: my $outside; 1681: if ($type eq 'integer' || $type eq 'number') { 1682: $outside = (sort { $a <=> $b } @{$spec->{memberof}})[-1] + 1; 1683: } else { 1684: $outside = 'INVALID_MEMBEROF'; 1685: } 1686: push @cases, { %mandatory_args, ( $field => $outside, _STATUS => 'DIES' ) }; 1687: } else { 1688: # Generate edge cases for min/max 1689: if($type eq 'integer') { 1690: push @cases, @{_generate_integer_cases($field, $spec, \%mandatory_args, _LINE => __LINE__)}; 1691: } elsif(($type eq 'number') || ($type eq 'float')) { 1692: push @cases, @{_generate_float_cases($field, $spec, \%mandatory_args, _LINE => __LINE__)}; 1693: } elsif($type eq 'string') { 1694: push @cases, @{_generate_string_cases($field, $spec, \%mandatory_args)}; 1695: } elsif ($type eq 'arrayref') { 1696: if (defined $spec->{min}) { 1697: my $len = $spec->{min}; 1698: push @cases, 1699: { %mandatory_args, $field => [ (1) x ($len + 1) ] }, # just inside 1700: { %mandatory_args, $field => [ (1) x $len ] }; # border 1701: push @cases, { %mandatory_args, $field => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside 1702: } else { 1703: push @cases, { %mandatory_args, $field => [] } if($config{'test_empty'}); # No min, empty array should be allowable 1704: } 1705: if (defined $spec->{max}) { 1706: my $len = $spec->{max}; 1707: push @cases, 1708: { %mandatory_args, $field => [ (1) x ($len - 1) ] }, # just inside 1709: { %mandatory_args, $field => [ (1) x $len ] }, # border 1710: { %mandatory_args, $field => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside 1711: } elsif((defined $spec->{min}) || ($spec->{min} <= 3)) { 1712: push @cases, { %mandatory_args, $field => [ 'first', undef, 'third' ], _DESCRIPTION => 'undef in an arrayref', _LINE => __LINE__ } if($config{test_undef}); 1713: } 1714: } elsif ($type eq 'hashref') { 1715: if (defined $spec->{min}) { 1716: my $len = $spec->{min}; 1717: push @cases, 1718: { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. ($len + 1) } }, 1719: { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. $len } }; 1720: push @cases, { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0; 1721: } else { 1722: push @cases, { %mandatory_args, $field => {} } if($config{'test_empty'}); # No min, empty hash should be allowable 1723: } 1724: if (defined $spec->{max}) { 1725: my $len = $spec->{max}; 1726: push @cases, 1727: { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. ($len - 1) } }, 1728: { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. $len } }, 1729: { %mandatory_args, $field => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' }; 1730: } 1731: } elsif ($type eq 'boolean') { 1732: push @cases, @{_generate_boolean_cases($field, $spec, \%mandatory_args)}; 1733: } 1734: } 1735: 1736: # case_sensitive tests for memberof 1737: if (defined $spec->{memberof} && exists $spec->{case_sensitive}) { 1738: if (!$spec->{case_sensitive}) { 1739: # Generate mixed-case versions of memberof values 1740: foreach my $val (@{$spec->{memberof}}) { 1741: push @cases, { %mandatory_args, ( $field => uc($val) ) }, 1742: { %mandatory_args, ( $field => lc($val) ) }, 1743: { %mandatory_args, ( $field => ucfirst(lc($val)) ) }; 1744: } 1745: } 1746: } 1747: 1748: # Add notmemberof tests 1749: if (defined $spec->{notmemberof}) { 1750: my @blacklist = @{$spec->{notmemberof}}; 1751: # Each blacklisted value should die 1752: foreach my $val (@blacklist) { 1753: push @cases, { %mandatory_args, ( $field => $val, _STATUS => 'DIES' ) }; 1754: } 1755: # Non-blacklisted value should pass 1756: push @cases, { %mandatory_args, ( $field => '_not_in_blacklist_' ) }; 1757: } 1758: 1759: # semantic tests 1760: if(defined(my $semantic = $spec->{'semantic'})) { 1761: if($semantic eq 'unix_timestamp') { 1762: push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) }, 1763: { %mandatory_args, ( 0 ) }, 1764: { %mandatory_args, ( 1 ) }, 1765: { %mandatory_args, ( time ) }, 1766: { %mandatory_args, ( 2147483647 ) }, 1767: { %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) }, 1768: { %mandatory_args, ( 2147483648, _STATUS => 'DIES' ) }; 1769: } else { 1770: diag("semantic type $semantic is not yet supported"); 1771: } 1772: } 1773: if(@relationships) { 1774: diag('Run relationship tests') if($ENV{'TEST_VERBOSE'}); 1775: 1776: foreach my $rel (@relationships) { 1777: my $type = $rel->{type}; 1778: 1779: if($type eq 'mutually_exclusive') { 1780: my ($p1, $p2) = @{ $rel->{params} }; 1781: # Both specified — should die 1782: run_test( 1783: { _STATUS => 'DIES', 1784: _DESCRIPTION => "mutually exclusive: $p1 and $p2 both given" }, 1785: { %mandatory_args, $p1 => 'val1', $p2 => 'val2' }, 1786: \%output, 1787: $positions 1788: ); 1789: # Each alone — should live 1790: run_test( 1791: { _DESCRIPTION => "mutually exclusive: only $p1 given" }, 1792: { %mandatory_args, $p1 => 'val1' }, 1793: \%output, 1794: $positions 1795: ); 1796: run_test( 1797: { _DESCRIPTION => "mutually exclusive: only $p2 given" }, 1798: { %mandatory_args, $p2 => 'val2' }, 1799: \%output, 1800: $positions 1801: ); 1802: 1803: } elsif($type eq 'required_group') { 1804: my @params = @{ $rel->{params} }; 1805: # None specified — should die 1806: my %none = map { $_ => undef } @params; 1807: run_test( 1808: { _STATUS => 'DIES', 1809: _DESCRIPTION => 'required_group: none of (' . join(', ', @params) . ') given' }, 1810: { %mandatory_args, %none }, 1811: \%output, 1812: $positions 1813: ); 1814: # Each alone — should live 1815: foreach my $p (@params) { 1816: run_test( 1817: { _DESCRIPTION => "required_group: only $p given" }, 1818: { %mandatory_args, $p => 'val' }, 1819: \%output, 1820: $positions 1821: ); 1822: } 1823: 1824: } elsif($type eq 'conditional_requirement') { 1825: my ($if_param, $then_param) = ($rel->{if}, $rel->{then_required}); 1826: # if_param set, then_param missing — should die 1827: run_test( 1828: { _STATUS => 'DIES', 1829: _DESCRIPTION => "conditional: $if_param set but $then_param missing" }, 1830: { %mandatory_args, $if_param => 'val', $then_param => undef }, 1831: \%output, 1832: $positions 1833: ); 1834: # Both set — should live 1835: run_test( 1836: { _DESCRIPTION => "conditional: $if_param and $then_param both set" }, 1837: { %mandatory_args, $if_param => 'val', $then_param => 'val' }, 1838: \%output, 1839: $positions 1840: ); 1841: # if_param absent — then_param absence should not matter 1842: run_test( 1843: { _DESCRIPTION => "conditional: $if_param absent so $then_param not required" }, 1844: { %mandatory_args, $then_param => undef }, 1845: \%output, 1846: $positions 1847: ); 1848: 1849: } elsif($type eq 'dependency') { 1850: my ($param, $requires) = ($rel->{param}, $rel->{requires}); 1851: # param set, requires missing — should die 1852: run_test( 1853: { _STATUS => 'DIES', 1854: _DESCRIPTION => "dependency: $param set but $requires missing" }, 1855: { %mandatory_args, $param => 'val', $requires => undef }, 1856: \%output, 1857: $positions 1858: ); 1859: # Both set — should live 1860: run_test( 1861: { _DESCRIPTION => "dependency: $param and $requires both set" }, 1862: { %mandatory_args, $param => 'val', $requires => 'val' }, 1863: \%output, 1864: $positions 1865: ); 1866: 1867: } elsif($type eq 'value_constraint') { 1868: my ($if_param, $then_param, $op, $val) = 1869: ($rel->{if}, $rel->{then}, $rel->{operator}, $rel->{value}); 1870: # if_param set, then_param wrong value — should die 1871: my $wrong_val = ($op eq '==') ? $val + 1 : $val - 1; 1872: run_test( 1873: { _STATUS => 'DIES', 1874: _DESCRIPTION => "value_constraint: $if_param set, $then_param = $wrong_val (wrong)" }, 1875: { %mandatory_args, $if_param => 'val', $then_param => $wrong_val }, 1876: \%output, 1877: $positions 1878: ); 1879: # if_param set, then_param correct value — should live 1880: run_test( 1881: { _DESCRIPTION => "value_constraint: $if_param set, $then_param = $val (correct)" }, 1882: { %mandatory_args, $if_param => 'val', $then_param => $val }, 1883: \%output, 1884: $positions 1885: ); 1886: 1887: } elsif($type eq 'value_conditional') { 1888: my ($if_param, $equals, $then_param) = 1889: ($rel->{if}, $rel->{equals}, $rel->{then_required}); 1890: # if_param equals trigger value, then_param missing — should die 1891: run_test( 1892: { _STATUS => 'DIES', 1893: _DESCRIPTION => "value_conditional: $if_param='$equals', $then_param missing" }, 1894: { %mandatory_args, $if_param => $equals, $then_param => undef }, 1895: \%output, 1896: $positions 1897: ); 1898: # if_param equals trigger value, then_param present — should live 1899: run_test( 1900: { _DESCRIPTION => "value_conditional: $if_param='$equals', $then_param present" }, 1901: { %mandatory_args, $if_param => $equals, $then_param => 'val' }, 1902: \%output, 1903: $positions 1904: ); 1905: # if_param different value — then_param absence should not matter 1906: run_test( 1907: { _DESCRIPTION => "value_conditional: $if_param != '$equals', $then_param not required" }, 1908: { %mandatory_args, $if_param => '__other__', $then_param => undef }, 1909: \%output, 1910: $positions 1911: ); 1912: } 1913: } 1914: } 1915: } 1916: } 1917: 1918: return \@cases; 1919: } 1920: 1921: sub populate_positions 1922: { 1923: my $input = shift; 1924: 1925: my $rc; 1926: foreach my $arg (keys %{$input}) { 1927: my $spec = $input->{$arg} || {}; 1928: if(((ref($spec)) eq 'HASH') && defined($spec->{'position'})) { 1929: $rc->{$arg} = $spec->{'position'}; 1930: } else { 1931: if($rc) { 1932: ::diag("$arg is missing a position parameter in its schema"); 1933: } 1934: return; # All must be defined 1935: } 1936: } 1937: 1938: return $rc; 1939: } 1940: 1941: sub run_test 1942: { 1943: my($case, $input, $output, $positions) = @_; 1944: 1945: if($ENV{'TEST_VERBOSE'}) { 1946: diag('input: ', Dumper($input)); 1947: } 1948: 1949: my $name = delete local $case->{'_NAME'}; 1950: my $properties = delete local $case->{_PROPERTIES}; 1951: my $description = delete local $case->{_DESCRIPTION}; 1952: my $result; 1953: my $mess; 1954: my @alist = (); 1955: if(defined($input) && !ref($input)) { 1956: # $mess is later used as a sprintf() format string further 1957: # below — a literal '%' in $name/$input must be escaped to 1958: # '%%' first, the same as the aggregate branch does for 1959: # $args, or a value like '%s' / '%n' corrupts the sprintf call. 1960: (my $safe_input = $input) =~ s/%/%%/g; 1961: if($name) { 1962: (my $safe_name = $name) =~ s/%/%%/g; 1963: $mess = "[% function %]($safe_name = '$safe_input') %s"; 1964: } else { 1965: $mess = "[% function %]('$safe_input') %s"; 1966: } 1967: } elsif(defined($input)) { 1968: if($positions) { 1969: # Positional args 1970: foreach my $key (keys %{$input}) { 1971: if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES') && ($key ne '_DESCRIPTION')) { 1972: if(exists($positions->{$key})) { 1973: $alist[$positions->{$key}] = delete $input->{$key}; 1974: } else { 1975: diag("Lost position number for $key"); 1976: } 1977: } 1978: } 1979: @alist = grep { defined $_ } @alist; # Undefs will cause not enough args to be sent, which is a nice test 1980: $input = join(', ', @alist); 1981: } else { 1982: # Named args 1983: if(ref($input) ne 'HASH') { 1984: if($case->{'_STATUS'} ne 'DIES') { 1985: die('Input is missing list of arguments (perhaps you only listed types)'); 1986: } 1987: # e.g., we are passing a ref to a scalar to something that only takes a scalar, so it should cause the routine to die 1988: $positions = {}; 1989: $alist[0] = $input; 1990: } else { 1991: foreach my $key (sort keys %{$input}) { 1992: if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES')) { 1993: if(defined($input->{$key})) { 1994: push @alist, "'$key' => '$input->{$key}'"; 1995: } else { 1996: push @alist, "'$key' => undef"; 1997: } 1998: } 1999: } 2000: } 2001: } 2002: my $args = join(', ', @alist); 2003: $args =~ s/%/%%/g; 2004: $mess = "[% function %]($args) %s"; 2005: } else { 2006: $mess = "[% function %] %s"; 2007: } 2008: 2009: my $status = delete $case->{'_STATUS'} || $output->{'_STATUS'}; 2010: my $line = delete $case->{'_LINE'}; 2011: my %ENV_before = %ENV; 2012: my $cwd_before = Cwd::getcwd(); 2013: my %cwd_files_before = map { $_ => 1 } do { opendir(my $dh, '.') or die $!; readdir($dh) }; 2014: 2015: local $SIG{ALRM} = sub { die '__TIMEOUT__' }; 2016: if((!defined($config{timeout})) || ($config{timeout} > 0)) { 2017: alarm($config{'timeout'} // 10); 2018: } 2019: my $old_warn = $SIG{__WARN__}; 2020: my $old_die = $SIG{__DIE__}; 2021: my $ok = eval { 2022: if(defined($status)) { 2023: if($status eq 'DIES') { 2024: my $err; 2025: if($positions) { 2026: [% IF position_code %] 2027: if(defined($name)) { 2028: dies_ok { [% position_code %] } sprintf($mess, "dies (position test) - $name (status = DIES)"); 2029: } else { 2030: dies_ok { [% position_code %] } sprintf($mess, 'dies (position test, status = DIES)'); 2031: } 2032: $err = $@; 2033: [% ELSE %] 2034: ok(0, 'dies: position_code not defined'); 2035: [% END %] 2036: } else { 2037: dies_ok { [% call_code %] } sprintf($mess, 'dies'); 2038: $err = $@; 2039: ok(!defined($result)); 2040: } 2041: ok(defined($err)); 2042: ok(length($err)); 2043: ok(!ref($err)); 2044: if(defined($name)) { 2045: unlike($err, qr/unitialized/, "$name doesn't involve an uninitialized variable"); 2046: } else { 2047: unlike($err, qr/unitialized/, "Test doesn't involve an uninitialized variable"); 2048: } 2049: return; # There should be no output to validate 2050: } elsif($status eq 'WARNS') { 2051: warnings_exist { [% call_code %] } qr/./, sprintf($mess, 'warns'); 2052: } else { 2053: die 'TODO: properties' if(scalar keys %{$properties}); 2054: if($positions) { 2055: [% IF position_code %] 2056: if(defined($name)) { 2057: lives_ok { [% position_code %] } sprintf($mess, "survives (position test) - $name (status = LIVES)"); 2058: } else { 2059: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test, status = LIVES)'); 2060: } 2061: [% ELSE %] 2062: ok(0, 'position_code not defined'); 2063: [% END %] 2064: } elsif(defined($description)) { 2065: lives_ok { [% call_code %] } sprintf($mess, "survives ($description; status = LIVES)"); 2066: } elsif(defined($line)) { 2067: lives_ok { [% call_code %] } sprintf($mess, "survives (line = $line; status = LIVES)"); 2068: } else { 2069: lives_ok { [% call_code %] } sprintf($mess, 'survives (status = LIVES)'); 2070: } 2071: if($properties->{idempotent}) { 2072: [% determinism_code %] 2073: } 2074: } 2075: } elsif($positions) { 2076: if(defined($name)) { 2077: lives_ok { [% position_code %] } sprintf($mess, "survives (position test) - $name"); 2078: if($properties->{idempotent} && (scalar(@alist) == 1)) { 2079: [% UNLESS module %] 2080: ok([% function %]($alist[0]) eq [% function %]([% function %]($alist[0])), 'function is idempotent'); 2081: ok([% function %]($alist[0]) eq [% function %]($alist[0]), 'function is idempotent'); 2082: [% END %] 2083: } 2084: } else { 2085: die 'TODO: properties' if(scalar keys %{$properties}); 2086: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test)'); 2087: 2088: # An extra argument should be ignored, except for getsetters, so only test if there's more than one arg 2089: if(scalar(@alist) > 1) { 2090: push(@alist, 'foo'); 2091: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test, with extra argument)'); 2092: } 2093: } 2094: if($properties->{idempotent}) { 2095: [% determinism_code %] 2096: } 2097: } else { 2098: # Status not given, assume set to LIVES 2099: die 'TODO: properties' if(scalar keys %{$properties}); 2100: if(defined($description)) { 2101: lives_ok { [% call_code %] } sprintf($mess, "survives ($description)"); 2102: } elsif(defined($line)) { 2103: lives_ok { [% call_code %] } sprintf($mess, "survives (line = $line)"); 2104: } else { 2105: lives_ok { [% call_code %] } sprintf($mess, 'survives'); 2106: } 2107: if($properties->{idempotent}) { 2108: [% determinism_code %] 2109: } 2110: } 2111: 1; 2112: }; 2113: 2114: alarm 0; 2115: 2116: # Clean up any files the function created in cwd 2117: for my $f (do { opendir(my $dh, '.') or die $!; readdir($dh) }) { 2118: unlink $f if !$cwd_files_before{$f} && -f $f; 2119: } 2120: 2121: # Check the test did not timeout 2122: diag($@) if($@); 2123: ok((!defined($@)) || (length($@) == 0)); 2124: 2125: # Global side effect detection 2126: is(Cwd::getcwd(), $cwd_before, 'cwd not modified'); 2127: is_deeply(_filtered_env(\%ENV), _filtered_env(\%ENV_before), 'ENV not modified'); 2128: is($SIG{__WARN__}, $old_warn, 'warn handler is not changed'); 2129: is($SIG{__DIE__}, $old_die, 'die handler is not changed'); 2130: 2131: delete local $output->{'_STATUS'}; 2132: 2133: if(scalar keys %{$output}) { 2134: if($ENV{'TEST_VERBOSE'}) { 2135: diag('result: ', Dumper($result)); 2136: } 2137: returns_ok($result, $output, 'output validates'); 2138: if(((!defined($status)) || ($status eq 'OK')) && defined($result)) { 2139: is( 2140: Unicode::Normalize::NFC($result), 2141: Unicode::Normalize::NFC(Unicode::Normalize::NFD($result)), 2142: 'Unicode normalization stable' 2143: ); 2144: } 2145: } 2146: } 2147: 2148: # On Windows $PWD etc are not stable 2149: sub _filtered_env { 2150: my %env = %{ shift() }; 2151: 2152: if($^O eq 'MSWin32') { 2153: delete @env{ 2154: qw( 2155: PWD 2156: OLDPWD 2157: _ 2158: SHLVL 2159: ) 2160: }; 2161: } 2162: 2163: return \%env; 2164: } 2165: 2166: diag('Run Fuzz Tests') if($ENV{'TEST_VERBOSE'}); 2167: 2168: foreach my $case (@{fuzz_inputs()}) { 2169: # my %params; 2170: # lives_ok { %params = get_params(\%input, %$case) } 'Params::Get input check'; 2171: # lives_ok { validate_strict(\%input, %params) } 'Params::Validate::Strict input check'; 2172: 2173: my $input; 2174: if((ref($case) eq 'HASH') && exists($case->{'_input'})) { 2175: $input = $case->{'_input'}; 2176: } else { 2177: $input = $case; 2178: } 2179: 2180: if(my $line = ($case->{'_LINE'} || $input{'_LINE'})) { 2181: diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'}); 2182: } 2183: if(my $description = ($case->{'_DESCRIPTION'} || $input{'_DESCRIPTION'})) { 2184: diag("Test case $description") if($ENV{'TEST_VERBOSE'}); 2185: } 2186: 2187: { 2188: # local %ENV; 2189: run_test($case, $input, \%output, $positions); 2190: # delete $ENV{'LANG'}; 2191: # delete $ENV{'LC_ALL'}; 2192: # run_test($case, $input, \%output, $positions); 2193: # $ENV{'LANG'} = 'fr_FR.utf8'; 2194: # $ENV{'LC_ALL'} = 'fr_FR.utf8'; 2195: # run_test($case, $input, \%output, $positions); 2196: } 2197: } 2198: 2199: if(scalar(keys %transforms)) { 2200: diag('Run ', scalar(keys %transforms), ' transform tests'); 2201: } 2202: # diag('-' x 60); 2203: 2204: # Build the foundation - which is a basic test with sensible defaults in the field 2205: foreach my $transform (keys %transforms) { 2206: my $foundation = _fill_foundation(); # basic set of data with every field filled in with a sensible default value 2207: 2208: # The foundation should work 2209: my $case = { _NAME => "basic $transform test", _LINE => __LINE__ }; 2210: my $positions = populate_positions(\%input); 2211: run_test($case, $foundation, \%output, $positions); 2212: 2213: # Generate transform tests 2214: # Don't generate invalid data, that's all already done, 2215: # this is about verifying the transorms 2216: my @tests; 2217: diag("tests for transform $transform") if($ENV{'TEST_VERBOSE'}); 2218: 2219: # Now modify the foundation with test code 2220: 2221: # BUILD CODE TO CALL FUNCTION 2222: # CALL FUNCTION 2223: # CHECK STATUS CORRECT 2224: # IF STATUS EQ LIVES 2225: # CHECK OUTPUT USING returns_ok 2226: # FI 2227: 2228: my $transform_input = $transforms{$transform}{'input'} || {}; 2229: 2230: foreach my $field (keys %input) { 2231: my $spec = $transform_input->{$field} || {}; 2232: my $type = $spec->{type} || 'string'; 2233: 2234: # If there's a specific value, test that exact value 2235: if (exists $spec->{value}) { 2236: push @tests, { 2237: %{$foundation}, 2238: $field => $spec->{value}, 2239: _LINE => __LINE__, 2240: _DESCRIPTION => "$transform: $field=$spec->{value}" 2241: }; 2242: next; 2243: } 2244: 2245: # Generate edge cases based on type and contraints 2246: if($type eq 'integer') { 2247: push @tests, @{_generate_integer_cases($field, $spec, $foundation)}; 2248: } elsif(($type eq 'number') || ($type eq 'float')) { 2249: push @tests, @{_generate_float_cases($field, $spec, $foundation)}; 2250: } elsif($type eq 'string') { 2251: push @tests, @{_generate_string_cases($field, $spec, $foundation)}; 2252: } elsif($type eq 'boolean') { 2253: push @tests, @{_generate_boolean_cases($field, $spec, $foundation)}; 2254: } elsif ($type eq 'arrayref') { 2255: if(defined $spec->{min}) { 2256: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min} + 1) ) }; # just inside 2257: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min}) ) }; # border 2258: } else { 2259: push @tests, { %{$foundation}, ( $field => rand_arrayref() ) }; 2260: } 2261: if(defined $spec->{max}) { 2262: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max} - 1) ) }; # just inside 2263: if((defined $spec->{min}) && ($spec->{'min'} != $spec->{'max'})) { 2264: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max}) ) }; # border 2265: } 2266: } elsif((defined $spec->{min}) || ($spec->{min} <= 3)) { 2267: push @tests, { %{$foundation}, ( $field => [ 'foo', undef, 'bar' ] ), _DESCRIPTION => 'undef in an arrayref', _LINE => __LINE__ } if($config{test_undef}); 2268: } 2269: } else { 2270: die("TODO: transform type $type for test case"); 2271: } 2272: } 2273: 2274: if($config{dedup}) { 2275: @tests = @{_dedup_cases(\@tests)}; 2276: } 2277: 2278: { 2279: # local %ENV; 2280: my $transform_output = $transforms{$transform}{'output'} || {}; 2281: my $properties_array_ref = $transforms{$transform}{properties}; 2282: 2283: my $properties = {}; 2284: if($properties_array_ref) { 2285: $properties->{idempotent} = (grep { $_ eq 'idempotent'} @{$properties_array_ref}) ? 1 : 0; 2286: } 2287: 2288: foreach my $test(@tests) { 2289: if(my $line = (delete $test->{'_LINE'} || delete $input{'_LINE'})) { 2290: diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'}); 2291: } 2292: 2293: run_test({ _NAME => $transform, _PROPERTIES => $properties }, $test, $transform_output, $positions); 2294: # delete $ENV{'LANG'}; 2295: # delete $ENV{'LC_ALL'}; 2296: # run_test({ _NAME => $transform }, $test, \%output, $positions); 2297: # $ENV{'LANG'} = 'de_DE.utf8'; 2298: # $ENV{'LC_ALL'} = 'de_DE.utf8'; 2299: # run_test({ _NAME => $transform }, $test, \%output, $positions); 2300: } 2301: } 2302: } 2303: 2304: sub _fill_foundation 2305: { 2306: my $foundation; 2307: 2308: foreach my $field (keys %input) { 2309: my $spec = $input{$field} || {}; 2310: my $type = $spec->{type} || 'string'; 2311: 2312: if(($type eq 'number') || ($type eq 'float')) { 2313: if(defined $spec->{min}) { 2314: if(defined $spec->{max}) { 2315: $foundation->{$field} = $spec->{max}; # border 2316: } else { 2317: $foundation->{$field} = abs(rand_num()) + $spec->{'min'}; 2318: } 2319: } else { 2320: if(defined $spec->{max}) { 2321: $foundation->{$field} = $spec->{max}; # border 2322: } else { 2323: $foundation->{$field} = -0.01; # No min, so -0.01 should be allowable 2324: } 2325: } 2326: } elsif($type eq 'string') { 2327: if(defined $spec->{min} && $spec->{min} > 0) { 2328: $foundation->{$field} = rand_str($spec->{min}); 2329: } elsif(defined $spec->{max} && $spec->{max} > 0) { 2330: $foundation->{$field} = rand_str($spec->{max}); 2331: } else { 2332: $foundation->{$field} = 'test_value'; 2333: } 2334: } elsif ($type eq 'integer') { 2335: if (defined $spec->{min}) { 2336: $foundation->{$field} = $spec->{min}; 2337: } elsif (defined $spec->{max}) { 2338: $foundation->{$field} = rand_int() + $spec->{max}; 2339: } else { 2340: $foundation->{$field} = rand_int(); 2341: } 2342: } elsif ($type eq 'boolean') { 2343: $foundation->{$field} = 1; 2344: } elsif ($type eq 'arrayref') { 2345: $foundation->{$field} = rand_arrayref(defined($spec->{'min'}) ? $spec->{'min'} : ($spec->{'max'} // 5)); 2346: } elsif ($type eq 'hashref') { 2347: $foundation->{$field} = { key => 'value' }; 2348: } else { 2349: die("TODO: transform type $type for foundation"); 2350: } 2351: } 2352: return $foundation; 2353: } 2354: 2355: [% IF use_properties %] 2356: # ============================================================ 2357: # Property-Based Transform Tests (Test::LectroTest) 2358: # ============================================================ 2359: 2360: use Test::LectroTest::Compat; 2361: use Test::LectroTest::Generator qw(:common); 2362: use Scalar::Util qw(looks_like_number); 2363: 2364: diag('Run property-based transform tests') if($ENV{'TEST_VERBOSE'}); 2365: 2366: [% transform_properties_code %] 2367: 2368: [% END %] 2369: 2370: [% corpus_code %] 2371: 2372: done_testing(); 2373: 2374: 1; 2375: 2376: package MyTestPackage; 2377: 2378: sub new { return bless {}, 'MyTestPackage' } 2379: 2380: 1; 2381: __END__