/[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.8 by wakaba, Thu Sep 11 09:55:56 2008 UTC revision 1.14 by wakaba, Sun Sep 14 06:32:49 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 552  sub read { Line 557  sub 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.  ## NOTE: Provides a Perl |Encode| module wrapper object.
# Line 561  sub charset ($) { $_[0]->{charset} } Line 620  sub charset ($) { $_[0]->{charset} }
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 574  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}) {      if (not $self->{bom_checked}) {
689        if (defined $self->{bom_pattern}) {        if (defined $self->{bom_pattern}) {
# Line 593  sub getc ($) { Line 698  sub getc ($) {
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 602  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      my $fallback = $self->{fallback}->{$r};      my $fallback = $self->{fallback}->{$r};
719      if (defined $fallback) {      if (defined $fallback) {
720        ## NOTE: This is an HTML5 parse error.        ## NOTE: This is an HTML5 parse error.
721        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,        $self->{onerror}->($self, 'fallback-char-error', octets => \$r,
722                           char => \$fallback,                           char => \$fallback,
723                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});                           level => $self->{level}->{$self->{error_level}->{'fallback-char-error'}});
724        return $fallback;        ${$self->{char_buffer}} .= $fallback;
725      } elsif (exists $self->{fallback}->{$r}) {      } elsif (exists $self->{fallback}->{$r}) {
726        ## NOTE: This is an HTML5 parse error.  In addition, the octet        ## NOTE: This is an HTML5 parse error.  In addition, the octet
727        ## is not assigned with a character.        ## is not assigned with a character.
728        $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,        $self->{onerror}->($self, 'fallback-unassigned-error', octets => \$r,
729                           level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});                           level => $self->{level}->{$self->{error_level}->{'fallback-unassigned-error'}});
730          ${$self->{char_buffer}} .= $r;
731      } else {      } else {
732        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,        $self->{onerror}->($self, 'illegal-octets-error', octets => \$r,
733                           level => $self->{level}->{$self->{error_level}->{'illegal-octets-error'}});                           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], $+[0] - $-[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 656  sub ungetc ($$) { Line 794  sub ungetc ($$) {
794    unshift @{$_[0]->{character_queue}}, chr int ($_[1] or 0);    unshift @{$_[0]->{character_queue}}, chr int ($_[1] or 0);
795  } # ungetc  } # ungetc
796    
 ## TODO: This is not good for performance.  Should be replaced  
 ## by read-centric implementation.  
 sub read ($$$;$) {  
   #my ($self, $scalar, $length, $offset) = @_;  
   my $length = $_[2];  
   my $r = '';  
   while ($length > 0) {  
     my $c = $_[0]->getc;  
     last unless defined $c;  
     $r .= $c;  
     $length--;  
   }  
   substr ($_[1], $_[3]) = $r;  
       ## NOTE: This would do different thing from what Perl's |read| do  
       ## if $offset points beyond the end of the $scalar.  
   return length $r;  
 } # read  
   
797  package Whatpm::Charset::DecodeHandle::EUCJP;  package Whatpm::Charset::DecodeHandle::EUCJP;
798  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
799    
800  sub getc ($) {  sub read ($$$;$) {
801    my $self = $_[0];    my $self = $_[0];
802    return shift @{$self->{character_queue}} if @{$self->{character_queue}};    #my $scalar = $_[1];
803      my $length = $_[2];
804      my $offset = $_[3] || 0;
805      my $count = 0;
806      my $eof;
807      ## NOTE: It is incompatible with the standard Perl semantics
808      ## if $offset is greater than the length of $scalar.
809    
810    my $error;    A: {
811    if ($self->{continue}) {      return $count if $length < 1;
812      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,  
813                                     length $self->{byte_buffer})) {      if (my $l = (length ${$self->{char_buffer}}) - $self->{char_buffer_pos}) {
814        #        if ($l >= $length) {
815      } else {          substr ($_[1], $offset)
816        $error = 1;              = substr (${$self->{char_buffer}}, $self->{char_buffer_pos},
817      }                        $length);
818      $self->{continue} = 0;          $count += $length;
819    } elsif (512 > length $self->{byte_buffer}) {          $self->{char_buffer_pos} += $length;
820      $self->{filehandle}->read ($self->{byte_buffer}, 256,          $length = 0;
821                                 length $self->{byte_buffer});          return $count;
822    }        } else {
823              substr ($_[1], $offset)
824    my $r;              = substr (${$self->{char_buffer}}, $self->{char_buffer_pos});
825    unless ($error) {          $count += $l;
826      my $string = Encode::decode ($self->{perl_encoding_name},          $length -= $l;
827                                   $self->{byte_buffer},          ${$self->{char_buffer}} = '';
828                                   Encode::FB_QUIET ());          $self->{char_buffer_pos} = 0;
     if (length $string) {  
       push @{$self->{character_queue}}, split //, $string;  
       $r = shift @{$self->{character_queue}};  
       if (length $self->{byte_buffer}) {  
         $self->{continue} = 1;  
829        }        }
830      } else {        $offset = length $_[1];
831        if (length $self->{byte_buffer}) {      }
832    
833        if ($eof) {
834          return $count;
835        }
836    
837        my $error;
838        if ($self->{continue}) {
839          if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
840                                         length $self->{byte_buffer})) {
841            #
842          } else {
843          $error = 1;          $error = 1;
844          }
845          $self->{continue} = 0;
846        } elsif (512 > length $self->{byte_buffer}) {
847          if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
848                                         length $self->{byte_buffer})) {
849            #
850        } else {        } else {
851          $r = undef;          $eof = 1;
852        }        }
853      }      }
   }  
854    
855    if ($error) {      unless ($error) {
856      $r = substr $self->{byte_buffer}, 0, 1, '';        my $string = Encode::decode ($self->{perl_encoding_name},
857      my $etype = 'illegal-octets-error';                                     $self->{byte_buffer},
858      if ($r =~ /^[\xA1-\xFE]/) {                                     Encode::FB_QUIET ());
859        if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {        if (length $string) {
860          $r .= $1;          $self->{char_buffer} = \$string;
861            $self->{char_buffer_pos} = 0;
862            if (length $self->{byte_buffer}) {
863              $self->{continue} = 1;
864            }
865          } else {
866            if (length $self->{byte_buffer}) {
867              $error = 1;
868            } else {
869              ## NOTE: No further input.
870              redo A;
871            }
872          }
873        }
874    
875        if ($error) {
876          my $r = substr $self->{byte_buffer}, 0, 1, '';
877          my $etype = 'illegal-octets-error';
878          if ($r =~ /^[\xA1-\xFE]/) {
879            if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {
880              $r .= $1;
881              $etype = 'unassigned-code-point-error';
882            }
883          } elsif ($r eq "\x8F") {
884            if ($self->{byte_buffer} =~ s/^([\xA1-\xFE][\xA1-\xFE]?)//) {
885              $r .= $1;
886              $etype = 'unassigned-code-point-error' if length $1 == 2;
887            }
888          } elsif ($r eq "\x8E") {
889            if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {
890              $r .= $1;
891              $etype = 'unassigned-code-point-error';
892            }
893          } elsif ($r eq "\xA0" or $r eq "\xFF") {
894          $etype = 'unassigned-code-point-error';          $etype = 'unassigned-code-point-error';
895        }        }
896      } elsif ($r eq "\x8F") {        ## NOTE: Fixup line/column number by counting the number of
897        if ($self->{byte_buffer} =~ s/^([\xA1-\xFE][\xA1-\xFE]?)//) {        ## lines/columns in the string that is to be retuend by this
898          $r .= $1;        ## method call.
899          $etype = 'unassigned-code-point-error' if length $1 == 2;        my $line_diff = 0;
900          my $col_diff = 0;
901          my $set_col;
902          for (my $i = 0; $i < $count; $i++) {
903            my $s = substr $_[1], $i - $count, 1;
904            if ($s eq "\x0D") {
905              $line_diff++;
906              $col_diff = 0;
907              $set_col = 1;
908              $i++ if substr ($_[1], $i - $count + 1, 1) eq "\x0A";
909            } elsif ($s eq "\x0A") {
910              $line_diff++;
911              $col_diff = 0;
912              $set_col = 1;
913            } else {
914              $col_diff++;
915            }
916        }        }
917      } elsif ($r eq "\x8E") {        my $i = $self->{char_buffer_pos};
918        if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {        if ($count and substr (${$self->{char_buffer}}, -1, 1) eq "\x0D") {
919          $r .= $1;          if (substr (${$self->{char_buffer}}, $i, 1) eq "\x0A") {
920          $etype = 'unassigned-code-point-error';            $i++;
921            }
922        }        }
923      } elsif ($r eq "\xA0" or $r eq "\xFF") {        my $cb_length = length ${$self->{char_buffer}};
924        $etype = 'unassigned-code-point-error';        for (; $i < $cb_length; $i++) {
925            my $s = substr $_[1], $i, 1;
926            if ($s eq "\x0D") {
927              $line_diff++;
928              $col_diff = 0;
929              $set_col = 1;
930              $i++ if substr ($_[1], $i + 1, 1) eq "\x0A";
931            } elsif ($s eq "\x0A") {
932              $line_diff++;
933              $col_diff = 0;
934              $set_col = 1;
935            } else {
936              $col_diff++;
937            }
938          }
939          $self->{onerror}->($self, $etype, octets => \$r,
940                             level => $self->{level}->{$self->{error_level}->{$etype}},
941                             line_diff => $line_diff,
942                             ($set_col ? (column => 1) : ()),
943                             column_diff => $col_diff);
944              ## NOTE: Error handler may modify |octets| parameter, which
945              ## would be returned as part of the output.  Note that what
946              ## is returned would affect what |manakai_read_until| returns.
947          ${$self->{char_buffer}} .= $r;
948      }      }
949      $self->{onerror}->($self, $etype, octets => \$r,  
950                         level => $self->{level}->{$self->{error_level}->{$etype}});      redo A;
951    }    } # A
952      } # read
   return $r;  
 } # getc  
953    
954  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
955  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
# Line 863  sub getc ($) { Line 1071  sub getc ($) {
1071    return $r;    return $r;
1072  } # getc  } # getc
1073    
1074    ## TODO: This is not good for performance.  Should be replaced
1075    ## by read-centric implementation.
1076    sub read ($$$;$) {
1077      #my ($self, $scalar, $length, $offset) = @_;
1078      my $length = $_[2];
1079      my $r = '';
1080      while ($length > 0) {
1081        my $c = $_[0]->getc;
1082        last unless defined $c;
1083        $r .= $c;
1084        $length--;
1085      }
1086      substr ($_[1], $_[3]) = $r;
1087          ## NOTE: This would do different thing from what Perl's |read| do
1088          ## if $offset points beyond the end of the $scalar.
1089      return length $r;
1090    } # read
1091    
1092    sub manakai_read_until ($$$;$) {
1093      #my ($self, $scalar, $pattern, $offset) = @_;
1094      my $self = $_[0];
1095      my $c = $self->getc;
1096      if ($c =~ /^$_[2]/) {
1097        substr ($_[1], $_[3]) = $c;
1098        return 1;
1099      } elsif (defined $c) {
1100        $self->ungetc (ord $c);
1101        return 0;
1102      } else {
1103        return 0;
1104      }
1105    } # manakai_read_until
1106    
1107  package Whatpm::Charset::DecodeHandle::ShiftJIS;  package Whatpm::Charset::DecodeHandle::ShiftJIS;
1108  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
1109    
# Line 926  sub getc ($) { Line 1167  sub getc ($) {
1167    return $r;    return $r;
1168  } # getc  } # getc
1169    
1170    ## TODO: This is not good for performance.  Should be replaced
1171    ## by read-centric implementation.
1172    sub read ($$$;$) {
1173      #my ($self, $scalar, $length, $offset) = @_;
1174      my $length = $_[2];
1175      my $r = '';
1176      while ($length > 0) {
1177        my $c = $_[0]->getc;
1178        last unless defined $c;
1179        $r .= $c;
1180        $length--;
1181      }
1182      substr ($_[1], $_[3]) = $r;
1183          ## NOTE: This would do different thing from what Perl's |read| do
1184          ## if $offset points beyond the end of the $scalar.
1185    
1186      return length $r;
1187    } # read
1188    
1189    sub manakai_read_until ($$$;$) {
1190      #my ($self, $scalar, $pattern, $offset) = @_;
1191      my $self = $_[0];
1192      my $c = $self->getc;
1193      if ($c =~ /^$_[2]/) {
1194        substr ($_[1], $_[3]) = $c;
1195        return 1;
1196      } elsif (defined $c) {
1197        $self->ungetc (ord $c);
1198        return 0;
1199      } else {
1200        return 0;
1201      }
1202    } # manakai_read_until
1203    
1204  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =
1205  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =
1206  $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.8  
changed lines
  Added in v.1.14
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24