/[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.10 by wakaba, Fri Sep 12 03:31:40 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      ## NOTE: It is incompatible with the standard Perl semantics
586      ## if $offset is greater than the length of $scalar.
587    
588      A: {
589        return $count if $length < 1;
590    
591        if (my $l = length ${$self->{char_buffer}}) {
592          if ($l >= $length) {
593            substr ($_[1], $offset) = substr (${$self->{char_buffer}}, 0, $length);
594            $count += $length;
595            substr (${$self->{char_buffer}}, 0, $length) = '';
596            $length = 0;
597            return $count;
598          } else {
599            substr ($_[1], $offset) = ${$self->{char_buffer}};
600            $count += $l;
601            $length -= $l;
602            ${$self->{char_buffer}} = '';
603          }
604          $offset = length $_[1];
605        }
606    
607        if ($eof) {
608          return $count;
609        }
610        
611    my $error;    my $error;
612    if ($self->{continue}) {    if ($self->{continue}) {
# Line 568  sub getc ($) { Line 618  sub getc ($) {
618      }      }
619      $self->{continue} = 0;      $self->{continue} = 0;
620    } elsif (512 > length $self->{byte_buffer}) {    } elsif (512 > length $self->{byte_buffer}) {
621      $self->{filehandle}->read ($self->{byte_buffer}, 256,      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
622                                 length $self->{byte_buffer});                                     length $self->{byte_buffer})) {
623          #
624        } else {
625          $eof = 1;
626        }
627    }    }
628    
   my $r;  
629    unless ($error) {    unless ($error) {
630      if (not $self->{bom_checked}) {      if (not $self->{bom_checked}) {
631        if (defined $self->{bom_pattern}) {        if (defined $self->{bom_pattern}) {
# Line 587  sub getc ($) { Line 640  sub getc ($) {
640                                   $self->{byte_buffer},                                   $self->{byte_buffer},
641                                   Encode::FB_QUIET ());                                   Encode::FB_QUIET ());
642      if (length $string) {      if (length $string) {
643        push @{$self->{character_queue}}, split //, $string;        $self->{char_buffer} = \$string;
       $r = shift @{$self->{character_queue}};  
644        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
645          $self->{continue} = 1;          $self->{continue} = 1;
646        }        }
# Line 596  sub getc ($) { Line 648  sub getc ($) {
648        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
649          $error = 1;          $error = 1;
650        } else {        } else {
651          $r = undef;          ## NOTE: No further input
652            redo A;
653        }        }
654      }      }
655    }    }
656    
657    if ($error) {    if ($error) {
658      $r = substr $self->{byte_buffer}, 0, 1, '';      my $r = substr $self->{byte_buffer}, 0, 1, '';
659      my $fallback = $self->{fallback}->{$r};      my $fallback = $self->{fallback}->{$r};
660      if (defined $fallback) {      if (defined $fallback) {
661        ## 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.  
662        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,
663                           char => \$fallback,                           char => \$fallback,
664                           level => $self->{must_level});                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});
665        return $fallback;        ${$self->{char_buffer}} .= $fallback;
666        } elsif (exists $self->{fallback}->{$r}) {
667          ## NOTE: This is an HTML5 parse error.  In addition, the octet
668          ## is not assigned with a character.
669          $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,
670                             level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});
671          ${$self->{char_buffer}} .= $r;
672      } else {      } else {
673        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r);        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,
674                             level => $self->{level}->{$self->{error_level}->{'illegal-octets-error'}});
675          ${$self->{char_buffer}} .= $r;
676      }      }
677    }    }
678    
679    return $r;      redo A;
680      } # A
681  } # getc  } # getc
682    
683  sub has_bom ($) { $_[0]->{has_bom} }  sub has_bom ($) { $_[0]->{has_bom} }
# Line 707  sub getc ($) { Line 768  sub getc ($) {
768      } elsif ($r eq "\xA0" or $r eq "\xFF") {      } elsif ($r eq "\xA0" or $r eq "\xFF") {
769        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
770      }      }
771      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
772                           level => $self->{level}->{$self->{error_level}->{$etype}});
773    }    }
774        
775    return $r;    return $r;
776  } # getc  } # getc
777    
778    ## TODO: This is not good for performance.  Should be replaced
779    ## by read-centric implementation.
780    sub read ($$$;$) {
781      #my ($self, $scalar, $length, $offset) = @_;
782      my $length = $_[2];
783      my $r = '';
784      while ($length > 0) {
785        my $c = $_[0]->getc;
786        last unless defined $c;
787        $r .= $c;
788        $length--;
789      }
790      substr ($_[1], $_[3]) = $r;
791          ## NOTE: This would do different thing from what Perl's |read| do
792          ## if $offset points beyond the end of the $scalar.
793      return length $r;
794    } # read
795    
796  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
797  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
798    
# Line 768  sub getc ($) { Line 848  sub getc ($) {
848            } else {            } else {
849              $r = undef;              $r = undef;
850              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
851                                 state => $self->{state});                                 state => $self->{state},
852                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
853            }            }
854          }          }
855        } elsif ($self->{state} eq 'state_2442') { # 1983        } elsif ($self->{state} eq 'state_2442') { # 1983
# Line 784  sub getc ($) { Line 865  sub getc ($) {
865            } else {            } else {
866              $r = undef;              $r = undef;
867              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
868                                 state => $self->{state});                                 state => $self->{state},
869                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
870            }            }
871          }          }
872        } elsif ($self->{state} eq 'state_2440') { # 1978        } elsif ($self->{state} eq 'state_2440') { # 1978
# Line 800  sub getc ($) { Line 882  sub getc ($) {
882            } else {            } else {
883              $r = undef;              $r = undef;
884              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
885                                 state => $self->{state});                                 state => $self->{state},
886                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
887            }            }
888          }          }
889        } else {        } else {
# Line 822  sub getc ($) { Line 905  sub getc ($) {
905          $r .= "(H";          $r .= "(H";
906          $self->{state} = 'state_284A';          $self->{state} = 'state_284A';
907        }        }
908        $self->{onerror}->($self, $etype, octets => \$r);        $self->{onerror}->($self, $etype, octets => \$r,
909                             level => $self->{level}->{$self->{error_level}->{$etype}});
910      }      }
911    } # A    } # A
912        
913    return $r;    return $r;
914  } # getc  } # getc
915    
916    ## TODO: This is not good for performance.  Should be replaced
917    ## by read-centric implementation.
918    sub read ($$$;$) {
919      #my ($self, $scalar, $length, $offset) = @_;
920      my $length = $_[2];
921      my $r = '';
922      while ($length > 0) {
923        my $c = $_[0]->getc;
924        last unless defined $c;
925        $r .= $c;
926        $length--;
927      }
928      substr ($_[1], $_[3]) = $r;
929          ## NOTE: This would do different thing from what Perl's |read| do
930          ## if $offset points beyond the end of the $scalar.
931      return length $r;
932    } # read
933    
934  package Whatpm::Charset::DecodeHandle::ShiftJIS;  package Whatpm::Charset::DecodeHandle::ShiftJIS;
935  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
936    
# Line 885  sub getc ($) { Line 987  sub getc ($) {
987      } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {      } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {
988        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
989      }      }
990      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
991                           level => $self->{level}->{$self->{error_level}->{$etype}});
992    }    }
993    
994    return $r;    return $r;
995  } # getc  } # getc
996    
997    ## TODO: This is not good for performance.  Should be replaced
998    ## by read-centric implementation.
999    sub read ($$$;$) {
1000      #my ($self, $scalar, $length, $offset) = @_;
1001      my $length = $_[2];
1002      my $r = '';
1003      while ($length > 0) {
1004        my $c = $_[0]->getc;
1005        last unless defined $c;
1006        $r .= $c;
1007        $length--;
1008      }
1009      substr ($_[1], $_[3]) = $r;
1010          ## NOTE: This would do different thing from what Perl's |read| do
1011          ## if $offset points beyond the end of the $scalar.
1012      return length $r;
1013    } # read
1014    
1015  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =
1016  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =
1017  $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.10
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24