ext/Encode/lib/Encode/Tcl.pm

   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__