/[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.3 by wakaba, Sat May 17 12:29:24 2008 UTC revision 1.12 by wakaba, Sun Sep 14 03:07:58 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                 char_buffer_pos => 0,
18               character_queue => [],               character_queue => [],
19               filehandle => $_[2],               filehandle => $_[2],
20               charset => $_[1],               charset => $_[1],
# Line 530  require IO::Handle; Line 535  require IO::Handle;
535    
536  package Whatpm::Charset::DecodeHandle::ByteBuffer;  package Whatpm::Charset::DecodeHandle::ByteBuffer;
537    
538    ## NOTE: Provides a byte buffer wrapper object.
539    
540  sub new ($$) {  sub new ($$) {
541    my $self = bless {    my $self = bless {
542      buffer => '',      buffer => '',
# Line 543  sub read { Line 550  sub read {
550    my $pos = length $self->{buffer};    my $pos = length $self->{buffer};
551    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);
552    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);
553          ## NOTE: This would do different behavior from Perl's standard
554          ## |read| when $pos points beyond the end of the string.
555    return $r;    return $r;
556  } # read  } # read
557    
558  sub close { $_[0]->{filehandle}->close }  sub close { $_[0]->{filehandle}->close }
559    
560    package Whatpm::Charset::DecodeHandle::CharString;
561    
562    ## NOTE: Same as Perl's standard |open $handle, '<', \$char_string|,
563    ## but supports |ungetc| and other extensions.
564    
565    sub new ($$) {
566      my $self = bless {pos => 0}, shift;
567      $self->{string} = shift; # must be a scalar ref
568      return $self;
569    } # new
570    
571    sub getc ($) {
572      my $self = shift;
573      if ($self->{pos} < length ${$self->{string}}) {
574        return substr ${$self->{string}}, $self->{pos}++, 1;
575      } else {
576        return undef;
577      }
578    } # getc
579    
580    sub read ($$$$) {
581      #my ($self, $scalar, $length, $offset) = @_;
582      my $self = $_[0];
583      my $length = $_[2] || 0;
584      my $offset = $_[3];
585      ## NOTE: We don't support standard Perl semantics if $offset is
586      ## greater than the length of $scalar.
587      substr ($_[1], $offset) = substr (${$self->{string}}, $self->{pos}, $length);
588      my $count = (length $_[1]) - $offset;
589      $self->{pos} += $count;
590      return $count;
591    } # read
592    
593    sub manakai_read_until ($$$;$) {
594      #my ($self, $scalar, $pattern, $offset) = @_;
595      my $self = $_[0];
596      pos (${$self->{string}}) = $self->{pos};
597      if (${$self->{string}} =~ /\G(?>$_[2])+/) {
598        substr ($_[1], $_[3]) = substr (${$self->{string}}, $-[0], $+[0] - $-[0]);
599        $self->{pos} += $+[0] - $-[0];
600        return $+[0] - $-[0];
601      } else {
602        return 0;
603      }
604    } # manakai_read_until
605    
606    sub ungetc ($$) {
607      my $self = shift;
608      ## Ignore second parameter.
609      $self->{pos}-- if $self->{pos} > 0;
610    } # ungetc
611    
612    sub close ($) { }
613    
614  package Whatpm::Charset::DecodeHandle::Encode;  package Whatpm::Charset::DecodeHandle::Encode;
615    
616    ## NOTE: Provides a Perl |Encode| module wrapper object.
617    
618  sub charset ($) { $_[0]->{charset} }  sub charset ($) { $_[0]->{charset} }
619    
620  sub close ($) { $_[0]->{filehandle}->close }  sub close ($) { $_[0]->{filehandle}->close }
621    
622  sub getc ($) {  sub getc ($) {
623      my $c = '';
624      my $l = $_[0]->read ($c, 1);
625      if ($l) {
626        return $c;
627      } else {
628        return undef;
629      }
630    } # getc
631    
632    sub read ($$$;$) {
633    my $self = $_[0];    my $self = $_[0];
634    return shift @{$self->{character_queue}} if @{$self->{character_queue}};    # $scalar = $_[1];
635      my $length = $_[2];
636      my $offset = $_[3] || 0;
637      my $count = 0;
638      my $eof;
639      ## NOTE: It is incompatible with the standard Perl semantics
640      ## if $offset is greater than the length of $scalar.
641    
642      A: {
643        return $count if $length < 1;
644    
645        if (my $l = (length ${$self->{char_buffer}}) - $self->{char_buffer_pos}) {
646          if ($l >= $length) {
647            substr ($_[1], $offset)
648                = substr (${$self->{char_buffer}}, $self->{char_buffer_pos},
649                          $length);
650            $count += $length;
651            $self->{char_buffer_pos} += $length;
652            $length = 0;
653            return $count;
654          } else {
655            substr ($_[1], $offset)
656                = substr (${$self->{char_buffer}}, $self->{char_buffer_pos});
657            $count += $l;
658            $length -= $l;
659            ${$self->{char_buffer}} = '';
660            $self->{char_buffer_pos} = 0;
661          }
662          $offset = length $_[1];
663        }
664    
665        if ($eof) {
666          return $count;
667        }
668        
669    my $error;    my $error;
670    if ($self->{continue}) {    if ($self->{continue}) {
# Line 568  sub getc ($) { Line 676  sub getc ($) {
676      }      }
677      $self->{continue} = 0;      $self->{continue} = 0;
678    } elsif (512 > length $self->{byte_buffer}) {    } elsif (512 > length $self->{byte_buffer}) {
679      $self->{filehandle}->read ($self->{byte_buffer}, 256,      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
680                                 length $self->{byte_buffer});                                     length $self->{byte_buffer})) {
681          #
682        } else {
683          $eof = 1;
684        }
685    }    }
686    
   my $r;  
687    unless ($error) {    unless ($error) {
688        if (not $self->{bom_checked}) {
689          if (defined $self->{bom_pattern}) {
690            if ($self->{byte_buffer} =~ s/^$self->{bom_pattern}//) {
691              $self->{has_bom} = 1;
692            }
693          }
694          $self->{bom_checked} = 1;
695        }
696    
697      my $string = Encode::decode ($self->{perl_encoding_name},      my $string = Encode::decode ($self->{perl_encoding_name},
698                                   $self->{byte_buffer},                                   $self->{byte_buffer},
699                                   Encode::FB_QUIET ());                                   Encode::FB_QUIET ());
700      if (length $string) {      if (length $string) {
701        push @{$self->{character_queue}}, split //, $string;        $self->{char_buffer} = \$string;
702        $r = shift @{$self->{character_queue}};        $self->{char_buffer_pos} = 0;
703        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
704          $self->{continue} = 1;          $self->{continue} = 1;
705        }        }
# Line 587  sub getc ($) { Line 707  sub getc ($) {
707        if (length $self->{byte_buffer}) {        if (length $self->{byte_buffer}) {
708          $error = 1;          $error = 1;
709        } else {        } else {
710          $r = undef;          ## NOTE: No further input
711            redo A;
712        }        }
713      }      }
714    }    }
715    
716    if ($error) {    if ($error) {
717      $r = substr $self->{byte_buffer}, 0, 1, '';      my $r = substr $self->{byte_buffer}, 0, 1, '';
718      $self->{onerror}->($self, 'illegal-octets-error', octets => \$r);      my $fallback = $self->{fallback}->{$r};
719        if (defined $fallback) {
720          ## NOTE: This is an HTML5 parse error.
721          $self->{onerror}->($self, 'fallback-char-error', octets => \$r,
722                             char => \$fallback,
723                             level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});
724          ${$self->{char_buffer}} .= $fallback;
725        } elsif (exists $self->{fallback}->{$r}) {
726          ## NOTE: This is an HTML5 parse error.  In addition, the octet
727          ## is not assigned with a character.
728          $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,
729                             level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});
730          ${$self->{char_buffer}} .= $r;
731        } else {
732          $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,
733                             level => $self->{level}->{$self->{error_level}->{'illegal-octets-error'}});
734          ${$self->{char_buffer}} .= $r;
735        }
736    }    }
737    
738    return $r;      redo A;
739  } # getc    } # A
740    } # read
741    
742    sub manakai_read_until ($$$;$) {
743      #my ($self, $scalar, $pattern, $offset) = @_;
744      my $self = $_[0];
745      my $s = '';
746      $self->read ($s, 255);
747      if ($s =~ /^(?>$_[2])+/) {
748        my $rem_length = (length $s) - $+[0];
749        if ($rem_length) {
750          if ($self->{char_buffer_pos} > $rem_length) {
751            $self->{char_buffer_pos} -= $rem_length;
752          } else {
753            substr (${$self->{char_buffer}}, 0, $self->{char_buffer_pos})
754                = substr ($s, $+[0]);
755            $self->{char_buffer_pos} = 0;
756          }
757        }
758        substr ($_[1], $_[3]) = substr ($s, $+[0]);
759        return $+[0];
760      } elsif (length $s) {
761        if ($self->{char_buffer_pos} > length $s) {
762          $self->{char_buffer_pos} -= length $s;
763        } else {
764          substr (${$self->{char_buffer}}, 0, $self->{char_buffer_pos}) = $s;
765          $self->{char_buffer_pos} = 0;
766        }
767      }
768      return 0;
769    } # manakai_read_until
770    
771  sub has_bom ($) { $_[0]->{has_bom} }  sub has_bom ($) { $_[0]->{has_bom} }
772    
# Line 688  sub getc ($) { Line 856  sub getc ($) {
856      } elsif ($r eq "\xA0" or $r eq "\xFF") {      } elsif ($r eq "\xA0" or $r eq "\xFF") {
857        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
858      }      }
859      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
860                           level => $self->{level}->{$self->{error_level}->{$etype}});
861    }    }
862        
863    return $r;    return $r;
864  } # getc  } # getc
865    
866    ## TODO: This is not good for performance.  Should be replaced
867    ## by read-centric implementation.
868    sub read ($$$;$) {
869      #my ($self, $scalar, $length, $offset) = @_;
870      my $length = $_[2];
871      my $r = '';
872      while ($length > 0) {
873        my $c = $_[0]->getc;
874        last unless defined $c;
875        $r .= $c;
876        $length--;
877      }
878      substr ($_[1], $_[3]) = $r;
879          ## NOTE: This would do different thing from what Perl's |read| do
880          ## if $offset points beyond the end of the $scalar.
881      return length $r;
882    } # read
883    
884    sub manakai_read_until ($$$;$) {
885      #my ($self, $scalar, $pattern, $offset) = @_;
886      my $self = $_[0];
887      my $c = $self->getc;
888      if ($c =~ /^$_[2]/) {
889        substr ($_[1], $_[3]) = $c;
890        return 1;
891      } elsif (defined $c) {
892        $self->ungetc (ord $c);
893        return 0;
894      } else {
895        return 0;
896      }
897    } # manakai_read_until
898    
899  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
900  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
901    
# Line 749  sub getc ($) { Line 951  sub getc ($) {
951            } else {            } else {
952              $r = undef;              $r = undef;
953              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
954                                 state => $self->{state});                                 state => $self->{state},
955                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
956            }            }
957          }          }
958        } elsif ($self->{state} eq 'state_2442') { # 1983        } elsif ($self->{state} eq 'state_2442') { # 1983
# Line 765  sub getc ($) { Line 968  sub getc ($) {
968            } else {            } else {
969              $r = undef;              $r = undef;
970              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
971                                 state => $self->{state});                                 state => $self->{state},
972                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
973            }            }
974          }          }
975        } elsif ($self->{state} eq 'state_2440') { # 1978        } elsif ($self->{state} eq 'state_2440') { # 1978
# Line 781  sub getc ($) { Line 985  sub getc ($) {
985            } else {            } else {
986              $r = undef;              $r = undef;
987              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
988                                 state => $self->{state});                                 state => $self->{state},
989                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
990            }            }
991          }          }
992        } else {        } else {
# Line 803  sub getc ($) { Line 1008  sub getc ($) {
1008          $r .= "(H";          $r .= "(H";
1009          $self->{state} = 'state_284A';          $self->{state} = 'state_284A';
1010        }        }
1011        $self->{onerror}->($self, $etype, octets => \$r);        $self->{onerror}->($self, $etype, octets => \$r,
1012                             level => $self->{level}->{$self->{error_level}->{$etype}});
1013      }      }
1014    } # A    } # A
1015        
1016    return $r;    return $r;
1017  } # getc  } # getc
1018    
1019    ## TODO: This is not good for performance.  Should be replaced
1020    ## by read-centric implementation.
1021    sub read ($$$;$) {
1022      #my ($self, $scalar, $length, $offset) = @_;
1023      my $length = $_[2];
1024      my $r = '';
1025      while ($length > 0) {
1026        my $c = $_[0]->getc;
1027        last unless defined $c;
1028        $r .= $c;
1029        $length--;
1030      }
1031      substr ($_[1], $_[3]) = $r;
1032          ## NOTE: This would do different thing from what Perl's |read| do
1033          ## if $offset points beyond the end of the $scalar.
1034      return length $r;
1035    } # read
1036    
1037    sub manakai_read_until ($$$;$) {
1038      #my ($self, $scalar, $pattern, $offset) = @_;
1039      my $self = $_[0];
1040      my $c = $self->getc;
1041      if ($c =~ /^$_[2]/) {
1042        substr ($_[1], $_[3]) = $c;
1043        return 1;
1044      } elsif (defined $c) {
1045        $self->ungetc (ord $c);
1046        return 0;
1047      } else {
1048        return 0;
1049      }
1050    } # manakai_read_until
1051    
1052  package Whatpm::Charset::DecodeHandle::ShiftJIS;  package Whatpm::Charset::DecodeHandle::ShiftJIS;
1053  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
1054    
# Line 854  sub getc ($) { Line 1093  sub getc ($) {
1093    if ($error) {    if ($error) {
1094      $r = substr $self->{byte_buffer}, 0, 1, '';      $r = substr $self->{byte_buffer}, 0, 1, '';
1095      my $etype = 'illegal-octets-error';      my $etype = 'illegal-octets-error';
1096      if ($r =~ /^[\x81-\x9F\xE0-\xEF]/) {      if ($r =~ /^[\x81-\x9F\xE0-\xFC]/) {
1097        if ($self->{byte_buffer} =~ s/(.)//s) {        if ($self->{byte_buffer} =~ s/(.)//s) {
1098          $r .= $1;                     # not limited to \x40-\xFC - \x7F          $r .= $1;                     # not limited to \x40-\xFC - \x7F
1099          $etype = 'unassigned-code-point-error';          $etype = 'unassigned-code-point-error';
1100        }        }
1101      } elsif ($r =~ /^[\x80\xA0\xF0-\xFF]/) {        ## NOTE: Range [\xF0-\xFC] is unassigned and may be used as a single-byte
1102          ## character or as the first-byte of a double-byte character according
1103          ## to JIS X 0208:1997 Appendix 1.  However, the current practice is
1104          ## use the range as the first-byte of double-byte characters.
1105        } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {
1106        $etype = 'unassigned-code-point-error';        $etype = 'unassigned-code-point-error';
1107      }      }
1108      $self->{onerror}->($self, $etype, octets => \$r);      $self->{onerror}->($self, $etype, octets => \$r,
1109                           level => $self->{level}->{$self->{error_level}->{$etype}});
1110    }    }
1111    
1112    return $r;    return $r;
1113  } # getc  } # getc
1114    
1115    ## TODO: This is not good for performance.  Should be replaced
1116    ## by read-centric implementation.
1117    sub read ($$$;$) {
1118      #my ($self, $scalar, $length, $offset) = @_;
1119      my $length = $_[2];
1120      my $r = '';
1121      while ($length > 0) {
1122        my $c = $_[0]->getc;
1123        last unless defined $c;
1124        $r .= $c;
1125        $length--;
1126      }
1127      substr ($_[1], $_[3]) = $r;
1128          ## NOTE: This would do different thing from what Perl's |read| do
1129          ## if $offset points beyond the end of the $scalar.
1130    
1131      return length $r;
1132    } # read
1133    
1134    sub manakai_read_until ($$$;$) {
1135      #my ($self, $scalar, $pattern, $offset) = @_;
1136      my $self = $_[0];
1137      my $c = $self->getc;
1138      if ($c =~ /^$_[2]/) {
1139        substr ($_[1], $_[3]) = $c;
1140        return 1;
1141      } elsif (defined $c) {
1142        $self->ungetc (ord $c);
1143        return 0;
1144      } else {
1145        return 0;
1146      }
1147    } # manakai_read_until
1148    
1149  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =
1150  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =
1151  $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.3  
changed lines
  Added in v.1.12
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24