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 'E') ? 'Escape'   : 'Table';
 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;
 134
 135 1;
 136 __END__