/[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.9 by wakaba, Thu Sep 11 12:09:38 2008 UTC revision 1.14 by wakaba, Sun Sep 14 06:32:49 2008 UTC
# Line 14  sub create_decode_handle ($$$;$) { Line 14  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 = ''),               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 556  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 581  sub read ($$$;$) { Line 636  sub read ($$$;$) {
636    my $offset = $_[3] || 0;    my $offset = $_[3] || 0;
637    my $count = 0;    my $count = 0;
638    my $eof;    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: {    A: {
643      return $count if $length < 1;      return $count if $length < 1;
644    
645      if (my $l = length ${$self->{char_buffer}}) {      if (my $l = (length ${$self->{char_buffer}}) - $self->{char_buffer_pos}) {
646        if ($l >= $length) {        if ($l >= $length) {
647          substr ($_[1], $offset) = substr (${$self->{char_buffer}}, 0, $length);          substr ($_[1], $offset)
648                = substr (${$self->{char_buffer}}, $self->{char_buffer_pos},
649                          $length);
650          $count += $length;          $count += $length;
651          substr (${$self->{char_buffer}}, 0, $length) = '';          $self->{char_buffer_pos} += $length;
652          $length = 0;          $length = 0;
653          return $count;          return $count;
654        } else {        } else {
655          substr ($_[1], $offset) = ${$self->{char_buffer}};          substr ($_[1], $offset)
656                = substr (${$self->{char_buffer}}, $self->{char_buffer_pos});
657          $count += $l;          $count += $l;
658          $length -= $l;          $length -= $l;
659          ${$self->{char_buffer}} = '';          ${$self->{char_buffer}} = '';
660            $self->{char_buffer_pos} = 0;
661        }        }
662        $offset = length $_[1];        $offset = length $_[1];
663      }      }
# Line 638  sub read ($$$;$) { Line 699  sub read ($$$;$) {
699                                   Encode::FB_QUIET ());                                   Encode::FB_QUIET ());
700      if (length $string) {      if (length $string) {
701        $self->{char_buffer} = \$string;        $self->{char_buffer} = \$string;
702          $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 675  sub read ($$$;$) { Line 737  sub read ($$$;$) {
737    
738      redo A;      redo A;
739    } # A    } # A
740  } # getc  } # 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 706  sub ungetc ($$) { Line 797  sub ungetc ($$) {
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      }      }
     $self->{onerror}->($self, $etype, octets => \$r,  
                        level => $self->{level}->{$self->{error_level}->{$etype}});  
   }  
     
   return $r;  
 } # getc  
949    
950  ## TODO: This is not good for performance.  Should be replaced      redo A;
951  ## by read-centric implementation.    } # A
 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;  
952  } # read  } # read
953    
954  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
# Line 928  sub read ($$$;$) { Line 1089  sub read ($$$;$) {
1089    return length $r;    return length $r;
1090  } # read  } # 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 1006  sub read ($$$;$) { Line 1182  sub read ($$$;$) {
1182    substr ($_[1], $_[3]) = $r;    substr ($_[1], $_[3]) = $r;
1183        ## NOTE: This would do different thing from what Perl's |read| do        ## NOTE: This would do different thing from what Perl's |read| do
1184        ## if $offset points beyond the end of the $scalar.        ## if $offset points beyond the end of the $scalar.
1185    
1186    return length $r;    return length $r;
1187  } # read  } # 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.9  
changed lines
  Added in v.1.14
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24