Commit | Line | Data |
18586f54 |
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__ |