This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Bump Locale-Codes from 3.54 to 3.55
[perl5.git] / cpan / Locale-Codes / lib / Locale / Codes.pm
1 package Locale::Codes;
2 # Copyright (C) 2001      Canon Research Centre Europe (CRE).
3 # Copyright (C) 2002-2009 Neil Bowers
4 # Copyright (c) 2010-2017 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 ###############################################################################
9
10 use strict;
11 use warnings;
12 require 5.006;
13
14 use Carp;
15 use if $] >= 5.027007, 'deprecate';
16 use Locale::Codes::Constants;
17
18 our($VERSION);
19 $VERSION='3.55';
20
21 use Exporter qw(import);
22 our(@EXPORT_OK,%EXPORT_TAGS);
23 @EXPORT_OK   = @Locale::Codes::Constants::CONSTANTS;
24 %EXPORT_TAGS = ( 'constants' => [ @EXPORT_OK ] );
25
26 ###############################################################################
27 # GLOBAL DATA
28 ###############################################################################
29 # All of the data is stored in a couple global variables.  They are filled
30 # in by requiring the appropriate TYPE_Codes and TYPE_Retired modules.
31
32 our(%Data,%Retired);
33
34 # $Data{ TYPE }{ code2id   }{ CODESET } { CODE }  = [ ID, I ]
35 #              { id2code   }{ CODESET } { ID }    = CODE
36 #              { id2names  }{ ID }                = [ NAME, NAME, ... ]
37 #              { alias2id  }{ NAME }              = [ ID, I ]
38 #              { id        }                      = FIRST_UNUSED_ID
39 #              { codealias }{ CODESET } { ALIAS } = CODE
40 #
41 # $Retired{ TYPE }{ CODESET }{ code }{ CODE } = NAME
42 #                            { name }{ NAME } = [CODE,NAME]  (the key is lowercase)
43
44 ###############################################################################
45 # METHODS
46 ###############################################################################
47
48 sub new {
49    my($class,$type,$codeset,$show_errors) = @_;
50    my $self         = { 'type'     => '',
51                         'codeset'  => '',
52                         'err'      => (defined($show_errors) ? $show_errors : 1),
53                       };
54
55    bless $self,$class;
56
57    $self->type($type)        if ($type);
58    $self->codeset($codeset)  if ($codeset);
59    return $self;
60 }
61
62 sub show_errors {
63    my($self,$val) = @_;
64    $$self{'err'}  = $val;
65 }
66
67 sub type {
68    my($self,$type) = @_;
69
70    if (! exists $ALL_CODESETS{$type}) {
71       # uncoverable branch false
72       carp "ERROR: type: invalid argument: $type\n"  if ($$self{'err'});
73       return;
74    }
75
76    # uncoverable branch false
77    if (! $ALL_CODESETS{$type}{'loaded'}) {
78       my $label = $ALL_CODESETS{$type}{'module'};
79       eval "require Locale::Codes::${label}_Codes";
80       # uncoverable branch true
81       if ($@) {
82          # uncoverable statement
83          croak "ERROR: type: unable to load module: ${label}_Codes\n";
84       }
85       eval "require Locale::Codes::${label}_Retired";
86       # uncoverable branch true
87       if ($@) {
88          # uncoverable statement
89          croak "ERROR: type: unable to load module: ${label}_Retired\n";
90       }
91       $ALL_CODESETS{$type}{'loaded'} = 1;
92    }
93
94    $$self{'type'}    = $type;
95    $$self{'codeset'} = $ALL_CODESETS{$type}{'default'};
96 }
97
98 sub codeset {
99    my($self,$codeset) = @_;
100
101    my $type           = $$self{'type'};
102    if (! exists $ALL_CODESETS{$type}{'codesets'}{$codeset}) {
103       # uncoverable branch false
104       carp "ERROR: codeset: invalid argument: $codeset\n"  if ($$self{'err'});
105    }
106
107    $$self{'codeset'}  = $codeset;
108 }
109
110 sub version {
111   # uncoverable subroutine
112   # uncoverable statement
113   my($self) = @_;
114   # uncoverable statement
115   return $VERSION;
116 }
117
118 ###############################################################################
119
120 # This is used to validate a codeset and/or code.  It will also format
121 # a code for that codeset.
122 #
123 # (ERR,RET_CODE,RET_CODESET) = $o->_code([CODE [,CODESET]])
124 #
125 #    If CODE is empty/undef, only the codeset will be validated
126 #    and RET_CODE will be empty.
127 #
128 #    If CODE is passed in, it will be returned formatted correctly
129 #    for the codeset.
130 #
131 #    ERR will be 0 or 1.
132 #
133 #    If $no_check_code is 1, then the code will not be validated (i.e.
134 #    it doesn't already have to exist).  This will be useful for adding
135 #    a new code.
136 #
137 sub _code {
138    my($self,$code,$codeset,$no_check_code) = @_;
139    $code                    = ''  if (! defined($code));
140    $codeset                 = lc($codeset)  if (defined($codeset));
141
142    # uncoverable branch true
143    if (! $$self{'type'}) {
144       # uncoverable statement
145       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
146       # uncoverable statement
147       return (1);
148    }
149    my $type = $$self{'type'};
150    if ($codeset  &&  ! exists $ALL_CODESETS{$type}{'codesets'}{$codeset}) {
151       carp "ERROR: _code: invalid codeset provided: $codeset\n"
152         if ($$self{'err'});
153       return (1);
154    }
155
156    # If no codeset was passed in, return the codeset specified.
157
158    $codeset = $$self{'codeset'}  if (! defined($codeset)  ||  $codeset eq '');
159    return (0,'',$codeset)        if ($code eq '');
160
161    # Determine the properties of the codeset
162
163    my($op,@args) = @{ $ALL_CODESETS{$type}{'codesets'}{$codeset} };
164
165    if      ($op eq 'lc') {
166       $code = lc($code);
167    }
168
169    if ($op eq 'uc') {
170       $code = uc($code);
171    }
172
173    if ($op eq 'ucfirst') {
174       $code = ucfirst(lc($code));
175    }
176
177    # uncoverable branch false
178    if ($op eq 'numeric') {
179       if ($code =~ /^\d+$/) {
180          my $l = $args[0];
181          $code    = sprintf("%.${l}d", $code);
182
183       } else {
184          # uncoverable statement
185          carp "ERROR: _code: invalid numeric code: $code\n"  if ($$self{'err'});
186          # uncoverable statement
187          return (1);
188       }
189    }
190
191    # Determine if the code is in the codeset.
192
193    if (! $no_check_code  &&
194        ! exists $Data{$type}{'code2id'}{$codeset}{$code}  &&
195        ! exists $Retired{$type}{$codeset}{'code'}{$code}  &&
196        ! exists $Data{$type}{'codealias'}{$codeset}{$code}) {
197       carp "ERROR: _code: code not in codeset: $code [$codeset]\n"
198         if ($$self{'err'});
199       return (1);
200    }
201
202    return (0,$code,$codeset);
203 }
204
205 ###############################################################################
206
207 # $name = $o->code2name(CODE [,CODESET] [,'retired'])
208 # $code = $o->name2code(NAME [,CODESET] [,'retired'])
209 #
210 #    Returns the name associated with the CODE (or vice versa).
211 #
212 sub code2name {
213    my($self,@args)   = @_;
214    my $retired       = 0;
215    if (@args  &&  defined($args[$#args])  &&  lc($args[$#args]) eq 'retired') {
216       pop(@args);
217       $retired       = 1;
218    }
219
220    # uncoverable branch true
221    if (! $$self{'type'}) {
222       # uncoverable statement
223       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
224       # uncoverable statement
225       return (1);
226    }
227    my $type = $$self{'type'};
228
229    my ($err,$code,$codeset) = $self->_code(@args);
230    return undef  if ($err  ||  ! $code);
231
232    $code = $Data{$type}{'codealias'}{$codeset}{$code}
233      if (exists $Data{$type}{'codealias'}{$codeset}{$code});
234
235    if (exists $Data{$type}{'code2id'}{$codeset}{$code}) {
236       my ($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
237       my $name    = $Data{$type}{'id2names'}{$id}[$i];
238       return $name;
239
240    } elsif ($retired  &&  exists $Retired{$type}{$codeset}{'code'}{$code}) {
241       return $Retired{$type}{$codeset}{'code'}{$code};
242
243    } else {
244       return undef;
245    }
246 }
247
248 sub name2code {
249    my($self,$name,@args)   = @_;
250    return undef  if (! $name);
251    $name                   = lc($name);
252
253    my $retired       = 0;
254    if (@args  &&  defined($args[$#args])  &&  lc($args[$#args]) eq 'retired') {
255       pop(@args);
256       $retired       = 1;
257    }
258
259    # uncoverable branch true
260    if (! $$self{'type'}) {
261       # uncoverable statement
262       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
263       # uncoverable statement
264       return (1);
265    }
266    my $type = $$self{'type'};
267
268    my ($err,$tmp,$codeset) = $self->_code('',@args);
269    return undef  if ($err);
270
271    if (exists $Data{$type}{'alias2id'}{$name}) {
272       my $id = $Data{$type}{'alias2id'}{$name}[0];
273       if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
274          return $Data{$type}{'id2code'}{$codeset}{$id};
275       }
276
277    } elsif ($retired  &&  exists $Retired{$type}{$codeset}{'name'}{$name}) {
278       return $Retired{$type}{$codeset}{'name'}{$name}[0];
279    }
280
281    return undef;
282 }
283
284 # $code = $o->code2code(CODE,CODESET2)
285 # $code = $o->code2code(CODE,CODESET1,CODESET2)
286 #
287 #    Changes the code in the CODESET1 (or the current codeset) to another
288 #    codeset (CODESET2)
289 #
290 sub code2code {
291    my($self,@args) = @_;
292
293    # uncoverable branch true
294    if (! $$self{'type'}) {
295       # uncoverable statement
296       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
297       # uncoverable statement
298       return (1);
299    }
300    my $type = $$self{'type'};
301
302    my($code,$codeset1,$codeset2,$err);
303
304    if (@args == 2) {
305       ($code,$codeset2)      = @args;
306       ($err,$code,$codeset1) = $self->_code($code);
307       # uncoverable branch true
308       return undef  if ($err);
309
310    } elsif (@args == 3) {
311       ($code,$codeset1,$codeset2) = @args;
312       ($err,$code)                = $self->_code($code,$codeset1);
313       return undef  if ($err);
314       ($err)                      = $self->_code('',$codeset2);
315       # uncoverable branch true
316       return undef  if ($err);
317    }
318
319    my $name    = $self->code2name($code,$codeset1);
320    my $out     = $self->name2code($name,$codeset2);
321    return $out;
322 }
323
324 ###############################################################################
325
326 # @codes = $o->all_codes([CODESET] [,'retired']);
327 # @names = $o->all_names([CODESET] [,'retired']);
328 #
329 #    Returns all codes/names in the specified codeset, including retired
330 #    ones if the option is given.
331
332 sub all_codes {
333    my($self,@args)   = @_;
334    my $retired       = 0;
335    if (@args  &&  defined($args[$#args])  &&  lc($args[$#args]) eq 'retired') {
336       pop(@args);
337       $retired       = 1;
338    }
339
340    # uncoverable branch true
341    if (! $$self{'type'}) {
342       # uncoverable statement
343       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
344       # uncoverable statement
345       return (1);
346    }
347    my $type = $$self{'type'};
348
349    my ($err,$tmp,$codeset) = $self->_code('',@args);
350    return ()  if ($err);
351
352    my @codes = keys %{ $Data{$type}{'code2id'}{$codeset} };
353    push(@codes,keys %{ $Retired{$type}{$codeset}{'code'} })  if ($retired);
354    return (sort @codes);
355 }
356
357 sub all_names {
358    my($self,@args)   = @_;
359    my $retired       = 0;
360    if (@args  &&  defined($args[$#args])  &&  lc($args[$#args]) eq 'retired') {
361       pop(@args);
362       $retired       = 1;
363    }
364
365    # uncoverable branch true
366    if (! $$self{'type'}) {
367       # uncoverable statement
368       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
369       # uncoverable statement
370       return (1);
371    }
372    my $type = $$self{'type'};
373
374    my ($err,$tmp,$codeset) = $self->_code('',@args);
375    return ()  if ($err);
376
377    my @codes = $self->all_codes($codeset);
378    my @names;
379
380    foreach my $code (@codes) {
381       my($id,$i) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
382       my $name   = $Data{$type}{'id2names'}{$id}[$i];
383       push(@names,$name);
384    }
385    if ($retired) {
386       foreach my $lc (keys %{ $Retired{$type}{$codeset}{'name'} }) {
387          my $name = $Retired{$type}{$codeset}{'name'}{$lc}[1];
388          push @names,$name;
389       }
390    }
391    return (sort @names);
392 }
393
394 ###############################################################################
395
396 # $flag = $o->rename_code (CODE,NEW_NAME [,CODESET])
397 #
398 # Change the official name for a code. The original is retained
399 # as an alias, but the new name will be returned if you lookup the
400 # name from code.
401 #
402 # Returns 1 on success.
403 #
404 sub rename_code {
405    my($self,$code,$new_name,$codeset) = @_;
406
407    # uncoverable branch true
408    if (! $$self{'type'}) {
409       # uncoverable statement
410       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
411       # uncoverable statement
412       return 0;
413    }
414    my $type = $$self{'type'};
415
416    # Make sure $code/$codeset are both valid
417
418    my($err,$c,$cs) = $self->_code($code,$codeset);
419    if ($err) {
420       carp "ERROR: rename: Unknown code/codeset: $code [$codeset]\n"
421         if ($$self{'err'});
422       return 0;
423    }
424    ($code,$codeset) = ($c,$cs);
425
426    # Cases:
427    #   1. Renaming to a name which exists with a different ID
428    #      Error
429    #
430    #   2. Renaming to a name which exists with the same ID
431    #      Just change code2id (I value)
432    #
433    #   3. Renaming to a new name
434    #      Create a new alias
435    #      Change code2id (I value)
436
437    my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
438
439    if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
440       # Existing name (case 1 and 2)
441
442       my ($new_id,$i) = @{ $Data{$type}{'alias2id'}{lc($new_name)} };
443       if ($new_id != $id) {
444          # Case 1
445          carp "ERROR: rename: rename to an existing name not allowed\n"
446            if ($$self{'err'});
447          return 0;
448       }
449
450       # Case 2
451
452       $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
453
454    } else {
455
456       # Case 3
457
458       push @{ $Data{$type}{'id2names'}{$id} },$new_name;
459       my $i = $#{ $Data{$type}{'id2names'}{$id} };
460       $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
461       $Data{$type}{'code2id'}{$codeset}{$code}[1] = $i;
462    }
463
464    return 1;
465 }
466
467 ###############################################################################
468
469 # $flag = $o->add_code (CODE,NAME [,CODESET])
470 #
471 # Add a new code to the codeset. Both CODE and NAME must be
472 # unused in the code set.
473 #
474 sub add_code {
475    my($self,$code,$name,$codeset) = @_;
476
477    # uncoverable branch true
478    if (! $$self{'type'}) {
479       # uncoverable statement
480       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
481       # uncoverable statement
482       return 0;
483    }
484    my $type = $$self{'type'};
485
486    # Make sure that $codeset is valid.
487
488    my($err,$c,$cs) = $self->_code($code,$codeset,1);
489    if ($err) {
490       carp "ERROR: rename: Unknown codeset: $codeset\n"
491         if ($$self{'err'});
492       return 0;
493    }
494   ($code,$codeset) = ($c,$cs);
495
496    # Check that $code is unused.
497
498    if (exists $Data{$type}{'code2id'}{$codeset}{$code}  ||
499        exists $Data{$type}{'codealias'}{$codeset}{$code}) {
500       carp "add_code: code already in use: $code\n"  if ($$self{'err'});
501       return 0;
502    }
503
504    # Check to see that $name is unused in this code set.  If it is
505    # used (but not in this code set), we'll use that ID.  Otherwise,
506    # we'll need to get the next available ID.
507
508    my ($id,$i);
509    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
510       ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
511       if (exists $Data{$type}{'id2code'}{$codeset}{$id}) {
512          carp "add_code: name already in use: $name\n"  if ($$self{'err'});
513          return 0;
514       }
515
516    } else {
517       $id = $Data{$type}{'id'}++;
518       $i  = 0;
519       $Data{$type}{'alias2id'}{lc($name)} = [ $id,$i ];
520       $Data{$type}{'id2names'}{$id}       = [ $name ];
521    }
522
523    # Add the new code
524
525    $Data{$type}{'code2id'}{$codeset}{$code} = [ $id,$i ];
526    $Data{$type}{'id2code'}{$codeset}{$id}   = $code;
527
528    return 1;
529 }
530
531 ###############################################################################
532
533 # $flag = $o->delete_code (CODE [,CODESET])
534 #
535 # Delete a code from the codeset.
536 #
537 sub delete_code {
538    my($self,$code,$codeset) = @_;
539
540    # uncoverable branch true
541    if (! $$self{'type'}) {
542       # uncoverable statement
543       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
544       # uncoverable statement
545       return 0;
546    }
547    my $type = $$self{'type'};
548
549    # Make sure $code/$codeset are both valid
550
551    my($err,$c,$cs) = $self->_code($code,$codeset);
552    # uncoverable branch true
553    if ($err) {
554       # uncoverable statement
555       carp "ERROR: rename: Unknown code/codeset: $code [$codeset]\n"
556         if ($$self{'err'});
557       # uncoverable statement
558       return 0;
559    }
560    ($code,$codeset) = ($c,$cs);
561
562    # Delete the code
563
564    my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
565    delete $Data{$type}{'code2id'}{$codeset}{$code};
566    delete $Data{$type}{'id2code'}{$codeset}{$id};
567
568    # Delete any aliases that are linked to this code
569
570    foreach my $alias (keys %{ $Data{$type}{'codealias'}{$codeset} }) {
571       next  if ($Data{$type}{'codealias'}{$codeset}{$alias} ne $code);
572       delete $Data{$type}{'codealias'}{$codeset}{$alias};
573    }
574
575    # If this ID is not used in any other codeset, delete it completely.
576
577    foreach my $c (keys %{ $Data{$type}{'id2code'} }) {
578       return 1  if (exists $Data{$type}{'id2code'}{$c}{$id});
579    }
580
581    my @names = @{ $Data{$type}{'id2names'}{$id} };
582    delete $Data{$type}{'id2names'}{$id};
583
584    foreach my $name (@names) {
585       delete $Data{$type}{'alias2id'}{lc($name)};
586    }
587
588    return 1;
589 }
590
591 ###############################################################################
592
593 # $flag = $o->add_alias (NAME,NEW_NAME)
594 #
595 # Add a new alias. NAME must exist, and NEW_NAME must be unused.
596 #
597 sub add_alias {
598    my($self,$name,$new_name) = @_;
599
600    # uncoverable branch true
601    if (! $$self{'type'}) {
602       # uncoverable statement
603       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
604       # uncoverable statement
605       return 0;
606    }
607    my $type = $$self{'type'};
608
609    # Check that $name is used and $new_name is new.
610
611    my($id);
612    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
613       $id = $Data{$type}{'alias2id'}{lc($name)}[0];
614    } else {
615       carp "add_alias: name does not exist: $name\n"  if ($$self{'err'});
616       return 0;
617    }
618
619    if (exists $Data{$type}{'alias2id'}{lc($new_name)}) {
620       carp "add_alias: alias already in use: $new_name\n"  if ($$self{'err'});
621       return 0;
622    }
623
624    # Add the new alias
625
626    push @{ $Data{$type}{'id2names'}{$id} },$new_name;
627    my $i = $#{ $Data{$type}{'id2names'}{$id} };
628    $Data{$type}{'alias2id'}{lc($new_name)} = [ $id,$i ];
629
630    return 1;
631 }
632
633 ###############################################################################
634
635 # $flag = $o->delete_alias (NAME)
636 #
637 # This deletes a name from the list of names used by an element.
638 # NAME must be used, but must NOT be the only name in the list.
639 #
640 # Any id2name that references this name will be changed to
641 # refer to the first name in the list.
642 #
643 sub delete_alias {
644    my($self,$name) = @_;
645
646    # uncoverable branch true
647    if (! $$self{'type'}) {
648       # uncoverable statement
649       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
650       # uncoverable statement
651       return 0;
652    }
653    my $type = $$self{'type'};
654
655    # Check that $name is used.
656
657    my($id,$i);
658    if (exists $Data{$type}{'alias2id'}{lc($name)}) {
659       ($id,$i) = @{ $Data{$type}{'alias2id'}{lc($name)} };
660    } else {
661       carp "delete_alias: name does not exist: $name\n"  if ($$self{'err'});
662       return 0;
663    }
664
665    my $n = $#{ $Data{$type}{'id2names'}{$id} } + 1;
666    if ($n == 1) {
667       carp "delete_alias: only one name defined (use delete_code instead)\n"
668         if ($$self{'err'});
669       return 0;
670    }
671
672    # Delete the alias.
673
674    splice (@{ $Data{$type}{'id2names'}{$id} },$i,1);
675    delete $Data{$type}{'alias2id'}{lc($name)};
676
677    # Every element that refers to this ID:
678    #   Ignore     if I < $i
679    #   Set to 0   if I = $i
680    #   Decrement  if I > $i
681
682    foreach my $codeset (keys %{ $Data{$type}{'code2id'} }) {
683       foreach my $code (keys %{ $Data{$type}{'code2id'}{$codeset} }) {
684          my($jd,$j) = @{ $Data{$type}{'code2id'}{$codeset}{$code} };
685          next  if ($jd ne $id  ||
686                    $j < $i);
687          if ($i == $j) {
688             $Data{$type}{'code2id'}{$codeset}{$code}[1] = 0;
689          } else {
690             $Data{$type}{'code2id'}{$codeset}{$code}[1]--;
691          }
692       }
693    }
694
695    return 1;
696 }
697
698 ###############################################################################
699
700 # $flag = $o->replace_code (CODE,NEW_CODE [,CODESET])
701 #
702 # Change the official code. The original is retained as an alias, but
703 # the new code will be returned if do a name2code lookup.
704 #
705 sub replace_code {
706    my($self,$code,$new_code,$codeset) = @_;
707
708    # uncoverable branch true
709    if (! $$self{'type'}) {
710       # uncoverable statement
711       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
712       # uncoverable statement
713       return 0;
714    }
715    my $type = $$self{'type'};
716
717    # Make sure $code/$codeset are both valid (and that $new_code is the
718    # correct format)
719
720    my($err,$c,$cs) = $self->_code($code,$codeset);
721    if ($err) {
722       carp "ERROR: rename_code: Unknown code/codeset: $code [$codeset]\n"
723         if ($$self{'err'});
724       return 0;
725    }
726    ($code,$codeset) = ($c,$cs);
727
728    ($err,$new_code,$codeset) = $self->_code($new_code,$codeset,1);
729
730    # Cases:
731    #   1. Renaming code to an existing alias of this code:
732    #      Make the alias real and the code an alias
733    #
734    #   2. Renaming code to some other existing alias:
735    #      Error
736    #
737    #   3. Renaming code to some other code:
738    #      Error (
739    #
740    #   4. Renaming code to a new code:
741    #      Make code into an alias
742    #      Replace code with new_code.
743
744    if (exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
745       # Cases 1 and 2
746       if ($Data{$type}{'codealias'}{$codeset}{$new_code} eq $code) {
747          # Case 1
748
749          delete $Data{$type}{'codealias'}{$codeset}{$new_code};
750
751       } else {
752          # Case 2
753          carp "rename_code: new code already in use: $new_code\n"
754            if ($$self{'err'});
755          return 0;
756       }
757
758    } elsif (exists $Data{$type}{'code2id'}{$codeset}{$new_code}) {
759       # Case 3
760       carp "rename_code: new code already in use: $new_code\n"
761         if ($$self{'err'});
762       return 0;
763    }
764
765    # Cases 1 and 4
766
767    $Data{$type}{'codealias'}{$codeset}{$code} = $new_code;
768
769    my $id = $Data{$type}{'code2id'}{$codeset}{$code}[0];
770    $Data{$type}{'code2id'}{$codeset}{$new_code} =
771      $Data{$type}{'code2id'}{$codeset}{$code};
772    delete $Data{$type}{'code2id'}{$codeset}{$code};
773
774    $Data{$type}{'id2code'}{$codeset}{$id} = $new_code;
775
776    return 1;
777 }
778
779 ###############################################################################
780
781 # $flag = $o->add_code_alias (CODE,NEW_CODE [,CODESET])
782 #
783 # Adds an alias for the code.
784 #
785 sub add_code_alias {
786    my($self,$code,$new_code,$codeset) = @_;
787
788    # uncoverable branch true
789    if (! $$self{'type'}) {
790       # uncoverable statement
791       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
792       # uncoverable statement
793       return 0;
794    }
795    my $type = $$self{'type'};
796
797    # Make sure $code/$codeset are both valid and that the new code is
798    # properly formatted.
799
800    my($err,$c,$cs) = $self->_code($code,$codeset);
801    if ($err) {
802       carp "ERROR: add_code_alias: Unknown code/codeset: $code [$codeset]\n"
803         if ($$self{'err'});
804       return 0;
805    }
806    ($code,$codeset) = ($c,$cs);
807
808    ($err,$new_code,$cs) = $self->_code($new_code,$codeset,1);
809
810    # Check that $new_code does not exist.
811
812    if (exists $Data{$type}{'code2id'}{$codeset}{$new_code}  ||
813        exists $Data{$type}{'codealias'}{$codeset}{$new_code}) {
814       # uncoverable branch true
815       carp "add_code_alias: code already in use: $new_code\n"  if ($$self{'err'});
816       return 0;
817    }
818
819    # Add the alias
820
821    $Data{$type}{'codealias'}{$codeset}{$new_code} = $code;
822
823    return 1;
824 }
825
826 ###############################################################################
827
828 # $flag = $o->delete_code_alias (ALIAS [,CODESET])
829 #
830 # Deletes an alias for the code.
831 #
832 sub delete_code_alias {
833    my($self,$code,$codeset) = @_;
834
835    # uncoverable branch true
836    if (! $$self{'type'}) {
837       # uncoverable statement
838       carp "ERROR: no type set for Locale::Codes object\n"  if ($$self{'err'});
839       # uncoverable statement
840       return 0;
841    }
842    my $type = $$self{'type'};
843
844    # Make sure $code/$codeset are both valid
845
846    my($err,$c,$cs) = $self->_code($code,$codeset);
847    if ($err) {
848       # uncoverable branch true
849       carp "ERROR: rename: Unknown code/codeset: $code [$codeset]\n"
850         if ($$self{'err'});
851       return 0;
852    }
853    ($code,$codeset) = ($c,$cs);
854
855    # Check that $code exists in the codeset as an alias.
856
857    if (! exists $Data{$type}{'codealias'}{$codeset}{$code}) {
858       # uncoverable branch true
859       carp "delete_code_alias(): no alias defined: $code\n"  if ($$self{'err'});
860       return 0;
861    }
862
863    # Delete the alias
864
865    delete $Data{$type}{'codealias'}{$codeset}{$code};
866
867    return 1;
868 }
869
870 1;
871 # Local Variables:
872 # mode: cperl
873 # indent-tabs-mode: nil
874 # cperl-indent-level: 3
875 # cperl-continued-statement-offset: 2
876 # cperl-continued-brace-offset: 0
877 # cperl-brace-offset: 0
878 # cperl-brace-imaginary-offset: 0
879 # cperl-label-offset: 0
880 # End: