1package utf8; 2use strict; 3use warnings; 4use re "/aa"; # So we won't even try to look at above Latin1, potentially 5 # resulting in a recursive call 6 7sub DEBUG () { 0 } 8$|=1 if DEBUG; 9 10sub DESTROY {} 11 12my %Cache; 13 14sub croak { require Carp; Carp::croak(@_) } 15 16# Digits may be separated by a single underscore 17my $digits = qr/ ( [0-9] _? )+ (?!:_) /x; 18 19# A sign can be surrounded by white space 20my $sign = qr/ \s* [+-]? \s* /x; 21 22my $f_float = qr/ $sign $digits+ \. $digits* # e.g., 5.0, 5. 23 | $sign $digits* \. $digits+/x; # 0.7, .7 24 25# A number may be an integer, a rational, or a float with an optional exponent 26# We (shudder) accept a signed denominator 27my $number = qr{ ^ $sign $digits+ $ 28 | ^ $sign $digits+ \/ $sign $digits+ $ 29 | ^ $f_float (?: [Ee] [+-]? $digits )? $}x; 30 31sub _loose_name ($) { 32 # Given a lowercase property or property-value name, return its 33 # standardized version that is expected for look-up in the 'loose' hashes 34 # in Heavy.pl (hence, this depends on what mktables does). This squeezes 35 # out blanks, underscores and dashes. The complication stems from the 36 # grandfathered-in 'L_', which retains a single trailing underscore. 37 38# integer or float (no exponent) 39my $integer_or_float_re = qr/ ^ -? \d+ (:? \. \d+ )? $ /x; 40 41# Also includes rationals 42my $numeric_re = qr! $integer_or_float_re | ^ -? \d+ / \d+ $ !x; 43 return $_[0] if $_[0] =~ $numeric_re; 44 45 (my $loose = $_[0]) =~ s/[-_ \t]//g; 46 47 return $loose if $loose !~ / ^ (?: is | to )? l $/x; 48 return 'l_' if $_[0] =~ / l .* _ /x; # If original had a trailing '_' 49 return $loose; 50} 51 52## 53## "SWASH" == "SWATCH HASH". A "swatch" is a swatch of the Unicode landscape. 54## It's a data structure that encodes a set of Unicode characters. 55## 56 57{ 58 # If a floating point number is within this distance from the value of a 59 # fraction, it is considered to be that fraction, even if many more digits 60 # are specified that don't exactly match. 61 my $min_floating_slop; 62 63 # To guard against this program calling something that in turn ends up 64 # calling this program with the same inputs, and hence infinitely 65 # recursing, we keep a stack of the properties that are currently in 66 # progress, pushed upon entry, popped upon return. 67 my @recursed; 68 69 sub SWASHNEW { 70 my ($class, $type, $list, $minbits, $none) = @_; 71 my $user_defined = 0; 72 local $^D = 0 if $^D; 73 74 $class = "" unless defined $class; 75 print STDERR __LINE__, ": class=$class, type=$type, list=", 76 (defined $list) ? $list : ':undef:', 77 ", minbits=$minbits, none=$none\n" if DEBUG; 78 79 ## 80 ## Get the list of codepoints for the type. 81 ## Called from swash_init (see utf8.c) or SWASHNEW itself. 82 ## 83 ## Callers of swash_init: 84 ## op.c:pmtrans -- for tr/// and y/// 85 ## Unicode::UCD::prop_invlist 86 ## Unicode::UCD::prop_invmap 87 ## 88 ## Given a $type, our goal is to fill $list with the set of codepoint 89 ## ranges. If $type is false, $list passed is used. 90 ## 91 ## $minbits: 92 ## For binary properties, $minbits must be 1. 93 ## For character mappings (case and transliteration), $minbits must 94 ## be a number except 1. 95 ## 96 ## $list (or that filled according to $type): 97 ## Refer to perlunicode.pod, "User-Defined Character Properties." 98 ## 99 ## For binary properties, only characters with the property value 100 ## of True should be listed. The 3rd column, if any, will be ignored 101 ## 102 ## $none is undocumented, so I'm (khw) trying to do some documentation 103 ## of it now. It appears to be if there is a mapping in an input file 104 ## that maps to 'XXXX', then that is replaced by $none+1, expressed in 105 ## hexadecimal. It is used somehow in tr///. 106 ## 107 ## To make the parsing of $type clear, this code takes the a rather 108 ## unorthodox approach of last'ing out of the block once we have the 109 ## info we need. Were this to be a subroutine, the 'last' would just 110 ## be a 'return'. 111 ## 112 # If a problem is found $type is returned; 113 # Upon success, a new (or cached) blessed object is returned with 114 # keys TYPE, BITS, EXTRAS, LIST, and NONE with values having the 115 # same meanings as the input parameters. 116 # SPECIALS contains a reference to any special-treatment hash in the 117 # property. 118 # INVERT_IT is non-zero if the result should be inverted before use 119 # USER_DEFINED is non-zero if the result came from a user-defined 120 my $file; ## file to load data from, and also part of the %Cache key. 121 122 # Change this to get a different set of Unicode tables 123 my $unicore_dir = 'unicore'; 124 my $invert_it = 0; 125 my $list_is_from_mktables = 0; # Is $list returned from a mktables 126 # generated file? If so, we know it's 127 # well behaved. 128 129 if ($type) 130 { 131 # Verify that this isn't a recursive call for this property. 132 # Can't use croak, as it may try to recurse to here itself. 133 my $class_type = $class . "::$type"; 134 if (grep { $_ eq $class_type } @recursed) { 135 CORE::die "panic: Infinite recursion in SWASHNEW for '$type'\n"; 136 } 137 push @recursed, $class_type; 138 139 $type =~ s/^\s+//; 140 $type =~ s/\s+$//; 141 142 # regcomp.c surrounds the property name with '__" and '_i' if this 143 # is to be caseless matching. 144 my $caseless = $type =~ s/^(.*)__(.*)_i$/$1$2/; 145 146 print STDERR __LINE__, ": type=$type, caseless=$caseless\n" if DEBUG; 147 148 GETFILE: 149 { 150 ## 151 ## It could be a user-defined property. Look in current 152 ## package if no package given 153 ## 154 155 156 my $caller0 = caller(0); 157 my $caller1 = $type =~ s/(.+)::// 158 ? $1 159 : $caller0 eq 'main' 160 ? 'main' 161 : caller(1); 162 163 if (defined $caller1 && $type =~ /^I[ns]\w+$/) { 164 my $prop = "${caller1}::$type"; 165 if (exists &{$prop}) { 166 # stolen from Scalar::Util::PP::tainted() 167 my $tainted; 168 { 169 local($@, $SIG{__DIE__}, $SIG{__WARN__}); 170 local $^W = 0; 171 no warnings; 172 eval { kill 0 * $prop }; 173 $tainted = 1 if $@ =~ /^Insecure/; 174 } 175 die "Insecure user-defined property \\p{$prop}\n" 176 if $tainted; 177 no strict 'refs'; 178 $list = &{$prop}($caseless); 179 $user_defined = 1; 180 last GETFILE; 181 } 182 } 183 184 # During Perl's compilation, this routine may be called before 185 # the tables are constructed. If so, we have a chicken/egg 186 # problem. If we die, the tables never get constructed, so 187 # keep going, but return an empty table so only what the code 188 # has compiled in internally (currently ASCII/Latin1 range 189 # matching) will work. 190 BEGIN { 191 # Poor man's constant, to avoid a run-time check. 192 $utf8::{miniperl} 193 = \! defined &DynaLoader::boot_DynaLoader; 194 } 195 if (miniperl) { 196 eval "require '$unicore_dir/Heavy.pl'"; 197 if ($@) { 198 print STDERR __LINE__, ": '$@'\n" if DEBUG; 199 pop @recursed if @recursed; 200 return $type; 201 } 202 } 203 else { 204 require "$unicore_dir/Heavy.pl"; 205 } 206 BEGIN { delete $utf8::{miniperl} } 207 208 # All property names are matched caselessly 209 my $property_and_table = CORE::lc $type; 210 print STDERR __LINE__, ": $property_and_table\n" if DEBUG; 211 212 # See if is of the compound form 'property=value', where the 213 # value indicates the table we should use. 214 my ($property, $table, @remainder) = 215 split /\s*[:=]\s*/, $property_and_table, -1; 216 if (@remainder) { 217 pop @recursed if @recursed; 218 return $type; 219 } 220 221 my $prefix; 222 if (! defined $table) { 223 224 # Here, is the single form. The property becomes empty, and 225 # the whole value is the table. 226 $table = $property; 227 $prefix = $property = ""; 228 } else { 229 print STDERR __LINE__, ": $property\n" if DEBUG; 230 231 # Here it is the compound property=table form. The property 232 # name is always loosely matched, and always can have an 233 # optional 'is' prefix (which isn't true in the single 234 # form). 235 $property = _loose_name($property) =~ s/^is//r; 236 237 # And convert to canonical form. Quit if not valid. 238 $property = $utf8::loose_property_name_of{$property}; 239 if (! defined $property) { 240 pop @recursed if @recursed; 241 return $type; 242 } 243 244 $prefix = "$property="; 245 246 # If the rhs looks like it is a number... 247 print STDERR __LINE__, ": table=$table\n" if DEBUG; 248 249 if ($table =~ $number) { 250 print STDERR __LINE__, ": table=$table\n" if DEBUG; 251 252 # Split on slash, in case it is a rational, like \p{1/5} 253 my @parts = split m{ \s* / \s* }x, $table, -1; 254 print __LINE__, ": $type\n" if @parts > 2 && DEBUG; 255 256 foreach my $part (@parts) { 257 print __LINE__, ": part=$part\n" if DEBUG; 258 259 $part =~ s/^\+\s*//; # Remove leading plus 260 $part =~ s/^-\s*/-/; # Remove blanks after unary 261 # minus 262 263 # Remove underscores between digits. 264 $part =~ s/(?<= [0-9] ) _ (?= [0-9] ) //xg; 265 266 # No leading zeros (but don't make a single '0' 267 # into a null string) 268 $part =~ s/ ^ ( -? ) 0+ /$1/x; 269 $part .= '0' if $part eq '-' || $part eq ""; 270 271 # No trailing zeros after a decimal point 272 $part =~ s/ ( \. [0-9]*? ) 0+ $ /$1/x; 273 274 # Begin with a 0 if a leading decimal point 275 $part =~ s/ ^ ( -? ) \. /${1}0./x; 276 277 # Ensure not a trailing decimal point: turn into an 278 # integer 279 $part =~ s/ \. $ //x; 280 281 print STDERR __LINE__, ": part=$part\n" if DEBUG; 282 #return $type if $part eq ""; 283 } 284 285 # If a rational... 286 if (@parts == 2) { 287 288 # If denominator is negative, get rid of it, and ... 289 if ($parts[1] =~ s/^-//) { 290 291 # If numerator is also negative, convert the 292 # whole thing to positive, else move the minus 293 # to the numerator 294 if ($parts[0] !~ s/^-//) { 295 $parts[0] = '-' . $parts[0]; 296 } 297 } 298 $table = join '/', @parts; 299 } 300 elsif ($property ne 'nv' || $parts[0] !~ /\./) { 301 302 # Here is not numeric value, or doesn't have a 303 # decimal point. No further manipulation is 304 # necessary. (Note the hard-coded property name. 305 # This could fail if other properties eventually 306 # had fractions as well; perhaps the cjk ones 307 # could evolve to do that. This hard-coding could 308 # be fixed by mktables generating a list of 309 # properties that could have fractions.) 310 $table = $parts[0]; 311 } else { 312 313 # Here is a floating point numeric_value. Convert 314 # to rational. Get a normalized form, like 315 # 5.00E-01, and look that up in the hash 316 317 my $float = sprintf "%.*e", 318 $utf8::e_precision, 319 0 + $parts[0]; 320 321 if (exists $utf8::nv_floating_to_rational{$float}) { 322 $table = $utf8::nv_floating_to_rational{$float}; 323 } else { 324 pop @recursed if @recursed; 325 return $type; 326 } 327 } 328 print STDERR __LINE__, ": $property=$table\n" if DEBUG; 329 } 330 } 331 332 # Combine lhs (if any) and rhs to get something that matches 333 # the syntax of the lookups. 334 $property_and_table = "$prefix$table"; 335 print STDERR __LINE__, ": $property_and_table\n" if DEBUG; 336 337 # First try stricter matching. 338 $file = $utf8::stricter_to_file_of{$property_and_table}; 339 340 # If didn't find it, try again with looser matching by editing 341 # out the applicable characters on the rhs and looking up 342 # again. 343 my $strict_property_and_table; 344 if (! defined $file) { 345 346 # This isn't used unless the name begins with 'to' 347 $strict_property_and_table = $property_and_table =~ s/^to//r; 348 $table = _loose_name($table); 349 $property_and_table = "$prefix$table"; 350 print STDERR __LINE__, ": $property_and_table\n" if DEBUG; 351 $file = $utf8::loose_to_file_of{$property_and_table}; 352 } 353 354 # Add the constant and go fetch it in. 355 if (defined $file) { 356 357 # If the file name contains a !, it means to invert. The 358 # 0+ makes sure result is numeric 359 $invert_it = 0 + $file =~ s/!//; 360 361 if ($utf8::why_deprecated{$file}) { 362 warnings::warnif('deprecated', "Use of '$type' in \\p{} or \\P{} is deprecated because: $utf8::why_deprecated{$file};"); 363 } 364 365 if ($caseless 366 && exists $utf8::caseless_equivalent{$property_and_table}) 367 { 368 $file = $utf8::caseless_equivalent{$property_and_table}; 369 } 370 371 # The pseudo-directory '#' means that there really isn't a 372 # file to read, the data is in-line as part of the string; 373 # we extract it below. 374 $file = "$unicore_dir/lib/$file.pl" unless $file =~ m!^#/!; 375 last GETFILE; 376 } 377 print STDERR __LINE__, ": didn't find $property_and_table\n" if DEBUG; 378 379 ## 380 ## Last attempt -- see if it's a standard "To" name 381 ## (e.g. "ToLower") ToTitle is used by ucfirst(). 382 ## The user-level way to access ToDigit() and ToFold() 383 ## is to use Unicode::UCD. 384 ## 385 # Only check if caller wants non-binary 386 if ($minbits != 1) { 387 if ($property_and_table =~ s/^to//) { 388 # Look input up in list of properties for which we have 389 # mapping files. First do it with the strict approach 390 if (defined ($file = $utf8::strict_property_to_file_of{ 391 $strict_property_and_table})) 392 { 393 $type = $utf8::file_to_swash_name{$file}; 394 print STDERR __LINE__, ": type set to $type\n" 395 if DEBUG; 396 $file = "$unicore_dir/$file.pl"; 397 last GETFILE; 398 } 399 elsif (defined ($file = 400 $utf8::loose_property_to_file_of{$property_and_table})) 401 { 402 $type = $utf8::file_to_swash_name{$file}; 403 print STDERR __LINE__, ": type set to $type\n" 404 if DEBUG; 405 $file = "$unicore_dir/$file.pl"; 406 last GETFILE; 407 } # If that fails see if there is a corresponding binary 408 # property file 409 elsif (defined ($file = 410 $utf8::loose_to_file_of{$property_and_table})) 411 { 412 413 # Here, there is no map file for the property we 414 # are trying to get the map of, but this is a 415 # binary property, and there is a file for it that 416 # can easily be translated to a mapping, so use 417 # that, treating this as a binary property. 418 # Setting 'minbits' here causes it to be stored as 419 # such in the cache, so if someone comes along 420 # later looking for just a binary, they get it. 421 $minbits = 1; 422 423 # The 0+ makes sure is numeric 424 $invert_it = 0 + $file =~ s/!//; 425 $file = "$unicore_dir/lib/$file.pl" 426 unless $file =~ m!^#/!; 427 last GETFILE; 428 } 429 } 430 } 431 432 ## 433 ## If we reach this line, it's because we couldn't figure 434 ## out what to do with $type. Ouch. 435 ## 436 437 pop @recursed if @recursed; 438 return $type; 439 } # end of GETFILE block 440 441 if (defined $file) { 442 print STDERR __LINE__, ": found it (file='$file')\n" if DEBUG; 443 444 ## 445 ## If we reach here, it was due to a 'last GETFILE' above 446 ## (exception: user-defined properties and mappings), so we 447 ## have a filename, so now we load it if we haven't already. 448 449 # The pseudo-directory '#' means the result isn't really a 450 # file, but is in-line, with semi-colons to be turned into 451 # new-lines. Since it is in-line there is no advantage to 452 # caching the result 453 if ($file =~ s!^#/!!) { 454 $list = $utf8::inline_definitions[$file]; 455 } 456 else { 457 # Here, we have an actual file to read in and load, but it 458 # may already have been read-in and cached. The cache key 459 # is the class and file to load, and whether the results 460 # need to be inverted. 461 my $found = $Cache{$class, $file, $invert_it}; 462 if ($found and ref($found) eq $class) { 463 print STDERR __LINE__, ": Returning cached swash for '$class,$file,$invert_it' for \\p{$type}\n" if DEBUG; 464 pop @recursed if @recursed; 465 return $found; 466 } 467 468 local $@; 469 local $!; 470 $list = do $file; die $@ if $@; 471 } 472 473 $list_is_from_mktables = 1; 474 } 475 } # End of $type is non-null 476 477 # Here, either $type was null, or we found the requested property and 478 # read it into $list 479 480 my $extras = ""; 481 482 my $bits = $minbits; 483 484 # mktables lists don't have extras, like '&utf8::prop', so don't need 485 # to separate them; also lists are already sorted, so don't need to do 486 # that. 487 if ($list && ! $list_is_from_mktables) { 488 my $taint = substr($list,0,0); # maintain taint 489 490 # Separate the extras from the code point list, and make sure 491 # user-defined properties and tr/// are well-behaved for 492 # downstream code. 493 if ($user_defined || $none) { 494 my @tmp = split(/^/m, $list); 495 my %seen; 496 no warnings; 497 498 # The extras are anything that doesn't begin with a hex digit. 499 $extras = join '', $taint, grep /^[^0-9a-fA-F]/, @tmp; 500 501 # Remove the extras, and sort the remaining entries by the 502 # numeric value of their beginning hex digits, removing any 503 # duplicates. 504 $list = join '', $taint, 505 map { $_->[1] } 506 sort { $a->[0] <=> $b->[0] } 507 map { /^([0-9a-fA-F]+)/ && !$seen{$1}++ ? [ CORE::hex($1), $_ ] : () } 508 @tmp; # XXX doesn't do ranges right 509 } 510 else { 511 # mktables has gone to some trouble to make non-user defined 512 # properties well-behaved, so we can skip the effort we do for 513 # user-defined ones. Any extras are at the very beginning of 514 # the string. 515 516 # This regex splits out the first lines of $list into $1 and 517 # strips them off from $list, until we get one that begins 518 # with a hex number, alone on the line, or followed by a tab. 519 # Either portion may be empty. 520 $list =~ s/ \A ( .*? ) 521 (?: \z | (?= ^ [0-9a-fA-F]+ (?: \t | $) ) ) 522 //msx; 523 524 $extras = "$taint$1"; 525 } 526 } 527 528 if ($none) { 529 my $hextra = sprintf "%04x", $none + 1; 530 $list =~ s/\tXXXX$/\t$hextra/mg; 531 } 532 533 if ($minbits != 1 && $minbits < 32) { # not binary property 534 my $top = 0; 535 while ($list =~ /^([0-9a-fA-F]+)(?:[\t]([0-9a-fA-F]+)?)(?:[ \t]([0-9a-fA-F]+))?/mg) { 536 my $min = CORE::hex $1; 537 my $max = defined $2 ? CORE::hex $2 : $min; 538 my $val = defined $3 ? CORE::hex $3 : 0; 539 $val += $max - $min if defined $3; 540 $top = $val if $val > $top; 541 } 542 my $topbits = 543 $top > 0xffff ? 32 : 544 $top > 0xff ? 16 : 8; 545 $bits = $topbits if $bits < $topbits; 546 } 547 548 my @extras; 549 if ($extras) { 550 for my $x ($extras) { 551 my $taint = substr($x,0,0); # maintain taint 552 pos $x = 0; 553 while ($x =~ /^([^0-9a-fA-F\n])(.*)/mg) { 554 my $char = "$1$taint"; 555 my $name = "$2$taint"; 556 print STDERR __LINE__, ": char [$char] => name [$name]\n" 557 if DEBUG; 558 if ($char =~ /[-+!&]/) { 559 my ($c,$t) = split(/::/, $name, 2); # bogus use of ::, really 560 my $subobj; 561 if ($c eq 'utf8') { 562 $subobj = utf8->SWASHNEW($t, "", $minbits, 0); 563 } 564 elsif (exists &$name) { 565 $subobj = utf8->SWASHNEW($name, "", $minbits, 0); 566 } 567 elsif ($c =~ /^([0-9a-fA-F]+)/) { 568 $subobj = utf8->SWASHNEW("", $c, $minbits, 0); 569 } 570 print STDERR __LINE__, ": returned from getting sub object for $name\n" if DEBUG; 571 if (! ref $subobj) { 572 pop @recursed if @recursed && $type; 573 return $subobj; 574 } 575 push @extras, $name => $subobj; 576 $bits = $subobj->{BITS} if $bits < $subobj->{BITS}; 577 $user_defined = $subobj->{USER_DEFINED} 578 if $subobj->{USER_DEFINED}; 579 } 580 } 581 } 582 } 583 584 if (DEBUG) { 585 print STDERR __LINE__, ": CLASS = $class, TYPE => $type, BITS => $bits, NONE => $none, INVERT_IT => $invert_it, USER_DEFINED => $user_defined"; 586 print STDERR "\nLIST =>\n$list" if defined $list; 587 print STDERR "\nEXTRAS =>\n$extras" if defined $extras; 588 print STDERR "\n"; 589 } 590 591 my $SWASH = bless { 592 TYPE => $type, 593 BITS => $bits, 594 EXTRAS => $extras, 595 LIST => $list, 596 NONE => $none, 597 USER_DEFINED => $user_defined, 598 @extras, 599 } => $class; 600 601 if ($file) { 602 $Cache{$class, $file, $invert_it} = $SWASH; 603 if ($type 604 && exists $utf8::SwashInfo{$type} 605 && exists $utf8::SwashInfo{$type}{'specials_name'}) 606 { 607 my $specials_name = $utf8::SwashInfo{$type}{'specials_name'}; 608 no strict "refs"; 609 print STDERR "\nspecials_name => $specials_name\n" if DEBUG; 610 $SWASH->{'SPECIALS'} = \%$specials_name; 611 } 612 $SWASH->{'INVERT_IT'} = $invert_it; 613 } 614 615 pop @recursed if @recursed && $type; 616 617 return $SWASH; 618 } 619} 620 621# Now SWASHGET is recasted into a C function S_swatch_get (see utf8.c). 622 6231; 624