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