1use strict; 2use warnings; 3use Test::More; 4use Prima::sys::Test; 5use Prima::Application; 6 7my $w; 8my $z; 9 10my %opt; 11my %glyphs; 12my $high_unicode_char; 13 14sub xtr($) 15{ 16 my $xtr = shift; 17 18 $xtr =~ tr[A-Z][\N{U+5d0}-\N{U+5e8}]; # hebrew 19 # RTL(|/) ligates to %, with ZWJ (fribidi) or without (harfbuzz) 20 $xtr =~ tr[|/%0][\x{627}\x{644}\x{fefb}\x{feff}]; 21 $xtr =~ tr[+-][\x{200d}\x{200c}]; 22 $xtr =~ s[\^][$high_unicode_char]g if defined $high_unicode_char; 23 24 return $xtr; 25} 26 27sub glyphs($) 28{ 29 my $str = xtr(shift); 30 my %g; 31 for my $c ( split //, $str ) { 32 my $k = $w-> text_shape($c, polyfont => 0); 33 return unless $k; 34 $g{$c} = $k->glyphs->[0]; 35 } 36 return %glyphs = %g; 37} 38 39sub no_glyphs($) 40{ 41 my $str = xtr(shift); 42 my %g; 43 for my $c ( split //, $str ) { 44 $g{$c} = ord($c); 45 } 46 return %glyphs = %g; 47} 48 49sub glyphs_fully_resolved 50{ 51 return 0 unless scalar keys %glyphs; 52 return 0 == scalar grep { !$_ } values %glyphs; 53} 54 55sub gmap($) { [ @glyphs{ split //, $_[0] } ] } 56 57sub r { map { $_ | to::RTL } @_ } 58sub R { reverse r @_ } 59 60sub comp 61{ 62 my ( $got, $exp, $name, $hexy, $text) = @_; 63 64 if ( !$got && !$exp) { # undef and 0 are same, whatever 65 ok(1, $name); 66 return; 67 } 68 goto FAIL unless 69 ((ref($got) // '') eq 'ARRAY') && 70 ((ref($exp) // '') eq 'ARRAY') && 71 @$got == @$exp; 72 73 for ( my $i = 0; $i < @$got; $i++) { 74 goto FAIL if ($got->[$i] // '<undef>') ne ($exp->[$i] // '<undef>'); 75 } 76 ok(1, $name); 77 return; 78 79FAIL: 80 ok(0, "$name {$text}"); 81 $got ||= ['<undef>']; 82 $exp ||= ['<undef>']; 83 $exp = [ map { defined($_) ? $_ : '<undef>' } @$exp ]; 84 $got = [ map { defined($_) ? $_ : '<undef>' } @$got ]; 85 if ( $hexy ) { 86 @$got = map { /^\d+$/ ? (sprintf q(%x), $_) : $_ } @$got; 87 @$exp = map { /^\d+$/ ? (sprintf q(%x), $_) : $_ } @$exp; 88 } else { 89 $_ = '-' . ($_ & ~to::RTL) for grep { /^\d+$/ && $_ & to::RTL } @$got; 90 $_ = '-' . ($_ & ~to::RTL) for grep { /^\d+$/ && $_ & to::RTL } @$exp; 91 } 92 diag(sprintf("got [@$got], expected [@$exp]")); 93} 94 95sub t2 96{ 97 my ( $text, $glyphs, $indexes, $name, %opt) = @_; 98 99 my $orig_text = $text; 100 my $orig_glyphs = $glyphs . '#'; 101 $text = xtr $text; 102 $glyphs = xtr $glyphs; 103 $text =~ tr 104 [<>=] 105 #[\x{2067}\x{2066}\x{2069}] 106 [\x{202B}\x{202a}\x{202c}] 107 ; 108 109 $z = $w-> text_shape($text, %opt, polyfont => 0); 110 return ok(0, "$name (undefined)") unless defined $z; 111 return ok(0, "$name (unnecessary, retval=0)") unless $z; 112 comp($z->glyphs, gmap $glyphs, "$name (glyphs)", 1, $orig_text); 113 if ( defined $indexes ) { 114 comp($z->indexes, $indexes, "$name (indexes)", 0, $_[0]); 115 return; 116 } 117 118 my %rev = reverse %glyphs; 119 my $v = join '', 120 map { 121 my $ofs = $_ & ~to::RTL; 122 my $char = sprintf("(%x)",$_); 123 AGAIN: 124 if ( $ofs >= 0 && $ofs < length($orig_text)) { 125 $char = substr($orig_text, $ofs, 1); 126 if ( $char =~ /[\<\>\=]/ ) { 127 $ofs++; 128 goto AGAIN; 129 } 130 if ($_ & to::RTL) { 131 $char = "(+$char)" if $char !~ /[A-Z\/\|\%0\+\-\.\s\?\`\<\>\^]/; 132 } else { 133 $char = "(-$char)" if $char !~ /[a-z\+\-\.\s\"\d\^]/; 134 } 135 } elsif ( $ofs == length($orig_text)) { 136 $char = '#'; 137 } 138 $char 139 } 140 @{$z->indexes // []}; 141 unless (is($v, $orig_glyphs, "$name (indexes)")) { 142 my $got = $z->indexes // ['<undef>']; 143 $got = [ map { defined($_) ? $_ : '<undef>' } @$got ]; 144 $_ = '-' . ($_ & ~to::RTL) for grep { /^\d+$/ && $_ & to::RTL } @$got; 145 diag("got indexes: [@$got]"); 146 } 147} 148 149sub t 150{ 151 my ( $text, $glyphs, $name, %opt) = @_; 152 t2($text, $glyphs, undef, $name, %opt); 153} 154 155sub find_char 156{ 157 my ($font, $char) = @_; 158 $w->font($font); 159 my @r = @{ $w->get_font_ranges }; 160 my $found = 0; 161 my @chars = map { ord } split '', $char; 162 for ( my $i = 0; $i < @r; $i += 2 ) { 163 my ( $l, $r ) = @r[$i, $i+1]; 164 for my $c ( @chars ) { 165 $found++ if $l <= $c && $r >= $c; 166 } 167 last if $found == @chars; 168 } 169 return $found == @chars; 170} 171 172sub find_high_unicode_char 173{ 174 my ($font) = @_; 175 $w->font($font); 176 my @r = @{ $w->get_font_ranges }; 177 my @range; 178 my $found; 179 for ( my $i = 0; $i < @r; $i += 2 ) { 180 my ( $l, $r ) = @r[$i, $i+1]; 181 next unless $r >= 0x10000; 182 $l = 0x10000 if $l < 0x10000; 183 push @range, $l .. $r; 184 return \@range; 185 } 186 return undef; 187} 188 189sub find_high_unicode_font 190{ 191 my $c = find_high_unicode_char($w->font); 192 return $c if defined $c; 193 my @f = @{$::application->fonts}; 194 for my $f ( @f ) { 195 next unless $f->{vector}; 196 $c = find_high_unicode_char($f); 197 return $c if defined $c; 198 } 199 return undef; 200} 201 202# try to find font with given letters 203# aim at highest standard, ie ttf/xft + scaling + bidi fonts 204sub find_vector_font 205{ 206 my $find_char = shift; 207 return 1 if find_char($w->font, $find_char); 208 209 my $got_rtl; 210 my $found; 211 my @f = @{$::application->fonts}; 212 213 # fontconfig fonts 214 for my $f ( @f ) { 215 next unless $f->{vector}; 216 next unless $f->{name} =~ /^[A-Z]/; 217 next unless find_char($f, $find_char); 218 $found = $f; 219 $got_rtl = 1; 220 goto FOUND; 221 } 222 223FOUND: 224 $w->font->name($found->{name}) if $found; 225 226 return $got_rtl; 227} 228 229sub find_glyphs 230{ 231 my ($font, $glyphs) = @_; 232 $w->font($font); 233 my $null = $w->text_shape(chr($w->font->defaultChar), polyfont => 0); 234 $null = $null ? $null->glyphs->[0] : 0; 235 236 my $z = $w->text_shape($glyphs, polyfont => 0); 237 return 0 unless $z; 238 return !grep { $_ == $null || $_ == 0 } @{$z->glyphs}; 239} 240 241# a font may have glyphs but won't know how to ligate them, i.e. glyph found but script not found 242sub find_shaping_font 243{ 244 my $glyphs = shift; 245 return 1 if find_glyphs($w->font, $glyphs); 246 247 my $got_rtl; 248 my $found; 249 my @f = @{$::application->fonts}; 250 251 # fontconfig fonts 252 for my $f ( @f ) { 253 next unless $f->{vector}; 254 next unless $f->{name} =~ /^[A-Z]/; 255 next unless find_glyphs($f, $glyphs); 256 $found = $f; 257 $got_rtl = 1; 258 goto FOUND; 259 } 260 261FOUND: 262 $w->font->name($found->{name}) if $found; 263 264 return $got_rtl; 265} 266 267sub check_noshape_nofribidi 268{ 269 t('12', '12', 'ltr'); 270 t('12ABC', '12CBA', 'rtl in ltr'); 271 t('>AB', 'BA', 'bidi'); 272 273 $glyphs{"\0"} = 0; 274 t2('12ABC', "\0"x5, [0,1,R(2..4),5], 'null shaping', level => ts::None); 275} 276 277sub check_noreorder 278{ 279 t2('12ABC', '12CBA', [0,1,R(2..4),5], 'reorder glyphs', level => ts::Glyphs, reorder => 1); 280 t2('12ABC', '12ABC', [0,1,r(2..4),5], 'noreorder glyphs', level => ts::Glyphs, reorder => 0); 281 t2('12ABC', '12CBA', [0,1,R(2..4),5], 'reorder full', level => ts::Full, reorder => 1); 282 t2('12ABC', '12ABC', [0,1,r(2..4),5], 'noreorder full', level => ts::Full, reorder => 0); 283} 284 285# very minimal support for bidi and X11 core fonts only 286sub test_minimal 287{ 288 ok(1, "test minimal"); 289 no_glyphs '12ABC'; 290 check_noshape_nofribidi(); 291} 292 293# very minimal support for bidi with xft but no harfbuzz 294sub test_glyph_mapping 295{ 296 ok(1, "test glyph mapping without bidi"); 297 298 SKIP: { 299 glyphs "12ABC"; 300 skip("text shaping is not available", 1) unless glyphs_fully_resolved; 301 check_noshape_nofribidi(); 302 check_noreorder(); 303 } 304} 305 306sub check_proper_bidi 307{ 308 # http://unicode.org/reports/tr9/tr9-22.html 309 SKIP : { 310 glyphs ' ACDEIMNORUYSacdeghimnrs.?"`'; 311 skip("not enough glyphs for proper bidi test", 1) unless glyphs_fully_resolved; 312 t( 313 'car means CAR.', 314 'car means RAC.', 315 'example 1'); 316 t( 317 '<car MEANS CAR.=', 318 '.RAC SNAEM car', 319 'example 2'); 320 t( 321 'he said "<car MEANS CAR=."', 322 'he said "RAC SNAEM car."', 323 'example 3'); 324 t( 325 'DID YOU SAY `>he said "<car MEANS CAR="=`?', 326 '?`he said "RAC SNAEM car"` YAS UOY DID', 327 'example 4', 328 rtl => 1); # XXX not needed for autodetect 329 } 330} 331 332sub test_fribidi 333{ 334 ok(1, "test bidi"); 335 SKIP: { 336 glyphs "12ABC|/%0"; 337 skip("text shaping is not available", 1) unless glyphs_fully_resolved; 338 339 check_noshape_nofribidi(); 340 check_noreorder(); 341 t('12ABC', 'CBA12', 'rtl in rtl', rtl => 1); 342 t2('/|', '%0', [R(0,1),2], 'arabic ligation with ZW nobreaker'); 343 t('|/', '/|', 'no arabic ligation'); 344 345 check_proper_bidi(); 346 } 347} 348 349sub test_shaping 350{ 351 my ($found) = @_; 352 ok(1, "test shaping"); 353 354 SKIP: { 355 skip("no vector fonts", 1) unless $found; 356 357 glyphs "12ABC"; 358 skip("text shaping is not available", 1) unless glyphs_fully_resolved; 359 check_noshape_nofribidi(); 360 check_noreorder(); 361 362 my $z = $w->text_shape('12', polyfont => 0); 363 ok((4 == @{$z->positions // []}), "positions are okay"); 364 ok((2 == @{$z->advances // []}), "advances are okay"); 365 366 $z = $w->text_shape('12', level => ts::Glyphs, polyfont => 0); 367 is_deeply($z->indexes, [0,1,2], "glyph mapper indexes are okay"); 368 ok((0 == @{$z->positions // []}), "glyph mapper positions are okay"); 369 ok((0 == @{$z->advances // []}), "glyph mapper advances are okay"); 370 371 $z = $w->text_shape('12', level => ts::Glyphs, advances => 1, polyfont => 0); 372 ok((4 == @{$z->positions // []}), "glyph mapper positions w/advances are okay"); 373 ok((2 == @{$z->advances // []}), "glyph mapper advances a w/advances are okay"); 374 375 if ( $opt{fribidi} ) { 376 t('12ABC', 'CBA12', 'rtl in rtl', rtl => 1); 377 } 378 379 SKIP: { 380 glyphs "|-/%"; 381 skip("arabic shaping is not available", 1) unless glyphs_fully_resolved; 382 t('|/', '/|', 'no arabic ligation'); 383 t2('/|', '%', [r(0),2], 'arabic ligation'); 384 if ( $opt{fribidi} ) { 385 t('/-|', '|-/', 'arabic non-ligation'); 386 check_proper_bidi(); 387 } 388 } 389 390 SKIP: { 391 skip("no devanagari font", 1) unless find_vector_font("\x{924}"); 392 my $z = $w-> text_shape("\x{924}\x{94d}\x{928}", polyfont => 0); 393 ok( $z && scalar(grep {$_} @{$z->glyphs}), 'devanagari shaping'); 394 } 395 396 SKIP: { 397 skip("no khmer font", 1) unless find_vector_font("\x{179f}"); 398 my $z = $w-> text_shape("\x{179f}\x{17b9}\x{1784}\x{17d2}", polyfont => 0); 399 ok( $z && scalar(grep {$_} @{$z->glyphs}), 'khmer shaping'); 400 } 401 } 402} 403 404sub test_bytes 405{ 406 ok(1, "bytes"); 407 408 my $k = $w-> text_shape("A\x{fe}", level => ts::Bytes, polyfont => 0); 409 is( 2, scalar(@{$k->glyphs}), "two bytes mapped to two glyphs"); 410 is_deeply( $k->indexes, [0,1,2], "two bytes index array"); 411} 412 413sub test_high_unicode 414{ 415 ok(1, "high unicode"); 416 417 my $k = $w-> text_shape("\x{10FF00}" x 2, polyfont => 0); 418 is_deeply( $k->glyphs, [0,0], "unresolvable glyphs"); 419 420 SKIP: { 421 my $chars = find_high_unicode_font; 422 skip("no fonts with characters above 0x10000", 1) unless $chars && @$chars; 423 #splice(@$chars, 256); # win32 reports empty glyphs as available, but surely in 256 should be at least one valid glyph 424 425 my $char; 426 %glyphs = (); 427 for my $c (@$chars) { 428 my $k = $w-> text_shape(chr($c), polyfont => 0); 429 next unless $k && $k->glyphs->[0]; 430 $high_unicode_char = chr($char = $c); # as ^ 431 $glyphs{$high_unicode_char} = $k->glyphs->[0]; 432 last; 433 } 434 skip("text shaping is not available", 1) unless defined $char; 435 t("^^", "^^", sprintf("found char U+%x in " . $w->font->name . " as glyph %x", $char, $glyphs{$high_unicode_char})); 436 } 437} 438 439sub test_glyphs_wrap 440{ SKIP: { 441 skip("no font at all", 1) unless find_shaping_font( "12"); 442 $w->font->size(12); 443 my $z = $w-> text_shape('12', advances => 1, polyfont => 0); 444 is( 2, scalar( @{ $z->glyphs // [] }), "text '12' resolved to 2 glyphs"); 445 446 my ($tw) = @{ $z->advances // [ $w->get_text_width('1') ] }; 447 448 my $r = $w-> text_wrap( $z, 0, tw::BreakSingle ); 449 is_deeply( $r, [], "wrap that doesn't fit"); 450 451 $r = $w-> text_wrap( $z, 0, tw::ReturnFirstLineLength ); 452 is( $r, 1, "tw::ReturnFirstLineLength"); 453 454 $r = $w-> text_wrap( $z, 0, tw::ReturnChunks ); 455 is_deeply( $r, [0,1,1,1], "tw::ReturnChunks"); 456 457 $r = $w-> text_wrap( $z, 0, 0 ); 458 is( scalar(@$r), 2, "wrap: split to 2 pieces"); 459 is_deeply( $r->[0]->glyphs, [ $z->glyphs->[0] ], "glyphs 1"); 460 is_deeply( $r->[1]->glyphs, [ $z->glyphs->[1] ], "glyphs 2"); 461 is_deeply( $r->[0]->indexes, [ $z->indexes->[0], length('12') ], "indexes 1"); 462 is_deeply( $r->[1]->indexes, [ $z->indexes->[1], length('12') ], "indexes 2"); 463 if ( $z-> advances ) { 464 is( $r->[0]->advances->[0], $z->advances->[0], "advances 1"); 465 is( $r->[1]->advances->[0], $z->advances->[1], "advances 2"); 466 is_deeply( $r->[0]->positions, [ @{$z->positions}[0,1] ], "positions 1"); 467 is_deeply( $r->[1]->positions, [ @{$z->positions}[2,3] ], "positions 2"); 468 } 469 470 $r = $w-> text_wrap( $z, 1_000_000, 0 ); 471 is_deeply($r->[0], $z, "quick clone"); 472 473 SKIP: { if ( $opt{shaping} ) { 474 skip("no arabic font", 1) unless find_shaping_font( xtr('|/%')); 475 $w->font->size(12); 476 glyphs "|/%"; 477 skip("arabic shaping is not available", 1) unless glyphs_fully_resolved; 478 # that is tested already, rely on that: t2('/|', '%', [r(0)], 'arabic ligation'); 479 $z = $w-> text_shape(xtr('|/|'), polyfont => 0); # 2 glyphs, | and /|, visually /| is on the left 480 $r = $w-> text_wrap($z, 0, tw::ReturnChunks); 481 is_deeply($r, [0,1 , 1,1], "ligature wrap, chunks"); 482 $r = $w-> text_wrap($z, 0, 0); 483 is_deeply($r->[0]->glyphs, [$glyphs{xtr '%'}], 'ligature wrap, left glyphs'); 484 is_deeply($r->[0]->indexes, [r(1),length('|/|')], 'ligature wrap, left indexes'); 485 is_deeply($r->[1]->glyphs, [$glyphs{xtr '|'}], 'ligature wrap, right glyphs'); 486 is_deeply($r->[1]->indexes, [r(0),length('|/|')], 'ligature wrap, right indexes'); 487 488 $z = $w-> text_wrap_shape(xtr('/|') . "\n" . xtr('/|') . "~p", 489 undef, 490 options => tw::CalcMnemonic|tw::NewLineBreak|tw::CollapseTilde, 491 rtl => 1 492 ); 493 is( $z->[-1]->{tildeLine}, 1, "tilde is at line 1"); 494 is( $z->[-1]->{tildePos}, 2, "'p' is at position 2"); 495 }} 496}} 497 498sub test_combining { SKIP: { 499 skip("no combining without shaping", 1) unless $opt{shaping}; 500 skip("no extended latin font", 1) unless find_shaping_font( "f\x{100}\x{300}"); 501 my $xp; 502 if ( $^O =~ /win32/i) { 503 my $info = $::application->get_system_info; 504 $xp = 1 if $info->{release} < 6; 505 } 506 507 # A with a dash on top combined with an acute 508 # acute must be combined with no advance 509 $w->font->size(12); 510 my $z = $w-> text_shape( "\x{100}\x{300}", polyfont => 0 )->advances; 511 if ( !$z && $w->font->name ne $::application->get_default_font->{name} ) { 512 $w->font->set( %{ $::application-> get_default_font}, size => 12 ); 513 $z = $w-> text_shape( "\x{100}\x{300}", polyfont => 0 )->advances; 514 skip($w->font->name . " does not create advances table", 1) unless $z; 515 } 516 ok( $z->[0] != 0, "'A' has non-zero advance"); 517 if ( $xp ) { 518 if ($z->[1] == 0 ) { 519 ok( 1, "joined 'acute' has zero advance"); 520 } else { 521 skip("This XP is bad at combining, skip ", 1); 522 } 523 } else { 524 ok( $z->[1] == 0, "joined 'acute' has zero advance"); 525 } 526 527 # ff may be a ligature, but that's not essential - 528 # the main interest here to see that ZWNJ is indeed ZW 529 $z = $w-> text_shape( "f\x{200c}f", polyfont => 0 )->advances; 530 ok( $z->[0] != 0, "'f' has non-zero advance"); 531 ok( $z->[1] == 0, "ZWNJ has zero advance"); 532}} 533 534sub dump_bitmap 535{ 536 my ( $text, $i ) = @_; 537 diag("Bitmap dump $text " . $i->width . "x" . $i->height); 538 my ($x,$y) = $i->size; 539 for my $Y ( 1..$y) { 540 my $str = ''; 541 for my $X ( 1..$x) { 542 my $px = $i->pixel($X-1, $y-$Y); 543 $str .= ($px ? '*' : ' '); 544 } 545 diag($str); 546 } 547} 548 549sub test_drawing 550{ SKIP: { 551 glyphs "12"; 552 skip("glyph drawing is not available", 1) unless glyphs_fully_resolved; 553 554 $w-> backColor(cl::Black); 555 $w-> color(cl::White); 556 $w-> font-> set( height => 25, style => fs::Underlined ); 557 $w-> clear; 558 $w-> text_out( "12", 5, 5 ); 559 my $i = $w->image; 560 $i->type(im::Byte); 561 my $sum1 = $i->sum; 562 skip("text drawing on bitmap is not available", 1) unless $sum1; 563 564 my $z = $w-> text_shape('12', polyfont => 0); 565 skip("shaping is not available", 1) unless $z; 566 567 $w-> clear; 568 $w-> text_out( $z, 5, 5 ); 569 $i = $w->image; 570 $i->type(im::Byte); 571 my $sum2 = $i->sum; 572 is($sum2, $sum1, "glyphs plotting"); 573 574 $w-> clear; 575 $w-> text_out( $z->glyphs, 5, 5 ); 576 $i = $w->image; 577 $i->type(im::Byte); 578 $sum2 = $i->sum; 579 is($sum2, $sum1, "glyphs plotting, terse version"); 580 581 $w-> clear; 582 $w-> font-> set( height => 25, style => fs::Underlined, direction => -10 ); 583 $w-> text_out( "12", 5, 5 ); 584 $i = $w->image; 585 $i->type(im::Byte); 586 $sum1 = $i->sum; 587 my $data1 = $i; 588 589 $z = $w-> text_shape('12', polyfont => 0, level => ts::Glyphs); 590 $w-> clear; 591 $w-> text_out( $z, 5, 5 ); 592 $i = $w->image; 593 $i->type(im::Byte); 594 $sum2 = $i->sum; 595 is($sum2, $sum1, "glyphs plotting 45 degrees"); 596 if ( $sum2 ne $sum1 ) { 597 dump_bitmap('1', $data1); 598 dump_bitmap('2', $i); 599 } 600}} 601 602sub run_test 603{ 604 my $unix = shift; 605 606 $w = Prima::DeviceBitmap-> create( type => dbt::Pixmap, width => 32, height => 32); 607 my $found = find_vector_font(xtr('A')); 608 609 my $z = $w-> text_shape( "1", polyfont => 0 ); 610 plan skip_all => "Shaping is not available" if defined $z && $z eq '0'; 611 612 $opt{fribidi} = 1 if Prima::Application->get_system_value(sv::FriBidi); 613 if ( $unix ) { 614 %opt = (%opt, map { $_ => 1 } split ' ', Prima::Application->sys_action('shaper')); 615 if ( $opt{harfbuzz} && $opt{xft}) { 616 $opt{shaping} = 1; 617 test_shaping($found, $opt{fribidi}); 618 } elsif ( $opt{fribidi}) { 619 test_fribidi; 620 } elsif ( $opt{xft}) { 621 test_glyph_mapping; 622 } else { 623 test_minimal; 624 } 625 } else { 626 $opt{shaping} = 1; 627 test_shaping($found, $opt{fribidi}); 628 } 629 test_bytes; 630 test_high_unicode; 631 test_drawing; 632 test_glyphs_wrap; 633 test_combining; 634} 635 636if ( Prima::Application-> get_system_info->{apc} == apc::Unix ) { 637 if ( @ARGV ) { 638 run_test(1); 639 } else { 640 my %options = Prima::options(); 641 my @opt = grep { m/^no-(fribidi|harfbuzz|xft)$/ } sort keys %options; 642 for ( my $i = 0; $i < 2 ** @opt; $i++) { 643 my @xopt = map { "--$_" } @opt[ grep { $i & (1 << $_) } 0..$#opt ]; 644 my @inc = map { "-I$_" } @INC; 645 for ( split "\n", `$^X @inc $0 @xopt TEST 2>&1`) { 646 if (m/^(ok|not ok)\s+\d+(.*)/) { 647 my ( $ok, $info ) = ( $1 eq 'ok', $2); 648 if ( $info =~ /# skip (.*)/) { 649 SKIP: { skip("(@xopt) $1", 1) }; 650 } else { 651 ok($ok, "(@xopt) $info"); 652 } 653 } elsif ( m/# SKIP (.*)/) { 654 SKIP: { skip("(@xopt) $1", 1) }; 655 } elsif ( !m/^\d+\.\.\d+/) { 656 warn "$_\n"; 657 } 658 } 659 } 660 } 661} else { 662 run_test(0); 663} 664 665done_testing; 666 667 668