/[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.6 by wakaba, Sun May 18 06:07:22 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 530  require IO::Handle; Line 534  require IO::Handle;
534    
535  package Whatpm::Charset::DecodeHandle::ByteBuffer;  package Whatpm::Charset::DecodeHandle::ByteBuffer;
536    
537    ## NOTE: Provides a byte buffer wrapper object.
538    
539  sub new ($$) {  sub new ($$) {
540    my $self = bless {    my $self = bless {
541      buffer => '',      buffer => '',
# Line 543  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 550  sub close { $_[0]->{filehandle}->close } Line 558  sub close { $_[0]->{filehandle}->close }
558    
559  package Whatpm::Charset::DecodeHandle::Encode;  package Whatpm::Charset::DecodeHandle::Encode;
560    
561    ## NOTE: Provides a Perl |Encode| module wrapper object.
562    
563  sub charset ($) { $_[0]->{charset} }  sub charset ($) { $_[0]->{charset} }
564    
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 568  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 587  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 596  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.  Applied to Web ISO-8859-1        ## NOTE: This is an HTML5 parse error.
       ## and Web ISO-8859-11 encodings.  
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->{must_level});                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});
662        return $fallback;        ${$self->{char_buffer}} .= $fallback;
663        } elsif (exists $self->{fallback}->{$r}) {
664          ## NOTE: This is an HTML5 parse error.  In addition, the octet
665          ## is not assigned with a character.
666          $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,
667                             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'}});
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 707  sub getc ($) { Line 765  sub getc ($) {
765      } elsif ($r eq "\xA0" or $r eq "\xFF") {      } elsif ($r eq "\xA0" or $r eq "\xFF") {
766        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
767      }      }
768      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
769                           level => $self->{level}->{$self->{error_level}->{$etype}});
770    }    }
771        
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 768  sub getc ($) { Line 845  sub getc ($) {
845            } else {            } else {
846              $r = undef;              $r = undef;
847              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
848                                 state => $self->{state});                                 state => $self->{state},
849                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
850            }            }
851          }          }
852        } elsif ($self->{state} eq 'state_2442') { # 1983        } elsif ($self->{state} eq 'state_2442') { # 1983
# Line 784  sub getc ($) { Line 862  sub getc ($) {
862            } else {            } else {
863              $r = undef;              $r = undef;
864              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
865                                 state => $self->{state});                                 state => $self->{state},
866                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
867            }            }
868          }          }
869        } elsif ($self->{state} eq 'state_2440') { # 1978        } elsif ($self->{state} eq 'state_2440') { # 1978
# Line 800  sub getc ($) { Line 879  sub getc ($) {
879            } else {            } else {
880              $r = undef;              $r = undef;
881              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
882                                 state => $self->{state});                                 state => $self->{state},
883                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
884            }            }
885          }          }
886        } else {        } else {
# Line 822  sub getc ($) { Line 902  sub getc ($) {
902          $r .= "(H";          $r .= "(H";
903          $self->{state} = 'state_284A';          $self->{state} = 'state_284A';
904        }        }
905        $self->{onerror}->($self, $etype, octets => \$r);        $self->{onerror}->($self, $etype, octets => \$r,
906                             level => $self->{level}->{$self->{error_level}->{$etype}});
907      }      }
908    } # A    } # A
909        
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 885  sub getc ($) { Line 984  sub getc ($) {
984      } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {      } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {
985        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
986      }      }
987      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
988                           level => $self->{level}->{$self->{error_level}->{$etype}});
989    }    }
990    
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.6  
changed lines
  Added in v.1.9
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24