[Summary view] [Print] [Text view]

   1  
   2  # Time-stamp: "2004-10-06 23:26:33 ADT"
   3  # Sean M. Burke <sburke@cpan.org>
   4  
   5  require 5.000;
   6  package I18N::LangTags;
   7  use strict;
   8  use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION %Panic);
   9  require Exporter;
  10  @ISA = qw(Exporter);
  11  @EXPORT = qw();
  12  @EXPORT_OK = qw(is_language_tag same_language_tag
  13                  extract_language_tags super_languages
  14                  similarity_language_tag is_dialect_of
  15                  locale2language_tag alternate_language_tags
  16                  encode_language_tag panic_languages
  17                  implicate_supers
  18                  implicate_supers_strictly
  19                 );
  20  %EXPORT_TAGS = ('ALL' => \@EXPORT_OK);
  21  
  22  $VERSION = "0.35";
  23  
  24  sub uniq { my %seen; return grep(!($seen{$_}++), @_); } # a util function
  25  
  26  
  27  =head1 NAME
  28  
  29  I18N::LangTags - functions for dealing with RFC3066-style language tags
  30  
  31  =head1 SYNOPSIS
  32  
  33    use I18N::LangTags();
  34  
  35  ...or specify whichever of those functions you want to import, like so:
  36  
  37    use I18N::LangTags qw(implicate_supers similarity_language_tag);
  38  
  39  All the exportable functions are listed below -- you're free to import
  40  only some, or none at all.  By default, none are imported.  If you
  41  say:
  42  
  43      use I18N::LangTags qw(:ALL)
  44  
  45  ...then all are exported.  (This saves you from having to use
  46  something less obvious like C<use I18N::LangTags qw(/./)>.)
  47  
  48  If you don't import any of these functions, assume a C<&I18N::LangTags::>
  49  in front of all the function names in the following examples.
  50  
  51  =head1 DESCRIPTION
  52  
  53  Language tags are a formalism, described in RFC 3066 (obsoleting
  54  1766), for declaring what language form (language and possibly
  55  dialect) a given chunk of information is in.
  56  
  57  This library provides functions for common tasks involving language
  58  tags as they are needed in a variety of protocols and applications.
  59  
  60  Please see the "See Also" references for a thorough explanation
  61  of how to correctly use language tags.
  62  
  63  =over
  64  
  65  =cut
  66  
  67  ###########################################################################
  68  
  69  =item * the function is_language_tag($lang1)
  70  
  71  Returns true iff $lang1 is a formally valid language tag.
  72  
  73     is_language_tag("fr")            is TRUE
  74     is_language_tag("x-jicarilla")   is FALSE
  75         (Subtags can be 8 chars long at most -- 'jicarilla' is 9)
  76  
  77     is_language_tag("sgn-US")    is TRUE
  78         (That's American Sign Language)
  79  
  80     is_language_tag("i-Klikitat")    is TRUE
  81         (True without regard to the fact noone has actually
  82          registered Klikitat -- it's a formally valid tag)
  83  
  84     is_language_tag("fr-patois")     is TRUE
  85         (Formally valid -- altho descriptively weak!)
  86  
  87     is_language_tag("Spanish")       is FALSE
  88     is_language_tag("french-patois") is FALSE
  89         (No good -- first subtag has to match
  90          /^([xXiI]|[a-zA-Z]{2,3})$/ -- see RFC3066)
  91  
  92     is_language_tag("x-borg-prot2532") is TRUE
  93         (Yes, subtags can contain digits, as of RFC3066)
  94  
  95  =cut
  96  
  97  sub is_language_tag {
  98  
  99    ## Changes in the language tagging standards may have to be reflected here.
 100  
 101    my($tag) = lc($_[0]);
 102  
 103    return 0 if $tag eq "i" or $tag eq "x";
 104    # Bad degenerate cases that the following
 105    #  regexp would erroneously let pass
 106  
 107    return $tag =~ 
 108      /^(?:  # First subtag
 109           [xi] | [a-z]{2,3}
 110        )
 111        (?:  # Subtags thereafter
 112           -           # separator
 113           [a-z0-9]{1,8}  # subtag  
 114        )*
 115      $/xs ? 1 : 0;
 116  }
 117  
 118  ###########################################################################
 119  
 120  =item * the function extract_language_tags($whatever)
 121  
 122  Returns a list of whatever looks like formally valid language tags
 123  in $whatever.  Not very smart, so don't get too creative with
 124  what you want to feed it.
 125  
 126    extract_language_tags("fr, fr-ca, i-mingo")
 127      returns:   ('fr', 'fr-ca', 'i-mingo')
 128  
 129    extract_language_tags("It's like this: I'm in fr -- French!")
 130      returns:   ('It', 'in', 'fr')
 131    (So don't just feed it any old thing.)
 132  
 133  The output is untainted.  If you don't know what tainting is,
 134  don't worry about it.
 135  
 136  =cut
 137  
 138  sub extract_language_tags {
 139  
 140    ## Changes in the language tagging standards may have to be reflected here.
 141  
 142    my($text) =
 143      $_[0] =~ m/(.+)/  # to make for an untainted result
 144      ? $1 : ''
 145    ;
 146    
 147    return grep(!m/^[ixIX]$/s, # 'i' and 'x' aren't good tags
 148      $text =~ 
 149      m/
 150        \b
 151        (?:  # First subtag
 152           [iIxX] | [a-zA-Z]{2,3}
 153        )
 154        (?:  # Subtags thereafter
 155           -           # separator
 156           [a-zA-Z0-9]{1,8}  # subtag  
 157        )*
 158        \b
 159      /xsg
 160    );
 161  }
 162  
 163  ###########################################################################
 164  
 165  =item * the function same_language_tag($lang1, $lang2)
 166  
 167  Returns true iff $lang1 and $lang2 are acceptable variant tags
 168  representing the same language-form.
 169  
 170     same_language_tag('x-kadara', 'i-kadara')  is TRUE
 171        (The x/i- alternation doesn't matter)
 172     same_language_tag('X-KADARA', 'i-kadara')  is TRUE
 173        (...and neither does case)
 174     same_language_tag('en',       'en-US')     is FALSE
 175        (all-English is not the SAME as US English)
 176     same_language_tag('x-kadara', 'x-kadar')   is FALSE
 177        (these are totally unrelated tags)
 178     same_language_tag('no-bok',    'nb')       is TRUE
 179        (no-bok is a legacy tag for nb (Norwegian Bokmal))
 180  
 181  C<same_language_tag> works by just seeing whether
 182  C<encode_language_tag($lang1)> is the same as
 183  C<encode_language_tag($lang2)>.
 184  
 185  (Yes, I know this function is named a bit oddly.  Call it historic
 186  reasons.)
 187  
 188  =cut
 189  
 190  sub same_language_tag {
 191    my $el1 = &encode_language_tag($_[0]);
 192    return 0 unless defined $el1;
 193     # this avoids the problem of
 194     # encode_language_tag($lang1) eq and encode_language_tag($lang2)
 195     # being true if $lang1 and $lang2 are both undef
 196  
 197    return $el1 eq &encode_language_tag($_[1]) ? 1 : 0;
 198  }
 199  
 200  ###########################################################################
 201  
 202  =item * the function similarity_language_tag($lang1, $lang2)
 203  
 204  Returns an integer representing the degree of similarity between
 205  tags $lang1 and $lang2 (the order of which does not matter), where
 206  similarity is the number of common elements on the left,
 207  without regard to case and to x/i- alternation.
 208  
 209     similarity_language_tag('fr', 'fr-ca')           is 1
 210        (one element in common)
 211     similarity_language_tag('fr-ca', 'fr-FR')        is 1
 212        (one element in common)
 213  
 214     similarity_language_tag('fr-CA-joual',
 215                             'fr-CA-PEI')             is 2
 216     similarity_language_tag('fr-CA-joual', 'fr-CA')  is 2
 217        (two elements in common)
 218  
 219     similarity_language_tag('x-kadara', 'i-kadara')  is 1
 220        (x/i- doesn't matter)
 221  
 222     similarity_language_tag('en',       'x-kadar')   is 0
 223     similarity_language_tag('x-kadara', 'x-kadar')   is 0
 224        (unrelated tags -- no similarity)
 225  
 226     similarity_language_tag('i-cree-syllabic',
 227                             'i-cherokee-syllabic')   is 0
 228        (no B<leftmost> elements in common!)
 229  
 230  =cut
 231  
 232  sub similarity_language_tag {
 233    my $lang1 = &encode_language_tag($_[0]);
 234    my $lang2 = &encode_language_tag($_[1]);
 235     # And encode_language_tag takes care of the whole
 236     #  no-nyn==nn, i-hakka==zh-hakka, etc, things
 237     
 238    # NB: (i-sil-...)?  (i-sgn-...)?
 239  
 240    return undef if !defined($lang1) and !defined($lang2);
 241    return 0 if !defined($lang1) or !defined($lang2);
 242  
 243    my @l1_subtags = split('-', $lang1);
 244    my @l2_subtags = split('-', $lang2);
 245    my $similarity = 0;
 246  
 247    while(@l1_subtags and @l2_subtags) {
 248      if(shift(@l1_subtags) eq shift(@l2_subtags)) {
 249        ++$similarity;
 250      } else {
 251        last;
 252      } 
 253    }
 254    return $similarity;
 255  }
 256  
 257  ###########################################################################
 258  
 259  =item * the function is_dialect_of($lang1, $lang2)
 260  
 261  Returns true iff language tag $lang1 represents a subform of
 262  language tag $lang2.
 263  
 264  B<Get the order right!  It doesn't work the other way around!>
 265  
 266     is_dialect_of('en-US', 'en')            is TRUE
 267       (American English IS a dialect of all-English)
 268  
 269     is_dialect_of('fr-CA-joual', 'fr-CA')   is TRUE
 270     is_dialect_of('fr-CA-joual', 'fr')      is TRUE
 271       (Joual is a dialect of (a dialect of) French)
 272  
 273     is_dialect_of('en', 'en-US')            is FALSE
 274       (all-English is a NOT dialect of American English)
 275  
 276     is_dialect_of('fr', 'en-CA')            is FALSE
 277  
 278     is_dialect_of('en',    'en'   )         is TRUE
 279     is_dialect_of('en-US', 'en-US')         is TRUE
 280       (B<Note:> these are degenerate cases)
 281  
 282     is_dialect_of('i-mingo-tom', 'x-Mingo') is TRUE
 283       (the x/i thing doesn't matter, nor does case)
 284  
 285     is_dialect_of('nn', 'no')               is TRUE
 286       (because 'nn' (New Norse) is aliased to 'no-nyn',
 287        as a special legacy case, and 'no-nyn' is a
 288        subform of 'no' (Norwegian))
 289  
 290  =cut
 291  
 292  sub is_dialect_of {
 293  
 294    my $lang1 = &encode_language_tag($_[0]);
 295    my $lang2 = &encode_language_tag($_[1]);
 296  
 297    return undef if !defined($lang1) and !defined($lang2);
 298    return 0 if !defined($lang1) or !defined($lang2);
 299  
 300    return 1 if $lang1 eq $lang2;
 301    return 0 if length($lang1) < length($lang2);
 302  
 303    $lang1 .= '-';
 304    $lang2 .= '-';
 305    return
 306      (substr($lang1, 0, length($lang2)) eq $lang2) ? 1 : 0;
 307  }
 308  
 309  ###########################################################################
 310  
 311  =item * the function super_languages($lang1)
 312  
 313  Returns a list of language tags that are superordinate tags to $lang1
 314  -- it gets this by removing subtags from the end of $lang1 until
 315  nothing (or just "i" or "x") is left.
 316  
 317     super_languages("fr-CA-joual")  is  ("fr-CA", "fr")
 318  
 319     super_languages("en-AU")  is  ("en")
 320  
 321     super_languages("en")  is  empty-list, ()
 322  
 323     super_languages("i-cherokee")  is  empty-list, ()
 324      ...not ("i"), which would be illegal as well as pointless.
 325  
 326  If $lang1 is not a valid language tag, returns empty-list in
 327  a list context, undef in a scalar context.
 328  
 329  A notable and rather unavoidable problem with this method:
 330  "x-mingo-tom" has an "x" because the whole tag isn't an
 331  IANA-registered tag -- but super_languages('x-mingo-tom') is
 332  ('x-mingo') -- which isn't really right, since 'i-mingo' is
 333  registered.  But this module has no way of knowing that.  (But note
 334  that same_language_tag('x-mingo', 'i-mingo') is TRUE.)
 335  
 336  More importantly, you assume I<at your peril> that superordinates of
 337  $lang1 are mutually intelligible with $lang1.  Consider this
 338  carefully.
 339  
 340  =cut 
 341  
 342  sub super_languages {
 343    my $lang1 = $_[0];
 344    return() unless defined($lang1) && &is_language_tag($lang1);
 345  
 346    # a hack for those annoying new (2001) tags:
 347    $lang1 =~ s/^nb\b/no-bok/i; # yes, backwards
 348    $lang1 =~ s/^nn\b/no-nyn/i; # yes, backwards
 349    $lang1 =~ s/^[ix](-hakka\b)/zh$1/i; # goes the right way
 350     # i-hakka-bork-bjork-bjark => zh-hakka-bork-bjork-bjark
 351  
 352    my @l1_subtags = split('-', $lang1);
 353  
 354    ## Changes in the language tagging standards may have to be reflected here.
 355  
 356    # NB: (i-sil-...)?
 357  
 358    my @supers = ();
 359    foreach my $bit (@l1_subtags) {
 360      push @supers, 
 361        scalar(@supers) ? ($supers[-1] . '-' . $bit) : $bit;
 362    }
 363    pop @supers if @supers;
 364    shift @supers if @supers && $supers[0] =~ m<^[iIxX]$>s;
 365    return reverse @supers;
 366  }
 367  
 368  ###########################################################################
 369  
 370  =item * the function locale2language_tag($locale_identifier)
 371  
 372  This takes a locale name (like "en", "en_US", or "en_US.ISO8859-1")
 373  and maps it to a language tag.  If it's not mappable (as with,
 374  notably, "C" and "POSIX"), this returns empty-list in a list context,
 375  or undef in a scalar context.
 376  
 377     locale2language_tag("en") is "en"
 378  
 379     locale2language_tag("en_US") is "en-US"
 380  
 381     locale2language_tag("en_US.ISO8859-1") is "en-US"
 382  
 383     locale2language_tag("C") is undef or ()
 384  
 385     locale2language_tag("POSIX") is undef or ()
 386  
 387     locale2language_tag("POSIX") is undef or ()
 388  
 389  I'm not totally sure that locale names map satisfactorily to language
 390  tags.  Think REAL hard about how you use this.  YOU HAVE BEEN WARNED.
 391  
 392  The output is untainted.  If you don't know what tainting is,
 393  don't worry about it.
 394  
 395  =cut 
 396  
 397  sub locale2language_tag {
 398    my $lang =
 399      $_[0] =~ m/(.+)/  # to make for an untainted result
 400      ? $1 : ''
 401    ;
 402  
 403    return $lang if &is_language_tag($lang); # like "en"
 404  
 405    $lang =~ tr<_><->;  # "en_US" -> en-US
 406    $lang =~ s<(?:[\.\@][-_a-zA-Z0-9]+)+$><>s;  # "en_US.ISO8859-1" -> en-US
 407     # it_IT.utf8@euro => it-IT
 408  
 409    return $lang if &is_language_tag($lang);
 410  
 411    return;
 412  }
 413  
 414  ###########################################################################
 415  
 416  =item * the function encode_language_tag($lang1)
 417  
 418  This function, if given a language tag, returns an encoding of it such
 419  that:
 420  
 421  * tags representing different languages never get the same encoding.
 422  
 423  * tags representing the same language always get the same encoding.
 424  
 425  * an encoding of a formally valid language tag always is a string
 426  value that is defined, has length, and is true if considered as a
 427  boolean.
 428  
 429  Note that the encoding itself is B<not> a formally valid language tag.
 430  Note also that you cannot, currently, go from an encoding back to a
 431  language tag that it's an encoding of.
 432  
 433  Note also that you B<must> consider the encoded value as atomic; i.e.,
 434  you should not consider it as anything but an opaque, unanalysable
 435  string value.  (The internals of the encoding method may change in
 436  future versions, as the language tagging standard changes over time.)
 437  
 438  C<encode_language_tag> returns undef if given anything other than a
 439  formally valid language tag.
 440  
 441  The reason C<encode_language_tag> exists is because different language
 442  tags may represent the same language; this is normally treatable with
 443  C<same_language_tag>, but consider this situation:
 444  
 445  You have a data file that expresses greetings in different languages.
 446  Its format is "[language tag]=[how to say 'Hello']", like:
 447  
 448            en-US=Hiho
 449            fr=Bonjour
 450            i-mingo=Hau'
 451  
 452  And suppose you write a program that reads that file and then runs as
 453  a daemon, answering client requests that specify a language tag and
 454  then expect the string that says how to greet in that language.  So an
 455  interaction looks like:
 456  
 457            greeting-client asks:    fr
 458            greeting-server answers: Bonjour
 459  
 460  So far so good.  But suppose the way you're implementing this is:
 461  
 462            my %greetings;
 463            die unless open(IN, "<in.dat");
 464            while(<IN>) {
 465              chomp;
 466              next unless /^([^=]+)=(.+)/s;
 467              my($lang, $expr) = ($1, $2);
 468              $greetings{$lang} = $expr;
 469            }
 470            close(IN);
 471  
 472  at which point %greetings has the contents:
 473  
 474            "en-US"   => "Hiho"
 475            "fr"      => "Bonjour"
 476            "i-mingo" => "Hau'"
 477  
 478  And suppose then that you answer client requests for language $wanted
 479  by just looking up $greetings{$wanted}.
 480  
 481  If the client asks for "fr", that will look up successfully in
 482  %greetings, to the value "Bonjour".  And if the client asks for
 483  "i-mingo", that will look up successfully in %greetings, to the value
 484  "Hau'".
 485  
 486  But if the client asks for "i-Mingo" or "x-mingo", or "Fr", then the
 487  lookup in %greetings fails.  That's the Wrong Thing.
 488  
 489  You could instead do lookups on $wanted with:
 490  
 491            use I18N::LangTags qw(same_language_tag);
 492            my $response = '';
 493            foreach my $l2 (keys %greetings) {
 494              if(same_language_tag($wanted, $l2)) {
 495                $response = $greetings{$l2};
 496                last;
 497              }
 498            }
 499  
 500  But that's rather inefficient.  A better way to do it is to start your
 501  program with:
 502  
 503            use I18N::LangTags qw(encode_language_tag);
 504            my %greetings;
 505            die unless open(IN, "<in.dat");
 506            while(<IN>) {
 507              chomp;
 508              next unless /^([^=]+)=(.+)/s;
 509              my($lang, $expr) = ($1, $2);
 510              $greetings{
 511                          encode_language_tag($lang)
 512                        } = $expr;
 513            }
 514            close(IN);
 515  
 516  and then just answer client requests for language $wanted by just
 517  looking up
 518  
 519            $greetings{encode_language_tag($wanted)}
 520  
 521  And that does the Right Thing.
 522  
 523  =cut
 524  
 525  sub encode_language_tag {
 526    # Only similarity_language_tag() is allowed to analyse encodings!
 527  
 528    ## Changes in the language tagging standards may have to be reflected here.
 529  
 530    my($tag) = $_[0] || return undef;
 531    return undef unless &is_language_tag($tag);
 532  
 533    # For the moment, these legacy variances are few enough that
 534    #  we can just handle them here with regexps.
 535    $tag =~ s/^iw\b/he/i; # Hebrew
 536    $tag =~ s/^in\b/id/i; # Indonesian
 537    $tag =~ s/^cre\b/cr/i; # Cree
 538    $tag =~ s/^jw\b/jv/i; # Javanese
 539    $tag =~ s/^[ix]-lux\b/lb/i;  # Luxemburger
 540    $tag =~ s/^[ix]-navajo\b/nv/i;  # Navajo
 541    $tag =~ s/^ji\b/yi/i;  # Yiddish
 542    # SMB 2003 -- Hm.  There's a bunch of new XXX->YY variances now,
 543    #  but maybe they're all so obscure I can ignore them.   "Obscure"
 544    #  meaning either that the language is obscure, and/or that the
 545    #  XXX form was extant so briefly that it's unlikely it was ever
 546    #  used.  I hope.
 547    #
 548    # These go FROM the simplex to complex form, to get
 549    #  similarity-comparison right.  And that's okay, since
 550    #  similarity_language_tag is the only thing that
 551    #  analyzes our output.
 552    $tag =~ s/^[ix]-hakka\b/zh-hakka/i;  # Hakka
 553    $tag =~ s/^nb\b/no-bok/i;  # BACKWARDS for Bokmal
 554    $tag =~ s/^nn\b/no-nyn/i;  # BACKWARDS for Nynorsk
 555  
 556    $tag =~ s/^[xiXI]-//s;
 557     # Just lop off any leading "x/i-"
 558  
 559    return "~" . uc($tag);
 560  }
 561  
 562  #--------------------------------------------------------------------------
 563  
 564  =item * the function alternate_language_tags($lang1)
 565  
 566  This function, if given a language tag, returns all language tags that
 567  are alternate forms of this language tag.  (I.e., tags which refer to
 568  the same language.)  This is meant to handle legacy tags caused by
 569  the minor changes in language tag standards over the years; and
 570  the x-/i- alternation is also dealt with.
 571  
 572  Note that this function does I<not> try to equate new (and never-used,
 573  and unusable)
 574  ISO639-2 three-letter tags to old (and still in use) ISO639-1
 575  two-letter equivalents -- like "ara" -> "ar" -- because
 576  "ara" has I<never> been in use as an Internet language tag,
 577  and RFC 3066 stipulates that it never should be, since a shorter
 578  tag ("ar") exists.
 579  
 580  Examples:
 581  
 582            alternate_language_tags('no-bok')       is ('nb')
 583            alternate_language_tags('nb')           is ('no-bok')
 584            alternate_language_tags('he')           is ('iw')
 585            alternate_language_tags('iw')           is ('he')
 586            alternate_language_tags('i-hakka')      is ('zh-hakka', 'x-hakka')
 587            alternate_language_tags('zh-hakka')     is ('i-hakka', 'x-hakka')
 588            alternate_language_tags('en')           is ()
 589            alternate_language_tags('x-mingo-tom')  is ('i-mingo-tom')
 590            alternate_language_tags('x-klikitat')   is ('i-klikitat')
 591            alternate_language_tags('i-klikitat')   is ('x-klikitat')
 592  
 593  This function returns empty-list if given anything other than a formally
 594  valid language tag.
 595  
 596  =cut
 597  
 598  my %alt = qw( i x   x i   I X   X I );
 599  sub alternate_language_tags {
 600    my $tag = $_[0];
 601    return() unless &is_language_tag($tag);
 602  
 603    my @em; # push 'em real goood!
 604  
 605    # For the moment, these legacy variances are few enough that
 606    #  we can just handle them here with regexps.
 607    
 608    if(     $tag =~ m/^[ix]-hakka\b(.*)/i) {push @em, "zh-hakka$1";
 609    } elsif($tag =~ m/^zh-hakka\b(.*)/i) {  push @em, "x-hakka$1", "i-hakka$1";
 610  
 611    } elsif($tag =~ m/^he\b(.*)/i) { push @em, "iw$1";
 612    } elsif($tag =~ m/^iw\b(.*)/i) { push @em, "he$1";
 613  
 614    } elsif($tag =~ m/^in\b(.*)/i) { push @em, "id$1";
 615    } elsif($tag =~ m/^id\b(.*)/i) { push @em, "in$1";
 616  
 617    } elsif($tag =~ m/^[ix]-lux\b(.*)/i) { push @em, "lb$1";
 618    } elsif($tag =~ m/^lb\b(.*)/i) {       push @em, "i-lux$1", "x-lux$1";
 619  
 620    } elsif($tag =~ m/^[ix]-navajo\b(.*)/i) { push @em, "nv$1";
 621    } elsif($tag =~ m/^nv\b(.*)/i) {          push @em, "i-navajo$1", "x-navajo$1";
 622  
 623    } elsif($tag =~ m/^yi\b(.*)/i) { push @em, "ji$1";
 624    } elsif($tag =~ m/^ji\b(.*)/i) { push @em, "yi$1";
 625  
 626    } elsif($tag =~ m/^nb\b(.*)/i) {     push @em, "no-bok$1";
 627    } elsif($tag =~ m/^no-bok\b(.*)/i) { push @em, "nb$1";
 628    
 629    } elsif($tag =~ m/^nn\b(.*)/i) {     push @em, "no-nyn$1";
 630    } elsif($tag =~ m/^no-nyn\b(.*)/i) { push @em, "nn$1";
 631    }
 632  
 633    push @em, $alt{$1} . $2 if $tag =~ /^([XIxi])(-.+)/;
 634    return @em;
 635  }
 636  
 637  ###########################################################################
 638  
 639  {
 640    # Init %Panic...
 641    
 642    my @panic = (  # MUST all be lowercase!
 643     # Only large ("national") languages make it in this list.
 644     #  If you, as a user, are so bizarre that the /only/ language
 645     #  you claim to accept is Galician, then no, we won't do you
 646     #  the favor of providing Catalan as a panic-fallback for
 647     #  you.  Because if I start trying to add "little languages" in
 648     #  here, I'll just go crazy.
 649  
 650     # Scandinavian lgs.  All based on opinion and hearsay.
 651     'sv' => [qw(nb no da nn)],
 652     'da' => [qw(nb no sv nn)], # I guess
 653     [qw(no nn nb)], [qw(no nn nb sv da)],
 654     'is' => [qw(da sv no nb nn)],
 655     'fo' => [qw(da is no nb nn sv)], # I guess
 656     
 657     # I think this is about the extent of tolerable intelligibility
 658     #  among large modern Romance languages.
 659     'pt' => [qw(es ca it fr)], # Portuguese, Spanish, Catalan, Italian, French
 660     'ca' => [qw(es pt it fr)],
 661     'es' => [qw(ca it fr pt)],
 662     'it' => [qw(es fr ca pt)],
 663     'fr' => [qw(es it ca pt)],
 664     
 665     # Also assume that speakers of the main Indian languages prefer
 666     #  to read/hear Hindi over English
 667     [qw(
 668       as bn gu kn ks kok ml mni mr ne or pa sa sd te ta ur
 669     )] => 'hi',
 670      # Assamese, Bengali, Gujarati, [Hindi,] Kannada (Kanarese), Kashmiri,
 671      # Konkani, Malayalam, Meithei (Manipuri), Marathi, Nepali, Oriya,
 672      # Punjabi, Sanskrit, Sindhi, Telugu, Tamil, and Urdu.
 673     'hi' => [qw(bn pa as or)],
 674     # I welcome finer data for the other Indian languages.
 675     #  E.g., what should Oriya's list be, besides just Hindi?
 676     
 677     # And the panic languages for English is, of course, nil!
 678  
 679     # My guesses at Slavic intelligibility:
 680     ([qw(ru be uk)]) x 2,  # Russian, Belarusian, Ukranian
 681     'sr' => 'hr', 'hr' => 'sr', # Serb + Croat
 682     'cs' => 'sk', 'sk' => 'cs', # Czech + Slovak
 683  
 684     'ms' => 'id', 'id' => 'ms', # Malay + Indonesian
 685  
 686     'et' => 'fi', 'fi' => 'et', # Estonian + Finnish
 687  
 688     #?? 'lo' => 'th', 'th' => 'lo', # Lao + Thai
 689  
 690    );
 691    my($k,$v);
 692    while(@panic) {
 693      ($k,$v) = splice(@panic,0,2);
 694      foreach my $k (ref($k) ? @$k : $k) {
 695        foreach my $v (ref($v) ? @$v : $v) {
 696          push @{$Panic{$k} ||= []}, $v unless $k eq $v;
 697        }
 698      }
 699    }
 700  }
 701  
 702  =item * the function @langs = panic_languages(@accept_languages)
 703  
 704  This function takes a list of 0 or more language
 705  tags that constitute a given user's Accept-Language list, and
 706  returns a list of tags for I<other> (non-super)
 707  languages that are probably acceptable to the user, to be
 708  used I<if all else fails>.
 709  
 710  For example, if a user accepts only 'ca' (Catalan) and
 711  'es' (Spanish), and the documents/interfaces you have
 712  available are just in German, Italian, and Chinese, then
 713  the user will most likely want the Italian one (and not
 714  the Chinese or German one!), instead of getting
 715  nothing.  So C<panic_languages('ca', 'es')> returns
 716  a list containing 'it' (Italian).
 717  
 718  English ('en') is I<always> in the return list, but
 719  whether it's at the very end or not depends
 720  on the input languages.  This function works by consulting
 721  an internal table that stipulates what common
 722  languages are "close" to each other.
 723  
 724  A useful construct you might consider using is:
 725  
 726    @fallbacks = super_languages(@accept_languages);
 727    push @fallbacks, panic_languages(
 728      @accept_languages, @fallbacks,
 729    );
 730  
 731  =cut
 732  
 733  sub panic_languages {
 734    # When in panic or in doubt, run in circles, scream, and shout!
 735    my(@out, %seen);
 736    foreach my $t (@_) {
 737      next unless $t;
 738      next if $seen{$t}++; # so we don't return it or hit it again
 739      # push @out, super_languages($t); # nah, keep that separate
 740      push @out, @{ $Panic{lc $t} || next };
 741    }
 742    return grep !$seen{$_}++,  @out, 'en';
 743  }
 744  
 745  #---------------------------------------------------------------------------
 746  #---------------------------------------------------------------------------
 747  
 748  =item * the function implicate_supers( ...languages... )
 749  
 750  This takes a list of strings (which are presumed to be language-tags;
 751  strings that aren't, are ignored); and after each one, this function
 752  inserts super-ordinate forms that don't already appear in the list.
 753  The original list, plus these insertions, is returned.
 754  
 755  In other words, it takes this:
 756  
 757    pt-br de-DE en-US fr pt-br-janeiro
 758  
 759  and returns this:
 760  
 761    pt-br pt de-DE de en-US en fr pt-br-janeiro
 762  
 763  This function is most useful in the idiom
 764  
 765    implicate_supers( I18N::LangTags::Detect::detect() );
 766  
 767  (See L<I18N::LangTags::Detect>.)
 768  
 769  
 770  =item * the function implicate_supers_strictly( ...languages... )
 771  
 772  This works like C<implicate_supers> except that the implicated
 773  forms are added to the end of the return list.
 774  
 775  In other words, implicate_supers_strictly takes a list of strings
 776  (which are presumed to be language-tags; strings that aren't, are
 777  ignored) and after the whole given list, it inserts the super-ordinate forms 
 778  of all given tags, minus any tags that already appear in the input list.
 779  
 780  In other words, it takes this:
 781  
 782    pt-br de-DE en-US fr pt-br-janeiro
 783  
 784  and returns this:
 785  
 786    pt-br de-DE en-US fr pt-br-janeiro pt de en
 787  
 788  The reason this function has "_strictly" in its name is that when
 789  you're processing an Accept-Language list according to the RFCs, if
 790  you interpret the RFCs quite strictly, then you would use
 791  implicate_supers_strictly, but for normal use (i.e., common-sense use,
 792  as far as I'm concerned) you'd use implicate_supers.
 793  
 794  =cut
 795  
 796  sub implicate_supers {
 797    my @languages = grep is_language_tag($_), @_;
 798    my %seen_encoded;
 799    foreach my $lang (@languages) {
 800      $seen_encoded{ I18N::LangTags::encode_language_tag($lang) } = 1
 801    }
 802  
 803    my(@output_languages);
 804    foreach my $lang (@languages) {
 805      push @output_languages, $lang;
 806      foreach my $s ( I18N::LangTags::super_languages($lang) ) {
 807        # Note that super_languages returns the longest first.
 808        last if $seen_encoded{ I18N::LangTags::encode_language_tag($s) };
 809        push @output_languages, $s;
 810      }
 811    }
 812    return uniq( @output_languages );
 813  
 814  }
 815  
 816  sub implicate_supers_strictly {
 817    my @tags = grep is_language_tag($_), @_;
 818    return uniq( @_,   map super_languages($_), @_ );
 819  }
 820  
 821  
 822  
 823  ###########################################################################
 824  1;
 825  __END__
 826  
 827  =back
 828  
 829  =head1 ABOUT LOWERCASING
 830  
 831  I've considered making all the above functions that output language
 832  tags return all those tags strictly in lowercase.  Having all your
 833  language tags in lowercase does make some things easier.  But you
 834  might as well just lowercase as you like, or call
 835  C<encode_language_tag($lang1)> where appropriate.
 836  
 837  =head1 ABOUT UNICODE PLAINTEXT LANGUAGE TAGS
 838  
 839  In some future version of I18N::LangTags, I plan to include support
 840  for RFC2482-style language tags -- which are basically just normal
 841  language tags with their ASCII characters shifted into Plane 14.
 842  
 843  =head1 SEE ALSO
 844  
 845  * L<I18N::LangTags::List|I18N::LangTags::List>
 846  
 847  * RFC 3066, C<ftp://ftp.isi.edu/in-notes/rfc3066.txt>, "Tags for the
 848  Identification of Languages".  (Obsoletes RFC 1766)
 849  
 850  * RFC 2277, C<ftp://ftp.isi.edu/in-notes/rfc2277.txt>, "IETF Policy on
 851  Character Sets and Languages".
 852  
 853  * RFC 2231, C<ftp://ftp.isi.edu/in-notes/rfc2231.txt>, "MIME Parameter
 854  Value and Encoded Word Extensions: Character Sets, Languages, and
 855  Continuations".
 856  
 857  * RFC 2482, C<ftp://ftp.isi.edu/in-notes/rfc2482.txt>, 
 858  "Language Tagging in Unicode Plain Text".
 859  
 860  * Locale::Codes, in
 861  C<http://www.perl.com/CPAN/modules/by-module/Locale/>
 862  
 863  * ISO 639-2, "Codes for the representation of names of languages",
 864  including two-letter and three-letter codes,
 865  C<http://www.loc.gov/standards/iso639-2/langcodes.html>
 866  
 867  * The IANA list of registered languages (hopefully up-to-date),
 868  C<http://www.iana.org/assignments/language-tags>
 869  
 870  =head1 COPYRIGHT
 871  
 872  Copyright (c) 1998+ Sean M. Burke. All rights reserved.
 873  
 874  This library is free software; you can redistribute it and/or
 875  modify it under the same terms as Perl itself.
 876  
 877  The programs and documentation in this dist are distributed in
 878  the hope that they will be useful, but without any warranty; without
 879  even the implied warranty of merchantability or fitness for a
 880  particular purpose.
 881  
 882  =head1 AUTHOR
 883  
 884  Sean M. Burke C<sburke@cpan.org>
 885  
 886  =cut
 887