Commit | Line | Data |
f768f60b |
1 | package Locale::Codes; |
2 | # Copyright (C) 2001 Canon Research Centre Europe (CRE). |
3 | # Copyright (C) 2002-2009 Neil Bowers |
4 | # Copyright (c) 2010-2010 Sullivan Beck |
5 | # This program is free software; you can redistribute it and/or modify it |
6 | # under the same terms as Perl itself. |
7 | |
8 | use strict; |
9 | use warnings; |
10 | require 5.002; |
11 | |
12 | use Carp; |
13 | |
14 | #======================================================================= |
15 | # Public Global Variables |
16 | #======================================================================= |
17 | |
18 | # This module is not called directly... %Data is filled in by the |
19 | # calling modules. |
20 | |
21 | use vars qw($VERSION %Data); |
22 | |
23 | # $Data{ TYPE }{ code2id }{ CODESET } { CODE } = [ ID, I ] |
24 | # { id2code }{ CODESET } { ID } = CODE |
25 | # { id2names }{ ID } = [ NAME, NAME, ... ] |
26 | # { alias2id }{ NAME } = [ ID, I ] |
27 | # { id } = FIRST_UNUSED_ID |
28 | # { codealias }{ CODESET } { ALIAS } = CODE |
29 | |
30 | $VERSION='3.12'; |
31 | |
32 | #======================================================================= |
33 | # |
34 | # _code2name ( TYPE,CODE,CODESET ) |
35 | # |
36 | #======================================================================= |
37 | |
38 | sub _code2name { |
39 | my($type,$code,$codeset) = @_; |
40 | |
41 | $code = $Data{$type}{'codealias'}{$codeset}{$code} |
42 | if (exists $Data{$type}{'codealias'}{$codeset}{$code}); |
43 | |
44 | if (exists $Data{$type}{'code2id'}{$codeset} && |
45 | exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
46 | my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} }; |
47 | my $name = $Data{$type}{'id2names'}{$id}[$i]; |
48 | return $name; |
49 | } else { |
50 | #--------------------------------------------------------------- |
51 | # no such code! |
52 | #--------------------------------------------------------------- |
53 | return undef; |
54 | } |
55 | } |
56 | |
57 | #======================================================================= |
58 | # |
59 | # _name2code ( TYPE,NAME,CODESET ) |
60 | # |
61 | #======================================================================= |
62 | |
63 | sub _name2code { |
64 | my($type,$name,$codeset) = @_; |
65 | $name = "" if (! $name); |
66 | $name = lc($name); |
67 | |
68 | if (exists $Data{$type}{'alias2id'}{$name}) { |
69 | my $id = $Data{$type}{'alias2id'}{$name}[0]; |
70 | if (exists $Data{$type}{'id2code'}{$codeset}{$id}) { |
71 | return $Data{$type}{'id2code'}{$codeset}{$id}; |
72 | } |
73 | } |
74 | |
75 | #--------------------------------------------------------------- |
76 | # no such name! |
77 | #--------------------------------------------------------------- |
78 | return undef; |
79 | } |
80 | |
81 | #======================================================================= |
82 | # |
83 | # _code2code ( TYPE,CODE,CODESET ) |
84 | # |
85 | #======================================================================= |
86 | |
87 | sub _code2code { |
88 | my($type,$code,$inset,$outset) = @_; |
89 | |
90 | my $name = _code2name($type,$code,$inset); |
91 | my $outcode = _name2code($type,$name,$outset); |
92 | return $outcode; |
93 | } |
94 | |
95 | #======================================================================= |
96 | # |
97 | # _all_codes ( TYPE,CODESET ) |
98 | # |
99 | #======================================================================= |
100 | |
101 | sub _all_codes { |
102 | my($type,$codeset) = @_; |
103 | |
104 | if (! exists $Data{$type}{'code2id'}{$codeset}) { |
105 | return (); |
106 | } |
107 | my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} }; |
108 | return (sort @codes); |
109 | } |
110 | |
111 | #======================================================================= |
112 | # |
113 | # _all_names ( TYPE,CODESET ) |
114 | # |
115 | #======================================================================= |
116 | |
117 | sub _all_names { |
118 | my($type,$codeset) = @_; |
119 | |
120 | my @codes = _all_codes($type,$codeset); |
121 | return () if (! @codes); |
122 | my @names; |
123 | |
124 | foreach my $code (@codes) { |
125 | my($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} }; |
126 | my $name = $Data{$type}{'id2names'}{$id}[$i]; |
127 | push(@names,$name); |
128 | } |
129 | return (sort @names); |
130 | } |
131 | |
132 | #======================================================================= |
133 | # |
134 | # _rename ( TYPE,CODE,NAME,CODESET ) |
135 | # |
136 | # Change the official name for a code. The original is retained |
137 | # as an alias, but the new name will be returned if you lookup the |
138 | # name from code. |
139 | # |
140 | #======================================================================= |
141 | |
142 | sub _rename { |
143 | my($type,$code,$new_name,$codeset,$nowarn) = @_; |
144 | |
145 | if (! $codeset) { |
146 | carp "rename_$type(): unknown codeset\n" unless ($nowarn); |
147 | return 0; |
148 | } |
149 | |
150 | $code = $Data{$type}{'codealias'}{$codeset}{$code} |
151 | if (exists $Data{$type}{'codealias'}{$codeset}{$code}); |
152 | |
153 | # Check that $code exists in the codeset. |
154 | |
155 | my $id; |
156 | if (exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
157 | $id = $Data{$type}{'code2id'}{$codeset}{$code}[0]; |
158 | } else { |
159 | carp "rename_$type(): unknown code: $code\n" unless ($nowarn); |
160 | return 0; |
161 | } |
162 | |
163 | # Cases: |
164 | # 1. Renaming to a name which exists with a different ID |
165 | # Error |
166 | # |
167 | # 2. Renaming to a name which exists with the same ID |
168 | # Just change code2id (I value) |
169 | # |
170 | # 3. Renaming to a new name |
171 | # Create a new alias |
172 | # Change code2id (I value) |
173 | |
174 | if (exists $Data{$type}{'alias2id'}{lc($new_name)}) { |
175 | # Existing name (case 1 and 2) |
176 | |
177 | my ($new_id,$i) = @{ $Data{$type}{'alias2id'}{lc($new_name)} }; |
178 | if ($new_id != $id) { |
179 | # Case 1 |
180 | carp "rename_$type(): rename to an existing $type not allowed\n" |
181 | unless ($nowarn); |
182 | return 0; |
183 | } |
184 | |
185 | # Case 2 |
186 | |
187 | $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i; |
188 | |
189 | } else { |
190 | |
191 | # Case 3 |
192 | |
193 | push @{ $Data{$type}{'id2names'}{$id} },$new_name; |
194 | my $i = $#{ $Data{$type}{'id2names'}{$id} }; |
195 | $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ]; |
196 | $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i; |
197 | } |
198 | |
199 | return 1; |
200 | } |
201 | |
202 | #======================================================================= |
203 | # |
204 | # _add_code ( TYPE,CODE,NAME,CODESET ) |
205 | # |
206 | # Add a new code to the codeset. Both CODE and NAME must be |
207 | # unused in the code set. |
208 | # |
209 | #======================================================================= |
210 | |
211 | sub _add_code { |
212 | my($type,$code,$name,$codeset,$nowarn) = @_; |
213 | |
214 | if (! $codeset) { |
215 | carp "add_$type(): unknown codeset\n" unless ($nowarn); |
216 | return 0; |
217 | } |
218 | |
219 | # Check that $code is unused. |
220 | |
221 | if (exists $Data{$type}{'code2id'}{$codeset}{$code} || |
222 | exists $Data{$type}{'codealias'}{$codeset}{$code}) { |
223 | carp "add_$type(): code already in use: $code\n" unless ($nowarn); |
224 | return 0; |
225 | } |
226 | |
227 | # Check to see that $name is unused in this code set. If it is |
228 | # used (but not in this code set), we'll use that ID. Otherwise, |
229 | # we'll need to get the next available ID. |
230 | |
231 | my ($id,$i); |
232 | if (exists $Data{$type}{'alias2id'}{lc($name)}) { |
233 | ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} }; |
234 | if (exists $Data{$type}{'id2code'}{$codeset}{$id}) { |
235 | carp "add_$type(): name already in use: $name\n" unless ($nowarn); |
236 | return 0; |
237 | } |
238 | |
239 | } else { |
240 | $id = $Data{$type}{'id'}++; |
241 | $i = 0; |
242 | $Data{$type}{'alias2id'}{lc($name)} = [ $id,$i ]; |
243 | $Data{$type}{'id2names'}{$id} = [ $name ]; |
244 | } |
245 | |
246 | # Add the new code |
247 | |
248 | $Data{$type}{'code2id'}{$codeset}{$code} = [ $id,$i ]; |
249 | $Data{$type}{'id2code'}{$codeset}{$id} = $code; |
250 | |
251 | return 1; |
252 | } |
253 | |
254 | #======================================================================= |
255 | # |
256 | # _delete_code ( TYPE,CODE,CODESET ) |
257 | # |
258 | # Delete a code from the codeset. |
259 | # |
260 | #======================================================================= |
261 | |
262 | sub _delete_code { |
263 | my($type,$code,$codeset,$nowarn) = @_; |
264 | |
265 | if (! $codeset) { |
266 | carp "delete_$type(): unknown codeset\n" unless ($nowarn); |
267 | return 0; |
268 | } |
269 | |
270 | $code = $Data{$type}{'codealias'}{$codeset}{$code} |
271 | if (exists $Data{$type}{'codealias'}{$codeset}{$code}); |
272 | |
273 | # Check that $code is valid. |
274 | |
275 | if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
276 | carp "delete_$type(): code does not exist: $code\n" unless ($nowarn); |
277 | return 0; |
278 | } |
279 | |
280 | # Delete the code |
281 | |
282 | my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0]; |
283 | delete $Data{$type}{'code2id'}{$codeset}{$code}; |
284 | delete $Data{$type}{'id2code'}{$codeset}{$id}; |
285 | |
286 | # Delete any aliases that are linked to this code |
287 | |
288 | foreach my $alias (keys %{ $Data{$type}{'codealias'}{$codeset} }) { |
289 | next if ($Data{$type}{'codealias'}{$codeset}{$alias} ne $code); |
290 | delete $Data{$type}{'codealias'}{$codeset}{$alias}; |
291 | } |
292 | |
293 | # If this ID is not used in any other codeset, delete it completely. |
294 | |
295 | foreach my $c (keys %{ $Data{$type}{'id2code'} }) { |
296 | return 1 if (exists $Data{$type}{'id2code'}{$c}{$id}); |
297 | } |
298 | |
299 | my @names = @{ $Data{$type}{'id2names'}{$id} }; |
300 | delete $Data{$type}{'id2names'}{$id}; |
301 | |
302 | foreach my $name (@names) { |
303 | delete $Data{$type}{'alias2id'}{lc($name)}; |
304 | } |
305 | |
306 | return 1; |
307 | } |
308 | |
309 | #======================================================================= |
310 | # |
311 | # _add_alias ( TYPE,NAME,NEW_NAME ) |
312 | # |
313 | # Add a new alias. NAME must exist, and NEW_NAME must be unused. |
314 | # |
315 | #======================================================================= |
316 | |
317 | sub _add_alias { |
318 | my($type,$name,$new_name,$nowarn) = @_; |
319 | |
320 | # Check that $name is used and $new_name is new. |
321 | |
322 | my($id); |
323 | if (exists $Data{$type}{'alias2id'}{lc($name)}) { |
324 | $id = $Data{$type}{'alias2id'}{lc($name)}[0]; |
325 | } else { |
326 | carp "add_${type}_alias(): name does not exist: $name\n" unless ($nowarn); |
327 | return 0; |
328 | } |
329 | |
330 | if (exists $Data{$type}{'alias2id'}{lc($new_name)}) { |
331 | carp "add_${type}_alias(): alias already in use: $new_name\n" unless ($nowarn); |
332 | return 0; |
333 | } |
334 | |
335 | # Add the new alias |
336 | |
337 | push @{ $Data{$type}{'id2names'}{$id} },$new_name; |
338 | my $i = $#{ $Data{$type}{'id2names'}{$id} }; |
339 | $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ]; |
340 | |
341 | return 1; |
342 | } |
343 | |
344 | #======================================================================= |
345 | # |
346 | # _delete_alias ( TYPE,NAME ) |
347 | # |
348 | # This deletes a name from the list of names used by an element. |
349 | # NAME must be used, but must NOT be the only name in the list. |
350 | # |
351 | # Any id2name that references this name will be changed to |
352 | # refer to the first name in the list. |
353 | # |
354 | #======================================================================= |
355 | |
356 | sub _delete_alias { |
357 | my($type,$name,$nowarn) = @_; |
358 | |
359 | # Check that $name is used. |
360 | |
361 | my($id,$i); |
362 | if (exists $Data{$type}{'alias2id'}{lc($name)}) { |
363 | ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} }; |
364 | } else { |
365 | carp "delete_${type}_alias(): name does not exist: $name\n" unless ($nowarn); |
366 | return 0; |
367 | } |
368 | |
369 | my $n = $#{ $Data{$type}{'id2names'}{$id} }; |
370 | if ($n == 1) { |
371 | carp "delete_${type}_alias(): only one name defined (use _delete_${type} instead)\n" |
372 | unless ($nowarn); |
373 | return 0; |
374 | } |
375 | |
376 | # Delete the alias. |
377 | |
378 | splice (@{ $Data{$type}{'id2names'}{$id} },$i,1); |
379 | delete $Data{$type}{'alias2id'}{lc($name)}; |
380 | |
381 | # Every element that refers to this ID: |
382 | # Ignore if I < $i |
383 | # Set to 0 if I = $i |
384 | # Decrement if I > $i |
385 | |
386 | foreach my $codeset (keys %{ $Data{'code2id'} }) { |
387 | foreach my $code (keys %{ $Data{'code2id'}{$codeset} }) { |
388 | my($jd,$j) = @{ $Data{'code2id'}{$codeset}{$code} }; |
389 | next if ($jd ne $id || |
390 | $j < $i); |
391 | if ($i == $j) { |
392 | $Data{'code2id'}{$codeset}{$code}[1] = 0; |
393 | } else { |
394 | $Data{'code2id'}{$codeset}{$code}[1]--; |
395 | } |
396 | } |
397 | } |
398 | |
399 | return 1; |
400 | } |
401 | |
402 | #======================================================================= |
403 | # |
404 | # _rename_code ( TYPE,CODE,NEW_CODE,CODESET ) |
405 | # |
406 | # Change the official code. The original is retained as an alias, but |
407 | # the new name will be returned if you lookup the code from name. |
408 | # |
409 | #======================================================================= |
410 | |
411 | sub _rename_code { |
412 | my($type,$code,$new_code,$codeset,$nowarn) = @_; |
413 | |
414 | if (! $codeset) { |
415 | carp "rename_$type(): unknown codeset\n" unless ($nowarn); |
416 | return 0; |
417 | } |
418 | |
419 | $code = $Data{$type}{'codealias'}{$codeset}{$code} |
420 | if (exists $Data{$type}{'codealias'}{$codeset}{$code}); |
421 | |
422 | # Check that $code exists in the codeset. |
423 | |
424 | if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
425 | carp "rename_$type(): unknown code: $code\n" unless ($nowarn); |
426 | return 0; |
427 | } |
428 | |
429 | # Cases: |
430 | # 1. Renaming code to an existing alias of this code: |
431 | # Make the alias real and the code an alias |
432 | # |
433 | # 2. Renaming code to some other existing alias: |
434 | # Error |
435 | # |
436 | # 3. Renaming code to some other code: |
437 | # Error ( |
438 | # |
439 | # 4. Renaming code to a new code: |
440 | # Make code into an alias |
441 | # Replace code with new_code. |
442 | |
443 | if (exists $Data{$type}{'codealias'}{$codeset}{$new_code}) { |
444 | # Cases 1 and 2 |
445 | if ($Data{$type}{'codealias'}{$codeset}{$new_code} eq $code) { |
446 | # Case 1 |
447 | |
448 | delete $Data{$type}{'codealias'}{$codeset}{$new_code}; |
449 | |
450 | } else { |
451 | # Case 2 |
452 | carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn); |
453 | return 0; |
454 | } |
455 | |
456 | } elsif (exists $Data{$type}{'code2id'}{$codeset}{$new_code}) { |
457 | # Case 3 |
458 | carp "rename_$type(): new code already in use: $new_code\n" unless ($nowarn); |
459 | return 0; |
460 | } |
461 | |
462 | # Cases 1 and 4 |
463 | |
464 | $Data{$type}{'codealias'}{$codeset}{$code} = $new_code; |
465 | |
466 | my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0]; |
467 | $Data{$type}{'code2id'}{$codeset}{$new_code} = $Data{$type}{'code2id'}{$codeset}{$code}; |
468 | delete $Data{$type}{'code2id'}{$codeset}{$code}; |
469 | |
470 | $Data{$type}{'id2code'}{$codeset}{$id} = $new_code; |
471 | |
472 | return 1; |
473 | } |
474 | |
475 | #======================================================================= |
476 | # |
477 | # _add_code_alias ( TYPE,CODE,NEW_CODE,CODESET ) |
478 | # |
479 | # Adds an alias for the code. |
480 | # |
481 | #======================================================================= |
482 | |
483 | sub _add_code_alias { |
484 | my($type,$code,$new_code,$codeset,$nowarn) = @_; |
485 | |
486 | if (! $codeset) { |
487 | carp "add_${type}_code_alias(): unknown codeset\n" unless ($nowarn); |
488 | return 0; |
489 | } |
490 | |
491 | $code = $Data{$type}{'codealias'}{$codeset}{$code} |
492 | if (exists $Data{$type}{'codealias'}{$codeset}{$code}); |
493 | |
494 | # Check that $code exists in the codeset and that $new_code |
495 | # does not exist. |
496 | |
497 | if (! exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
498 | carp "add_${type}_code_alias(): unknown code: $code\n" unless ($nowarn); |
499 | return 0; |
500 | } |
501 | |
502 | if (exists $Data{$type}{'code2id'}{$codeset}{$new_code} || |
503 | exists $Data{$type}{'codealias'}{$codeset}{$new_code}) { |
504 | carp "add_${type}_code_alias(): code already in use: $new_code\n" unless ($nowarn); |
505 | return 0; |
506 | } |
507 | |
508 | # Add the alias |
509 | |
510 | $Data{$type}{'codealias'}{$codeset}{$new_code} = $code; |
511 | |
512 | return 1; |
513 | } |
514 | |
515 | #======================================================================= |
516 | # |
517 | # _delete_code_alias ( TYPE,CODE,CODESET ) |
518 | # |
519 | # Deletes an alias for the code. |
520 | # |
521 | #======================================================================= |
522 | |
523 | sub _delete_code_alias { |
524 | my($type,$code,$codeset,$nowarn) = @_; |
525 | |
526 | if (! $codeset) { |
527 | carp "delete_${type}_code_alias(): unknown codeset\n" unless ($nowarn); |
528 | return 0; |
529 | } |
530 | |
531 | # Check that $code exists in the codeset as an alias. |
532 | |
533 | if (! exists $Data{$type}{'codealias'}{$codeset}{$code}) { |
534 | carp "delete_${type}_code_alias(): no alias defined: $code\n" unless ($nowarn); |
535 | return 0; |
536 | } |
537 | |
538 | # Delete the alias |
539 | |
540 | delete $Data{$type}{'codealias'}{$codeset}{$code}; |
541 | |
542 | return 1; |
543 | } |
544 | |
545 | #======================================================================= |
546 | # |
547 | # alias_code ( ALIAS => CODE [ , CODESET ] ) |
548 | # |
549 | # Add an alias for an existing code. If the CODESET isn't specified, |
550 | # then we use the default (currently the alpha-2 codeset). |
551 | # |
552 | # Locale::Country::alias_code('uk' => 'gb'); |
553 | # |
554 | #======================================================================= |
555 | |
556 | # sub alias_code { |
557 | # my $nowarn = 0; |
558 | # $nowarn = 1, pop if ($_[$#_] eq "nowarn"); |
559 | # my $alias = shift; |
560 | # my $code = shift; |
561 | # my $codeset = @_ > 0 ? shift : LOCALE_CODE_DEFAULT; |
562 | |
563 | # return 0 if ($codeset !~ /^\d+$/); |
564 | |
565 | # if ($codeset == LOCALE_CODE_ALPHA_2) { |
566 | # $codeset = "alpha2"; |
567 | # $alias = lc($alias); |
568 | # } elsif ($codeset == LOCALE_CODE_ALPHA_3) { |
569 | # $codeset = "alpha3"; |
570 | # $alias = lc($alias); |
571 | # } elsif ($codeset == LOCALE_CODE_FIPS) { |
572 | # $codeset = "fips"; |
573 | # $alias = uc($alias); |
574 | # } elsif ($codeset == LOCALE_CODE_NUMERIC) { |
575 | # $codeset = "num"; |
576 | # return undef if ($alias =~ /\D/); |
577 | # $alias = sprintf("%.3d", $alias); |
578 | # } else { |
579 | # carp "rename_country(): unknown codeset\n" unless ($nowarn); |
580 | # return 0; |
581 | # } |
582 | |
583 | # # Check that $code exists in the codeset. |
584 | |
585 | # my ($id,$i); |
586 | # if (exists $Data{$type}{'code2id'}{$codeset}{$code}) { |
587 | # ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} }; |
588 | # } else { |
589 | # carp "alias_code: attempt to alias \"$alias\" to unknown country code \"$code\"\n" |
590 | # unless ($nowarn); |
591 | # return 0; |
592 | # } |
593 | |
594 | # # Cases: |
595 | # # The alias already exists. |
596 | # # Error |
597 | # # |
598 | # # It's new |
599 | # # Create a new entry in Code2CountryID |
600 | # # Replace the entiry in CountryID2Code |
601 | # # Regenerate %Codes |
602 | |
603 | # if (exists $Data{$type}{'code2id'}{$codeset}{$alias}) { |
604 | # carp "alias_code: attempt to alias \"$alias\" which is already in use\n" |
605 | # unless ($nowarn); |
606 | # return 0; |
607 | # } |
608 | |
609 | # $Data{$type}{'code2id'}{$codeset}{$alias} = [ $id, $i ]; |
610 | # $Data{$type}{'id2names'}ID2Code{$codeset}{$id} = $alias; |
611 | |
612 | # my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} }; |
613 | # $Locale::CountryCodes::Codes{$codeset} = [ sort @codes ]; |
614 | |
615 | # return $alias; |
616 | # } |
617 | |
618 | 1; |
619 | # Local Variables: |
620 | # mode: cperl |
621 | # indent-tabs-mode: nil |
622 | # cperl-indent-level: 3 |
623 | # cperl-continued-statement-offset: 2 |
624 | # cperl-continued-brace-offset: 0 |
625 | # cperl-brace-offset: 0 |
626 | # cperl-brace-imaginary-offset: 0 |
627 | # cperl-label-offset: -2 |
628 | # End: |