ext/Encode/lib/Encode/Tcl.pm

   1 package Encode::Tcl;
   2 BEGIN {
   3     if (ord("A") == 193) {
   4         die "Encode::Tcl 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 sub INC_search
  14 {
  15     foreach my $dir (@INC)
  16     {
  17         if (opendir(my $dh,"$dir/Encode"))
  18         {
  19             while (defined(my $name = readdir($dh)))
  20             {
  21                 if ($name =~ /^(.*)\.enc$/)
  22                 {
  23                     my $canon = $1;
  24                     my $obj = find_encoding($canon);
  25                     if (!defined($obj))
  26                     {
  27                         my $obj = bless { Name => $canon, File => "$dir/Encode/$name"},__PACKAGE__;
  28                         $obj->Define( $canon );
  29                         # warn "$canon => $obj\n";
  30                     }
  31                 }
  32             }
  33             closedir($dh);
  34         }
  35     }
  36 }
  37
  38 sub import
  39 {
  40     INC_search();
  41 }
  42
  43 sub no_map_in_encode ($$)
  44     # codepoint, enc-name;
  45 {
  46     carp sprintf "\"\\N{U+%x}\" does not map to %s", @_;
  47 # /* FIXME: Skip over the character, copy in replacement and continue
  48 #  * but that is messy so for now just fail.
  49 #  */
  50     return;
  51 }
  52
  53 sub no_map_in_decode ($$)
  54     # enc-name, string beginning the malform char;
  55 {
  56 # /* UTF-8 is supposed to be "Universal" so should not happen */
  57     croak sprintf "%s '%s' does not map to UTF-8", @_;
  58 }
  59
  60 sub encode
  61 {
  62     my $obj = shift;
  63     my $new = $obj->loadEncoding;
  64     return undef unless (defined $new);
  65     return $new->encode(@_);
  66 }
  67
  68 sub new_sequence
  69 {
  70     my $obj = shift;
  71     my $new = $obj->loadEncoding;
  72     return undef unless (defined $new);
  73     return $new->new_sequence(@_);
  74 }
  75
  76 sub decode
  77 {
  78     my $obj = shift;
  79     my $new = $obj->loadEncoding;
  80     return undef unless (defined $new);
  81     return $new->decode(@_);
  82 }
  83
  84 sub loadEncoding
  85 {
  86     my $obj = shift;
  87     my $file = $obj->{'File'};
  88     my $name = $obj->name;
  89     if (open(my $fh,$file))
  90     {
  91         my $type;
  92         while (1)
  93         {
  94             my $line = <$fh>;
  95             $type = substr($line,0,1);
  96             last unless $type eq '#';
  97         }
  98         my $subclass =
  99             ($type eq 'X') ? 'Extended' :
 100                 ($type eq 'E') ? 'Escape'   : 'Table';
 101         my $class = ref($obj) . '::' . $subclass;
 102         # carp "Loading $file";
 103         bless $obj,$class;
 104         return $obj if $obj->read($fh,$obj->name,$type);
 105     }
 106     else
 107     {
 108         croak("Cannot open $file for ".$obj->name);
 109     }
 110     $obj->Undefine($name);
 111     return undef;
 112 }
 113
 114 sub INC_find
 115 {
 116     my ($class,$name) = @_;
 117     my $enc;
 118     foreach my $dir (@INC)
 119     {
 120         last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
 121     }
 122     return $enc;
 123 }
 124
 125 require Encode::Tcl::Table;
 126 require Encode::Tcl::Escape;
 127 require Encode::Tcl::Extended;
 128
 129 1;
 130 __END__
 131
 132 =head1 NAME
 133
 134 Encode::Tcl - Tcl encodings
 135
 136 =head1 SYNOPSIS
 137
 138     use Encode;
 139     use Encode::Tcl;
 140     $unicode  = decode('shiftjis', $shiftjis);
 141     $shiftjis = encode('shiftjis', $unicode);
 142
 143 =head1 DESCRIPTION
 144
 145 This module provides the interface to encodings
 146 defined by the format of encoding tables borrowed from Tcl
 147 and not compiled in other Encode:: modules.
 148
 149 See also F<Encode/EncodeFormat.pod> and F<Encode/*.enc> files.
 150
 151 To find how to use this module in detail, see L<Encode>.
 152
 153 =head1 SEE ALSO
 154
 155 L<Encode>
 156
 157 L<Encode::Tcl::Table>
 158
 159 L<Encode::Tcl::Escape>
 160
 161 L<Encode::Tcl::Extended>
 162
 163 =cut