This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
EBCDIC: Disable Encode::JP and Encode::Tcl for now.
[perl5.git] / ext / Encode / lib / Encode / Tcl.pm
1 package Encode::Tcl;
2 BEGIN {
3     if (ord("A") == 193) {
4         die "Encode::JP not supported on EBCDIC\n";
5     }
6 }
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' :
106                 ($type eq 'H') ? 'HanZi'    :
107                     ($type eq 'E') ? 'Escape'   : 'Table';
108         my $class = ref($obj) . '::' . $subclass;
109         # carp "Loading $file";
110         bless $obj,$class;
111         return $obj if $obj->read($fh,$obj->name,$type);
112     }
113     else
114     {
115         croak("Cannot open $file for ".$obj->name);
116     }
117     $obj->Undefine($name);
118     return undef;
119 }
120
121 sub INC_find
122 {
123     my ($class,$name) = @_;
124     my $enc;
125     foreach my $dir (@INC)
126     {
127         last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
128     }
129     return $enc;
130 }
131
132 require Encode::Tcl::Table;
133 require Encode::Tcl::Escape;
134 require Encode::Tcl::Extended;
135 require Encode::Tcl::HanZi;
136
137 1;
138 __END__