/[suikacvs]/perl/lib/Encode/Charset.pm
Suika

Diff of /perl/lib/Encode/Charset.pm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.1 by wakaba, Fri Sep 20 14:01:45 2002 UTC revision 1.6 by wakaba, Sat Dec 14 11:02:25 2002 UTC
# Line 67  for my $f (0x30..0x5F, 0x7E) { Line 67  for my $f (0x30..0x5F, 0x7E) {
67      $CHARSET{G96n}->{ $_.$F }->{chars} = 96;      $CHARSET{G96n}->{ $_.$F }->{chars} = 96;
68      $CHARSET{G96n}->{ $_.$F }->{ucs} =      $CHARSET{G96n}->{ $_.$F }->{ucs} =
69        ({'' => 0xF4C000}->{ $_ }||0) + 96*96 * ($f-0x30);        ({'' => 0xF4C000}->{ $_ }||0) + 96*96 * ($f-0x30);
70        ## BUG: 94^n DRCSes with I byte have no mapping area        ## BUG: 96^n DRCSes with I byte have no mapping area
71    }    }
72  }  }
73      $CHARSET{G94n}->{"\x20\x40"}->{ucs} = 0x70460000;     ## DRCS 94^2 04/00
74      $CHARSET{G94n}->{P4_0} = $CHARSET{G94n}->{"\x20\x40"};
75      
76  for (0x60..0x6F) {  for (0x60..0x6F) {
77    my $F = pack 'C', $_;    my $F = pack 'C', $_;
78    ## BUG: 9x^3 sets have no mapping area    ## BUG: 9x^3 sets have no mapping area
# Line 106  $CHARSET{G96}->{A}->{ucs} = 0xA0;      ## ISO Line 109  $CHARSET{G96}->{A}->{ucs} = 0xA0;      ## ISO
109  $CHARSET{G94n}->{'B@'}->{dimension} = 2;        ## JIS X 0208-1990  $CHARSET{G94n}->{'B@'}->{dimension} = 2;        ## JIS X 0208-1990
110  $CHARSET{G94n}->{'B@'}->{chars} = 94;  $CHARSET{G94n}->{'B@'}->{chars} = 94;
111  $CHARSET{G94n}->{'B@'}->{ucs} = 0xE9F6C0 + 94*94*79;  $CHARSET{G94n}->{'B@'}->{ucs} = 0xE9F6C0 + 94*94*79;
112      
113      ## SJIS G3 mapping (JIS X 0213:2000 plane 2)
114      $CHARSET{G94n}->{"\x50"}->{Csjis_kuE} = { # ku - 1
115        0xF0 => 7,  0xF1 => 3,  0xF2 => 11, 0xF3 => 13, 0xF4 => 77,
116        0xF5 => 79, 0xF6 => 81, 0xF7 => 83, 0xF8 => 85, 0xF9 => 87,
117        0xFA => 89, 0xFB => 91, 0xFC => 93,
118      };
119      $CHARSET{G94n}->{"\x50"}->{Csjis_kuO} = { # ku - 1
120        0xF0  => 0,  0xF1 => 2,  0xF2 => 4,  0xF3 => 12, 0xF4 => 14,
121        0xF5  => 78, 0xF6 => 80, 0xF7 => 82, 0xF8 => 84, 0xF9 => 86,
122        0xFA  => 88, 0xFB => 90, 0xFC => 92,
123      };
124      $CHARSET{G94n}->{"\x50"}->{Csjis_first} = { reverse (
125        %{ $CHARSET{G94n}->{"\x50"}->{Csjis_kuE} },
126        %{ $CHARSET{G94n}->{"\x50"}->{Csjis_kuO} },
127      )};
128      
129    ## -- Control character sets    ## -- Control character sets
130    $CHARSET{C0}->{'@'}->{ucs} = 0x00;    ## ISO/IEC 6429 C0    $CHARSET{C0}->{'@'}->{ucs} = 0x00;    ## ISO/IEC 6429 C0
131    for ("\x40", "\x43", "\x44", "\x45", "\x46", "\x49", "\x4A", "\x4B", "\x4C") {    for ("\x40", "\x43", "\x44", "\x45", "\x46", "\x49", "\x4A", "\x4B", "\x4C") {
# Line 169  sub make_initial_coding_system { Line 188  sub make_initial_coding_system {
188      $CODING_SYSTEM{$F} = {};      $CODING_SYSTEM{$F} = {};
189      $CODING_SYSTEM{"\x2F".$F} = {reset_state => 1};      $CODING_SYSTEM{"\x2F".$F} = {reset_state => 1};
190    }    }
191      $CODING_SYSTEM{Csjis} = {perl_name => 'shiftjis'};
192  }  }
193    
194  sub make_charset (%) {  sub make_charset (%) {
# Line 179  sub make_charset (%) { Line 199  sub make_charset (%) {
199    $CHARSET{ $settype }->{ $setid } = \%set;    $CHARSET{ $settype }->{ $setid } = \%set;
200  }  }
201    
202  1;  ## Make a new ISO/IEC 2022-buffers object with default status
203  __END__  sub new_object {
204      my %C;
205      $C{bit} = 8;
206      $C{coding_system} = $CODING_SYSTEM{"\x40"};   ## ISO/IEC 2022
207      $C{CL} = 'C0'; $C{CR} = 'C1'; $C{ESC_Fe} = 'C1';
208      $C{C0} = $CHARSET{C0}->{"\x40"};      ## ISO/IEC 6429:1991 C0
209      $C{C1} = $CHARSET{C1}->{'64291991C1'};        ## ISO/IEC 6429:1991 C1
210      $C{GL} = 'G0'; $C{GR} = 'G1';
211      $C{G0} = $CHARSET{G94}->{"\x42"};     ## ISO/IEC 646:1991 IRV
212      #$C{G1} = $CHARSET{G96}->{"\x41"};    ## ISO/IEC 8859-1 GR
213      $C{G1} = $CHARSET{G94}->{"\x7E"};     ## empty set
214      $C{G2} = $CHARSET{G94}->{"\x7E"};     ## empty set
215      $C{G3} = $CHARSET{G94}->{"\x7E"};     ## empty set
216      $C{option} = {
217            C1invoke_to_right       => 0,   ## C1 invoked to: (0: ESC Fe, 1: CR)
218            G94n_designate_long     => 0,   ## (1: ESC 02/04 02/08 04/00..02)
219            designate_to    => {    ## Designated G buffer (-1: not to be outputed)
220                    C0      => {
221                            default => 0,
222                    },
223                    C1      => {
224                            default => 1,
225                    },
226                    G94     => {
227                            "\x42"  => 0,
228                            default => 0,
229                    },
230                    G96     => {
231                            default => 1,
232                    },
233                    G94n    => {
234                            default => 0,
235                    },
236                    G96n    => {
237                            default => 1,
238                    },
239                    coding_system => {
240                            default => -1,
241                    },
242            },
243            fallback_from_ucs       => 'replacement',
244                    ## 'replacement' / 'perl' / 'sgml' / 'sgml-hex' / 'x-u-escaped' / 'code'
245                    ## / 'quiet' / 'quiet+back' / 'quiet+warn' / 'quiet+back+warn' / 'croak'
246                    ## / code
247            final_to_set    => {
248                    C0 => {}, C1 => {}, G94 => {}, G94n => {},
249                    G96 => {}, G96n => {}, coding_system => {},
250            },
251            Ginvoke_by_single_shift => [0,0,0,0],   ## Invoked by SS
252            Ginvoke_to_left => [1,1,1,1],   ## Which invoked to? (1: L, 0: R)
253            private_set     => {    ## Private set vs Final byte
254                    C0      => [],
255                    C1      => [],
256                    G94     => [],
257                    G94n    => [[],[],[],[],["\x20\x40"]],
258                    G96     => [],
259                    #G96n   => [],  ## (not implemented)
260                    U96n    => [],  ## mule-unicode sets
261                    XC1     => {
262                            '64291991C1'    => undef,       ## ISO/IEC 6429:1991 C1
263                    },
264            },
265            reset => {      ## Reset status at top of line
266                    Gdesignation    => "\x42",      ## F of designation or 0
267                    Ginvoke => 1,
268            },
269            undef_char      => ["\x3F", {type => 'G94', charset => 'B'}],
270            use_revision    => 1,   ## Output IRR
271      };
272      \%C;
273    }
274    
275    sub new_object_sjis {
276      my $C = &new_object;
277      $C->{coding_system} = $CODING_SYSTEM{Csjis};
278      $C->{CR} = undef;
279      $C->{GR} = 'G2';      ## 0xA1-0xDF
280      $C->{G0} = $CHARSET{G94}->{J};        ## JIS X 0201:1997 Latin
281      $C->{G1} = $CHARSET{G94n}->{"\x4F"};  ## JIS X 0213:2000
282      $C->{G2} = $CHARSET{G94}->{I};        ## JIS X 0201:1997 Katakana
283      $C->{G3} = $CHARSET{G94n}->{"\x50"};  ## JIS X 0213:2000 plane 2
284      ## Special code area (0xFD-0xFF)
285      $C->{Gsmap} = {"\xA0" => "\x{F8F0}", "\xFD" => "\x{F8F1}", "\xFE" => "\x{F8F2}", "\xFF" => "\x{F8F3}"};
286      $C->{GsmapR} = {};    ## Reversed table
287      $C->{option}->{undef_char_sjis} = "\x81\xAC";
288      $C;
289    }
290    
291    our %FallbackFromUCS = (
292            perl    => sub { my $c = $_[1]; sprintf '\x{%04X}', ord $c },
293            sgml    => sub { my $c = $_[1]; sprintf '&#%d;', ord $c },
294            'sgml-hex'      => sub { my $c = $_[1]; sprintf '&#x%04X;', ord $c },
295            'x-u-escaped'   => sub { my $c = $_[1]; my $C = ord $c; sprintf $C > 0xFFFF ? '\U%08X' : '\u%04X', $C },
296    );
297    
298    sub fallback_escape ($$;%) {
299      my ($C, $c, %option) = @_;
300      my $f = ref ($C->{option}->{fallback_from_ucs}) eq 'CODE' ? $C->{option}->{fallback_from_ucs} :
301              $FallbackFromUCS{$C->{option}->{fallback_from_ucs}};
302      if (ref $f) {
303        Encode::_utf8_on ($c);
304        return &$f ($C, $c, %option);
305      }
306      undef;
307    }
308    
309  =head1 AUTHORS  =head1 AUTHORS
310    
311  Nanashi-san  Nanashi-san <nanashi-san@nanashi.invalid>
312    
313  Wakaba <w@suika.fam.cx>  Wakaba <w@suika.fam.cx>
314    
315  =head1 LICENSE  =head1 LICENSE
316    
317  Copyright 2002 AUTHORS  Copyright 2002 AUTHORS, all rights reserved.
318    
319  This library is free software; you can redistribute it  This library is free software; you can redistribute it
320  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
321    
322  =cut  =cut
323    
324  # $Date$  1; # $Date$
 ### Charset.pm ends here  
Legend:
Removed from v.1.1  
changed lines
  Added in v.1.6
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24