1#!./parrot 2# Copyright (C) 2001-2010, Parrot Foundation. 3 4=head1 NAME 5 6t/op/string.t - Parrot Strings 7 8=head1 SYNOPSIS 9 10 % prove t/op/string.t 11 12=head1 DESCRIPTION 13 14Tests Parrot string registers and operations. 15 16=cut 17 18.include 'except_types.pasm' 19 20.sub main :main 21 .include 'test_more.pir' 22 23 set_s_s_sc() 24 test_clone() 25 clone_null() 26 test_length_i_s() 27 zero_length_substr() 28 chopn_with_clone() 29 chopn_oob_values() 30 three_argument_chopn() 31 three_argument_chopn__oob_values() 32 substr_tests() 33 neg_substr_offset() 34 exception_substr_null_string() 35 exception_substr_oob() 36 exception_substr_oob_neg() 37 len_greater_than_strlen() 38 len_greater_than_strlen_neg_offset() 39 replace_w_rep_eq_length() 40 replace_w_replacement_gt_length() 41 replace_w_replacement_lt_length() 42 replace_vs_hash() 43 replace__offset_at_end_of_string() 44 exception_replace__offset_past_end_of_string() 45 replace_neg_offset_repl_eq_length() 46 replace_neg_offset_repl_gt_length() 47 replace_neg_offset_repl_lt_length() 48 exception_replace_neg_offset_out_of_string() 49 replace_length_gt_strlen() 50 replace_length_gt_strlen_neg_offset() 51 replace_only_substr() 52 three_arg_substr() 53 exception_substr__pos_offset_zero_length_string() 54 substr_offset_zero_zero_length_string() 55 exception_substr_offset_one_zero_length_string() 56 exception_substr_neg_offset_zero_length_string() 57 exception_substr_oob_utf8() 58 zero_length_substr_zero_length_string() 59 zero_length_substr_zero_length_string() 60 three_arg_substr_zero_length_string() 61 replace_zero_length_string() 62 four_arg_substr_replace_zero_length_string() 63 concat_s_s_sc_null_onto_null() 64 concat_s_sc_repeated_two_arg_concats() 65 concat_s_s_sc_foo_one_onto_null() 66 test_concat_s_s_sc() 67 concat_s_s_sc_s_sc() 68 concat_ensure_copy_is_made() 69 70 same_constant_twice_bug() 71 exception_two_param_ord_empty_string() 72 exception_two_param_ord_empty_string_register() 73 exception_three_param_ord_empty_string() 74 exception_three_param_ord_empty_string_register() 75 two_param_ord_one_character_string() 76 two_param_ord_multi_character_string() 77 two_param_ord_one_character_string_register() 78 three_param_ord_one_character_string() 79 three_param_ord_one_character_string_register() 80 three_param_ord_multi_character_string() 81 three_param_ord_multi_character_string_register() 82 exception_three_param_ord_multi_character_string() 83 exception_three_param_ord_multi_character_string() 84 three_param_ord_one_character_string_from_end() 85 three_param_ord_one_character_string_register_from_end() 86 three_param_ord_multi_character_string_from_end() 87 three_param_ord_multi_character_string_register_from_end() 88 exception_three_param_ord_multi_character_string_register_from_end_oob() 89 chr_of_thirty_two_is_space_in_ascii() 90 chr_of_sixty_five_is_a_in_ascii() 91 chr_of_one_hundred_and_twenty_two_is_z_in_ascii() 92 test_if_s_ic() 93 repeat_s_s_sc_i_ic() 94 exception_repeat_oob() 95 exception_repeat_oob_repeat_p_p_p() 96 exception_repeat_oob_repeate_p_p_i() 97 encodingname_oob() 98 index_three_arg_form() 99 index_four_arg_form() 100 index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen() 101 index_trac_1482() 102 index_null_strings() 103 index_embedded_nulls() 104 index_big_strings() 105 index_big_hard_to_match_strings() 106 index_with_different_charsets() 107 negative_index_bug_35959() 108 index_multibyte_matching() 109 index_multibyte_matching_two() 110 num_to_string() 111 string_to_int() 112 string_to_num() 113 concat_or_substr_cow() 114 constant_to_cstring() 115 cow_with_chopn_leaving_original_untouched() 116 check_that_bug_bug_16874_was_fixed() 117 stress_concat() 118 ord_and_substring_see_bug_17035() 119 120 test_sprintf() 121 other_form_of_sprintf_op() 122 sprintf_left_justify() 123 correct_precision_for_sprintf_x() 124 test_find_encoding() 125 test_assign() 126 assign_and_globber() 127 split_on_null_string() 128 split_on_empty_string() 129 split_on_non_empty_string() 130 test_join() 131 test_join_many() 132 eq_addr_or_ne_addr() 133 test_if_null_s_ic() 134 test_upcase() 135 test_downcase() 136 test_titlecase() 137 three_param_ord_one_character_string_register_i() 138 three_param_ord_multi_character_string_i() 139 three_param_ord_multi_character_string_register_i() 140 exception_three_param_ord_multi_character_string_i() 141 exception_three_param_ord_multi_character_string_i() 142 three_param_ord_one_character_string_from_end_i() 143 three_param_ord_one_character_string_register_from_end_i() 144 three_param_ord_multi_character_string_from_end_i() 145 three_param_ord_multi_character_string_register_from_end_i() 146 exception_three_param_ord_multi_character_string_register_from_end_oob_i() 147 more_string_to_int() 148 constant_string_and_modify_in_situ_op_rt_bug_60030() 149 corner_cases_of_numification() 150 non_canonical_nan_and_inf() 151 split_hll_mapped() 152 # END_OF_TESTS 153 join_get_string_returns_a_null_string() 154 155 done_testing() 156.end 157 158.macro exception_is ( M ) 159 .local pmc exception 160 .local string message 161 .get_results (exception) 162 163 message = exception['message'] 164 is( message, .M, .M ) 165.endm 166 167.sub set_s_s_sc 168 set $S4, "JAPH" 169 set $S5, $S4 170 171 is( $S4, "JAPH", '' ) 172 is( $S5, "JAPH", '' ) 173.end 174 175.sub test_clone 176 set $S0, "Foo1" 177 clone $S1, $S0 178 179 is( $S0, "Foo1", '' ) 180 is( $S1, "Foo1", '' ) 181 182 clone $S1, "Bar1" 183 is( $S1, "Bar1", '' ) 184.end 185 186.sub clone_null 187 null $S0 188 clone $S1, $S0 189 is( $S1, $S0, '' ) 190.end 191 192.sub test_length_i_s 193 set $I4, 0 194 set $S4, "JAPH" 195 length $I4, $S4 196 is( $I4, "4", '' ) 197.end 198 199.sub zero_length_substr 200 set $I4, 0 201 set $S4, "JAPH" 202 substr $S3, $S4, 1, 0 203 length $I4, $S3 204 is( $I4, "0", '' ) 205.end 206 207.sub chopn_with_clone 208 set $S4, "JAPHxyzw" 209 set $S5, "japhXYZW" 210 clone $S3, $S4 211 set $I1, 4 212 $S4 = chopn $S4, 3 213 $S4 = chopn $S4, 1 214 $S5 = chopn $S5, $I1 215 216 is( $S4, "JAPH", '' ) 217 is( $S5, "japh", '' ) 218 is( $S3, "JAPHxyzw", '' ) 219.end 220 221.sub chopn_oob_values 222 set $S1, "A string of length 21" 223 $S1 = chopn $S1, 0 224 is( $S1, "A string of length 21", '' ) 225 226 $S1 = chopn $S1, 4 227 is( $S1, "A string of lengt", '' ) 228 229 # -length cuts now 230 $S1 = chopn $S1, -4 231 is( $S1, "A st", '' ) 232 233 $S1 = chopn $S1, 1000 234 is( $S1, "", '' ) 235.end 236 237.sub three_argument_chopn 238 set $S1, "Parrot" 239 chopn $S2, $S1, 0 240 is( $S1, "Parrot", '' ) 241 is( $S2, "Parrot", '' ) 242 243 chopn $S2, $S1, 1 244 is( $S1, "Parrot", '' ) 245 is( $S2, "Parro", '' ) 246 247 set $I0, 2 248 chopn $S2, $S1, $I0 249 is( $S1, "Parrot", '' ) 250 is( $S2, "Parr", '' ) 251 252 chopn $S2, "Parrot", 3 253 is( $S2, "Par", '' ) 254 255 chopn $S1, $S1, 5 256 is( $S1, "P", '' ) 257 258 set $S1, "Parrot" 259 set $S3, $S1 260 chopn $S2, $S1, 3 261 is( $S3, "Parrot", '' ) 262.end 263# 264.sub three_argument_chopn__oob_values 265 set $S1, "Parrot" 266 chopn $S2, $S1, 7 267 is( $S1, "Parrot", '' ) 268 is( $S2, "", '' ) 269 270 chopn $S2, $S1, -1 271 is( $S1, "Parrot", '' ) 272 is( $S2, "P", '' ) 273.end 274 275.sub substr_tests 276 set $S4, "12345JAPH01" 277 set $I4, 5 278 set $I5, 4 279 280 substr $S5, $S4, $I4, $I5 281 is( $S5, "JAPH", '' ) 282 283 substr $S5, $S4, $I4, 4 284 is( $S5, "JAPH", '' ) 285 286 substr $S5, $S4, 5, $I5 287 is( $S5, "JAPH", '' ) 288 289 substr $S5, $S4, 5, 4 290 is( $S5, "JAPH", '' ) 291 292 substr $S5, "12345JAPH01", $I4, $I5 293 is( $S5, "JAPH", '' ) 294 295 substr $S5, "12345JAPH01", $I4, 4 296 is( $S5, "JAPH", '' ) 297 298 substr $S5, "12345JAPH01", 5, $I5 299 is( $S5, "JAPH", '' ) 300 301 substr $S5, "12345JAPH01", 5, 4 302 is( $S5, "JAPH", '' ) 303.end 304 305# negative offsets 306.sub neg_substr_offset 307 set $S0, "A string of length 21" 308 set $I0, -9 309 set $I1, 6 310 substr $S1, $S0, $I0, $I1 311 is( $S0, "A string of length 21", '' ) 312 is( $S1, "length", '' ) 313.end 314 315.sub exception_substr_null_string 316 .local string s 317 .local pmc eh 318 .local int r 319 null s 320 eh = new ['ExceptionHandler'] 321 eh.'handle_types'(.EXCEPTION_UNEXPECTED_NULL) 322 set_label eh, handler 323 push_eh eh 324 r = 1 325 substr s, s, 0, 0 326 r = 0 327 handler: 328 pop_eh 329 is(r, 1, "substr with null string throws" ) 330.end 331 332# This asks for substring that shouldn't be allowed... 333.sub exception_substr_oob 334 .local pmc eh 335 .local int r 336 set $S0, "A string of length 21" 337 set $I0, 99 338 set $I1, 6 339 eh = new ['ExceptionHandler'] 340 eh.'handle_types'(.EXCEPTION_SUBSTR_OUT_OF_STRING) 341 set_label eh, handler 342 push_eh eh 343 r = 1 344 345 substr $S1, $S0, $I0, $I1 346 r = 0 347 handler: 348 pop_eh 349 is(r, 1, "substr outside string throws" ) 350.end 351 352# This asks for substring that shouldn't be allowed... 353.sub exception_substr_oob_neg 354 .local pmc eh 355 .local int r 356 set $S0, "A string of length 21" 357 set $I0, -99 358 set $I1, 6 359 eh = new ['ExceptionHandler'] 360 eh.'handle_types'(.EXCEPTION_SUBSTR_OUT_OF_STRING) 361 set_label eh, handler 362 push_eh eh 363 r = 1 364 365 substr $S1, $S0, $I0, $I1 366 r = 0 367 handler: 368 pop_eh 369 is(r, 1, "substr outside string throws - negative" ) 370.end 371 372# This asks for substring much greater than length of original string 373.sub len_greater_than_strlen 374 set $S0, "A string of length 21" 375 set $I0, 12 376 set $I1, 1000 377 substr $S1, $S0, $I0, $I1 378 is( $S0, "A string of length 21", '' ) 379 is( $S1, "length 21", '' ) 380.end 381 382# The same, with a negative offset 383.sub len_greater_than_strlen_neg_offset 384 set $S0, "A string of length 21" 385 set $I0, -9 386 set $I1, 1000 387 substr $S1, $S0, $I0, $I1 388 is( $S0, "A string of length 21", '' ) 389 is( $S1, "length 21", '' ) 390.end 391 392.sub replace_w_rep_eq_length 393 set $S0, "abcdefghijk" 394 set $S1, "xyz" 395 replace $S2, $S0, 4, 3, $S1 396 is( $S2, "abcdxyzhijk", '' ) 397.end 398 399.sub replace_w_replacement_gt_length 400 set $S0, "abcdefghijk" 401 set $S1, "xyz0123" 402 $S2 = replace $S0, 4, 3, $S1 403 is( $S2, "abcdxyz0123hijk", '' ) 404.end 405 406.sub replace_w_replacement_lt_length 407 set $S0, "abcdefghijk" 408 set $S1, "x" 409 $S2 = replace $S0, 4, 3, $S1 410 is( $S2, "abcdxhijk", '' ) 411.end 412 413.sub replace__offset_at_end_of_string 414 set $S0, "abcdefghijk" 415 set $S1, "xyz" 416 $S2 = replace $S0, 11, 3, $S1 417 is( $S2, "abcdefghijkxyz", '' ) 418.end 419 420.sub replace_vs_hash 421 # Check that string hashval properly updated. 422 .local pmc hash 423 hash = new ['Hash'] 424 $S0 = "fooo" 425 hash[$S0] = 1 426 hash["foo"] = 42 427 $S0 = replace $S0, 1, 1, '' 428 $S1 = hash[$S0] 429 is( $S1, '42', 'replace behave it self') 430.end 431 432.sub exception_replace__offset_past_end_of_string 433 set $S0, "abcdefghijk" 434 set $S1, "xyz" 435 push_eh handler 436 $S2 = replace $S0, 12, 3, $S1 437 ok(0,"no exception") 438handler: 439 .exception_is( "Can only replace inside string or index after end of string" ) 440.end 441 442.sub replace_neg_offset_repl_eq_length 443 set $S0, "abcdefghijk" 444 set $S1, "xyz" 445 $S2 = replace $S0, -3, 3, $S1 446 is( $S2, "abcdefghxyz", '' ) 447.end 448 449.sub replace_neg_offset_repl_gt_length 450 set $S0, "abcdefghijk" 451 set $S1, "xyz" 452 $S2 = replace $S0, -6, 2, $S1 453 is( $S2, "abcdexyzhijk", '' ) 454.end 455 456.sub replace_neg_offset_repl_lt_length 457 set $S0, "abcdefghijk" 458 set $S1, "xyz" 459 $S2 = replace $S0, -6, 4, $S1 460 is( $S2, "abcdexyzjk", '' ) 461.end 462 463.sub exception_replace_neg_offset_out_of_string 464 set $S0, "abcdefghijk" 465 set $S1, "xyz" 466 push_eh handler 467 $S2 = replace $S0, -12, 4, $S1 468 ok(0,"no exception") 469handler: 470 .exception_is( "Can only replace inside string or index after end of string" ) 471.end 472 473.sub replace_length_gt_strlen 474 set $S0, "abcdefghijk" 475 set $S1, "xyz" 476 $S2 = replace $S0, 3, 11, $S1 477 is( $S2, "abcxyz", '' ) 478.end 479 480.sub replace_length_gt_strlen_neg_offset 481 set $S0, "abcdefghijk" 482 set $S1, "xyz" 483 $S2 = replace $S0, -3, 11, $S1 484 is( $S2, "abcdefghxyz", '' ) 485.end 486 487.sub replace_only_substr 488 set $S0, "abcdefghijk" 489 set $S1, "xyz" 490 $S2 = replace $S0, 3, 3, $S1 491 is( $S2, "abcxyzghijk", '' ) 492.end 493 494.sub three_arg_substr 495 set $S0, "JAPH" 496 substr $S1, $S0, 2 497 is( $S1, "PH", '' ) 498.end 499 500.sub exception_substr__pos_offset_zero_length_string 501 set $S0, "" 502 push_eh handler 503 substr $S1, $S0, 10, 3 504 ok(0,"no exception") 505handler: 506 .exception_is( "Cannot take substr outside string" ) 507.end 508 509.sub substr_offset_zero_zero_length_string 510 set $S0, "" 511 substr $S1, $S0, 0, 1 512 is( $S1, "", '' ) 513.end 514 515.sub exception_substr_offset_one_zero_length_string 516 set $S0, "" 517 push_eh handler 518 substr $S1, $S0, -1, 1 519 ok(0,"no exception") 520handler: 521 .exception_is( "Cannot take substr outside string" ) 522.end 523 524.sub exception_substr_neg_offset_zero_length_string 525 set $S0, "" 526 push_eh handler 527 substr $S1, $S0, -10, 5 528handler: 529 .exception_is( "Cannot take substr outside string" ) 530.end 531 532.sub exception_substr_oob_utf8 533 set $S0, utf8:"abc\uBEEFdef" 534 push_eh handler 535 substr $S1, $S0, 8, 5 536handler: 537 .exception_is( "Cannot take substr outside string" ) 538.end 539 540.sub zero_length_substr_zero_length_string 541 set $S0, "" 542 substr $S1, $S0, 10, 0 543 is( $S1, "", '' ) 544.end 545 546.sub zero_length_substr_zero_length_string 547 set $S0, "" 548 substr $S1, $S0, -10, 0 549 is( $S1, "", '' ) 550.end 551 552.sub three_arg_substr_zero_length_string 553 set $S0, "" 554 substr $S1, $S0, 2 555 is( $S1, "", '' ) 556.end 557 558.sub replace_zero_length_string 559 set $S0, "" 560 set $S1, "xyz" 561 $S2 = replace $S0, 0, 3, $S1 562 is( $S2, "xyz", '' ) 563 564 set $S3, "" 565 set $S4, "abcde" 566 $S5 = replace $S3, 0, 0, $S4 567 is( $S5, "abcde", '' ) 568.end 569 570.sub four_arg_substr_replace_zero_length_string 571 set $S0, "" 572 set $S1, "xyz" 573 $S0 = replace $S0, 0, 3, $S1 574 is( $S0, "xyz", '' ) 575 576 set $S2, "" 577 set $S3, "abcde" 578 $S2 = replace $S2, 0, 0, $S3 579 is( $S2, "abcde", '' ) 580.end 581 582.sub concat_s_s_sc_null_onto_null 583 $S0 = concat $S0, $S0 584 is( $S0, "", '' ) 585 $S1 = concat $S1, "" 586 is( $S1, "", '' ) 587.end 588 589.sub concat_s_sc_repeated_two_arg_concats 590 set $S12, "" 591 set $I0, 0 592WHILE: 593 $S12 = concat $S12, "hi" 594 add $I0, 1 595 lt $I0, 10, WHILE 596 is( $S12, "hihihihihihihihihihi", '' ) 597.end 598 599.sub concat_s_s_sc_foo_one_onto_null 600 $S0 = concat $S0, "foo1" 601 set $S1, "foo2" 602 $S2 = concat $S2, $S1 603 is( $S0, "foo1", '' ) 604 is( $S2, "foo2", '' ) 605.end 606 607.sub test_concat_s_s_sc 608 set $S1, "fish" 609 set $S2, "bone" 610 $S1 = concat $S1, $S2 611 is( $S1, "fishbone", '' ) 612.end 613 614.sub concat_s_s_sc_s_sc 615 set $S1, "japh" 616 set $S2, "JAPH" 617 concat $S0, "japh", "JAPH" 618 is( $S0, "japhJAPH", '' ) 619 620 concat $S0, $S1, "JAPH" 621 is( $S0, "japhJAPH", '' ) 622 623 concat $S0, "japh", $S2 624 is( $S0, "japhJAPH", '' ) 625 626 concat $S0, $S1, $S2 627 is( $S0, "japhJAPH", '' ) 628.end 629 630.sub concat_ensure_copy_is_made 631 set $S2, "JAPH" 632 concat $S0, $S2, "" 633 concat $S1, "", $S2 634 $S0 = chopn $S0, 1 635 $S1 = chopn $S1, 1 636 is( $S2, "JAPH", '' ) 637.end 638 639.sub same_constant_twice_bug 640 set $S0, "" 641 set $S1, "" 642 set $S2, "foo" 643 concat $S1, $S1, $S2 644 is( $S1, "foo", 'same constant twice bug' ) 645 is( $S0, "", 'same constant twice bug' ) 646.end 647 648.sub exception_two_param_ord_empty_string 649 push_eh handler 650 ord $I0,"" 651 ok(0, 'no exception: 2-param ord, empty string' ) 652 handler: 653 .exception_is( 'Cannot get character of empty string' ) 654.end 655 656.sub exception_two_param_ord_empty_string_register 657 push_eh handler 658 ord $I0,$S0 659 ok( 0, 'no exception: 2-param ord, empty string register' ) 660 handler: 661 .exception_is( 'Invalid operation on null string' ) 662.end 663 664.sub exception_three_param_ord_empty_string 665 push_eh handler 666 ord $I0,"",0 667 ok(0, 'no exception: 3-param ord, empty string' ) 668 handler: 669 .exception_is( 'Cannot get character of empty string' ) 670.end 671 672.sub exception_three_param_ord_empty_string_register 673 push_eh handler 674 ord $I0,$S0,0 675 ok( 0, 'no exception: 3-param ord, empty string register' ) 676 handler: 677 .exception_is( 'Invalid operation on null string' ) 678.end 679 680.sub two_param_ord_one_character_string 681 ord $I0,"a" 682 is( $I0, "97", '2-param ord, one-character string' ) 683.end 684 685.sub two_param_ord_multi_character_string 686 ord $I0,"abc" 687 is( $I0, "97", '2-param ord, multi-character string' ) 688.end 689 690.sub two_param_ord_one_character_string_register 691 set $S0,"a" 692 ord $I0,$S0 693 is( $I0, "97", '2-param ord, one-character string register' ) 694.end 695 696.sub three_param_ord_one_character_string 697 ord $I0,"a",0 698 is( $I0, "97", '3-param ord, one-character string' ) 699.end 700 701.sub three_param_ord_one_character_string_register 702 set $S0,"a" 703 ord $I0,$S0,0 704 is( $I0, "97", '3-param ord, one-character string register' ) 705.end 706 707.sub three_param_ord_multi_character_string 708 ord $I0,"ab",1 709 is( $I0, "98", '3-param ord, multi-character string' ) 710.end 711 712.sub three_param_ord_multi_character_string_register 713 set $S0,"ab" 714 ord $I0,$S0,1 715 is( $I0, "98", '3-param ord, multi-character string register' ) 716.end 717 718.sub exception_three_param_ord_multi_character_string 719 push_eh handler 720 ord $I0,"ab",2 721 ok( 0, 'no exception: 3-param ord, multi-character string' ) 722 handler: 723 .exception_is( 'Cannot get character past end of string' ) 724.end 725 726.sub exception_three_param_ord_multi_character_string 727 push_eh handler 728 set $S0,"ab" 729 ord $I0,$S0,2 730 ok( 0, 'no exception: 3-param ord, multi-character string' ) 731 handler: 732 .exception_is( 'Cannot get character past end of string' ) 733.end 734 735.sub three_param_ord_one_character_string_from_end 736 ord $I0,"a",-1 737 is( $I0, "97", '3-param ord, one-character string, from end' ) 738.end 739 740.sub three_param_ord_one_character_string_register_from_end 741 set $S0,"a" 742 ord $I0,$S0,-1 743 is( $I0, "97", '3-param ord, one-character string register, from end' ) 744.end 745 746.sub three_param_ord_multi_character_string_from_end 747 ord $I0,"ab",-1 748 is( $I0, "98", '3-param ord, multi-character string, from end' ) 749.end 750 751.sub three_param_ord_multi_character_string_register_from_end 752 set $S0,"ab" 753 ord $I0,$S0,-1 754 is( $I0, "98", '3-param ord, multi-character string register, from end' ) 755.end 756 757.sub exception_three_param_ord_multi_character_string_register_from_end_oob 758 push_eh handler 759 set $S0,"ab" 760 ord $I0,$S0,-3 761 ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB' ) 762 handler: 763 .exception_is( 'Cannot get character before beginning of string' ) 764.end 765 766.sub chr_of_thirty_two_is_space_in_ascii 767 chr $S0, 32 768 is( $S0, " ", 'chr of 32 is space in ASCII' ) 769.end 770 771.sub chr_of_sixty_five_is_a_in_ascii 772 chr $S0, 65 773 is( $S0, "A", 'chr of 65 is A in ASCII' ) 774.end 775 776.sub chr_of_one_hundred_and_twenty_two_is_z_in_ascii 777 chr $S0, 122 778 is( $S0, "z", 'chr of 122 is z in ASCII' ) 779.end 780 781.sub test_if_s_ic 782 set $S0, "I've told you once, I've told you twice..." 783 ok( $S0, 'normal strings are true' ) 784 785 set $S0, "0.0" 786 ok( $S0, '0.0 is true' ) 787 788 set $S0, "" 789 nok( $S0, 'empty string is false' ) 790 791 set $S0, "0" 792 nok( $S0, '"0" string is false' ) 793 794 set $S0, "0e0" 795 ok( $S0, 'string "0e0" is true' ) 796 797 set $S0, "x" 798 ok( $S0, 'string "x" is true' ) 799 800 set $S0, "\\x0" 801 ok( $S0, 'string "\\x0" is true' ) 802 803 set $S0, "\n" 804 ok( $S0, 'string "\n" is true' ) 805 806 set $S0, " " 807 ok( $S0, 'string " " is true' ) 808 809 # An empty register should be false... 810 nok( $S1, 'empty register is false' ) 811.end 812 813.sub repeat_s_s_sc_i_ic 814 set $S0, "x" 815 repeat $S1, $S0, 12 816 is( $S0, "x", 'repeat_s_s|sc_i|ic' ) 817 is( $S1, "xxxxxxxxxxxx", 'repeat_s_s|sc_i|ic' ) 818 819 set $I0, 12 820 set $S2, "X" 821 repeat $S3, $S2, $I0 822 is( $S2, "X", 'repeat_s_s|sc_i|ic' ) 823 is( $S3, "XXXXXXXXXXXX", 'repeat_s_s|sc_i|ic' ) 824 825 repeat $S4, "~", 12 826 is( $S4, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' ) 827 828 repeat $S5, "~", $I0 829 is( $S5, "~~~~~~~~~~~~", 'repeat_s_s|sc_i|ic' ) 830 831 832 repeat $S6, "***", 0 833 is( $S6, "", 'repeat_s_s|sc_i|ic' ) 834.end 835 836.sub exception_repeat_oob 837 push_eh handler 838 repeat $S0, "japh", -1 839 handler: 840 .exception_is( 'Cannot repeat with negative arg' ) 841.end 842 843.sub exception_repeat_oob_repeat_p_p_p 844 push_eh handler 845 $P0 = new ['String'] 846 $P1 = new ['String'] 847 $P2 = new ['Integer'] 848 $P2 = -1 849 repeat $P1, $P0, $P2 850 handler: 851 .exception_is( 'Cannot repeat with negative arg' ) 852.end 853 854.sub exception_repeat_oob_repeate_p_p_i 855 push_eh handler 856 $P0 = new ['String'] 857 $P1 = new ['String'] 858 repeat $P1, $P0, -1 859 handler: 860 .exception_is( 'Cannot repeat with negative arg' ) 861.end 862 863.sub encodingname_oob 864 $I0 = -1 865 $S0 = encodingname -1 866 $S0 = encodingname $I0 867 ok( 1, "no exceptions in encodingname_oob" ) 868.end 869 870.sub index_three_arg_form 871 set $S0, "Parrot" 872 set $S1, "Par" 873 index $I1, $S0, $S1 874 is( $I1, "0", 'index, 3-arg form' ) 875 876 set $S1, "rot" 877 index $I1, $S0, $S1 878 is( $I1, "3", 'index, 3-arg form' ) 879 880 set $S1, "bar" 881 index $I1, $S0, $S1 882 is( $I1, "-1", 'index, 3-arg form' ) 883 884 # Ascii - Non-ascii, same content 885 set $S0, "hello" 886 set $S1, utf8:"hello" 887 index $I1, $S0, $S1 888 is( $I1, "0", 'index, 3-arg form' ) 889 index $I1, $S1, $S0 890 is( $I1, "0", 'index, 3-arg form' ) 891 892 # Non-ascii, source shorter than searched 893 set $S0, utf8:"-o" 894 set $S1, utf8:"@INC" 895 index $I1, $S0, $S1 896 is( $I1, "-1", 'index, 3-arg form' ) 897.end 898 899.sub index_four_arg_form 900 set $S0, "Barbarian" 901 set $S1, "ar" 902 index $I1, $S0, $S1, 0 903 is( $I1, "1", 'index, 4-arg form' ) 904 905 index $I1, $S0, $S1, 2 906 is( $I1, "4", 'index, 4-arg form' ) 907 908 set $S1, "qwx" 909 index $I1, $S0, $S1, 0 910 is( $I1, "-1", 'index, 4-arg form' ) 911 912 # Ascii - Non-ascii, same content 913 set $S0, "hello" 914 set $S1, utf8:"hello" 915 index $I1, $S0, $S1, 0 916 is( $I1, "0", 'index, 4-arg form' ) 917 index $I1, $S1, $S0, 0 918 is( $I1, "0", 'index, 4-arg form' ) 919.end 920 921.sub index_four_arg_form_bug_twenty_two_thousand_seven_hundred_and_eighteen 922 set $S1, "This is not quite right" 923 set $S0, " is " 924 index $I0, $S1, $S0, 0 925 is( $I0, "4", 'index, 4-arg form, bug 22718' ) 926 927 set $S0, "is" 928 index $I0, $S1, $S0, 0 929 is( $I0, "2", 'index, 4-arg form, bug 22718' ) 930.end 931 932.sub index_trac_1482 933 $S0 = utf8:"bubuc" 934 $S1 = utf8:"buc" 935 936 $I0 = index $S0, $S1, 0 937 is ($I0, 2, 'index, 4-arg, partial-match causes failure: TT #1482') 938.end 939 940.sub index_null_strings 941 set $S0, "Parrot" 942 set $S1, "" 943 index $I1, $S0, $S1 944 is( $I1, "-1", 'index, null strings' ) 945 946 index $I1, $S0, $S1, 0 947 is( $I1, "-1", 'index, null strings' ) 948 949 index $I1, $S0, $S1, 5 950 is( $I1, "-1", 'index, null strings' ) 951 952 index $I1, $S0, $S1, 6 953 is( $I1, "-1", 'index, null strings' ) 954 955 set $S0, "" 956 set $S1, "a" 957 index $I1, $S0, $S1 958 is( $I1, "-1", 'index, null strings' ) 959 960 index $I1, $S0, $S1, 0 961 is( $I1, "-1", 'index, null strings' ) 962 963 set $S0, "Parrot" 964 null $S1 965 index $I1, $S0, $S1 966 is( $I1, "-1", 'index, null strings' ) 967 968 .local pmc eh 969 eh = new ['ExceptionHandler'] 970 eh.'handle_types'(.EXCEPTION_UNEXPECTED_NULL) 971 set_label eh, handler 972 push_eh eh 973 $I1 = 1 974 null $S0 975 null $S1 976 index $I0, $S0, $S1 977 $I1 = 0 978 handler: 979 pop_eh 980 is( $I1, "1", "index with null string throws" ) 981.end 982 983.sub index_embedded_nulls 984 set $S0, "Par\0\0rot" 985 set $S1, "\0" 986 index $I1, $S0, $S1 987 is( $I1, "3", 'index, embedded nulls' ) 988 989 index $I1, $S0, $S1, 4 990 is( $I1, "4", 'index, embedded nulls' ) 991.end 992 993.sub index_big_strings 994 set $S0, "a" 995 repeat $S0, $S0, 10000 996 set $S1, "a" 997 repeat $S1, $S1, 500 998 index $I1, $S0, $S1 999 is( $I1, "0", 'index, big strings' ) 1000 1001 index $I1, $S0, $S1, 1234 1002 is( $I1, "1234", 'index, big strings' ) 1003 1004 index $I1, $S0, $S1, 9501 1005 is( $I1, "-1", 'index, big strings' ) 1006.end 1007 1008# Builds a 24th iteration fibonacci string (approx. 100K) 1009.sub index_big_hard_to_match_strings 1010 set $S1, "a" 1011 set $S2, "b" 1012 set $I0, 0 1013 LOOP: 1014 set $S3, $S1 1015 concat $S1, $S2, $S3 1016 set $S2, $S3 1017 inc $I0 1018 lt $I0, 24, LOOP 1019 index $I1, $S1, $S2 1020 is( $I1, "46368", 'index, big, hard to match strings' ) 1021 index $I1, $S1, $S2, 50000 1022 is( $I1, "-1", 'index, big, hard to match strings' ) 1023.end 1024 1025.sub index_with_different_charsets 1026 set $S0, "Parrot" 1027 set $S1, "rot" 1028 index $I1, $S0, $S1 1029 is( $I1, "3", 'default - default' ) 1030 1031 set $S0, ascii:"Parrot" 1032 set $S1, ascii:"rot" 1033 index $I1, $S0, $S1 1034 is( $I1, "3", 'ascii - ascii') 1035 1036 set $S0, "Parrot" 1037 set $S1, ascii:"rot" 1038 index $I1, $S0, $S1 1039 is( $I1, "3", 'default - ascii' ) 1040 1041 set $S0, ascii:"Parrot" 1042 set $S1, "rot" 1043 index $I1, $S0, $S1 1044 is( $I1, "3", 'ascii - default' ) 1045 1046 set $S0, binary:"Parrot" 1047 set $S1, binary:"rot" 1048 index $I1, $S0, $S1 1049 is( $I1, 3, 'binary - binary' ) 1050.end 1051 1052.sub negative_index_bug_35959 1053 index $I1, "u", "t", -123456 1054 is( $I1, "-1", 'negative index #35959' ) 1055 1056 index $I1, "u", "t", -123456789 1057 is( $I1, "-1", 'negative index #35959' ) 1058.end 1059 1060.sub index_multibyte_matching 1061 set $S0, iso-8859-1:"\xAB" 1062 find_encoding $I0, "utf8" 1063 trans_encoding $S1, $S0, $I0 1064 is( $S0, $S1, 'equal' ) 1065 1066 index $I0, $S0, $S1 1067 is( $I0, "0", 'index, multibyte matching' ) 1068 1069 index $I0, $S1, $S0 1070 is( $I0, "0", 'index, multibyte matching' ) 1071.end 1072 1073.sub index_multibyte_matching_two 1074 set $S0, iso-8859-1:"\xAB\xBA" 1075 set $S1, utf8:"foo\xAB\xAB\xBAbar" 1076 index $I0, $S0, $S1 1077 is( $I0, "-1", 'index, multibyte matching 2' ) 1078 index $I0, $S1, $S0 1079 is( $I0, "4", 'index, multibyte matching 2' ) 1080 1081 set $S0, iso-8859-1:"abc\x{fc}def" 1082 set $S1, utf8:"\x{fc}" 1083 index $I1, $S0, $S1 1084 is( $I1, "3", 'index, iso-8859-1 - utf8' ) 1085.end 1086 1087.sub num_to_string 1088 set $N0, 80.43 1089 set $S0, $N0 1090 is( $S0, "80.43", 'num to string' ) 1091 1092 set $N0, -1.111111 1093 set $S0, $N0 1094 is( $S0, "-1.111111", 'num to string' ) 1095.end 1096 1097.sub string_to_int 1098 set $S0, "123" 1099 set $I0, $S0 1100 is( $I0, "123", 'string to int' ) 1101 1102 set $S0, " 1" 1103 set $I0, $S0 1104 is( $I0, "1", 'string to int' ) 1105 1106 set $S0, "-1" 1107 set $I0, $S0 1108 is( $I0, "-1", 'string to int' ) 1109 1110 set $S0, "Not a number" 1111 set $I0, $S0 1112 is( $I0, "0", 'string to int' ) 1113 1114 set $S0, "" 1115 set $I0, $S0 1116 is( $I0, "0", 'string to int' ) 1117.end 1118 1119.sub string_to_num 1120 set $S0, "6foo" 1121 set $N0, $S0 1122 is( $N0, "6", '6foo to num' ) 1123 1124 set $S0, "16foo" 1125 set $N0, $S0 1126 is( $N0, "16", '16foo to num' ) 1127.end 1128 1129.sub concat_or_substr_cow 1130 set $S0, "<JA" 1131 set $S1, "PH>" 1132 set $S2, "" 1133 concat $S2, $S2, $S0 1134 concat $S2, $S2, $S1 1135 is( $S2, "<JAPH>", 'concat/substr (COW)' ) 1136 1137 substr $S0, $S2, 1, 4 1138 is( $S0, "JAPH", 'concat/substr (COW)' ) 1139.end 1140 1141.sub constant_to_cstring 1142 stringinfo $I0, "\n", 2 1143 stringinfo $I1, "\n", 2 1144 is( $I1, $I0, 'constant to cstring' ) 1145 1146 stringinfo $I2, "\n", 2 1147 is( $I2, $I0, 'constant to cstring' ) 1148.end 1149 1150.sub cow_with_chopn_leaving_original_untouched 1151 set $S0, "ABCD" 1152 clone $S1, $S0 1153 $S0 = chopn $S0, 1 1154 is( $S0, "ABC", 'COW with chopn leaving original untouched' ) 1155 is( $S1, "ABCD", 'COW with chopn leaving original untouched' ) 1156.end 1157 1158.sub check_that_bug_bug_16874_was_fixed 1159 set $S0, "foo " 1160 set $S1, "bar " 1161 set $S2, "quux " 1162 set $S15, "" 1163 $S15 = concat $S15, $S0 1164 $S15 = concat $S15, $S1 1165 $S15 = concat $S15, $S2 1166 is( $S15, "foo bar quux ", 'Check that bug #16874 was fixed' ) 1167.end 1168 1169.sub stress_concat 1170 set $I0, 1000 1171 set $S0, "michael" 1172 LOOP: 1173 set $S2, $I0 1174 concat $S1, $S0, $S2 1175 concat $S3, "mic", "hael" 1176 concat $S3, $S3, $S2 1177 eq $S1, $S3, BOTTOM 1178 ok(0, 'failed stress concat test') 1179 end 1180 1181 BOTTOM: 1182 sub $I0, $I0, 1 1183 ne $I0, 0, LOOP 1184 ok(1, 'stress concat test') 1185.end 1186 1187.sub ord_and_substring_see_bug_17035 1188 set $S0, "abcdef" 1189 substr $S1, $S0, 2, 3 1190 ord $I0, $S0, 2 1191 ord $I1, $S1, 0 1192 ne $I0, $I1, fail 1193 ord $I0, $S0, 3 1194 ord $I1, $S1, 1 1195 ne $I0, $I1, fail 1196 ord $I0, $S0, 4 1197 ord $I1, $S1, 2 1198 ne $I0, $I1, fail 1199 ok(1, 'ord and substring #17035') 1200 goto end 1201 fail: 1202 ok(0, 'failed: ord and substring #17035') 1203 end: 1204.end 1205 1206.sub test_sprintf 1207 branch MAIN 1208 NEWARYP: 1209 new $P1, 'ResizablePMCArray' 1210 set $P1[0], $P0 1211 local_return $P4 1212 NEWARYS: 1213 new $P1, 'ResizablePMCArray' 1214 set $P1[0], $S0 1215 local_return $P4 1216 NEWARYI: 1217 new $P1, 'ResizablePMCArray' 1218 set $P1[0], $I0 1219 local_return $P4 1220 NEWARYN: 1221 new $P1, 'ResizablePMCArray' 1222 set $P1[0], $N0 1223 local_return $P4 1224 PRINTF: 1225 sprintf $S2, $S1, $P1 1226 is( $S2, $S99, $S1 ) 1227 local_return $P4 1228 1229 MAIN: 1230 new $P4, 'ResizableIntegerArray' 1231 set $S1, "Hello, %s" 1232 set $S0, "Parrot!" 1233 set $S99, "Hello, Parrot!" 1234 local_branch $P4, NEWARYS 1235 local_branch $P4, PRINTF 1236 1237 set $S1, "Hash[0x%x]" 1238 set $I0, 256 1239 set $S99, "Hash[0x100]" 1240 local_branch $P4, NEWARYI 1241 local_branch $P4, PRINTF 1242 1243 set $S1, "Hash[0x%lx]" 1244 set $I0, 256 1245 set $S99, "Hash[0x100]" 1246 local_branch $P4, NEWARYI 1247 local_branch $P4, PRINTF 1248 1249 set $S1, "Hello, %.2s!" 1250 set $S0, "Parrot" 1251 set $S99, "Hello, Pa!" 1252 local_branch $P4, NEWARYS 1253 local_branch $P4, PRINTF 1254 1255 set $S1, "Hello, %Ss" 1256 set $S0, $S2 1257 set $S99, "Hello, Hello, Pa!" 1258 local_branch $P4, NEWARYS 1259 local_branch $P4, PRINTF 1260 1261 set $S1, "1 == %Pd" 1262 new $P0, 'Integer' 1263 set $P0, 1 1264 set $S99, "1 == 1" 1265 local_branch $P4, NEWARYP 1266 local_branch $P4, PRINTF 1267 1268 set $S1, "-255 == %vd" 1269 set $I0, -255 1270 set $S99, "-255 == -255" 1271 local_branch $P4, NEWARYI 1272 local_branch $P4, PRINTF 1273 1274 set $S1, "+123 == %+vd" 1275 set $I0, 123 1276 set $S99, "+123 == +123" 1277 local_branch $P4, NEWARYI 1278 local_branch $P4, PRINTF 1279 1280 set $S1, "256 == %vu" 1281 set $I0, 256 1282 set $S99, "256 == 256" 1283 local_branch $P4, NEWARYI 1284 local_branch $P4, PRINTF 1285 1286 load_bytecode 'config.pbc' 1287 .local pmc config 1288 .local string osname, gccversion 1289 config = _config() 1290 osname = config['osname'] 1291 gccversion = config['gccversion'] 1292 ne osname, 'MSWin32', nomingw 1293 eq gccversion, '', nomingw 1294 goto mingw 1295 nomingw: 1296 set $S1, "1 == %+vu" 1297 set $I0, 1 1298 set $S99, "1 == 1" 1299 local_branch $P4, NEWARYI 1300 local_branch $P4, PRINTF 1301 1302 set $S1, "001 == %+0.3u" 1303 set $I0, 1 1304 set $S99, "001 == 001" 1305 local_branch $P4, NEWARYI 1306 local_branch $P4, PRINTF 1307 goto nomingw2 1308 1309 mingw: 1310 say "196 # skip [GH #823] %+vu on mingw" 1311 say "197 # skip [GH #823] %+0.3u on mingw" 1312 nomingw2: 1313 set $S1, "001 == %0.3u" 1314 set $I0, 1 1315 set $S99, "001 == 001" 1316 local_branch $P4, NEWARYI 1317 local_branch $P4, PRINTF 1318 1319 set $S1, "0.500000 == %f" 1320 set $N0, 0.5 1321 set $S99, "0.500000 == 0.500000" 1322 local_branch $P4, NEWARYN 1323 local_branch $P4, PRINTF 1324 1325 set $S1, "0.500 == %5.3f" 1326 set $N0, 0.5 1327 set $S99, "0.500 == 0.500" 1328 local_branch $P4, NEWARYN 1329 local_branch $P4, PRINTF 1330 1331 set $S1, "0.001 == %g" 1332 set $N0, 0.001 1333 set $S99, "0.001 == 0.001" 1334 local_branch $P4, NEWARYN 1335 local_branch $P4, PRINTF 1336 1337 set $S1, "1e+06 == %g" 1338 set $N0, 1.0e6 1339 set $S99, "1e+06 == 1e+06" 1340 local_branch $P4, NEWARYN 1341 local_branch $P4, PRINTF 1342 1343 set $S1, "0.5 == %3.3g" 1344 set $N0, 0.5 1345 set $S99, "0.5 == 0.5" 1346 local_branch $P4, NEWARYN 1347 local_branch $P4, PRINTF 1348 1349 set $S1, "%% == %%" 1350 set $I0, 0 1351 set $S99, "% == %" 1352 local_branch $P4, NEWARYI 1353 local_branch $P4, PRINTF 1354 1355 set $S1, "That's all, %s" 1356 set $S0, "folks!" 1357 set $S99, "That's all, folks!" 1358 local_branch $P4, NEWARYS 1359 local_branch $P4, PRINTF 1360.end 1361 1362.sub other_form_of_sprintf_op 1363 new $P4, 'ResizableIntegerArray' 1364 new $P3, 'String' 1365 new $P2, 'String' 1366 set $P2, "15 is %b" 1367 new $P1, 'ResizablePMCArray' 1368 set $P1[0], 15 1369 sprintf $P3, $P2, $P1 1370 is( $P3, "15 is 1111", 'other form of sprintf op' ) 1371 1372 new $P2, 'String' 1373 set $P2, "128 is %o" 1374 new $P1, 'ResizablePMCArray' 1375 set $P1[0], 128 1376 sprintf $P3, $P2, $P1 1377 is( $P3, "128 is 200", 'other form of sprintf op' ) 1378.end 1379 1380.sub sprintf_left_justify 1381 $P0 = new 'ResizablePMCArray' 1382 $P1 = new 'Integer' 1383 $P1 = 10 1384 $P0[0] = $P1 1385 $P1 = new 'String' 1386 $P1 = "foo" 1387 $P0[1] = $P1 1388 $P1 = new 'String' 1389 $P1 = "bar" 1390 $P0[2] = $P1 1391 $S0 = sprintf "%-*s - %s", $P0 1392 is( $S0, "foo - bar", 'sprintf - left justify' ) 1393.end 1394 1395 1396.sub correct_precision_for_sprintf_x 1397 .include "iglobals.pasm" 1398 1399 # Create the string via concat 1400 .local pmc interp # a handle to our interpreter object. 1401 interp = getinterp 1402 .local pmc config 1403 config = interp[.IGLOBALS_CONFIG_HASH] 1404 .local int intvalsize 1405 intvalsize = config['intvalsize'] 1406 1407 $S0 = '' 1408 $I0 = 1 1409 $I1 = intvalsize * 2 1410 loop: 1411 $S0 = concat $S0, 'f' 1412 inc $I0 1413 le $I0, $I1, loop 1414 padding_loop: 1415 $S0 = concat $S0, ' ' 1416 inc $I0 1417 le $I0, 20, padding_loop 1418 1419 # Now see what sprintf comes up with 1420 $P0 = new 'ResizablePMCArray' 1421 $P0[0] = -1 1422 $S1 = sprintf "%-20x", $P0 1423 is( $S1, $S0, 'Correct precision for %x' ) 1424.end 1425 1426.sub test_find_encoding 1427 find_encoding $I0, "ascii" 1428 is( $I0, "0", 'find_encoding' ) 1429 find_encoding $I0, "iso-8859-1" 1430 is( $I0, "1", 'find_encoding' ) 1431 find_encoding $I0, "binary" 1432 is( $I0, "2", 'find_encoding' ) 1433 find_encoding $I0, "utf8" 1434 is( $I0, "3", 'find_encoding' ) 1435 find_encoding $I0, "unicode" 1436 is( $I0, "3", 'find_encoding' ) 1437 find_encoding $I0, "utf16" 1438 is( $I0, "4", 'find_encoding' ) 1439 find_encoding $I0, "ucs2" 1440 is( $I0, "5", 'find_encoding' ) 1441 find_encoding $I0, "ucs4" 1442 is( $I0, "6", 'find_encoding' ) 1443.end 1444 1445.sub test_assign 1446 set $S4, "JAPH" 1447 assign $S5, $S4 1448 is( $S4, "JAPH", 'assign' ) 1449 is( $S5, "JAPH", 'assign' ) 1450.end 1451 1452.sub assign_and_globber 1453 set $S4, "JAPH" 1454 assign $S5, $S4 1455 assign $S4, "Parrot" 1456 is( $S4, "Parrot", 'assign & globber' ) 1457 is( $S5, "JAPH", 'assign & globber' ) 1458.end 1459 1460.sub split_on_null_string 1461 .local string s, delim 1462 .local pmc p 1463 .local int i 1464 null s 1465 null delim 1466 split p, s, delim 1467 i = isnull p 1468 is(i, 1, 'split on null string and delim') 1469 1470 s = 'foo' 1471 split p, s, delim 1472 i = isnull p 1473 is(i, 1, 'split on null delim') 1474 1475 null s 1476 delim = 'bar' 1477 split p, s, delim 1478 i = isnull p 1479 is(i, 1, 'split on null string') 1480.end 1481 1482.sub split_on_empty_string 1483 split $P1, "", "" 1484 set $I1, $P1 1485 is( $I1, "0", 'split on empty string' ) 1486 1487 split $P0, "", "ab" 1488 set $I0, $P0 1489 is( $I0, "2", 'split on empty string' ) 1490 1491 set $S0, $P0[0] 1492 is( $S0, "a", 'split on empty string' ) 1493 1494 set $S0, $P0[1] 1495 is( $S0, "b", 'split on empty string' ) 1496.end 1497 1498.sub split_on_non_empty_string 1499 split $P0, "a", "afooabara" 1500 set $I0, $P0 1501 is( $I0, "5", 'split on non-empty string' ) 1502 1503 set $S0, $P0[0] 1504 is( $S0, "", 'split on non-empty string' ) 1505 set $S0, $P0[1] 1506 is( $S0, "foo", 'split on non-empty string' ) 1507 set $S0, $P0[2] 1508 is( $S0, "b", 'split on non-empty string' ) 1509 set $S0, $P0[3] 1510 is( $S0, "r", 'split on non-empty string' ) 1511 set $S0, $P0[4] 1512 is( $S0, "", 'split on non-empty string' ) 1513.end 1514 1515.sub test_join 1516 new $P0, 'ResizablePMCArray' 1517 join $S0, "--", $P0 1518 is( $S0, "", 'join' ) 1519 1520 push $P0, "a" 1521 join $S0, "--", $P0 1522 is( $S0, "a", 'join' ) 1523 1524 new $P0, 'ResizablePMCArray' 1525 push $P0, "a" 1526 push $P0, "b" 1527 join $S0, "--", $P0 1528 is( $S0, "a--b", 'join' ) 1529.end 1530 1531.sub 'test_join_many' 1532 $P1 = new ['ResizablePMCArray'] 1533 $I0 = 0 1534 loop: 1535 unless $I0 < 20000 goto done 1536 $P2 = new ['Integer'] 1537 assign $P2, $I0 1538 push $P1, $P2 1539 inc $I0 1540 goto loop 1541 done: 1542 $S0 = join ' ', $P1 1543 ok("Join of many temporary strings doesn't crash") 1544.end 1545 1546# join: get_string returns a null string -------- 1547.namespace ["Foo5"] 1548 .sub get_string :vtable :method 1549 .local string ret 1550 null ret 1551 .begin_return 1552 .set_return ret 1553 .end_return 1554 .end 1555.namespace [] # revert to root for next test 1556.sub join_get_string_returns_a_null_string 1557 newclass $P0, "Foo5" 1558 new $P0, 'ResizablePMCArray' 1559 $P1 = new "Foo5" 1560 push $P0, $P1 1561 join $S0, "", $P0 1562 is( $S0, "", 'join: get_string returns a null string' ) 1563.end 1564 1565.sub eq_addr_or_ne_addr 1566 set $S0, "Test" 1567 set $S1, $S0 1568 1569 set $I99, 1 1570 eq_addr $S1, $S0, OK1 1571 set $I99, 0 1572 OK1: 1573 ok($I99, 'eq_addr/ne_addr') 1574 1575 set $S0, $S1 1576 set $I99, 0 1577 ne_addr $S1, $S0, BAD4 1578 set $I99, 1 1579 BAD4: 1580 ok($I99, 'eq_addr/ne_addr') 1581.end 1582 1583.sub test_if_null_s_ic 1584 set $S0, "foo" 1585 $I99 = 0 1586 if_null $S0, ERROR 1587 $I99 = 1 1588 ERROR: 1589 ok($I99, 'if_null s_ic' ) 1590 1591 null $S0 1592 $I99 = 1 1593 if_null $S0, OK 1594 $I99 = 0 1595 OK: 1596 ok($I99, 'if_null s_ic' ) 1597.end 1598 1599.sub test_upcase 1600 set $S0, "abCD012yz" 1601 upcase $S1, $S0 1602 is( $S1, "ABCD012YZ", 'upcase' ) 1603 1604 push_eh catch1 1605 null $S9 1606 null $S0 1607 upcase $S1, $S0 1608 pop_eh 1609 goto null1 1610catch1: 1611 .get_results($P9) 1612 $S9 = $P9['message'] 1613 pop_eh 1614null1: 1615 is ($S9, "Can't upcase NULL string", 'upcase null') 1616 1617 push_eh catch2 1618 null $S9 1619 null $S0 1620 $S0 = upcase $S0 1621 pop_eh 1622 goto null2 1623catch2: 1624 .get_results($P9) 1625 $S9 = $P9['message'] 1626 pop_eh 1627null2: 1628 is ($S9, "Can't upcase NULL string", 'upcase inplace null') 1629 1630 push_eh catch3 1631 null $S9 1632 set $S0, binary:"abCD012yz" 1633 upcase $S1, $S0 1634 pop_eh 1635 goto null3 1636catch3: 1637 .get_results($P9) 1638 $S9 = $P9['message'] 1639 pop_eh 1640null3: 1641 is ($S9, "Invalid operation on binary string", 'upcase binary') 1642.end 1643 1644.sub test_downcase 1645 set $S0, "ABcd012YZ" 1646 downcase $S1, $S0 1647 is( $S1, "abcd012yz", 'downcase' ) 1648 1649 push_eh catch1 1650 null $S9 1651 null $S0 1652 downcase $S1, $S0 1653 pop_eh 1654 goto null1 1655catch1: 1656 .get_results($P9) 1657 $S9 = $P9['message'] 1658 pop_eh 1659null1: 1660 is ($S9, "Can't downcase NULL string", 'downcase null') 1661 1662 push_eh catch2 1663 null $S9 1664 null $S0 1665 $S0 = downcase $S0 1666 pop_eh 1667 goto null2 1668catch2: 1669 .get_results($P9) 1670 $S9 = $P9['message'] 1671 pop_eh 1672null2: 1673 is ($S9, "Can't downcase NULL string", 'downcase inplace null') 1674.end 1675 1676.sub test_titlecase 1677 set $S0, "aBcd012YZ" 1678 titlecase $S1, $S0 1679 is( $S1, "Abcd012yz", 'titlecase' ) 1680 1681 push_eh catch1 1682 null $S9 1683 null $S0 1684 titlecase $S1, $S0 1685 pop_eh 1686 goto null1 1687catch1: 1688 .get_results($P9) 1689 $S9 = $P9['message'] 1690 pop_eh 1691null1: 1692 is ($S9, "Can't titlecase NULL string", 'titlecase null') 1693 1694 push_eh catch2 1695 null $S9 1696 null $S0 1697 $S0 = titlecase $S0 1698 pop_eh 1699 goto null2 1700catch2: 1701 .get_results($P9) 1702 $S9 = $P9['message'] 1703 pop_eh 1704null2: 1705 is ($S9, "Can't titlecase NULL string", 'titlecase inplace null') 1706.end 1707 1708.sub three_param_ord_one_character_string_register_i 1709 set $S0,"a" 1710 set $I1, 0 1711 ord $I0,$S0,$I1 1712 is( $I0, "97", '3-param ord, one-character string register, I' ) 1713.end 1714 1715.sub three_param_ord_multi_character_string_i 1716 set $I1, 1 1717 ord $I0,"ab",$I1 1718 is( $I0, "98", '3-param ord, multi-character string, I' ) 1719.end 1720 1721.sub three_param_ord_multi_character_string_register_i 1722 set $I1, 1 1723 set $S0,"ab" 1724 ord $I0,$S0,$I1 1725 is( $I0, "98", '3-param ord, multi-character string register, I' ) 1726.end 1727 1728.sub exception_three_param_ord_multi_character_string_i 1729 push_eh handler 1730 set $I1, 2 1731 ord $I0,"ab",$I1 1732 ok( 0, 'no exception: 3-param ord, multi-character string, I' ) 1733 handler: 1734 .exception_is( 'Cannot get character past end of string' ) 1735.end 1736 1737.sub exception_three_param_ord_multi_character_string_i 1738 push_eh handler 1739 set $I1, 2 1740 set $S0,"ab" 1741 ord $I0,$S0,$I1 1742 ok( 0, 'no exception: 3-param ord, multi-character string, I' ) 1743 handler: 1744 .exception_is( 'Cannot get character past end of string' ) 1745.end 1746 1747.sub three_param_ord_one_character_string_from_end_i 1748 set $I1, -1 1749 ord $I0,"a",$I1 1750 is( $I0, "97", '3-param ord, one-character string, from end, I' ) 1751.end 1752 1753.sub three_param_ord_one_character_string_register_from_end_i 1754 set $I1, -1 1755 set $S0,"a" 1756 ord $I0,$S0,$I1 1757 is( $I0, "97", '3-param ord, one-character string register, from end, I' ) 1758.end 1759 1760.sub three_param_ord_multi_character_string_from_end_i 1761 set $I1, -1 1762 ord $I0,"ab",$I1 1763 is( $I0, "98", '3-param ord, multi-character string, from end, I' ) 1764.end 1765 1766.sub three_param_ord_multi_character_string_register_from_end_i 1767 set $I1, -1 1768 set $S0,"ab" 1769 ord $I0,$S0,$I1 1770 is( $I0, "98", '3-param ord, multi-character string register, from end, I' ) 1771.end 1772 1773.sub exception_three_param_ord_multi_character_string_register_from_end_oob_i 1774 push_eh handler 1775 set $I1, -3 1776 set $S0,"ab" 1777 ord $I0,$S0,$I1 1778 ok( 0, 'no exception: 3-param ord, multi-character string register, from end, OOB, I' ) 1779 handler: 1780 .exception_is( 'Cannot get character before beginning of string' ) 1781.end 1782 1783# Utility method for more_string_to_int 1784.sub 'print_as_integer' 1785 .param string s 1786 .param string answer 1787 $I0 = s 1788 concat $S99, 'string to int: ', s 1789 is( $I0, answer, $S99 ) 1790.end 1791 1792.sub more_string_to_int 1793 print_as_integer('-4', "-4") 1794 print_as_integer('X-4',"0") 1795 print_as_integer('--4',"0") 1796 print_as_integer('+',"0") 1797 print_as_integer('++',"0") 1798 print_as_integer('+2',"2") 1799 print_as_integer(' +3',"3") 1800 print_as_integer('++4',"0") 1801 print_as_integer('+ 5',"0") 1802 print_as_integer('-',"0") 1803 print_as_integer('--56',"0") 1804 print_as_integer(' -+67',"0") 1805 print_as_integer('+-78',"0") 1806 print_as_integer(' -089xyz',"-89") 1807 print_as_integer('- 89',"0") 1808.end 1809 1810# Utility sub for constant_string_and_modify_in_situ_op_rt_bug_60030 1811.sub doit_sub_for_but_60030 1812 .param string s 1813 $I0 = index s, '::' 1814 is( s, "Foo::Bar", 'bug 60030' ) 1815 s = replace s, $I0, 2, "/" 1816 is( s, "Foo/Bar", 'bug 60030' ) 1817 collect 1818 is( s, "Foo/Bar", 'bug 60030' ) 1819.end 1820.sub constant_string_and_modify_in_situ_op_rt_bug_60030 1821 1822 doit_sub_for_but_60030('Foo::Bar') 1823 # repeat to prove that the constant 'Foo4::Bar4' remains unchanged 1824 doit_sub_for_but_60030('Foo::Bar') 1825.end 1826 1827.sub corner_cases_of_numification 1828 is( 2147483647.0, "2147483647", 'corner cases of numification' ) 1829 is( -2147483648.0, "-2147483648", 'corner cases of numification' ) 1830.end 1831 1832.sub non_canonical_nan_and_inf 1833 $N0 = 'nan' 1834 is( $N0, "NaN", 'Non canonical nan and inf' ) 1835 1836 $N0 = 'iNf' 1837 is( $N0, "Inf", 'Non canonical nan and inf' ) 1838 1839 $N0 = 'INFINITY' 1840 is( $N0, "Inf", 'Non canonical nan and inf' ) 1841 1842 $N0 = '-INF' 1843 is( $N0, "-Inf", 'Non canonical nan and inf' ) 1844 1845 $N0 = '-Infinity' 1846 is( $N0, "-Inf", 'Non canonical nan and inf' ) 1847.end 1848 1849.HLL 'foohll' 1850.sub split_hll_mapped 1851 .include 'test_more.pir' 1852 1853 .local pmc RSA, fooRSA 1854 RSA = get_class ['ResizableStringArray'] 1855 fooRSA = subclass ['ResizableStringArray'], 'fooRSA' 1856 1857 .local pmc interp 1858 interp = getinterp 1859 interp.'hll_map'(RSA, fooRSA) 1860 1861 .local pmc a 1862 split a, "a", "afooabara" 1863 1864 .local string t 1865 t = typeof a 1866 is( t, 'fooRSA', 'split - hll mapped' ) 1867 1868 .local int n, i 1869 n = a 1870 is( n, '5', 'split - hll mapped' ) 1871 1872 .local string s 1873 s = a[0] 1874 is( s, '', 'split - hll mapped' ) 1875 s = a[1] 1876 is( s, 'foo', 'split - hll mapped' ) 1877 s = a[2] 1878 is( s, 'b', 'split - hll mapped' ) 1879 s = a[3] 1880 is( s, 'r', 'split - hll mapped' ) 1881 s = a[4] 1882 is( s, '', 'split - hll mapped' ) 1883.end 1884 1885# Local Variables: 1886# mode: pir 1887# fill-column: 100 1888# End: 1889# vim: expandtab shiftwidth=4 ft=pir: 1890