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

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

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

revision 1.10 by wakaba, Wed Oct 16 10:39:35 2002 UTC revision 1.15 by wakaba, Wed Dec 18 12:57:40 2002 UTC
# Line 342  sub internal_to_iso2022 ($;%) { Line 342  sub internal_to_iso2022 ($;%) {
342    $C ||= &new_object;    $C ||= &new_object;
343        
344    my $r = '';    my $r = '';
345    for my $c (split //, $s) {    my @c = split //, $s;
346      my $cc = ord $c;  Encode::_utf8_off ($c);    for my $i (0..$#c) {
347        my $c = $c[$i]; my $cc = ord $c;  Encode::_utf8_off ($c);
348      my $t;      my $t;
349      if ($cc <= 0x1F) {      if ($cc <= 0x1F) {
350        $t = _i2c ($c, $C, type => 'C0', charset => '@');        $t = _i2c ($c, $C, type => 'C0', charset => '@');
# Line 452  sub internal_to_iso2022 ($;%) { Line 453  sub internal_to_iso2022 ($;%) {
453                         ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);                         ->[ ($cc / 0x10000) - 0x7042 ]->[ $c / 8836 ]);
454      }      }
455      if (defined $t) {      if (defined $t) {
456          ## Back to ISO/IEC 2022 if necessary
457        $t = _i2o ($t, $C, cs_F => "\x40")        $t = _i2o ($t, $C, cs_F => "\x40")
458          if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};          if $C->{coding_system} ne $CODING_SYSTEM{"\x40"};
459      } else {      } else {
460          ## Output in UCS-n or UTF-n if character can't be represented in ISO/IEC 2022
461        my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;        my $F;  my @F = qw~G /G /H /I  B  /A /D /F~;
462        push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;        push @F, qw~/J /K /L~ if $cc <= 0x10FFFF;
463        push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;        push @F, qw~/@ /C /E~ if $cc <= 0xFFFF;
# Line 468  sub internal_to_iso2022 ($;%) { Line 471  sub internal_to_iso2022 ($;%) {
471        }        }
472        $t = _i2o ($c, $C, cs_F => $F) if $F;        $t = _i2o ($c, $C, cs_F => $F) if $F;
473      }      }
474      if (defined $t) {      if (defined $t) {   ## Output the character itself
475        $r .= $t;        $r .= $t;
476        } elsif ($C->{option}->{fallback_from_ucs} =~ /quiet/) {
477          $r .= _back2ascii ($C) if $C->{option}->{fallback_from_ucs} =~ /back/;
478          return ($r, halfway => 1, converted_length => $i,
479                  warn => $C->{option}->{fallback_from_ucs} =~ /warn/ ? 1 : 0,
480                  reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
481        } elsif ($C->{option}->{fallback_from_ucs} eq 'croak') {
482          return ($r, halfway => 1, die => 1,
483                  reason => sprintf (q(U+%04X: There is no character mapped to), $cc));
484      } else {      } else {
485        unless ($C->{option}->{undef_char}->[0] eq "\x20") {        ## Try to output with fallback escape sequence (if specified)
486          $t = _i2g ($C->{option}->{undef_char}->[0], $C,        my $t = Encode::Charset->fallback_escape ($C, $c);
487                      %{ $C->{option}->{undef_char}->[1] });        if (defined $t) {
488        } else {  ## SP          my %D = (fallback => $C->{option}->{fallback_from_ucs}, reset => $C->{option}->{reset});
489          $t = _back2ascii ($C) . "\x20";          $C->{option}->{fallback_from_ucs} = 'croak';
490            $C->{option}->{reset_at_end} = {Gdesignation => 0, Ginvoke => 0};
491            eval q{$t = $C->{_encoder}->_encode_internal ($t, $C)} or undef $t;
492            $C->{option}->{fallback_from_ucs} = $D{fallback};
493            $C->{option}->{reset_at_end} = $D{reset_at_end};
494          }
495          if (defined $t) {
496            $r .= $t;
497          } else {  ## Replacement character specified in charset definition
498            unless ($C->{option}->{undef_char}->[0] eq "\x20") {    ## A graphic character
499              $t = _i2g ($C->{option}->{undef_char}->[0], $C,
500                          %{ $C->{option}->{undef_char}->[1] });
501            } else {        ## SPACE
502              $t = _back2ascii ($C) . "\x20";
503            }
504            $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?
505                  $t : _i2o ($t, $C, cs_F => "\x40");
506        }        }
       $r .= $C->{coding_system} eq $CODING_SYSTEM{"\x40"} ?  
             $t : _i2o ($t, $C, cs_F => "\x40");  
507      }      }
508    }    }
509    $r . _back2ascii ($C);    ($r . _back2ascii ($C, at => 'reset_at_end'));
510  }  }
511    
512  ## $O{charset} eq undef means that charset is same as the current designated one.  ## $O{charset} eq undef means that charset is same as the current designated one.
# Line 598  sub _i2g ($%%) { Line 623  sub _i2g ($%%) {
623    $s =~ tr/\x00-\x7F/\x80-\xFF/ unless $left;    $s =~ tr/\x00-\x7F/\x80-\xFF/ unless $left;
624    $r . $s;    $r . $s;
625  }  }
626  sub _back2ascii (%) {  sub _back2ascii ($;%) {
627    my ($C, %O) = @_;    my ($C, %O) = @_;
628    my $r = '';    my $r = '';
629    if ($C->{option}->{reset}->{Gdesignation}) {    $O{at} ||= 'reset';
630      my $F = $C->{option}->{reset}->{Gdesignation};      # \x42    if ($C->{option}->{$O{at}}->{Gdesignation}||$C->{option}->{reset}->{Gdesignation}) {
631        my $F = $C->{option}->{$O{at}}->{Gdesignation}
632             || $C->{option}->{reset}->{Gdesignation};      # \x42
633      $r .= "\x1B\x28".$F unless $C->{G0} eq $CHARSET{G94}->{$F};      $r .= "\x1B\x28".$F unless $C->{G0} eq $CHARSET{G94}->{$F};
634      $C->{G0} = $CHARSET{G94}->{$F};      $C->{G0} = $CHARSET{G94}->{$F};
635      if ($O{reset_all}) {      if ($O{reset_all}) {
# Line 611  sub _back2ascii (%) { Line 638  sub _back2ascii (%) {
638        $C->{G3} = $CHARSET{G94}->{"\x7E"};        $C->{G3} = $CHARSET{G94}->{"\x7E"};
639      }      }
640    }    }
641    if ($C->{option}->{reset}->{Ginvoke}) {    if ($C->{option}->{$O{at}}->{Ginvoke}||$C->{option}->{reset}->{Ginvoke}) {
642      if ($C->{GL} ne 'G0') {      if ($C->{GL} ne 'G0') {
643        $r .= $C->{C0}->{C_LS0} || ($C->{C0} = $CHARSET{C0}->{'@'},"\x1B\x21\x40\x0F");        $r .= $C->{C0}->{C_LS0} || ($C->{C0} = $CHARSET{C0}->{'@'},"\x1B\x21\x40\x0F");
644        $C->{GL} = 'G0';        $C->{GL} = 'G0';
# Line 689  sub _i2o ($\%%) { Line 716  sub _i2o ($\%%) {
716    $r . $s;    $r . $s;
717  }  }
718    
 1;  
 __END__  
   
719  =head1 SEE ALSO  =head1 SEE ALSO
720    
721  ISO/IEC 646:1991, "7-bit coded graphic character set for intormation interchange".  ISO/IEC 646:1991, "7-bit coded graphic character set for intormation interchange".
# Line 707  ISO/IEC 6429:1992, "Control Functions fo Line 731  ISO/IEC 6429:1992, "Control Functions fo
731    
732  ISO/IEC 8859, "8-Bit Single-Byte Coded Graphic Character Sets".  ISO/IEC 8859, "8-Bit Single-Byte Coded Graphic Character Sets".
733    
734  Encode, perlunicode  L<Encode>, perlunicode
735    
736  =head1 TODO  =head1 TODO
737    
# Line 760  not implemented yet. Line 784  not implemented yet.
784    
785  =head1 AUTHORS  =head1 AUTHORS
786    
787  Nanashi-san  Nanashi-san  <nanashi.san@nanashi.invalid>
788    
789  Wakaba <w@suika.fam.cx>  Wakaba <w@suika.fam.cx>
790    
791  =head1 LICENSE  =head1 LICENSE
792    
793  Copyright 2002 AUTHORS  Copyright 2002 AUTHORS, all rights reserved.
794    
795  This library is free software; you can redistribute it  This library is free software; you can redistribute it
796  and/or modify it under the same terms as Perl itself.  and/or modify it under the same terms as Perl itself.
797    
798  =cut  =cut
799    
800  # $Date$  1; # $Date$
 ### ISO2022.pm ends here  
Legend:
Removed from v.1.10  
changed lines
  Added in v.1.15
admin@suikawiki.org
 ViewVC Help
Powered by ViewVC 1.1.24