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: 0.94 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
   9
  10 use Encode qw(find_encoding);
  11 use base 'Encode::Encoding';
  12 use Carp;
  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, 1); # skip external tables
  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 'E') ? 'Escape'   : 'Table';
 102         my $class = ref($obj) . '::' . $subclass;
 103         # carp "Loading $file";
 104         bless $obj,$class;
 105         return $obj if $obj->read($fh,$obj->name,$type);
 106     }
 107     else
 108     {
 109         croak("Cannot open $file for ".$obj->name);
 110     }
 111     $obj->Undefine($name);
 112     return undef;
 113 }
 114
 115 sub INC_find
 116 {
 117     my ($class,$name) = @_;
 118     my $enc;
 119     foreach my $dir (@INC)
 120     {
 121         last if ($enc = $class->loadEncoding($name,"$dir/Encode/$name.enc"));
 122     }
 123     return $enc;
 124 }
 125
 126 require Encode::Tcl::Table;
 127 require Encode::Tcl::Escape;
 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 =cut