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.41'; 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.41 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:Mutants (Total: 1, Killed: 1, Survived: 0)
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__)) { 74: shift; 75: } 76: 77: return \Data::Section::Simple::get_data_section($_[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: { $arg_name => { a => 1 } }, 709: { $arg_name => [], _STATUS => 'DIES' }, 710: { $arg_name => 66, _STATUS => 'DIES' }, 711: { $arg_name => sub { die 'fail' }, _STATUS => 'DIES' }, 712: { $arg_name => 'scalar when hashref is needed', _STATUS => 'DIES' }, 713: { $arg_name => \'scalarref when hashref is needed', _STATUS => 'DIES' }; 714: } elsif ($type eq 'arrayref') { 715: my $circular_ref = []; 716: push @{$circular_ref}, $circular_ref; 717: 718: push @cases, 719: { $arg_name => [1,2] }, 720: { $arg_name => $circular_ref, _STATUS => 'DIES', _DESCRIPTION => 'circular ref is caught' }, 721: { $arg_name => { a => 1 }, _STATUS => 'DIES' }; 722: } elsif($type eq 'object') { 723: if($spec->{'isa'}) { 724: push @cases, { $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ }; 725: push @cases, { $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ }; 726: 727: # Test dies when given the wrong type of object 728: push @cases, { $arg_name => new_ok('MyTestPackage'), _STATUS => 'DIES', _LINE => __LINE__ }; 729: 730: use_ok($spec->{isa}); 731: push @cases, { $arg_name => new_ok($spec->{isa}) }; 732: } elsif(!$spec->{can}) { 733: Carp::carp("neither 'isa' nor 'can' is defined - what type of object should be sent?"); 734: } 735: } elsif($type eq 'any') { 736: push @cases, 737: { %mandatory_args, $arg_name => 'string_value' }, 738: { %mandatory_args, $arg_name => 42 }, 739: { %mandatory_args, $arg_name => 3.14 }, 740: { %mandatory_args, $arg_name => [] }, 741: { %mandatory_args, $arg_name => {} }, 742: { %mandatory_args, $arg_name => undef }; 743: } 744: 745: # --- matches (regex) --- 746: if (defined $spec->{matches}) { 747: my $regex = $spec->{matches}; 748: for my $string(@regex_tests) { 749: if($string =~ $regex) { 750: push @cases, { %mandatory_args, ( $arg_name => $string ) }; 751: } else { 752: push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) }; 753: } 754: } 755: } 756: 757: # --- nomatch (regex) --- 758: if (defined $spec->{nomatch}) { 759: my $regex = $spec->{nomatch}; 760: for my $string(@regex_tests) { 761: if($string =~ $regex) { 762: push @cases, { %mandatory_args, ( $arg_name => $string, _STATUS => 'DIES' ) }; 763: } else { 764: push @cases, { %mandatory_args, ( $arg_name => $string ) }; 765: } 766: } 767: } 768: 769: # --- memberof --- 770: if (defined $spec->{memberof}) { 771: my @set = @{ $spec->{memberof} }; 772: push @cases, { %mandatory_args, ( $arg_name => $set[0] ) } if @set; 773: push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_', _STATUS => 'DIES' ) }; 774: } 775: 776: # --- notmemberof --- 777: if (defined $spec->{notmemberof}) { 778: my @set = @{ $spec->{notmemberof} }; 779: push @cases, { %mandatory_args, ( $arg_name => $set[0], _STATUS => 'DIES' ) } if @set; 780: push @cases, { %mandatory_args, ( $arg_name => '_not_in_set_' ) }; 781: } 782: 783: # --- semantic --- 784: if(defined(my $semantic = $spec->{'semantic'})) { 785: if(defined(my $semantic = $spec->{'semantic'})) { 786: push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) }, 787: { %mandatory_args, ( $arg_name => 0 ) }, 788: { %mandatory_args, ( $arg_name => 1 ) }, 789: { %mandatory_args, ( $arg_name => time ) }, 790: { %mandatory_args, ( $arg_name => 2147483647 ) }, 791: { %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) }, 792: { %mandatory_args, ( $arg_name => 2147483648, _STATUS => 'DIES' ) }; 793: } elsif($semantic eq 'email') { 794: push @cases, 795: { %mandatory_args, ( $arg_name => 'user@example.com' ) }, 796: { %mandatory_args, ( $arg_name => 'user+tag@sub.example.co.uk' ) }, 797: { %mandatory_args, ( $arg_name => '@nodomain', _STATUS => 'DIES' ) }, 798: { %mandatory_args, ( $arg_name => 'noatsign', _STATUS => 'DIES' ) }, 799: { %mandatory_args, ( $arg_name => 'user@', _STATUS => 'DIES' ) }, 800: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }, 801: { %mandatory_args, ( $arg_name => 'user@' . ('a' x 256) . '.com', _STATUS => 'DIES' ) }; 802: } elsif($semantic eq 'filepath') { 803: push @cases, 804: { %mandatory_args, ( $arg_name => '/tmp/test.txt' ) }, 805: { %mandatory_args, ( $arg_name => 'relative/path.txt' ) }, 806: { %mandatory_args, ( $arg_name => '.' ) }, 807: { %mandatory_args, ( $arg_name => '..' ) }, 808: { %mandatory_args, ( $arg_name => '../../etc/passwd', _STATUS => 'DIES' ) }, 809: { %mandatory_args, ( $arg_name => '/etc/passwd' . "\0", _STATUS => 'DIES' ) }, 810: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }, 811: { %mandatory_args, ( $arg_name => '/' . ('a' x 4096), _STATUS => 'DIES' ) }; 812: if($^O eq 'MSWin32') { 813: push @cases, 814: { %mandatory_args, ( $arg_name => 'C:\\Users\\test\\file.txt' ) }, 815: { %mandatory_args, ( $arg_name => 'D:\\' ) }, 816: { %mandatory_args, ( $arg_name => 'relative\\path.txt' ) }, 817: { %mandatory_args, ( $arg_name => 'C:\\..\\..\\Windows\\System32', _STATUS => 'DIES' ) }, 818: { %mandatory_args, ( $arg_name => 'C:\\path\\' . "\0" . 'file', _STATUS => 'DIES' ) }, 819: { %mandatory_args, ( $arg_name => 'COM1', _STATUS => 'DIES' ) }, # reserved device name 820: { %mandatory_args, ( $arg_name => 'NUL', _STATUS => 'DIES' ) }, # reserved device name 821: { %mandatory_args, ( $arg_name => 'C:\\path\\file?.txt', _STATUS => 'DIES' ) }, # wildcard 822: { %mandatory_args, ( $arg_name => 'C:\\path\\file*.txt', _STATUS => 'DIES' ) }, # wildcard 823: { %mandatory_args, ( $arg_name => '\\\\server\\share\\file.txt' ) }; # UNC path 824: } 825: } elsif($semantic eq 'date_string') { 826: push @cases, 827: { %mandatory_args, ( $arg_name => '2024-01-01' ) }, 828: { %mandatory_args, ( $arg_name => '1970-01-01' ) }, 829: { %mandatory_args, ( $arg_name => '2024-02-29' ) }, # leap day 830: { %mandatory_args, ( $arg_name => '2023-02-29', _STATUS => 'DIES' ) }, # not a leap year 831: { %mandatory_args, ( $arg_name => '2024-13-01', _STATUS => 'DIES' ) }, # month 13 832: { %mandatory_args, ( $arg_name => '2024-00-01', _STATUS => 'DIES' ) }, # month 0 833: { %mandatory_args, ( $arg_name => '01-01-2024', _STATUS => 'DIES' ) }, # wrong order 834: { %mandatory_args, ( $arg_name => '2024/01/01', _STATUS => 'DIES' ) }, # wrong separator 835: { %mandatory_args, ( $arg_name => 'not-a-date', _STATUS => 'DIES' ) }, 836: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }; 837: } elsif($semantic eq 'iso8601_string') { 838: push @cases, 839: { %mandatory_args, ( $arg_name => '2024-01-01T00:00:00Z' ) }, 840: { %mandatory_args, ( $arg_name => '2024-06-15T12:30:45Z' ) }, 841: { %mandatory_args, ( $arg_name => '2024-01-01T00:00:00+05:30' ) }, 842: { %mandatory_args, ( $arg_name => '2024-01-01' ) }, # date only - check if accepted 843: { %mandatory_args, ( $arg_name => '2024-01-01T25:00:00Z', _STATUS => 'DIES' ) }, # hour 25 844: { %mandatory_args, ( $arg_name => '2024-01-01T00:61:00Z', _STATUS => 'DIES' ) }, # minute 61 845: { %mandatory_args, ( $arg_name => 'not-a-datetime', _STATUS => 'DIES' ) }, 846: { %mandatory_args, ( $arg_name => '', _STATUS => 'DIES' ) }; 847: } else { 848: diag("semantic type $semantic is not yet supported"); 849: } 850: } 851: } 852: } 853: } 854: 855: # Optional deduplication 856: # my %seen; 857: # @cases = grep { !$seen{join '|', %$_}++ } @cases; 858: 859: # Random data test cases 860: # Uses type_edge_cases sometimes 861: if(scalar keys %input) { 862: if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) { 863: # our %input = ( type => 'string' ); 864: my $type = $input{'type'}; 865: for (1..[% iterations_code %]) { 866: my $case_input; 867: if (@edge_case_array && rand() < PROB_EDGE_CASE) { 868: # Sometimes pick a field-specific edge-case 869: $case_input = _pick_from(\@edge_case_array); 870: } elsif(exists $type_edge_cases{$type} && rand() < 0.3) { 871: # Sometimes pick a type-level edge-case 872: $case_input = _pick_from($type_edge_cases{$type}); 873: } elsif($type eq 'string') { 874: if($input{matches}) { 875: $case_input = Data::Random::String::Matches->create_random_string({ regex => $input{'matches'} }); 876: } else { 877: $case_input = rand_str(); 878: } 879: } elsif($type eq 'integer') { 880: my $min = $input{'min'} // 0; 881: 882: $case_input = int(rand_int() + $min); 883: # If it's takes an integer, a float should die 884: push @cases, { _input => $case_input + 0.1, _STATUS => 'DIES', _LINE => __LINE__ }; 885: } elsif(($type eq 'number') || ($type eq 'float')) { 886: $case_input = rand_num() + $input{'min'}; 887: } elsif($type eq 'boolean') { 888: $case_input = rand_bool(); 889: } else { 890: die "TODO: type $type"; 891: } 892: push @cases, { _input => $case_input, _STATUS => 'OK', _LINE => __LINE__ } if($case_input); 893: } 894: } else { 895: # our %input = ( str => { type => 'string' } ); 896: push @cases, @{generate_tests(\%input, \%mandatory_args, _LINE => __LINE__)}; 897: 898: } 899: } 900: 901: # edge-cases 902: if($config{'test_undef'}) { 903: if($all_optional) { 904: push @cases, { '_DESCRIPTION' => 'No args since all are optional' }; 905: } else { 906: # Note that this is set on the input rather than output 907: push @cases, { '_STATUS' => 'DIES' }; # At least one argument is needed 908: } 909: } 910: 911: if(scalar keys %input) { 912: push @cases, { '_STATUS' => 'DIES', map { $_ => undef } keys %input } if($config{'test_undef'}); 913: } else { 914: push @cases, { '_DESCRIPTION' => 'Takes no input' }; # Takes no input 915: } 916: 917: # If it's not in mandatory_strings it sets to 'undef' which is the idea, to test { value => undef } in the args 918: # _LINE has to go first or else the undef in there mucks up the hash format 919: push @cases, { _LINE => __LINE__, map { $_ => $mandatory_strings{$_} } keys %input, %mandatory_objects } if($config{'test_undef'} && !$positions); 920: 921: push @candidate_bad, '' if($config{'test_empty'}); 922: push @candidate_bad, undef if($config{'test_undef'}); 923: push @candidate_bad, "\0" if($config{'test_nuls'}); 924: 925: # generate numeric, string, hashref and arrayref min/max edge cases 926: # TODO: For hashref and arrayref, if there's a $spec->{schema} field, use that for the data that's being generated 927: if(((scalar keys %input) == 1) && exists($input{'type'}) && !ref($input{'type'})) { 928: # our %input = ( type => 'string' ); 929: my $type = $input{type}; 930: if (exists $input{memberof} && ref $input{memberof} eq 'ARRAY' && @{$input{memberof}}) { 931: # Generate edge cases for memberof inside values 932: foreach my $val (@{$input{memberof}}) { 933: push @cases, 934: { _input => $val, _LINE => __LINE__ }, 935: { _input => " $val", _LINE => __LINE__, _STATUS => 'DIES' }, 936: { _input => "$val ", _LINE => __LINE__, _STATUS => 'DIES' }, 937: { _input => substr($val, 0, -1), _LINE => __LINE__, _STATUS => 'DIES' }; 938: if($val =~ /[A-Z]/) { 939: push @cases, { _input => lc($val), _LINE => __LINE__, _STATUS => 'DIES' }; 940: } 941: if($val =~ /[a-z]/) { 942: push @cases, { _input => uc($val), _LINE => __LINE__, _STATUS => 'DIES' }; 943: } 944: } 945: # outside value 946: my $outside; 947: if(($type eq 'integer') || ($type eq 'number') || ($type eq 'float')) { 948: $outside = (sort { $a <=> $b } @{$input{memberof}})[-1] + 1; 949: } else { 950: $outside = 'INVALID_MEMBEROF'; 951: } 952: push @cases, { _input => $outside, _STATUS => 'DIES' }; 953: } else { 954: # Generate edge cases for min/max 955: if($type eq 'integer') { 956: push @cases, @{_generate_integer_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 957: } elsif(($type eq 'number') || ($type eq 'float')) { 958: push @cases, @{_generate_float_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 959: } elsif ($type eq 'string') { 960: push @cases, @{_generate_string_cases('_input', \%input, \%mandatory_args, _LINE => __LINE__)}; 961: } elsif ($type eq 'arrayref') { 962: if (defined $input{min}) { 963: my $len = $input{min}; 964: push @cases, { _input => [ (1) x ($len + 1) ] }; # just inside 965: push @cases, { _input => [ (1) x $len ] }; # border 966: push @cases, { _input => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside 967: } else { 968: push @cases, { _input => [] } if($config{'test_empty'}); # No min, empty array should be allowable 969: } 970: if (defined $input{max}) { 971: my $len = $input{max}; 972: push @cases, { _input => [ (1) x ($len - 1) ] }; # just inside 973: push @cases, { _input => [ (1) x $len ] }; # border 974: push @cases, { _input => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside 975: } 976: } elsif ($type eq 'hashref') { 977: if (defined $input{min}) { 978: my $len = $input{min}; 979: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) } }; 980: push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } }; 981: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0; 982: } else { 983: push @cases, { _input => {} } if($config{'test_empty'}); # No min, empty hash should be allowable 984: } 985: if (defined $input{max}) { 986: my $len = $input{max}; 987: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len - 1) } }; 988: push @cases, { _input => { map { "k$_" => 1 }, 1 .. $len } }; 989: push @cases, { _input => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' }; 990: } 991: } elsif ($type eq 'boolean') { 992: push @cases, @{_generate_boolean_cases('_input', \%input, \%mandatory_args)}; 993: } 994: 995: # Test all edge cases 996: foreach my $edge(@edge_case_array) { 997: push @cases, { _input => $edge, _DESCRIPTION => 'edge case' }; 998: } 999: } 1000: } else { 1001: # our %input = ( str => { type => 'string' } ); 1002: push @cases, @{generate_tests(\%input, \%mandatory_args)}; 1003: } 1004: 1005: # fuzzing can easily generate repeats 1006: if($config{'dedup'}) { 1007: return _dedup_cases(\@cases); 1008: } 1009: 1010: # use Data::Dumper; 1011: # die(Dumper(@cases)); 1012: 1013: return \@cases; 1014: } 1015: 1016: # Functions to generate test cases 1017: sub _generate_integer_cases { 1018: my ($arg_name, $spec, $mandatory_args) = @_; 1019: my @cases; 1020: 1021: foreach my $i (-42, -1, 42) { 1022: if(((!defined $spec->{min}) || ($spec->{min} <= $i)) && ((!defined($spec->{max})) || ($spec->{max} >= $i))) { 1023: push @cases, { %{$mandatory_args}, ( $arg_name => $i ) }; 1024: } else { 1025: push @cases, { %{$mandatory_args}, ( $arg_name => $i, _STATUS => 'DIES' ) }; 1026: } 1027: } 1028: 1029: [% IF module %] 1030: # Send wrong data type - builtins aren't good at checking this 1031: push @cases, 1032: { %{$mandatory_args}, ( $arg_name => "test string in integer field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) }, 1033: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1034: { %{$mandatory_args}, ( $arg_name => 3.14, _STATUS => 'DIES' ) }, # Float 1035: { %{$mandatory_args}, ( $arg_name => 'xyz', _STATUS => 'DIES' ) }, 1036: { %{$mandatory_args}, ( $arg_name => \42, _STATUS => 'DIES' ) }, # Scalar ref 1037: { %{$mandatory_args}, ( $arg_name => *STDOUT, _STATUS => 'DIES' ) }, # Global variable 1038: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }; 1039: [% END %] 1040: 1041: # min/max numeric boundaries 1042: if (defined $spec->{min}) { 1043: my $min = $spec->{min}; 1044: push @cases, 1045: { %{$mandatory_args}, ( $arg_name => $min - 1, _STATUS => 'DIES' ) }, 1046: { %{$mandatory_args}, ( $arg_name => " $min ", _LINE => __LINE__ ) }, # border, padded integer 1047: { %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ) }, # border 1048: { %{$mandatory_args}, ( $arg_name => $min + 1 ) }; # just inside 1049: 1050: if(!defined $spec->{max}) { 1051: push @cases, { %{$mandatory_args}, ( $arg_name => int($min + abs(rand_int())) ), _LINE => __LINE__ }; 1052: } 1053: if($min <= 0) { 1054: push @cases, { %{$mandatory_args}, ( $arg_name => -0.0, _STATUS => 'OK' ) }; # Negative 0 1055: } 1056: } else { 1057: push @cases, 1058: { %{$mandatory_args}, ( $arg_name => 1e5, _STATUS => 'OK' ) }, # Scientific notation 1059: { %{$mandatory_args}, ( $arg_name => 1_000, _STATUS => 'OK' ) }, # Underscored 1060: { %{$mandatory_args}, ( $arg_name => ' 42 ', _STATUS => 'OK' ) }; # Padded integer 1061: } 1062: 1063: if (defined $spec->{max}) { 1064: my $max = $spec->{max}; 1065: push @cases, 1066: { %{$mandatory_args}, ( $arg_name => $max - 1 ) }, 1067: { %{$mandatory_args}, ( $arg_name => $max ) }, 1068: { %{$mandatory_args}, ( $arg_name => $max + 1, _STATUS => 'DIES' ) }; 1069: 1070: if(defined $spec->{min}) { 1071: # Test 0 if it's in range 1072: push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0); 1073: } else { 1074: push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_int() ), _DESCRIPTION => 'max is defined but min is not' }; 1075: if($max >= 0) { 1076: push @cases, { %{$mandatory_args}, ( $arg_name => -0.0, _STATUS => 'OK' ) }; # Negative 0 1077: if($max == 0) { 1078: push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_int()) * -1 ), _LINE => __LINE__ }; # Any negative integer 1079: } 1080: } 1081: } 1082: } elsif(!defined $spec->{min}) { 1083: # Can take any number, so give it one 1084: push @cases, 1085: { %{$mandatory_args}, ( $arg_name => rand_int() ), _LINE => __LINE__ }, 1086: { %{$mandatory_args}, ( $arg_name => 0) }; # 0 is in range 1087: } 1088: 1089: return \@cases; 1090: } 1091: 1092: sub _generate_float_cases { 1093: my ($arg_name, $spec, $mandatory_args) = @_; 1094: my @cases; 1095: 1096: if((!defined $spec->{min}) || ($spec->{min} <= -0.1)) { 1097: push @cases, { %{$mandatory_args}, ( $arg_name => -0.1, _LINE => __LINE__ ) }; 1098: } 1099: if((!defined $spec->{min}) || ($spec->{min} <= 43.56)) { 1100: push @cases, { %{$mandatory_args}, ( $arg_name => 43.56 ) }; 1101: } 1102: 1103: [% IF module %] 1104: # Send wrong data type - builtins aren't good at checking this 1105: push @cases, 1106: { %{$mandatory_args}, ( $arg_name => "test string in float field $arg_name", _STATUS => 'DIES', _LINE => __LINE__ ) }, 1107: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1108: { %{$mandatory_args}, ( $arg_name => \42.1, _STATUS => 'DIES' ) }, # Scalar ref 1109: # NaN and Inf are valid according to looks_like_number() so we 1110: # cannot assume they die 1111: # { %{$mandatory_args}, ( $arg_name => "NaN", _STATUS => 'DIES' ) }, 1112: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }; 1113: [% END %] 1114: 1115: # min/max numeric boundaries 1116: if (defined $spec->{min}) { 1117: my $min = $spec->{min}; 1118: push @cases, 1119: { %{$mandatory_args}, ( $arg_name => $min - 0.001, _STATUS => 'DIES' ) }, 1120: { %{$mandatory_args}, ( $arg_name => $min, _LINE => __LINE__ ) }, # border 1121: { %{$mandatory_args}, ( $arg_name => $min + 0.001 ) }; # just inside 1122: 1123: [% IF module %] 1124: push @cases, { %{$mandatory_args}, ( $arg_name => "-inf", _STATUS => 'DIES' ) }; 1125: [% END %] 1126: 1127: if(!defined $spec->{max}) { 1128: push @cases, { %{$mandatory_args}, ( $arg_name => $min + rand_num() ), _DESCRIPTION => 'min is defined but max is not' }; 1129: if($min == 0) { 1130: push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_num()) ), _LINE => __LINE__ }; # Any positive number 1131: } 1132: } 1133: } 1134: if (defined $spec->{max}) { 1135: my $max = $spec->{max}; 1136: push @cases, 1137: { %{$mandatory_args}, ( $arg_name => $max - 0.000001 ) }, 1138: { %{$mandatory_args}, ( $arg_name => $max ) }, 1139: { %{$mandatory_args}, ( $arg_name => $max + 0.000001, _STATUS => 'DIES' ) }; 1140: 1141: [% IF module %] 1142: push @cases, 1143: { %{$mandatory_args}, ( $arg_name => "inf", _STATUS => 'DIES' ) }, 1144: { %{$mandatory_args}, ( $arg_name => 9**9**9, _STATUS => 'DIES' ) }; 1145: [% END %] 1146: 1147: if(defined $spec->{min}) { 1148: # Test 0 if it's in range 1149: push @cases, { %{$mandatory_args}, ( $arg_name => 0 ) } if($spec->{'min'} >= 0); 1150: } else { 1151: push @cases, { %{$mandatory_args}, ( $arg_name => $max - rand_num() ), _LINE => __LINE__ }; 1152: if($max == 0) { 1153: push @cases, { %{$mandatory_args}, ( $arg_name => abs(rand_num()) * -0.00000001 ) }; # Any negative number 1154: } 1155: } 1156: } elsif(!defined $spec->{min}) { 1157: # Can take any number, so give it some 1158: push @cases, 1159: { %{$mandatory_args}, ( $arg_name => rand_num(), _LINE => __LINE__ ) }, 1160: { %{$mandatory_args}, ( $arg_name => 1.23 ) }, 1161: { %{$mandatory_args}, ( $arg_name => -42.1 ) }, 1162: { %{$mandatory_args}, ( $arg_name => -0.0 ) }, # -0 is in range 1163: { %{$mandatory_args}, ( $arg_name => 0 ) }; # 0 is in range 1164: } 1165: 1166: return \@cases; 1167: } 1168: 1169: # basic boolean edge cases 1170: sub _generate_boolean_cases { 1171: my ($arg_name, $spec, $mandatory_args) = @_; 1172: 1173: my @cases; 1174: 1175: if(exists($spec->{'memberof'}) && (ref($spec->{'memberof'} eq 'ARRAY'))) { 1176: # memberof already defines allowed booleans 1177: foreach my $val (@{$spec->{memberof}}) { 1178: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1179: } 1180: } else { 1181: @cases = ( 1182: { %{$mandatory_args}, ( $arg_name => 0 ) }, 1183: { %{$mandatory_args}, ( $arg_name => 1 ) }, 1184: { %{$mandatory_args}, ( $arg_name => 'true' ) }, 1185: { %{$mandatory_args}, ( $arg_name => 'false' ) }, 1186: { %{$mandatory_args}, ( $arg_name => 'off' ) }, 1187: { %{$mandatory_args}, ( $arg_name => 'on' ) }, 1188: { %{$mandatory_args}, ( $arg_name => 'yes' ) }, 1189: { %{$mandatory_args}, ( $arg_name => 'no' ) }, 1190: { %{$mandatory_args}, ( $arg_name => 'xyzzy', _STATUS => 'DIES' ) }, # invalid boolean 1191: { %{$mandatory_args}, ( $arg_name => -1, _STATUS => 'DIES' ) }, # invalid boolean 1192: { %{$mandatory_args}, ( $arg_name => 2, _STATUS => 'DIES' ) }, # invalid boolean 1193: { %{$mandatory_args}, ( $arg_name => bless({}, 'Evil::Class'), _STATUS => 'DIES', _LINE => __LINE__ ) }, 1194: { %{$mandatory_args}, ( $arg_name => [ 1 ], _STATUS => 'DIES' ) } # invalid boolean 1195: ); 1196: } 1197: 1198: push @cases, { %{$mandatory_args}, ( $arg_name => undef, _STATUS => 'DIES' ) } if($config{'test_undef'}); 1199: push @cases, { %{$mandatory_args}, ( $arg_name => "\0", _STATUS => 'DIES' ) } if($config{'test_nuls'}); 1200: 1201: return \@cases; 1202: } 1203: 1204: sub _generate_string_cases 1205: { 1206: my ($arg_name, $spec, $mandatory_args, $properties_array_ref) = @_; 1207: 1208: my @cases; 1209: 1210: if (defined $spec->{min}) { 1211: my $len = $spec->{min}; 1212: if(my $re = $spec->{matches}) { 1213: if(ref($re) ne 'Regexp') { 1214: $re = qr/$re/; 1215: } 1216: my $random_string; 1217: if($spec->{'max'}) { 1218: $random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re }); 1219: } elsif($spec->{'min'}) { 1220: $random_string = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re }); 1221: } else { 1222: $random_string = Data::Random::String::Matches->create_random_string({ regex => $re }); 1223: } 1224: # Is hello allowed? 1225: foreach my $str('hello', $random_string) { 1226: if($str =~ $re) { 1227: if(!defined($spec->{'memberof'}) || (grep { $_ eq $str } @{$spec->{'memberof'}})) { 1228: if(defined($spec->{'notmemberof'}) && (grep { $_ eq $str } @{$spec->{'notmemberof'}})) { 1229: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1230: } else { 1231: push @cases, { %{$mandatory_args}, ( $arg_name => $str ) }; 1232: } 1233: } elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) { 1234: # Data::Random 1235: push @cases, { %{$mandatory_args}, ( _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] ) } 1236: } else { 1237: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1238: } 1239: } else { 1240: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1241: } 1242: } 1243: for my $count ($len + 1, $len, $len - 1) { 1244: next if ($count < 0); 1245: my $str = rand_str($count); 1246: if($str =~ $re) { 1247: push @cases, { %{$mandatory_args}, ( $arg_name => $str ) }; 1248: } else { 1249: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES' ) }; 1250: } 1251: } 1252: } else { 1253: # matches is not defined 1254: if(!defined($spec->{'memberof'}) || (grep { $_ eq 'hello' } @{$spec->{'memberof'}})) { 1255: if(defined($spec->{'notmemberof'}) && (grep { $_ eq 'hello' } @{$spec->{'notmemberof'}})) { 1256: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1257: } elsif((!defined($spec->{max})) || ($spec->{max} >= 5)) { 1258: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'OK' ) }; 1259: } else { 1260: push @cases, 1261: { %{$mandatory_args}, ( $arg_name => 'plugh', _LINE => __LINE__, _STATUS => 'DIES' ) }, 1262: { %{$mandatory_args}, ( $arg_name => ' ', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1263: } 1264: # Check that trimmed strings work 1265: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len, _LINE => __LINE__, _STATUS => 'OK' ) }; 1266: } else { 1267: push @cases, { %{$mandatory_args}, ( $arg_name => 'hello', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1268: } 1269: if(!defined($spec->{'memberof'})) { 1270: push @cases, { %{$mandatory_args}, ( $arg_name => "he\nlo", _LINE => __LINE__, _STATUS => 'OK' ) }, 1271: { %{$mandatory_args}, ( $arg_name => "\nhell", _LINE => __LINE__, _STATUS => 'OK' ) }, 1272: { %{$mandatory_args}, ( $arg_name => "hell\n", _LINE => __LINE__, _STATUS => 'OK' ) }, 1273: { %{$mandatory_args}, ( $arg_name => ' hell', _LINE => __LINE__, _STATUS => 'OK' ) }, 1274: { %{$mandatory_args}, ( $arg_name => rand_str($len) . "\n" . rand_str($len), _LINE => __LINE__, _STATUS => 'OK' ) }; 1275: } 1276: 1277: if($len <= 0) { 1278: 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 1279: push @cases, 1280: { %{$mandatory_args}, ( $arg_name => ' ', _LINE => __LINE__ ) }, 1281: { %{$mandatory_args}, ( $arg_name => "\n", _LINE => __LINE__ ) }, 1282: # Don't confuse if() with if(defined()) 1283: { %{$mandatory_args}, ( $arg_name => '0', _STATUS => 'DIES' ) }; 1284: 1285: if($config{'test_security'}) { 1286: push @cases, 1287: { %{$mandatory_args}, ( $arg_name => '<script>alert(1)</script>', _LINE => __LINE__ ) }, 1288: { %{$mandatory_args}, ( $arg_name => "'; DROP TABLE foo --", _LINE => __LINE__ ) }; 1289: } 1290: } 1291: } 1292: } elsif($config{'test_empty'}) { 1293: # No min, empty string should be allowable 1294: if(defined($spec->{'memberof'}) && (!grep { $_ eq '' } @{$spec->{'memberof'}})) { 1295: push @cases, { %{$mandatory_args}, ( $arg_name => '', _LINE => __LINE__, _STATUS => 'DIES' ) }; 1296: } else { 1297: push @cases, { %{$mandatory_args}, ( $arg_name => '', _LINE => __LINE__ ) }; 1298: } 1299: } 1300: if (defined $spec->{max}) { 1301: my $len = $spec->{max}; 1302: if((!defined($spec->{min})) || ($spec->{min} != $len)) { 1303: if(my $re = $spec->{matches}) { 1304: for my $count ($len - 1, $len, $len + 1) { 1305: my $str = rand_str($count); 1306: if($str =~ $re) { 1307: if($count > $len) { 1308: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _LINE => __LINE__, _STATUS => 'DIES' ) }; 1309: } else { 1310: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _LINE => __LINE__ ) }; 1311: } 1312: } else { 1313: push @cases, { %{$mandatory_args}, ( $arg_name => $str, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1314: } 1315: } 1316: } else { 1317: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _LINE => __LINE__ ) }; # just inside 1318: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len), _LINE => __LINE__ ) }; # border 1319: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len + 1), _LINE => __LINE__, _STATUS => 'DIES' ) }; # outside 1320: } 1321: } elsif(defined($spec->{min}) && ($spec->{min} == $len)) { 1322: if($len >= 2) { 1323: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len - 1, _LINE => __LINE__, _DESCRIPTION => 'max == min', _STATUS => 'DIES' ) }; 1324: } 1325: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len, _LINE => __LINE__, _DESCRIPTION => 'max == min' ) }; 1326: push @cases, { %{$mandatory_args}, ( $arg_name => ' ' x $len + 1, _LINE => __LINE__, _DESCRIPTION => 'max == min', _STATUS => 'DIES' ) }; 1327: } 1328: } elsif((!$spec->{matches}) && (!$spec->{memberof})) { 1329: # TODO: send them if they match the regex 1330: if(exists($spec->{'min'})) { 1331: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(($spec->{'min'} + 1) * 1_000), _LINE => __LINE__ ) }; 1332: } else { 1333: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(65535), _LINE => __LINE__, _DESCRIPTION => 'Long string nearly 64K characters' ) }; 1334: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str(65536), _LINE => __LINE__, _DESCRIPTION => 'Long string 64K characters' ) }; 1335: } 1336: if((!exists($spec->{min})) || ($spec->{min} <= 1)) { 1337: push @cases, { %{$mandatory_args}, ( $arg_name => "\x{FEFF}", _STATUS => 'OK', _LINE => __LINE__, _DESCRIPTION => 'Byte order marker' ) }; 1338: } else { 1339: push @cases, { %{$mandatory_args}, ( $arg_name => "\x{FEFF}", _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'Byte order marker' ) }; 1340: } 1341: } 1342: 1343: if((!exists($spec->{min})) || ($spec->{min} == 0)) { 1344: # '' should die unless it's in the memberof list 1345: if(defined($spec->{'memberof'}) && (!grep { $_ eq '' } @{$spec->{'memberof'}})) { 1346: push @cases, { %{$mandatory_args}, ( $arg_name => '', _NAME => $arg_name, _STATUS => 'DIES', _LINE => __LINE__ ) } 1347: } elsif(defined($spec->{'memberof'}) && !defined($spec->{'max'})) { 1348: # Data::Random 1349: push @cases, { %{$mandatory_args}, _input => (rand_set(set => $spec->{'memberof'}, size => 1))[0] } 1350: } elsif($config{'test_empty'} && !$spec->{'memberof'}) { 1351: push @cases, { %{$mandatory_args}, ( $arg_name => '', _NAME => $arg_name, _LINE => __LINE__ ) }; 1352: } 1353: } 1354: # push @cases, { $arg_name => "emoji \x{1F600}" }; 1355: 1356: unless(defined($spec->{memberof}) || defined($spec->{matches})) { 1357: # --- min/max string/array boundaries --- 1358: if(defined $spec->{min}) { 1359: my $len = $spec->{min}; 1360: if($len == 1) { 1361: if($config{'test_empty'}) { 1362: push @cases, { %{$mandatory_args}, ( $arg_name => '', _STATUS => 'DIES', _LINE => __LINE__ ) }; 1363: } 1364: } elsif($len > 0) { 1365: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _STATUS => 'DIES' ) }; 1366: } 1367: if((!defined($spec->{max})) || ($spec->{max} >= $len + 1)) { 1368: push @cases, 1369: { %{$mandatory_args}, ( $arg_name => rand_str($len) ) }, 1370: { %{$mandatory_args}, ( $arg_name => rand_str($len + 1) ) }; 1371: } 1372: if($len <= 1) { 1373: push @cases, 1374: { %{$mandatory_args}, ( $arg_name => "\n" ) }, # new lines are fun 1375: { %{$mandatory_args}, ( $arg_name => ' ' ) }, 1376: { %{$mandatory_args}, ( $arg_name => " \n " ) }; 1377: } 1378: } else { 1379: push @cases, 1380: { %{$mandatory_args}, ( $arg_name => "\n" ) }, # new lines are fun 1381: { %{$mandatory_args}, ( $arg_name => ' ' ) }, 1382: { %{$mandatory_args}, ( $arg_name => " \n " ) }; 1383: } 1384: if (defined $spec->{max}) { 1385: my $len = $spec->{max}; 1386: if((!defined($spec->{min})) || ($spec->{min} < ($len - 1))) { 1387: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1) ) }; 1388: } else { 1389: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len - 1), _STATUS => 'DIES' ) }; 1390: } 1391: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len) ) }; 1392: push @cases, { %{$mandatory_args}, ( $arg_name => rand_str($len + 1), _STATUS => 'DIES' ) }; 1393: } 1394: } 1395: 1396: if(defined $spec->{matches}) { 1397: my $re = $spec->{matches}; 1398: 1399: # --- Positive controls --- 1400: foreach my $val (@candidate_good) { 1401: if ($val =~ $re) { 1402: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1403: last; # one good match is enough 1404: } 1405: } 1406: 1407: # --- Negative controls --- 1408: foreach my $val (@candidate_bad) { 1409: if(!defined($val)) { 1410: push @cases, { _input => undef, _STATUS => 'DIES', _LINE => __LINE__ } if($config{'test_undef'}); 1411: } elsif ($val !~ $re) { 1412: push @cases, { _input => $val, _STATUS => 'DIES', _LINE => __LINE__ }; 1413: } 1414: } 1415: push @cases, { $arg_name => undef, _STATUS => 'DIES' } if($config{'test_undef'}); 1416: } 1417: if(defined $spec->{nomatch}) { 1418: my $re = $spec->{nomatch}; 1419: 1420: # --- Positive controls --- 1421: foreach my $val (@candidate_good) { 1422: if ($val !~ $re) { 1423: push @cases, { %{$mandatory_args}, ( $arg_name => $val ) }; 1424: last; # one good match is enough 1425: } 1426: } 1427: 1428: # --- Negative controls --- 1429: foreach my $val (@candidate_bad) { 1430: if ($val =~ $re) { 1431: push @cases, { $arg_name => $val, _STATUS => 'DIES' }; 1432: } 1433: } 1434: } 1435: 1436: [% IF module %] 1437: # Send wrong data type - builtins aren't good at checking this 1438: if($config{'test_nuls'}) { 1439: push @cases, 1440: { %{$mandatory_args}, $arg_name => "\0", _STATUS => 'DIES', _LINE => __LINE__ }, 1441: { %{$mandatory_args}, $arg_name => "nul\0", _STATUS => 'DIES', _LINE => __LINE__ }, 1442: { %{$mandatory_args}, $arg_name => "\0nul", _STATUS => 'DIES', _LINE => __LINE__ }; 1443: if(defined($spec->{matches})) { 1444: my $re = $spec->{matches}; 1445: foreach my $val (@candidate_good) { 1446: $val = "$val\0"; 1447: if ($val !~ $re) { 1448: push @cases, { %{$mandatory_args}, ( $arg_name => $val, _STATUS => 'DIES', _DESCRIPTION => 'Nul byte after regex' ) }; 1449: } 1450: $val = "\0$val"; 1451: if ($val !~ $re) { 1452: push @cases, { %{$mandatory_args}, ( $arg_name => $val, _STATUS => 'DIES', _DESCRIPTION => 'Nul byte before regex' ) }; 1453: } 1454: } 1455: } 1456: } 1457: if($config{'test_empty'}) { 1458: push @cases, 1459: { %{$mandatory_args}, ( $arg_name => [], _STATUS => 'DIES', _LINE => __LINE__ ) }, 1460: { %{$mandatory_args}, ( $arg_name => {}, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1461: } 1462: push @cases, 1463: { %{$mandatory_args}, ( $arg_name => \'ref to scalar', _STATUS => 'DIES', _LINE => __LINE__ ) }, 1464: { %{$mandatory_args}, ( $arg_name => sub { die 'boom' }, _STATUS => 'DIES', _LINE => __LINE__ ) }, 1465: { %{$mandatory_args}, ( $arg_name => bless({}, 'Evil::Class'), _STATUS => 'DIES', _LINE => __LINE__ ) }, 1466: # { %{$mandatory_args}, ( $arg_name => [1, 2, 3], _STATUS => 'DIES', _LINE => __LINE__ ) }, # Generates false positives. Why? 1467: { %{$mandatory_args}, ( $arg_name => { a => 1 }, _STATUS => 'DIES', _LINE => __LINE__ ) }; 1468: [% END %] 1469: 1470: return \@cases; 1471: } 1472: 1473: # dedup, fuzzing can easily generate repeats 1474: # FIXME: I don't think this catches them all 1475: # FIXME: Handle cases with Class::Simple calls 1476: # FIXME: The JSON encoding fails on various data types that are sent (e.g. scalar refs, objects) so don't bother 1477: sub _dedup_cases 1478: { 1479: my $cases = shift; 1480: 1481: # Do not use JSON::MaybeXS because it will fail on non utf-8 characters 1482: require JSON::PP; 1483: JSON::PP->import(); 1484: 1485: # return inside eval{} returns from the eval block, not from 1486: # _dedup_cases — the deduped result must be captured here, or 1487: # this always falls through to the unduplicated $cases below. 1488: # 1489: # encode_json() does not sort hash keys, so two structurally 1490: # identical case hashrefs can serialize with different key order 1491: # (Perl's per-hash iteration order randomisation) and dodge the 1492: # %seen check below — use ->canonical to make the dump order-stable. 1493: my $rc = eval { 1494: my $json = JSON::PP->new->canonical; 1495: my %seen; 1496: my @rc = grep { 1497: my $dump = $json->encode($_); 1498: !$seen{$dump}++ 1499: } @{$cases}; 1500: 1501: return \@rc; 1502: }; 1503: # Carp::carp(__PACKAGE__, ": disabling deduping: $@"); 1504: 1505: return $@ ? $cases : $rc; 1506: } 1507: 1508: sub generate_tests 1509: { 1510: my $input = $_[0]; 1511: my %mandatory_args = %{$_[1]}; 1512: 1513: my @cases; 1514: 1515: foreach my $field (keys %input) { 1516: my $spec = $input{$field} || {}; 1517: foreach my $field(keys %{$spec}) { 1518: next if($field =~ /^_/); # Ignore comments 1519: if(!grep({ $_ eq $field } ('type', 'min', 'max', 'optional', 'matches', 'can', 'position', 'memberof', 'semantic', 'isa'))) { 1520: die("TODO: handle schema keyword '$field'"); 1521: } 1522: } 1523: } 1524: 1525: # Build a test of the mandatory args 1526: push @cases, { _input => \%mandatory_args, status => 'OK' } if(keys %mandatory_args); 1527: 1528: for (1..[% iterations_code %]) { 1529: # One by one change each of the mandatory fields 1530: foreach my $field (keys %input) { 1531: my $spec = $input{$field} || {}; 1532: next if $spec->{'memberof'}; # Memberof data is created below 1533: my $type = $spec->{type} || 'string'; 1534: 1535: my %case_input = (%mandatory_args); 1536: # 1) Sometimes pick a field-specific edge-case 1537: if (exists $edge_cases{$field} && rand() < PROB_EDGE_CASE) { 1538: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1539: $case_input{$field} = _pick_from($edge_cases{$field}); 1540: next; 1541: } 1542: 1543: # 2) Sometimes pick a type-level edge-case 1544: if (exists $type_edge_cases{$type} && rand() < 0.3) { 1545: $case_input{$field} = _pick_from($type_edge_cases{$type}); 1546: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1547: next; 1548: } 1549: 1550: # 3) Sormal random generation by type 1551: if ($type eq 'string') { 1552: if(my $re = $spec->{matches}) { 1553: if(ref($re) ne 'Regexp') { 1554: $re = qr/$re/; 1555: } 1556: if($spec->{'max'}) { 1557: $case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'max'}, regex => $re }); 1558: } elsif($spec->{'min'}) { 1559: $case_input{$field} = Data::Random::String::Matches->create_random_string({ length => $spec->{'min'}, regex => $re }); 1560: } else { 1561: $case_input{$field} = Data::Random::String::Matches->create_random_string({ regex => $re }); 1562: } 1563: } elsif(my $semantic = $spec->{'semantic'}) { 1564: if($semantic eq 'email') { 1565: $case_input{$field} = rand_email($spec->{'max'} // $spec->{'min'}); 1566: } else { 1567: diag(__LINE__, ": TODO: handle semantic type '$semantic'"); 1568: } 1569: } elsif(!$spec->{'memberof'}) { 1570: if(my $min = $spec->{min}) { 1571: $case_input{$field} = rand_str($min); 1572: if($config{'test_empty'} && ($min == 0)) { 1573: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1574: $case_input{$field} = ''; 1575: } 1576: } else { 1577: $case_input{$field} = rand_str(); 1578: if($config{'test_empty'}) { 1579: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1580: $case_input{$field} = ''; 1581: } 1582: } 1583: } 1584: } elsif ($type eq 'integer') { 1585: if(my $min = $spec->{min}) { 1586: if(my $max = $spec->{'max'}) { 1587: $case_input{$field} = int(rand($max - $min + 1)) + $min; 1588: } else { 1589: $case_input{$field} = rand_int() + $min; 1590: } 1591: } elsif(exists($spec->{min})) { 1592: # min == 0 1593: if(my $max = $spec->{'max'}) { 1594: $case_input{$field} = int(rand($max + 1)); 1595: } else { 1596: $case_input{$field} = int(abs(rand_int())); 1597: } 1598: } else { 1599: push @cases, 1600: # If it's takes an integer, a float should die 1601: { _input => rand_int() + 0.2, _STATUS => 'DIES', _LINE => __LINE__ }, 1602: # Integers passed as a string 1603: { _input => "007", _STATUS => 'OK', _LINE => __LINE__ }, 1604: { _input => "0x10", _STATUS => 'OK', _LINE => __LINE__ }, 1605: { _input => "1_000", _STATUS => 'OK', _LINE => __LINE__ }; 1606: $case_input{$field} = rand_int(); 1607: } 1608: } elsif ($type eq 'boolean') { 1609: $case_input{$field} = rand_bool(); 1610: } elsif ($type eq 'number') { 1611: if(my $min = $spec->{min}) { 1612: $case_input{$field} = rand_num() + $min; 1613: } else { 1614: $case_input{$field} = rand_num(); 1615: } 1616: } elsif ($type eq 'arrayref') { 1617: my $circular_ref = []; 1618: push @{$circular_ref}, $circular_ref; 1619: 1620: push @cases, { %mandatory_args, ($field => $circular_ref, _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => "Don't accept array ref with circular references") }; 1621: 1622: if(my $element_type = $input{element_type}) { 1623: if($element_type eq 'integer') { 1624: push @cases, 1625: { %mandatory_args, ($field => '0.3', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'float in list of integers') }, 1626: { %mandatory_args, ($field => 'string in array of ints', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'string in list of integers') }; 1627: } elsif($element_type eq 'boolean') { 1628: push @cases, 1629: { %mandatory_args, ($field => 2, _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => '2 list of booleans') }, 1630: { %mandatory_args, ($field => '0.3', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'float in list of booleans') }, 1631: { %mandatory_args, ($field => 'string in array of bools', _STATUS => 'DIES', _LINE => __LINE__, _DESCRIPTION => 'string in list of booleans') }; 1632: } 1633: } 1634: 1635: $case_input{$field} = rand_arrayref(); 1636: } elsif ($type eq 'hashref') { 1637: $case_input{$field} = rand_hashref(); 1638: } elsif($config{'test_undef'}) { 1639: $case_input{$field} = undef; 1640: } 1641: 1642: # 4) occasionally drop optional fields 1643: if ($spec->{optional} && rand() < 0.25) { 1644: delete $case_input{$field}; 1645: } 1646: push @cases, { _input => \%case_input, status => 'OK' } if(keys %case_input); 1647: 1648: ##################### 1649: # FIXME: Start of duplicated code from the above part of the loop. 1650: # Go through and remove duplications then remove this code 1651: if (exists $spec->{memberof} && ref $spec->{memberof} eq 'ARRAY' && @{$spec->{memberof}}) { 1652: # Generate edge cases for memberof 1653: # inside values 1654: foreach my $val (@{$input{memberof}}) { 1655: push @cases, 1656: { %mandatory_args, ( $field => $val ) }, 1657: { %mandatory_args, ( $field => " $val", _LINE => __LINE__, _STATUS => 'DIES' ) }, 1658: { %mandatory_args, ( $field => "$val ", _LINE => __LINE__, _STATUS => 'DIES' ) }, 1659: { %mandatory_args, ( $field => substr($val, 0, -1), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1660: if($val =~ /[A-Z]/) { 1661: push @cases, { %mandatory_args, ( $field => lc($val), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1662: } 1663: if($val =~ /[a-z]/) { 1664: push @cases, { %mandatory_args, ( $field => uc($val), _LINE => __LINE__, _STATUS => 'DIES' ) }; 1665: } 1666: } 1667: # outside value 1668: my $outside; 1669: if ($type eq 'integer' || $type eq 'number') { 1670: $outside = (sort { $a <=> $b } @{$spec->{memberof}})[-1] + 1; 1671: } else { 1672: $outside = 'INVALID_MEMBEROF'; 1673: } 1674: push @cases, { %mandatory_args, ( $field => $outside, _STATUS => 'DIES' ) }; 1675: } else { 1676: # Generate edge cases for min/max 1677: if($type eq 'integer') { 1678: push @cases, @{_generate_integer_cases($field, $spec, \%mandatory_args, _LINE => __LINE__)}; 1679: } elsif(($type eq 'number') || ($type eq 'float')) { 1680: push @cases, @{_generate_float_cases($field, $spec, \%mandatory_args, _LINE => __LINE__)}; 1681: } elsif($type eq 'string') { 1682: push @cases, @{_generate_string_cases($field, $spec, \%mandatory_args)}; 1683: } elsif ($type eq 'arrayref') { 1684: if (defined $spec->{min}) { 1685: my $len = $spec->{min}; 1686: push @cases, 1687: { $field => [ (1) x ($len + 1) ] }, # just inside 1688: { $field => [ (1) x $len ] }; # border 1689: push @cases, { $field => [ (1) x ($len - 1) ], _STATUS => 'DIES' } if $len > 0; # outside 1690: } else { 1691: push @cases, { $field => [] } if($config{'test_empty'}); # No min, empty array should be allowable 1692: } 1693: if (defined $spec->{max}) { 1694: my $len = $spec->{max}; 1695: push @cases, 1696: { $field => [ (1) x ($len - 1) ] }, # just inside 1697: { $field => [ (1) x $len ] }, # border 1698: { $field => [ (1) x ($len + 1) ], _STATUS => 'DIES' }; # outside 1699: } 1700: } elsif ($type eq 'hashref') { 1701: if (defined $spec->{min}) { 1702: my $len = $spec->{min}; 1703: push @cases, 1704: { $field => { map { "k$_" => 1 }, 1 .. ($len + 1) } }, 1705: { $field => { map { "k$_" => 1 }, 1 .. $len } }; 1706: push @cases, { $field => { map { "k$_" => 1 }, 1 .. ($len - 1) }, _STATUS => 'DIES' } if $len > 0; 1707: } else { 1708: push @cases, { $field => {} } if($config{'test_empty'}); # No min, empty hash should be allowable 1709: } 1710: if (defined $spec->{max}) { 1711: my $len = $spec->{max}; 1712: push @cases, 1713: { $field => { map { "k$_" => 1 }, 1 .. ($len - 1) } }, 1714: { $field => { map { "k$_" => 1 }, 1 .. $len } }, 1715: { $field => { map { "k$_" => 1 }, 1 .. ($len + 1) }, _STATUS => 'DIES' }; 1716: } 1717: } elsif ($type eq 'boolean') { 1718: push @cases, @{_generate_boolean_cases($field, $spec, \%mandatory_args)}; 1719: } 1720: } 1721: 1722: # case_sensitive tests for memberof 1723: if (defined $spec->{memberof} && exists $spec->{case_sensitive}) { 1724: if (!$spec->{case_sensitive}) { 1725: # Generate mixed-case versions of memberof values 1726: foreach my $val (@{$spec->{memberof}}) { 1727: push @cases, { %mandatory_args, ( $field => uc($val) ) }, 1728: { %mandatory_args, ( $field => lc($val) ) }, 1729: { %mandatory_args, ( $field => ucfirst(lc($val)) ) }; 1730: } 1731: } 1732: } 1733: 1734: # Add notmemberof tests 1735: if (defined $spec->{notmemberof}) { 1736: my @blacklist = @{$spec->{notmemberof}}; 1737: # Each blacklisted value should die 1738: foreach my $val (@blacklist) { 1739: push @cases, { %mandatory_args, ( $field => $val, _STATUS => 'DIES' ) }; 1740: } 1741: # Non-blacklisted value should pass 1742: push @cases, { %mandatory_args, ( $field => '_not_in_blacklist_' ) }; 1743: } 1744: 1745: # semantic tests 1746: if(defined(my $semantic = $spec->{'semantic'})) { 1747: if($semantic eq 'unix_timestamp') { 1748: push @cases, { %mandatory_args, ( -1, _STATUS => 'DIES' ) }, 1749: { %mandatory_args, ( 0 ) }, 1750: { %mandatory_args, ( 1 ) }, 1751: { %mandatory_args, ( time ) }, 1752: { %mandatory_args, ( 2147483647 ) }, 1753: { %mandatory_args, ( 45.67, _STATUS => 'DIES', _DESCRIPTION => 'UNIX timestamp should not be a float' ) }, 1754: { %mandatory_args, ( 2147483648, _STATUS => 'DIES' ) }; 1755: } else { 1756: diag("semantic type $semantic is not yet supported"); 1757: } 1758: } 1759: if(@relationships) { 1760: diag('Run relationship tests') if($ENV{'TEST_VERBOSE'}); 1761: 1762: foreach my $rel (@relationships) { 1763: my $type = $rel->{type}; 1764: 1765: if($type eq 'mutually_exclusive') { 1766: my ($p1, $p2) = @{ $rel->{params} }; 1767: # Both specified — should die 1768: run_test( 1769: { _STATUS => 'DIES', 1770: _DESCRIPTION => "mutually exclusive: $p1 and $p2 both given" }, 1771: { %mandatory_args, $p1 => 'val1', $p2 => 'val2' }, 1772: \%output, 1773: $positions 1774: ); 1775: # Each alone — should live 1776: run_test( 1777: { _DESCRIPTION => "mutually exclusive: only $p1 given" }, 1778: { %mandatory_args, $p1 => 'val1' }, 1779: \%output, 1780: $positions 1781: ); 1782: run_test( 1783: { _DESCRIPTION => "mutually exclusive: only $p2 given" }, 1784: { %mandatory_args, $p2 => 'val2' }, 1785: \%output, 1786: $positions 1787: ); 1788: 1789: } elsif($type eq 'required_group') { 1790: my @params = @{ $rel->{params} }; 1791: # None specified — should die 1792: my %none = map { $_ => undef } @params; 1793: run_test( 1794: { _STATUS => 'DIES', 1795: _DESCRIPTION => 'required_group: none of (' . join(', ', @params) . ') given' }, 1796: { %mandatory_args, %none }, 1797: \%output, 1798: $positions 1799: ); 1800: # Each alone — should live 1801: foreach my $p (@params) { 1802: run_test( 1803: { _DESCRIPTION => "required_group: only $p given" }, 1804: { %mandatory_args, $p => 'val' }, 1805: \%output, 1806: $positions 1807: ); 1808: } 1809: 1810: } elsif($type eq 'conditional_requirement') { 1811: my ($if_param, $then_param) = ($rel->{if}, $rel->{then_required}); 1812: # if_param set, then_param missing — should die 1813: run_test( 1814: { _STATUS => 'DIES', 1815: _DESCRIPTION => "conditional: $if_param set but $then_param missing" }, 1816: { %mandatory_args, $if_param => 'val', $then_param => undef }, 1817: \%output, 1818: $positions 1819: ); 1820: # Both set — should live 1821: run_test( 1822: { _DESCRIPTION => "conditional: $if_param and $then_param both set" }, 1823: { %mandatory_args, $if_param => 'val', $then_param => 'val' }, 1824: \%output, 1825: $positions 1826: ); 1827: # if_param absent — then_param absence should not matter 1828: run_test( 1829: { _DESCRIPTION => "conditional: $if_param absent so $then_param not required" }, 1830: { %mandatory_args, $then_param => undef }, 1831: \%output, 1832: $positions 1833: ); 1834: 1835: } elsif($type eq 'dependency') { 1836: my ($param, $requires) = ($rel->{param}, $rel->{requires}); 1837: # param set, requires missing — should die 1838: run_test( 1839: { _STATUS => 'DIES', 1840: _DESCRIPTION => "dependency: $param set but $requires missing" }, 1841: { %mandatory_args, $param => 'val', $requires => undef }, 1842: \%output, 1843: $positions 1844: ); 1845: # Both set — should live 1846: run_test( 1847: { _DESCRIPTION => "dependency: $param and $requires both set" }, 1848: { %mandatory_args, $param => 'val', $requires => 'val' }, 1849: \%output, 1850: $positions 1851: ); 1852: 1853: } elsif($type eq 'value_constraint') { 1854: my ($if_param, $then_param, $op, $val) = 1855: ($rel->{if}, $rel->{then}, $rel->{operator}, $rel->{value}); 1856: # if_param set, then_param wrong value — should die 1857: my $wrong_val = ($op eq '==') ? $val + 1 : $val - 1; 1858: run_test( 1859: { _STATUS => 'DIES', 1860: _DESCRIPTION => "value_constraint: $if_param set, $then_param = $wrong_val (wrong)" }, 1861: { %mandatory_args, $if_param => 'val', $then_param => $wrong_val }, 1862: \%output, 1863: $positions 1864: ); 1865: # if_param set, then_param correct value — should live 1866: run_test( 1867: { _DESCRIPTION => "value_constraint: $if_param set, $then_param = $val (correct)" }, 1868: { %mandatory_args, $if_param => 'val', $then_param => $val }, 1869: \%output, 1870: $positions 1871: ); 1872: 1873: } elsif($type eq 'value_conditional') { 1874: my ($if_param, $equals, $then_param) = 1875: ($rel->{if}, $rel->{equals}, $rel->{then_required}); 1876: # if_param equals trigger value, then_param missing — should die 1877: run_test( 1878: { _STATUS => 'DIES', 1879: _DESCRIPTION => "value_conditional: $if_param='$equals', $then_param missing" }, 1880: { %mandatory_args, $if_param => $equals, $then_param => undef }, 1881: \%output, 1882: $positions 1883: ); 1884: # if_param equals trigger value, then_param present — should live 1885: run_test( 1886: { _DESCRIPTION => "value_conditional: $if_param='$equals', $then_param present" }, 1887: { %mandatory_args, $if_param => $equals, $then_param => 'val' }, 1888: \%output, 1889: $positions 1890: ); 1891: # if_param different value — then_param absence should not matter 1892: run_test( 1893: { _DESCRIPTION => "value_conditional: $if_param != '$equals', $then_param not required" }, 1894: { %mandatory_args, $if_param => '__other__', $then_param => undef }, 1895: \%output, 1896: $positions 1897: ); 1898: } 1899: } 1900: } 1901: } 1902: } 1903: 1904: return \@cases; 1905: } 1906: 1907: sub populate_positions 1908: { 1909: my $input = shift; 1910: 1911: my $rc; 1912: foreach my $arg (keys %{$input}) { 1913: my $spec = $input->{$arg} || {}; 1914: if(((ref($spec)) eq 'HASH') && defined($spec->{'position'})) { 1915: $rc->{$arg} = $spec->{'position'}; 1916: } else { 1917: if($rc) { 1918: ::diag("$arg is missing a position parameter in its schema"); 1919: } 1920: return; # All must be defined 1921: } 1922: } 1923: 1924: return $rc; 1925: } 1926: 1927: sub run_test 1928: { 1929: my($case, $input, $output, $positions) = @_; 1930: 1931: if($ENV{'TEST_VERBOSE'}) { 1932: diag('input: ', Dumper($input)); 1933: } 1934: 1935: my $name = delete local $case->{'_NAME'}; 1936: my $properties = delete local $case->{_PROPERTIES}; 1937: my $description = delete local $case->{_DESCRIPTION}; 1938: my $result; 1939: my $mess; 1940: my @alist = (); 1941: if(defined($input) && !ref($input)) { 1942: # $mess is later used as a sprintf() format string further 1943: # below — a literal '%' in $name/$input must be escaped to 1944: # '%%' first, the same as the aggregate branch does for 1945: # $args, or a value like '%s' / '%n' corrupts the sprintf call. 1946: (my $safe_input = $input) =~ s/%/%%/g; 1947: if($name) { 1948: (my $safe_name = $name) =~ s/%/%%/g; 1949: $mess = "[% function %]($safe_name = '$safe_input') %s"; 1950: } else { 1951: $mess = "[% function %]('$safe_input') %s"; 1952: } 1953: } elsif(defined($input)) { 1954: if($positions) { 1955: # Positional args 1956: foreach my $key (keys %{$input}) { 1957: if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES') && ($key ne '_DESCRIPTION')) { 1958: if(exists($positions->{$key})) { 1959: $alist[$positions->{$key}] = delete $input->{$key}; 1960: } else { 1961: diag("Lost position number for $key"); 1962: } 1963: } 1964: } 1965: @alist = grep { defined $_ } @alist; # Undefs will cause not enough args to be sent, which is a nice test 1966: $input = join(', ', @alist); 1967: } else { 1968: # Named args 1969: if(ref($input) ne 'HASH') { 1970: if($case->{'_STATUS'} ne 'DIES') { 1971: die('Input is missing list of arguments (perhaps you only listed types)'); 1972: } 1973: # 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 1974: $positions = {}; 1975: $alist[0] = $input; 1976: } else { 1977: foreach my $key (sort keys %{$input}) { 1978: if(($key ne '_STATUS') && ($key ne '_NAME') && ($key ne '_LINE') && ($key ne '_PROPERTIES')) { 1979: if(defined($input->{$key})) { 1980: push @alist, "'$key' => '$input->{$key}'"; 1981: } else { 1982: push @alist, "'$key' => undef"; 1983: } 1984: } 1985: } 1986: } 1987: } 1988: my $args = join(', ', @alist); 1989: $args =~ s/%/%%/g; 1990: $mess = "[% function %]($args) %s"; 1991: } else { 1992: $mess = "[% function %] %s"; 1993: } 1994: 1995: my $status = delete $case->{'_STATUS'} || $output->{'_STATUS'}; 1996: my $line = delete $case->{'_LINE'}; 1997: my %ENV_before = %ENV; 1998: my $cwd_before = Cwd::getcwd(); 1999: 2000: local $SIG{ALRM} = sub { die '__TIMEOUT__' }; 2001: if((!defined($config{timeout})) || ($config{timeout} > 0)) { 2002: alarm($config{'timeout'} // 10); 2003: } 2004: my $old_warn = $SIG{__WARN__}; 2005: my $old_die = $SIG{__DIE__}; 2006: my $ok = eval { 2007: if(defined($status)) { 2008: if($status eq 'DIES') { 2009: my $err; 2010: if($positions) { 2011: [% IF position_code %] 2012: if(defined($name)) { 2013: dies_ok { [% position_code %] } sprintf($mess, "dies (position test) - $name (status = DIES)"); 2014: } else { 2015: dies_ok { [% position_code %] } sprintf($mess, 'dies (position test, status = DIES)'); 2016: } 2017: $err = $@; 2018: [% ELSE %] 2019: ok(0, 'dies: position_code not defined'); 2020: [% END %] 2021: } else { 2022: dies_ok { [% call_code %] } sprintf($mess, 'dies'); 2023: $err = $@; 2024: ok(!defined($result)); 2025: } 2026: ok(defined($err)); 2027: ok(length($err)); 2028: ok(!ref($err)); 2029: if(defined($name)) { 2030: unlike($err, qr/unitialized/, "$name doesn't involve an uninitialized variable"); 2031: } else { 2032: unlike($err, qr/unitialized/, "Test doesn't involve an uninitialized variable"); 2033: } 2034: return; # There should be no output to validate 2035: } elsif($status eq 'WARNS') { 2036: warnings_exist { [% call_code %] } qr/./, sprintf($mess, 'warns'); 2037: } else { 2038: die 'TODO: properties' if(scalar keys %{$properties}); 2039: if($positions) { 2040: [% IF position_code %] 2041: if(defined($name)) { 2042: lives_ok { [% position_code %] } sprintf($mess, "survives (position test) - $name (status = LIVES)"); 2043: } else { 2044: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test, status = LIVES)'); 2045: } 2046: [% ELSE %] 2047: ok(0, 'position_code not defined'); 2048: [% END %] 2049: } elsif(defined($description)) { 2050: lives_ok { [% call_code %] } sprintf($mess, "survives ($description; status = LIVES)"); 2051: } elsif(defined($line)) { 2052: lives_ok { [% call_code %] } sprintf($mess, "survives (line = $line; status = LIVES)"); 2053: } else { 2054: lives_ok { [% call_code %] } sprintf($mess, 'survives (status = LIVES)'); 2055: } 2056: if($properties->{idempotent}) { 2057: [% determinism_code %] 2058: } 2059: } 2060: } elsif($positions) { 2061: if(defined($name)) { 2062: lives_ok { [% position_code %] } sprintf($mess, "survives (position test) - $name"); 2063: if($properties->{idempotent} && (scalar(@alist) == 1)) { 2064: [% UNLESS module %] 2065: ok([% function %]($alist[0]) eq [% function %]([% function %]($alist[0])), 'function is idempotent'); 2066: ok([% function %]($alist[0]) eq [% function %]($alist[0]), 'function is idempotent'); 2067: [% END %] 2068: } 2069: } else { 2070: die 'TODO: properties' if(scalar keys %{$properties}); 2071: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test)'); 2072: 2073: # An extra argument should be ignored, except for getsetters, so only test if there's more than one arg 2074: if(scalar(@alist) > 1) { 2075: push(@alist, 'foo'); 2076: lives_ok { [% position_code %] } sprintf($mess, 'survives (position test, with extra argument)'); 2077: } 2078: } 2079: if($properties->{idempotent}) { 2080: [% determinism_code %] 2081: } 2082: } else { 2083: # Status not given, assume set to LIVES 2084: die 'TODO: properties' if(scalar keys %{$properties}); 2085: if(defined($description)) { 2086: lives_ok { [% call_code %] } sprintf($mess, "survives ($description)"); 2087: } elsif(defined($line)) { 2088: lives_ok { [% call_code %] } sprintf($mess, "survives (line = $line)"); 2089: } else { 2090: lives_ok { [% call_code %] } sprintf($mess, 'survives'); 2091: } 2092: if($properties->{idempotent}) { 2093: [% determinism_code %] 2094: } 2095: } 2096: 1; 2097: }; 2098: 2099: alarm 0; 2100: 2101: # Check the test did not timeout 2102: diag($@) if($@); 2103: ok((!defined($@)) || (length($@) == 0)); 2104: 2105: # Global side effect detection 2106: is(Cwd::getcwd(), $cwd_before, 'cwd not modified'); 2107: is_deeply(_filtered_env(\%ENV), _filtered_env(\%ENV_before), 'ENV not modified'); 2108: is($SIG{__WARN__}, $old_warn, 'warn handler is not changed'); 2109: is($SIG{__DIE__}, $old_die, 'die handler is not changed'); 2110: 2111: delete local $output->{'_STATUS'}; 2112: 2113: if(scalar keys %{$output}) { 2114: if($ENV{'TEST_VERBOSE'}) { 2115: diag('result: ', Dumper($result)); 2116: } 2117: returns_ok($result, $output, 'output validates'); 2118: if(((!defined($status)) || ($status eq 'OK')) && defined($result)) { 2119: is( 2120: Unicode::Normalize::NFC($result), 2121: Unicode::Normalize::NFC(Unicode::Normalize::NFD($result)), 2122: 'Unicode normalization stable' 2123: ); 2124: } 2125: } 2126: } 2127: 2128: # On Windows $PWD etc are not stable 2129: sub _filtered_env { 2130: my %env = %{ shift() }; 2131: 2132: if($^O eq 'MSWin32') { 2133: delete @env{ 2134: qw( 2135: PWD 2136: OLDPWD 2137: _ 2138: SHLVL 2139: ) 2140: }; 2141: } 2142: 2143: return \%env; 2144: } 2145: 2146: diag('Run Fuzz Tests') if($ENV{'TEST_VERBOSE'}); 2147: 2148: foreach my $case (@{fuzz_inputs()}) { 2149: # my %params; 2150: # lives_ok { %params = get_params(\%input, %$case) } 'Params::Get input check'; 2151: # lives_ok { validate_strict(\%input, %params) } 'Params::Validate::Strict input check'; 2152: 2153: my $input; 2154: if((ref($case) eq 'HASH') && exists($case->{'_input'})) { 2155: $input = $case->{'_input'}; 2156: } else { 2157: $input = $case; 2158: } 2159: 2160: if(my $line = ($case->{'_LINE'} || $input{'_LINE'})) { 2161: diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'}); 2162: } 2163: if(my $description = ($case->{'_DESCRIPTION'} || $input{'_DESCRIPTION'})) { 2164: diag("Test case $description") if($ENV{'TEST_VERBOSE'}); 2165: } 2166: 2167: { 2168: # local %ENV; 2169: run_test($case, $input, \%output, $positions); 2170: # delete $ENV{'LANG'}; 2171: # delete $ENV{'LC_ALL'}; 2172: # run_test($case, $input, \%output, $positions); 2173: # $ENV{'LANG'} = 'fr_FR.utf8'; 2174: # $ENV{'LC_ALL'} = 'fr_FR.utf8'; 2175: # run_test($case, $input, \%output, $positions); 2176: } 2177: } 2178: 2179: if(scalar(keys %transforms)) { 2180: diag('Run ', scalar(keys %transforms), ' transform tests'); 2181: } 2182: # diag('-' x 60); 2183: 2184: # Build the foundation - which is a basic test with sensible defaults in the field 2185: foreach my $transform (keys %transforms) { 2186: my $foundation = _fill_foundation(); # basic set of data with every field filled in with a sensible default value 2187: 2188: # The foundation should work 2189: my $case = { _NAME => "basic $transform test", _LINE => __LINE__ }; 2190: my $positions = populate_positions(\%input); 2191: run_test($case, $foundation, \%output, $positions); 2192: 2193: # Generate transform tests 2194: # Don't generate invalid data, that's all already done, 2195: # this is about verifying the transorms 2196: my @tests; 2197: diag("tests for transform $transform") if($ENV{'TEST_VERBOSE'}); 2198: 2199: # Now modify the foundation with test code 2200: 2201: # BUILD CODE TO CALL FUNCTION 2202: # CALL FUNCTION 2203: # CHECK STATUS CORRECT 2204: # IF STATUS EQ LIVES 2205: # CHECK OUTPUT USING returns_ok 2206: # FI 2207: 2208: my $transform_input = $transforms{$transform}{'input'} || {}; 2209: 2210: foreach my $field (keys %input) { 2211: my $spec = $transform_input->{$field} || {}; 2212: my $type = $spec->{type} || 'string'; 2213: 2214: # If there's a specific value, test that exact value 2215: if (exists $spec->{value}) { 2216: push @tests, { 2217: %{$foundation}, 2218: $field => $spec->{value}, 2219: _LINE => __LINE__, 2220: _DESCRIPTION => "$transform: $field=$spec->{value}" 2221: }; 2222: next; 2223: } 2224: 2225: # Generate edge cases based on type and contraints 2226: if($type eq 'integer') { 2227: push @tests, @{_generate_integer_cases($field, $spec, $foundation)}; 2228: } elsif(($type eq 'number') || ($type eq 'float')) { 2229: push @tests, @{_generate_float_cases($field, $spec, $foundation, _LINE => __LINE__)}; 2230: } elsif($type eq 'string') { 2231: push @tests, @{_generate_string_cases($field, $spec, $foundation)}; 2232: } elsif($type eq 'boolean') { 2233: push @tests, @{_generate_boolean_cases($field, $spec, $foundation)}; 2234: } elsif ($type eq 'arrayref') { 2235: if(defined $spec->{min}) { 2236: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min} + 1) ) }; # just inside 2237: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{min}) ) }; # border 2238: } else { 2239: push @tests, { %{$foundation}, ( $field => rand_arrayref() ) }; 2240: } 2241: if(defined $spec->{max}) { 2242: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max} - 1) ) }; # just inside 2243: if((defined $spec->{min}) && ($spec->{'min'} != $spec->{'max'})) { 2244: push @tests, { %{$foundation}, ( $field => rand_arrayref($spec->{max}) ) }; # border 2245: } 2246: } 2247: } else { 2248: die("TODO: transform type $type for test case"); 2249: } 2250: } 2251: 2252: if($config{dedup}) { 2253: @tests = @{_dedup_cases(\@tests)}; 2254: } 2255: 2256: { 2257: # local %ENV; 2258: my $transform_output = $transforms{$transform}{'output'} || {}; 2259: my $properties_array_ref = $transforms{$transform}{properties}; 2260: 2261: my $properties = {}; 2262: if($properties_array_ref) { 2263: $properties->{idempotent} = (grep { $_ eq 'idempotent'} @{$properties_array_ref}) ? 1 : 0; 2264: } 2265: 2266: foreach my $test(@tests) { 2267: if(my $line = (delete $test->{'_LINE'} || delete $input{'_LINE'})) { 2268: diag("Test case from line number $line") if($ENV{'TEST_VERBOSE'}); 2269: } 2270: 2271: run_test({ _NAME => $transform, _PROPERTIES => $properties }, $test, $transform_output, $positions); 2272: # delete $ENV{'LANG'}; 2273: # delete $ENV{'LC_ALL'}; 2274: # run_test({ _NAME => $transform }, $test, \%output, $positions); 2275: # $ENV{'LANG'} = 'de_DE.utf8'; 2276: # $ENV{'LC_ALL'} = 'de_DE.utf8'; 2277: # run_test({ _NAME => $transform }, $test, \%output, $positions); 2278: } 2279: } 2280: } 2281: 2282: sub _fill_foundation 2283: { 2284: my $foundation; 2285: 2286: foreach my $field (keys %input) { 2287: my $spec = $input{$field} || {}; 2288: my $type = $spec->{type} || 'string'; 2289: 2290: if(($type eq 'number') || ($type eq 'float')) { 2291: if(defined $spec->{min}) { 2292: if(defined $spec->{max}) { 2293: $foundation->{$field} = $spec->{max}; # border 2294: } else { 2295: $foundation->{$field} = rand_num() + $spec->{'min'}; 2296: } 2297: } else { 2298: if(defined $spec->{max}) { 2299: $foundation->{$field} = $spec->{max}; # border 2300: } else { 2301: $foundation->{$field} = -0.01; # No min, so -0.01 should be allowable 2302: } 2303: } 2304: } elsif($type eq 'string') { 2305: if(defined $spec->{min} && $spec->{min} > 0) { 2306: $foundation->{$field} = rand_str($spec->{min}); 2307: } elsif(defined $spec->{max} && $spec->{max} > 0) { 2308: $foundation->{$field} = rand_str($spec->{max}); 2309: } else { 2310: $foundation->{$field} = 'test_value'; 2311: } 2312: } elsif ($type eq 'integer') { 2313: if (defined $spec->{min}) { 2314: $foundation->{$field} = $spec->{min}; 2315: } elsif (defined $spec->{max}) { 2316: $foundation->{$field} = rand_int() + $spec->{max}; 2317: } else { 2318: $foundation->{$field} = rand_int(); 2319: } 2320: } elsif ($type eq 'boolean') { 2321: $foundation->{$field} = 1; 2322: } elsif ($type eq 'arrayref') { 2323: $foundation->{$field} = rand_arrayref(defined($spec->{'min'}) ? $spec->{'min'} : ($spec->{'max'} // 5)); 2324: } elsif ($type eq 'hashref') { 2325: $foundation->{$field} = { key => 'value' }; 2326: } else { 2327: die("TODO: transform type $type for foundation"); 2328: } 2329: } 2330: return $foundation; 2331: } 2332: 2333: [% IF use_properties %] 2334: # ============================================================ 2335: # Property-Based Transform Tests (Test::LectroTest) 2336: # ============================================================ 2337: 2338: use Test::LectroTest::Compat; 2339: use Test::LectroTest::Generator qw(:common); 2340: use Scalar::Util qw(looks_like_number); 2341: 2342: diag('Run property-based transform tests') if($ENV{'TEST_VERBOSE'}); 2343: 2344: [% transform_properties_code %] 2345: 2346: [% END %] 2347: 2348: [% corpus_code %] 2349: 2350: done_testing(); 2351: 2352: 1; 2353: 2354: package MyTestPackage; 2355: 2356: sub new { return bless {}, 'MyTestPackage' } 2357: 2358: 1; 2359: __END__