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