This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
8a2efb937a373b1eebffa6a23694ba6b4e954933
[perl5.git] / ext / Encode / lib / Encode / Tcl.pm
1 package Encode::Tcl;
2 use strict;
3 our $VERSION = do {my @r=(q$Revision: 1.1 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r};
4 use Encode qw(find_encoding);
5 use base 'Encode::Encoding';
6 use Carp;
7
8 =head1 NAME
9
10 Encode::Tcl - Tcl encodings
11
12 =cut
13
14     sub INC_search
15 {
16     foreach my $dir (@INC)
17     {
18         if (opendir(my $dh,"$dir/Encode"))
19         {
20             while (defined(my $name = readdir($dh)))
21             {
22                 if ($name =~ /^(.*)\.enc$/)
23                 {
24                     my $canon = $1;
25                     my $obj = find_encoding($canon);
26                     if (!defined($obj))
27                     {
28                         my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
29                         $obj->Define( $canon );
30                         # warn "$canon => $obj\n";
31                     }
32                 }
33             }
34             closedir($dh);
35         }
36     }
37 }
38
39 sub import
40 {
41     INC_search();
42 }
43
44 sub no_map_in_encode ($$)
45     # codepoint, enc-name;
46 {
47     carp sprintf "\"\\N{U+%x}\" does not map to %s", @_;
48 # /* FIXME: Skip over the character, copy in replacement and continue
49 #  * but that is messy so for now just fail.
50 #  */
51     return;
52 }
53
54 sub no_map_in_decode ($$)
55     # enc-name, string beginning the malform char;
56 {
57 # /* UTF-8 is supposed to be "Universal" so should not happen */
58     croak sprintf "%s '%s' does not map to UTF-8", @_;
59 }
60
61 sub encode
62 {
63     my $obj = shift;
64     my $new = $obj->loadEncoding;
65     return undef unless (defined $new);
66     return $new->encode(@_);
67 }
68
69 sub new_sequence
70 {
71     my $obj = shift;
72     my $new = $obj->loadEncoding;
73     return undef unless (defined $new);
74     return $new->new_sequence(@_);
75 }
76
77 sub decode
78 {
79     my $obj = shift;
80     my $new = $obj->loadEncoding;
81     return undef unless (defined $new);
82     return $new->decode(@_);
83 }
84
85 sub loadEncoding
86 {
87     my $obj = shift;
88     my $file = $obj->{'File'};
89     my $name = $obj->name;
90     if (open(my $fh,$file))
91     {
92         my $type;
93         while (1)
94         {
95             my $line = <$fh>;
96             $type = substr($line,0,1);
97             last unless $type eq '#';
98         }
99         my $subclass =
100             ($type eq 'X') ? 'Extended' :
101                 ($type eq 'H') ? 'HanZi'    :
102                     ($type eq 'E') ? 'Escape'   : 'Table';
103         my $class = ref($obj) . '::' . $subclass;
104         # carp "Loading $file";
105         bless $obj,$class;
106         return $obj if $obj->read($fh,$obj->name,$type);
107     }
108     else
109     {
110         croak("Cannot open $file for ".$obj->name);
111     }
112     $obj->Undefine($name);
113     return undef;
114 }
115
116 sub INC_find
117 {
118     my ($class,$name) = @_;
119     my $enc;
120     foreach my $dir (@INC)
121     {
122         last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
123     }
124     return $enc;
125 }
126
127 require Encode::Tcl::Table;
128 require Encode::Tcl::Escape;
129 require Encode::Tcl::Extended;
130 require Encode::Tcl::HanZi;
131
132 1;
133 __END__