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