/[suikacvs]/markup/html/whatpm/Whatpm/Charset/DecodeHandle.pm
Suika

Diff of /markup/html/whatpm/Whatpm/Charset/DecodeHandle.pm

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

revision 1.7 by wakaba, Wed Sep 10 10:27:09 2008 UTC revision 1.9 by wakaba, Thu Sep 11 12:09:38 2008 UTC
# Line 1  Line 1 
1  package Whatpm::Charset::DecodeHandle;  package Whatpm::Charset::DecodeHandle;
2  use strict;  use strict;
3    
4    ## NOTE: |Message::Charset::Info| uses this module without calling
5    ## the constructor.
6    
7  my $XML_AUTO_CHARSET = q<http://suika.fam.cx/www/2006/03/xml-entity/>;  my $XML_AUTO_CHARSET = q<http://suika.fam.cx/www/2006/03/xml-entity/>;
8  my $IANA_CHARSET = q<urn:x-suika-fam-cx:charset:>;  my $IANA_CHARSET = q<urn:x-suika-fam-cx:charset:>;
9  my $PERL_CHARSET = q<http://suika.fam.cx/~wakaba/archive/2004/dis/Charset/Perl.>;  my $PERL_CHARSET = q<http://suika.fam.cx/~wakaba/archive/2004/dis/Charset/Perl.>;
# Line 10  my $XML_CHARSET = q<http://suika.fam.cx/ Line 13  my $XML_CHARSET = q<http://suika.fam.cx/
13  sub create_decode_handle ($$$;$) {  sub create_decode_handle ($$$;$) {
14    my $csdef = $Whatpm::Charset::CharsetDef->{$_[1]};    my $csdef = $Whatpm::Charset::CharsetDef->{$_[1]};
15    my $obj = {    my $obj = {
16                 char_buffer => \(my $s = ''),
17               character_queue => [],               character_queue => [],
18               filehandle => $_[2],               filehandle => $_[2],
19               charset => $_[1],               charset => $_[1],
# Line 545  sub read { Line 549  sub read {
549    my $pos = length $self->{buffer};    my $pos = length $self->{buffer};
550    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);
551    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);
552          ## NOTE: This would do different behavior from Perl's standard
553          ## |read| when $pos points beyond the end of the string.
554    return $r;    return $r;
555  } # read  } # read
556    
# Line 559  sub charset ($) { $_[0]->{charset} } Line 565  sub charset ($) { $_[0]->{charset} }
565  sub close ($) { $_[0]->{filehandle}->close }  sub close ($) { $_[0]->{filehandle}->close }
566    
567  sub getc ($) {  sub getc ($) {
568      my $c = '';
569      my $l = $_[0]->read ($c, 1);
570      if ($l) {
571        return $c;
572      } else {
573        return undef;
574      }
575    } # getc
576    
577    sub read ($$$;$) {
578    my $self = $_[0];    my $self = $_[0];
579    return shift @{$self->{character_queue}} if @{$self->{character_queue}};    # $scalar = $_[1];
580      my $length = $_[2];
581      my $offset = $_[3] || 0;
582      my $count = 0;
583      my $eof;
584    
585      A: {
586        return $count if $length < 1;
587    
588        if (my $l = length ${$self->{char_buffer}}) {
589          if ($l >= $length) {
590            substr ($_[1], $offset) = substr (${$self->{char_buffer}}, 0, $length);
591            $count += $length;
592            substr (${$self->{char_buffer}}, 0, $length) = '';
593            $length = 0;
594            return $count;
595          } else {
596            substr ($_[1], $offset) = ${$self->{char_buffer}};
597            $count += $l;
598            $length -= $l;
599            ${$self->{char_buffer}} = '';
600          }
601          $offset = length $_[1];
602        }
603    
604        if ($eof) {
605          return $count;
606        }
607        
608    my $error;    my $error;
609    if ($self->{continue}) {    if ($self->{continue}) {
# Line 572  sub getc ($) { Line 615  sub getc ($) {
615      }      }
616      $self->{continue} = 0;      $self->{continue} = 0;
617    } elsif (512 > length $self->{byte_buffer}) {    } elsif (512 > length $self->{byte_buffer}) {
618      $self->{filehandle}->read ($self->{byte_buffer}, 256,      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
619                                 length $self->{byte_buffer});                                     length $self->{byte_buffer})) {
620          #
621        } else {
622          $eof = 1;
623        }
624    }    }
625    
   my $r;  
626    unless ($error) {    unless ($error) {
627      if (not $self->{bom_checked}) {      if (not $self->{bom_checked}) {
628        if (defined $self->{bom_pattern}) {        if (defined $self->{bom_pattern}) {
# Line 591  sub getc ($) { Line 637  sub getc ($) {
637                                   $self->{byte_buffer},                                   $self->{byte_buffer},
638                                   Encode::FB_QUIET ());                                   Encode::FB_QUIET ());
639      if (length $string) {      if (length $string) {
640        push @{$self->{character_queue}}, split //, $string;        $self->{char_buffer} = \$string;
       $r = shift @{$self->{character_queue}};  
641        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
642          $self->{continue} = 1;          $self->{continue} = 1;
643        }        }
# Line 600  sub getc ($) { Line 645  sub getc ($) {
645        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
646          $error = 1;          $error = 1;
647        } else {        } else {
648          $r = undef;          ## NOTE: No further input
649            redo A;
650        }        }
651      }      }
652    }    }
653    
654    if ($error) {    if ($error) {
655      $r = substr $self->{byte_buffer}, 0, 1, '';      my $r = substr $self->{byte_buffer}, 0, 1, '';
656      my $fallback = $self->{fallback}->{$r};      my $fallback = $self->{fallback}->{$r};
657      if (defined $fallback) {      if (defined $fallback) {
658        ## NOTE: This is an HTML5 parse error.        ## NOTE: This is an HTML5 parse error.
659        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,
660                           char => \$fallback,                           char => \$fallback,
661                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});
662        return $fallback;        ${$self->{char_buffer}} .= $fallback;
663      } elsif (exists $self->{fallback}->{$r}) {      } elsif (exists $self->{fallback}->{$r}) {
664        ## NOTE: This is an HTML5 parse error.  In addition, the octet        ## NOTE: This is an HTML5 parse error.  In addition, the octet
665        ## is not assigned with a character.        ## is not assigned with a character.
666        $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,        $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,
667                           level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});                           level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});
668          ${$self->{char_buffer}} .= $r;
669      } else {      } else {
670        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,
671                           level => $self->{level}->{$self->{error_level}->{'illegal-octets-error'}});                           level => $self->{level}->{$self->{error_level}->{'illegal-octets-error'}});
672          ${$self->{char_buffer}} .= $r;
673      }      }
674    }    }
675    
676    return $r;      redo A;
677      } # A
678  } # getc  } # getc
679    
680  sub has_bom ($) { $_[0]->{has_bom} }  sub has_bom ($) { $_[0]->{has_bom} }
# Line 723  sub getc ($) { Line 772  sub getc ($) {
772    return $r;    return $r;
773  } # getc  } # getc
774    
775    ## TODO: This is not good for performance.  Should be replaced
776    ## by read-centric implementation.
777    sub read ($$$;$) {
778      #my ($self, $scalar, $length, $offset) = @_;
779      my $length = $_[2];
780      my $r = '';
781      while ($length > 0) {
782        my $c = $_[0]->getc;
783        last unless defined $c;
784        $r .= $c;
785        $length--;
786      }
787      substr ($_[1], $_[3]) = $r;
788          ## NOTE: This would do different thing from what Perl's |read| do
789          ## if $offset points beyond the end of the $scalar.
790      return length $r;
791    } # read
792    
793  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
794  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
795    
# Line 843  sub getc ($) { Line 910  sub getc ($) {
910    return $r;    return $r;
911  } # getc  } # getc
912    
913    ## TODO: This is not good for performance.  Should be replaced
914    ## by read-centric implementation.
915    sub read ($$$;$) {
916      #my ($self, $scalar, $length, $offset) = @_;
917      my $length = $_[2];
918      my $r = '';
919      while ($length > 0) {
920        my $c = $_[0]->getc;
921        last unless defined $c;
922        $r .= $c;
923        $length--;
924      }
925      substr ($_[1], $_[3]) = $r;
926          ## NOTE: This would do different thing from what Perl's |read| do
927          ## if $offset points beyond the end of the $scalar.
928      return length $r;
929    } # read
930    
931  package Whatpm::Charset::DecodeHandle::ShiftJIS;  package Whatpm::Charset::DecodeHandle::ShiftJIS;
932  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
933    
# Line 906  sub getc ($) { Line 991  sub getc ($) {
991    return $r;    return $r;
992  } # getc  } # getc
993    
994    ## TODO: This is not good for performance.  Should be replaced
995    ## by read-centric implementation.
996    sub read ($$$;$) {
997      #my ($self, $scalar, $length, $offset) = @_;
998      my $length = $_[2];
999      my $r = '';
1000      while ($length > 0) {
1001        my $c = $_[0]->getc;
1002        last unless defined $c;
1003        $r .= $c;
1004        $length--;
1005      }
1006      substr ($_[1], $_[3]) = $r;
1007          ## NOTE: This would do different thing from what Perl's |read| do
1008          ## if $offset points beyond the end of the $scalar.
1009      return length $r;
1010    } # read
1011    
1012  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =
1013  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =
1014  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:iso646-us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:iso646-us'} =
Legend:
Removed from v.1.7  
changed lines
  Added in v.1.9
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24