/[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.5 by wakaba, Sun May 18 04:15:52 2008 UTC revision 1.18 by wakaba, Mon Sep 15 07:19:03 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    use Message::Charset::Info;
7    
8  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/>;
9  my $IANA_CHARSET = q<urn:x-suika-fam-cx:charset:>;  my $IANA_CHARSET = q<urn:x-suika-fam-cx:charset:>;
10  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 14  my $XML_CHARSET = q<http://suika.fam.cx/
14  sub create_decode_handle ($$$;$) {  sub create_decode_handle ($$$;$) {
15    my $csdef = $Whatpm::Charset::CharsetDef->{$_[1]};    my $csdef = $Whatpm::Charset::CharsetDef->{$_[1]};
16    my $obj = {    my $obj = {
17                 category => 0,
18                 char_buffer => \(my $s = ''),
19                 char_buffer_pos => 0,
20               character_queue => [],               character_queue => [],
21               filehandle => $_[2],               filehandle => $_[2],
22               charset => $_[1],               charset => $_[1],
23               byte_buffer => '',               byte_buffer => '',
24               onerror => $_[3] || sub {},               onerror => $_[3] || sub {},
25                 #onerror_set
26              };              };
27    if ($csdef->{uri}->{$XML_AUTO_CHARSET} or    if ($csdef->{uri}->{$XML_AUTO_CHARSET} or
28        $obj->{charset} eq $XML_AUTO_CHARSET) {        $obj->{charset} eq $XML_AUTO_CHARSET) {
# Line 434  sub create_decode_handle ($$$;$) { Line 442  sub create_decode_handle ($$$;$) {
442        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];
443        require Encode::EUCJP1997;        require Encode::EUCJP1997;
444        if (Encode::find_encoding ($obj->{perl_encoding_name})) {        if (Encode::find_encoding ($obj->{perl_encoding_name})) {
445          return bless $obj, 'Whatpm::Charset::DecodeHandle::EUCJP';          $obj->{category} |= Message::Charset::Info::CHARSET_CATEGORY_EUCJP;
446            return bless $obj, 'Whatpm::Charset::DecodeHandle::Encode';
447        }        }
448      } elsif ($csdef->{uri}->{$XML_CHARSET.'shift_jis'} or      } elsif ($csdef->{uri}->{$XML_CHARSET.'shift_jis'} or
449               $csdef->{uri}->{$IANA_CHARSET.'shift_jis'}) {               $csdef->{uri}->{$IANA_CHARSET.'shift_jis'}) {
450        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];
451        require Encode::ShiftJIS1997;        require Encode::ShiftJIS1997;
452        if (Encode::find_encoding ($obj->{perl_encoding_name})) {        if (Encode::find_encoding ($obj->{perl_encoding_name})) {
453          return bless $obj, 'Whatpm::Charset::DecodeHandle::ShiftJIS';          return bless $obj, 'Whatpm::Charset::DecodeHandle::Encode';
454        }        }
455      } elsif ($csdef->{is_block_safe}) {      } elsif ($csdef->{is_block_safe}) {
456        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];        $obj->{perl_encoding_name} = $csdef->{perl_name}->[0];
# Line 530  require IO::Handle; Line 539  require IO::Handle;
539    
540  package Whatpm::Charset::DecodeHandle::ByteBuffer;  package Whatpm::Charset::DecodeHandle::ByteBuffer;
541    
542    ## NOTE: Provides a byte buffer wrapper object.
543    
544  sub new ($$) {  sub new ($$) {
545    my $self = bless {    my $self = bless {
546      buffer => '',      buffer => '',
# Line 543  sub read { Line 554  sub read {
554    my $pos = length $self->{buffer};    my $pos = length $self->{buffer};
555    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);    my $r = $self->{filehandle}->read ($self->{buffer}, $_[1], $pos);
556    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);    substr ($_[0], $_[2]) = substr ($self->{buffer}, $pos);
557          ## NOTE: This would do different behavior from Perl's standard
558          ## |read| when $pos points beyond the end of the string.
559    return $r;    return $r;
560  } # read  } # read
561    
562  sub close { $_[0]->{filehandle}->close }  sub close { $_[0]->{filehandle}->close }
563    
564    package Whatpm::Charset::DecodeHandle::CharString;
565    
566    ## NOTE: Same as Perl's standard |open $handle, '<', \$char_string|,
567    ## but supports |ungetc| and other extensions.
568    
569    sub new ($$) {
570      my $self = bless {pos => 0}, shift;
571      $self->{string} = shift; # must be a scalar ref
572      return $self;
573    } # new
574    
575    sub getc ($) {
576      my $self = shift;
577      if ($self->{pos} < length ${$self->{string}}) {
578        return substr ${$self->{string}}, $self->{pos}++, 1;
579      } else {
580        return undef;
581      }
582    } # getc
583    
584    sub read ($$$$) {
585      #my ($self, $scalar, $length, $offset) = @_;
586      my $self = $_[0];
587      my $length = $_[2] || 0;
588      my $offset = $_[3];
589      ## NOTE: We don't support standard Perl semantics if $offset is
590      ## greater than the length of $scalar.
591      substr ($_[1], $offset) = substr (${$self->{string}}, $self->{pos}, $length);
592      my $count = (length $_[1]) - $offset;
593      $self->{pos} += $count;
594      return $count;
595    } # read
596    
597    sub manakai_read_until ($$$;$) {
598      #my ($self, $scalar, $pattern, $offset) = @_;
599      my $self = $_[0];
600      pos (${$self->{string}}) = $self->{pos};
601      if (${$self->{string}} =~ /\G(?>$_[2])+/) {
602        substr ($_[1], $_[3]) = substr (${$self->{string}}, $-[0], $+[0] - $-[0]);
603        $self->{pos} += $+[0] - $-[0];
604        return $+[0] - $-[0];
605      } else {
606        return 0;
607      }
608    } # manakai_read_until
609    
610    sub ungetc ($$) {
611      my $self = shift;
612      ## Ignore second parameter.
613      $self->{pos}-- if $self->{pos} > 0;
614    } # ungetc
615    
616    sub close ($) { }
617    
618    sub onerror ($;$) { }
619    
620  package Whatpm::Charset::DecodeHandle::Encode;  package Whatpm::Charset::DecodeHandle::Encode;
621    
622    ## NOTE: Provides a Perl |Encode| module wrapper object.
623    
624  sub charset ($) { $_[0]->{charset} }  sub charset ($) { $_[0]->{charset} }
625    
626  sub close ($) { $_[0]->{filehandle}->close }  sub close ($) { $_[0]->{filehandle}->close }
627    
628  sub getc ($) {  sub getc ($) {
629    my $self = $_[0];    my $c = '';
630    return shift @{$self->{character_queue}} if @{$self->{character_queue}};    my $l = $_[0]->read ($c, 1);
631        if ($l) {
632    my $error;      return $c;
633    if ($self->{continue}) {    } else {
634      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,      return undef;
                                    length $self->{byte_buffer})) {  
       #  
     } else {  
       $error = 1;  
     }  
     $self->{continue} = 0;  
   } elsif (512 > length $self->{byte_buffer}) {  
     $self->{filehandle}->read ($self->{byte_buffer}, 256,  
                                length $self->{byte_buffer});  
635    }    }
636    } # getc
637    
638    my $r;  sub read ($$$;$) {
639    unless ($error) {    my $self = $_[0];
640      if (not $self->{bom_checked}) {    #my $scalar = $_[1];
641        if (defined $self->{bom_pattern}) {    my $length = $_[2];
642          if ($self->{byte_buffer} =~ s/^$self->{bom_pattern}//) {    my $offset = $_[3] || 0;
643            $self->{has_bom} = 1;    my $count = 0;
644          }    my $eof;
645        }    ## NOTE: It is incompatible with the standard Perl semantics
646        $self->{bom_checked} = 1;    ## if $offset is greater than the length of $scalar.
647      }  
648      A: {
649      my $string = Encode::decode ($self->{perl_encoding_name},      return $count if $length < 1;
650                                   $self->{byte_buffer},  
651                                   Encode::FB_QUIET ());      if (my $l = (length ${$self->{char_buffer}}) - $self->{char_buffer_pos}) {
652      if (length $string) {        if ($l >= $length) {
653        push @{$self->{character_queue}}, split //, $string;          substr ($_[1], $offset)
654        $r = shift @{$self->{character_queue}};              = substr (${$self->{char_buffer}}, $self->{char_buffer_pos},
655        if (length $self->{byte_buffer}) {                        $length);
656          $self->{continue} = 1;          $count += $length;
657            $self->{char_buffer_pos} += $length;
658            $length = 0;
659            return $count;
660          } else {
661            substr ($_[1], $offset)
662                = substr (${$self->{char_buffer}}, $self->{char_buffer_pos});
663            $count += $l;
664            $length -= $l;
665            ${$self->{char_buffer}} = '';
666            $self->{char_buffer_pos} = 0;
667        }        }
668      } else {        $offset = length $_[1];
669        if (length $self->{byte_buffer}) {      }
670    
671        if ($eof) {
672          return $count;
673        }
674    
675        my $error;
676        if ($self->{continue}) {
677          if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
678                                         length $self->{byte_buffer})) {
679            #
680          } else {
681          $error = 1;          $error = 1;
682          }
683          $self->{continue} = 0;
684        } elsif (512 > length $self->{byte_buffer}) {
685          if ($self->{filehandle}->read ($self->{byte_buffer}, 256,
686                                         length $self->{byte_buffer})) {
687            #
688        } else {        } else {
689          $r = undef;          $eof = 1;
690        }        }
691      }      }
   }  
692    
693    if ($error) {      unless ($error) {
694      $r = substr $self->{byte_buffer}, 0, 1, '';        if (not $self->{bom_checked}) {
695      $self->{onerror}->($self, 'illegal-octets-error', octets => \$r);          if (defined $self->{bom_pattern}) {
696    }            if ($self->{byte_buffer} =~ s/^$self->{bom_pattern}//) {
697                $self->{has_bom} = 1;
698              }
699            }
700            $self->{bom_checked} = 1;
701          }
702    
703    return $r;        my $string = Encode::decode ($self->{perl_encoding_name},
704  } # getc                                     $self->{byte_buffer},
705                                       Encode::FB_QUIET ());
706          if (length $string) {
707            $self->{char_buffer} = \$string;
708            $self->{char_buffer_pos} = 0;
709            if (length $self->{byte_buffer}) {
710              $self->{continue} = 1;
711            }
712          } else {
713            if (length $self->{byte_buffer}) {
714              $error = 1;
715            } else {
716              ## NOTE: No further input.
717              redo A;
718            }
719          }
720        }
721    
722        if ($error) {
723          my $r = substr $self->{byte_buffer}, 0, 1, '';
724          my $fallback;
725          my $etype = 'illegal-octets-error';
726          my %earg;
727          if ($self->{category}
728                  & Message::Charset::Info::CHARSET_CATEGORY_SJIS) {
729            if ($r =~ /^[\x81-\x9F\xE0-\xFC]/) {
730              if ($self->{byte_buffer} =~ s/(.)//s) {
731                $r .= $1;                     # not limited to \x40-\xFC - \x7F
732                $etype = 'unassigned-code-point-error';
733              }
734              ## NOTE: Range [\xF0-\xFC] is unassigned and may be used as a
735              ## single-byte character or as the first-byte of a double-byte
736              ## character, according to JIS X 0208:1997 Appendix 1.  However, the
737              ## current practice is using the range as first-bytes of double-byte
738              ## characters.
739            } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {
740              $etype = 'unassigned-code-point-error';
741            }
742          } elsif ($self->{category}
743                       & Message::Charset::Info::CHARSET_CATEGORY_EUCJP) {
744            if ($r =~ /^[\xA1-\xFE]/) {
745              if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {
746                $r .= $1;
747                $etype = 'unassigned-code-point-error';
748              }
749            } elsif ($r eq "\x8F") {
750              if ($self->{byte_buffer} =~ s/^([\xA1-\xFE][\xA1-\xFE]?)//) {
751                $r .= $1;
752                $etype = 'unassigned-code-point-error' if length $1 == 2;
753              }
754            } elsif ($r eq "\x8E") {
755              if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {
756                $r .= $1;
757                $etype = 'unassigned-code-point-error';
758              }
759            } elsif ($r eq "\xA0" or $r eq "\xFF") {
760              $etype = 'unassigned-code-point-error';
761            }
762          } else {
763            $fallback = $self->{fallback}->{$r};
764            if (defined $fallback) {
765              ## NOTE: This is an HTML5 parse error.
766              $etype = 'fallback-char-error';
767              $earg{char} = \$fallback;
768            } elsif (exists $self->{fallback}->{$r}) {
769              ## NOTE: This is an HTML5 parse error.  In addition, the octet
770              ## is not assigned with a character.
771              $etype = 'fallback-unassigned-error';
772            }
773          }
774    
775          ## NOTE: Fixup line/column number by counting the number of
776          ## lines/columns in the string that is to be retuend by this
777          ## method call.
778          my $line_diff = 0;
779          my $col_diff = 0;
780          my $set_col;
781          for (my $i = 0; $i < $count; $i++) {
782            my $s = substr $_[1], $i - $count, 1;
783            if ($s eq "\x0D") {
784              $line_diff++;
785              $col_diff = 0;
786              $set_col = 1;
787              $i++ if substr ($_[1], $i - $count + 1, 1) eq "\x0A";
788            } elsif ($s eq "\x0A") {
789              $line_diff++;
790              $col_diff = 0;
791              $set_col = 1;
792            } else {
793              $col_diff++;
794            }
795          }
796          my $i = $self->{char_buffer_pos};
797          if ($count and substr (${$self->{char_buffer}}, -1, 1) eq "\x0D") {
798            if (substr (${$self->{char_buffer}}, $i, 1) eq "\x0A") {
799              $i++;
800            }
801          }
802          my $cb_length = length ${$self->{char_buffer}};
803          for (; $i < $cb_length; $i++) {
804            my $s = substr $_[1], $i, 1;
805            if ($s eq "\x0D") {
806              $line_diff++;
807              $col_diff = 0;
808              $set_col = 1;
809              $i++ if substr ($_[1], $i + 1, 1) eq "\x0A";
810            } elsif ($s eq "\x0A") {
811              $line_diff++;
812              $col_diff = 0;
813              $set_col = 1;
814            } else {
815              $col_diff++;
816            }
817          }
818          $self->{onerror}->($self, $etype, octets => \$r, %earg,
819                             level => $self->{level}->{$self->{error_level}->{$etype}},
820                             line_diff => $line_diff,
821                             ($set_col ? (column => 1) : ()),
822                             column_diff => $col_diff);
823              ## NOTE: Error handler may modify |octets| parameter, which
824              ## would be returned as part of the output.  Note that what
825              ## is returned would affect what |manakai_read_until| returns.
826          ${$self->{char_buffer}} .= defined $fallback ? $fallback : $r;
827        }
828    
829        redo A;
830      } # A
831    } # read
832    
833    sub manakai_read_until ($$$;$) {
834      #my ($self, $scalar, $pattern, $offset) = @_;
835      my $self = $_[0];
836      my $s = '';
837      $self->read ($s, 255);
838      if ($s =~ /^(?>$_[2])+/) {
839        my $rem_length = (length $s) - $+[0];
840        if ($rem_length) {
841          if ($self->{char_buffer_pos} > $rem_length) {
842            $self->{char_buffer_pos} -= $rem_length;
843          } else {
844            substr (${$self->{char_buffer}}, 0, $self->{char_buffer_pos})
845                = substr ($s, $+[0]);
846            $self->{char_buffer_pos} = 0;
847          }
848        }
849        substr ($_[1], $_[3]) = substr ($s, $-[0], $+[0] - $-[0]);
850        return $+[0];
851      } elsif (length $s) {
852        if ($self->{char_buffer_pos} > length $s) {
853          $self->{char_buffer_pos} -= length $s;
854        } else {
855          substr (${$self->{char_buffer}}, 0, $self->{char_buffer_pos}) = $s;
856          $self->{char_buffer_pos} = 0;
857        }
858      }
859      return 0;
860    } # manakai_read_until
861    
862  sub has_bom ($) { $_[0]->{has_bom} }  sub has_bom ($) { $_[0]->{has_bom} }
863    
# Line 625  sub input_encoding ($) { Line 875  sub input_encoding ($) {
875    
876  sub onerror ($;$) {  sub onerror ($;$) {
877    if (@_ > 1) {    if (@_ > 1) {
878      $_[0]->{onerror} = $_[1];      if ($_[1]) {
879          $_[0]->{onerror} = $_[1];
880          $_[0]->{onerror_set} = 1;
881        } else {
882          $_[0]->{onerror} = sub { };
883          delete $_[0]->{onerror_set};
884        }
885    }    }
886    
887    return $_[0]->{onerror};    return $_[0]->{onerror_set} ? $_[0]->{onerror} : undef;
888  } # onerror  } # onerror
889    
890  sub ungetc ($$) {  sub ungetc ($$) {
891    unshift @{$_[0]->{character_queue}}, chr int ($_[1] or 0);    unshift @{$_[0]->{character_queue}}, chr int ($_[1] or 0);
892  } # ungetc  } # ungetc
893    
 package Whatpm::Charset::DecodeHandle::EUCJP;  
 push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  
   
 sub getc ($) {  
   my $self = $_[0];  
   return shift @{$self->{character_queue}} if @{$self->{character_queue}};  
   
   my $error;  
   if ($self->{continue}) {  
     if ($self->{filehandle}->read ($self->{byte_buffer}, 256,  
                                    length $self->{byte_buffer})) {  
       #  
     } else {  
       $error = 1;  
     }  
     $self->{continue} = 0;  
   } elsif (512 > length $self->{byte_buffer}) {  
     $self->{filehandle}->read ($self->{byte_buffer}, 256,  
                                length $self->{byte_buffer});  
   }  
     
   my $r;  
   unless ($error) {  
     my $string = Encode::decode ($self->{perl_encoding_name},  
                                  $self->{byte_buffer},  
                                  Encode::FB_QUIET ());  
     if (length $string) {  
       push @{$self->{character_queue}}, split //, $string;  
       $r = shift @{$self->{character_queue}};  
       if (length $self->{byte_buffer}) {  
         $self->{continue} = 1;  
       }  
     } else {  
       if (length $self->{byte_buffer}) {  
         $error = 1;  
       } else {  
         $r = undef;  
       }  
     }  
   }  
   
   if ($error) {  
     $r = substr $self->{byte_buffer}, 0, 1, '';  
     my $etype = 'illegal-octets-error';  
     if ($r =~ /^[\xA1-\xFE]/) {  
       if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {  
         $r .= $1;  
         $etype = 'unassigned-code-point-error';  
       }  
     } elsif ($r eq "\x8F") {  
       if ($self->{byte_buffer} =~ s/^([\xA1-\xFE][\xA1-\xFE]?)//) {  
         $r .= $1;  
         $etype = 'unassigned-code-point-error' if length $1 == 2;  
       }  
     } elsif ($r eq "\x8E") {  
       if ($self->{byte_buffer} =~ s/^([\xA1-\xFE])//) {  
         $r .= $1;  
         $etype = 'unassigned-code-point-error';  
       }  
     } elsif ($r eq "\xA0" or $r eq "\xFF") {  
       $etype = 'unassigned-code-point-error';  
     }  
     $self->{onerror}->($self, $etype, octets => \$r);  
   }  
     
   return $r;  
 } # getc  
   
894  package Whatpm::Charset::DecodeHandle::ISO2022JP;  package Whatpm::Charset::DecodeHandle::ISO2022JP;
895  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';
896    
# Line 758  sub getc ($) { Line 946  sub getc ($) {
946            } else {            } else {
947              $r = undef;              $r = undef;
948              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
949                                 state => $self->{state});                                 state => $self->{state},
950                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
951            }            }
952          }          }
953        } elsif ($self->{state} eq 'state_2442') { # 1983        } elsif ($self->{state} eq 'state_2442') { # 1983
# Line 774  sub getc ($) { Line 963  sub getc ($) {
963            } else {            } else {
964              $r = undef;              $r = undef;
965              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
966                                 state => $self->{state});                                 state => $self->{state},
967                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
968            }            }
969          }          }
970        } elsif ($self->{state} eq 'state_2440') { # 1978        } elsif ($self->{state} eq 'state_2440') { # 1978
# Line 790  sub getc ($) { Line 980  sub getc ($) {
980            } else {            } else {
981              $r = undef;              $r = undef;
982              $self->{onerror}->($self, 'invalid-state-error',              $self->{onerror}->($self, 'invalid-state-error',
983                                 state => $self->{state});                                 state => $self->{state},
984                                   level => $self->{level}->{$self->{error_level}->{'invalid-state-error'}});
985            }            }
986          }          }
987        } else {        } else {
# Line 812  sub getc ($) { Line 1003  sub getc ($) {
1003          $r .= "(H";          $r .= "(H";
1004          $self->{state} = 'state_284A';          $self->{state} = 'state_284A';
1005        }        }
1006        $self->{onerror}->($self, $etype, octets => \$r);        $self->{onerror}->($self, $etype, octets => \$r,
1007                             level => $self->{level}->{$self->{error_level}->{$etype}});
1008      }      }
1009    } # A    } # A
1010        
1011    return $r;    return $r;
1012  } # getc  } # getc
1013    
1014  package Whatpm::Charset::DecodeHandle::ShiftJIS;  ## TODO: This is not good for performance.  Should be replaced
1015  push our @ISA, 'Whatpm::Charset::DecodeHandle::Encode';  ## by read-centric implementation.
1016    sub read ($$$;$) {
1017  sub getc ($) {    #my ($self, $scalar, $length, $offset) = @_;
1018    my $self = $_[0];    my $length = $_[2];
1019    return shift @{$self->{character_queue}} if @{$self->{character_queue}};    my $r = '';
1020      while ($length > 0) {
1021    my $error;      my $c = $_[0]->getc;
1022    if ($self->{continue}) {      last unless defined $c;
1023      if ($self->{filehandle}->read ($self->{byte_buffer}, 256,      $r .= $c;
1024                                     length $self->{byte_buffer})) {      $length--;
       #  
     } else {  
       $error = 1;  
     }  
     $self->{continue} = 0;  
   } elsif (512 > length $self->{byte_buffer}) {  
     $self->{filehandle}->read ($self->{byte_buffer}, 256,  
                                length $self->{byte_buffer});  
1025    }    }
1026      substr ($_[1], $_[3]) = $r;
1027          ## NOTE: This would do different thing from what Perl's |read| do
1028          ## if $offset points beyond the end of the $scalar.
1029      return length $r;
1030    } # read
1031    
1032    my $r;  sub manakai_read_until ($$$;$) {
1033    unless ($error) {    #my ($self, $scalar, $pattern, $offset) = @_;
1034      my $string = Encode::decode ($self->{perl_encoding_name},    my $self = $_[0];
1035                                   $self->{byte_buffer},    my $c = $self->getc;
1036                                   Encode::FB_QUIET ());    if ($c =~ /^$_[2]/) {
1037      if (length $string) {      substr ($_[1], $_[3]) = $c;
1038        push @{$self->{character_queue}}, split //, $string;      return 1;
1039        $r = shift @{$self->{character_queue}};    } elsif (defined $c) {
1040        if (length $self->{byte_buffer}) {      $self->ungetc (ord $c);
1041          $self->{continue} = 1;      return 0;
1042        }    } else {
1043      } else {      return 0;
       if (length $self->{byte_buffer}) {  
         $error = 1;  
       } else {  
         $r = undef;  
       }  
     }  
   }  
     
   if ($error) {  
     $r = substr $self->{byte_buffer}, 0, 1, '';  
     my $etype = 'illegal-octets-error';  
     if ($r =~ /^[\x81-\x9F\xE0-\xFC]/) {  
       if ($self->{byte_buffer} =~ s/(.)//s) {  
         $r .= $1;                     # not limited to \x40-\xFC - \x7F  
         $etype = 'unassigned-code-point-error';  
       }  
       ## NOTE: Range [\xF0-\xFC] is unassigned and may be used as a single-byte  
       ## character or as the first-byte of a double-byte character according  
       ## to JIS X 0208:1997 Appendix 1.  However, the current practice is  
       ## use the range as the first-byte of double-byte characters.  
     } elsif ($r =~ /^[\x80\xA0\xFD-\xFF]/) {  
       $etype = 'unassigned-code-point-error';  
     }  
     $self->{onerror}->($self, $etype, octets => \$r);  
1044    }    }
1045    } # manakai_read_until
   return $r;  
 } # getc  
1046    
1047  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us-ascii'} =
1048  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =  $Whatpm::Charset::CharsetDef->{'urn:x-suika-fam-cx:charset:us'} =
Legend:
Removed from v.1.5  
changed lines
  Added in v.1.18
[email protected]
 ViewVC Help
Powered by ViewVC 1.1.24