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