/[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.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 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]);
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    
# Line 743  sub getc ($) { Line 863  sub getc ($) {
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 863  sub getc ($) { Line 1016  sub getc ($) {
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 926  sub getc ($) { Line 1112  sub getc ($) {
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.8  
changed lines
  Added in v.1.12
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24