diff options
author | Nick Ing-Simmons <nik@tiuk.ti.com> | 2002-04-26 17:36:16 +0000 |
---|---|---|
committer | Nick Ing-Simmons <nik@tiuk.ti.com> | 2002-04-26 17:36:16 +0000 |
commit | 5f228b1d3feafe3247efca23709f3c7bd5daf91b (patch) | |
tree | f917a045995abe71f5d8c726bebf6768680e3d73 /ext/Encode | |
parent | 2583bd17aea1ca96fac50929c91872157a7782b3 (diff) | |
parent | cb5780feb6b3d31503eb651fb2d3d543cc89f6c6 (diff) | |
download | perl-5f228b1d3feafe3247efca23709f3c7bd5daf91b.tar.gz |
Integrate mainline
p4raw-id: //depot/perlio@16194
Diffstat (limited to 'ext/Encode')
-rw-r--r-- | ext/Encode/AUTHORS | 1 | ||||
-rw-r--r-- | ext/Encode/CN/Makefile.PL | 15 | ||||
-rw-r--r-- | ext/Encode/Changes | 50 | ||||
-rw-r--r-- | ext/Encode/Encode.pm | 185 | ||||
-rw-r--r-- | ext/Encode/Encode.xs | 50 | ||||
-rw-r--r-- | ext/Encode/Encode/encode.h | 4 | ||||
-rw-r--r-- | ext/Encode/JP/Makefile.PL | 15 | ||||
-rw-r--r-- | ext/Encode/KR/Makefile.PL | 15 | ||||
-rw-r--r-- | ext/Encode/MANIFEST | 6 | ||||
-rw-r--r-- | ext/Encode/TW/Makefile.PL | 15 | ||||
-rw-r--r-- | ext/Encode/Unicode/Unicode.xs | 6 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/Config.pm | 7 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/Guess.pm | 297 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/JP/JIS7.pm | 12 | ||||
-rw-r--r-- | ext/Encode/lib/Encode/MIME/Header.pm | 212 | ||||
-rw-r--r-- | ext/Encode/t/CJKT.t | 3 | ||||
-rw-r--r-- | ext/Encode/t/at-cn.t | 4 | ||||
-rw-r--r-- | ext/Encode/t/at-tw.t | 4 | ||||
-rw-r--r-- | ext/Encode/t/fallback.t | 19 | ||||
-rw-r--r-- | ext/Encode/t/guess.t | 83 | ||||
-rw-r--r-- | ext/Encode/t/jperl.t | 4 | ||||
-rw-r--r-- | ext/Encode/t/mime-header.t | 77 |
22 files changed, 1023 insertions, 61 deletions
diff --git a/ext/Encode/AUTHORS b/ext/Encode/AUTHORS index 2ba72f844f..86100126b5 100644 --- a/ext/Encode/AUTHORS +++ b/ext/Encode/AUTHORS @@ -27,6 +27,7 @@ Nicholas Clark <nick@ccl4.org> Nick Ing-Simmons <nick@ing-simmons.net> Paul Marquess <paul_marquess@yahoo.co.uk> Philip Newton <pne@cpan.org> +Robin Barker <rmb1@cise.npl.co.uk> SADAHIRO Tomoyuki <SADAHIRO@cpan.org> Spider Boardman <spider@web.zk3.dec.com> Tatsuhiko Miyagawa <miyagawa@edge.co.jp> diff --git a/ext/Encode/CN/Makefile.PL b/ext/Encode/CN/Makefile.PL index 46b262dacd..775a8f5b38 100644 --- a/ext/Encode/CN/Makefile.PL +++ b/ext/Encode/CN/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (euc_cn_t => ['euc-cn.ucm', 'cp936.ucm', @@ -11,6 +12,20 @@ my %tables = (euc_cn_t => ['euc-cn.ucm', ir_165_t => ['ir-165.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'CN'; WriteMakefile( diff --git a/ext/Encode/Changes b/ext/Encode/Changes index 77a5f04120..ad4fabb76a 100644 --- a/ext/Encode/Changes +++ b/ext/Encode/Changes @@ -1,9 +1,53 @@ # Revision history for Perl extension Encode. # -# $Id: Changes,v 1.58 2002/04/22 23:54:22 dankogai Exp $ +# $Id: Changes,v 1.61 2002/04/26 03:02:04 dankogai Exp $ # -$Revision: 1.58 $ $Date: 2002/04/22 23:54:22 $ +$Revision: 1.61 $ $Date: 2002/04/26 03:02:04 $ +! t/mime-header.t + Now does decent tests besides use_ok() +! lib/Encode/Guess.pm t/guess.t + UI streamlined, document added +! Unicode/Unicode.xs + various signed/unsigned mismatch nits (#16173) + http://public.activestate.com/cgi-bin/perlbrowse?patch=16173 +! Encode.pm + POD: utf8-flag-related caveats added. A few sections completely + rewritten. +! Encode.xs +! AUTHORS + Thou shalt not assume %d works, either! + Robin Baker added to AUTHORS for this + Message-Id: <200204251132.MAA28237@tempest.npl.co.uk> +! t/CJKT.t + "Change 16144 by gsar@onru on 2002/04/24 18:59:05" + +1.60 2002/04/24 20:06:52 +! Encode.xs + "Thou shalt not assume %x works." -- jhi + Message-Id: <20020424210618.E24347@alpha.hut.fi> +! CN/Makefile.PL JP/Makefile.PL KR/Makefile.PL TW/Makefile.PL To make + low-memory build machines happy, now *.c is created for each *.ucm + (no table aggregation). You can still override this by setting + $ENV{AGGREGATE_TABLES}. + Message-Id: <00B1B3E4-579F-11D6-A441-00039301D480@dan.co.jp> ++ lib/Encode/Guess.pm ++ lib/Encode/JP/JIS7.pm + Encoding-autodetect (mainly for Japanese encoding) added. In a + course of development, JIS7.pm was improved. ++ lib/Encode/HTML/Header.pm ++ lib/Encode/Config.pm + MIME B/Q Header Encoding Added! +! Encode.pm Encode.xs t/fallback.t + new fallbacks; XMLCREF and HTMLCREF upon Bart's request. + Message-Id: <20020424130709.GA14211@tanglefoot> + +1.59 $ 2002/04/22 23:54:22 +! Encode.pm Encode.xs + needs_lines() and perlio_ok() are added to Internal encodings such + as utf8 so XML::SAX is happy. FB_* stub xsubs are now prototyped. + +1.58 2002/04/22 23:54:22 ! TW/TW.pm s/MacChineseSimp/MacChineseTrad/ # ... oops. ! bin/ucm2text @@ -467,7 +511,7 @@ $Revision: 1.58 $ $Date: 2002/04/22 23:54:22 $ Typo fixes and improvements by jhi Message-Id: <200204010201.FAA03564@alpha.hut.fi>, et al. -1.11 $Date: 2002/04/22 23:54:22 $ +1.11 $Date: 2002/04/26 03:02:04 $ + t/encoding.t + t/jperl.t ! MANIFEST diff --git a/ext/Encode/Encode.pm b/ext/Encode/Encode.pm index b03d93d707..e6c54f0a9f 100644 --- a/ext/Encode/Encode.pm +++ b/ext/Encode/Encode.pm @@ -1,12 +1,12 @@ package Encode; use strict; -our $VERSION = do { my @r = (q$Revision: 1.58 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.61 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; our $DEBUG = 0; use XSLoader (); XSLoader::load 'Encode'; require Exporter; -our @ISA = qw(Exporter); +use base qw/Exporter/; # Public, encouraged API is exported by default @@ -15,8 +15,10 @@ our @EXPORT = qw( encodings find_encoding ); -our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC PERLQQ); -our @FB_CONSTS = qw(FB_DEFAULT FB_QUIET FB_WARN FB_PERLQQ FB_CROAK); +our @FB_FLAGS = qw(DIE_ON_ERR WARN_ON_ERR RETURN_ON_ERR LEAVE_SRC + PERLQQ HTMLCREF XMLCREF); +our @FB_CONSTS = qw(FB_DEFAULT FB_CROAK FB_QUIET FB_WARN + FB_PERLQQ FB_HTMLCREF FB_XMLCREF); our @EXPORT_OK = ( @@ -194,6 +196,11 @@ sub predefine_encodings{ package Encode::UTF_EBCDIC; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$str,$chk) = @_; my $res = ''; @@ -221,6 +228,11 @@ sub predefine_encodings{ package Encode::Internal; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$str,$chk) = @_; utf8::upgrade($str); @@ -237,6 +249,11 @@ sub predefine_encodings{ package Encode::utf8; *name = sub{ shift->{'Name'} }; *new_sequence = sub{ return $_[0] }; + *needs_lines = sub{ 0 }; + *perlio_ok = sub { + eval{ require PerlIO::encoding }; + return $@ ? 0 : 1; + }; *decode = sub{ my ($obj,$octets,$chk) = @_; my $str = Encode::decode_utf8($octets); @@ -314,7 +331,7 @@ byte has 256 possible values, it easily fits in Perl's much larger =head2 TERMINOLOGY -=over 4 +=over 2 =item * @@ -339,7 +356,7 @@ and such details may change in future releases. =head1 PERL ENCODING API -=over 4 +=over 2 =item $octets = encode(ENCODING, $string[, CHECK]) @@ -351,7 +368,13 @@ For CHECK, see L</"Handling Malformed Data">. For example, to convert (internally UTF-8 encoded) Unicode string to iso-8859-1 (also known as Latin1), - $octets = encode("iso-8859-1", $unicode); + $octets = encode("iso-8859-1", $utf8); + +B<CAVEAT>: When you C<$octets = encode("utf8", $utf8)>, then $octets +B<ne> $utf8. Though they both contain the same data, the utf8 flag +for $octets is B<always> off. When you encode anything, utf8 flag of +the result is always off, even when it contains completely valid utf8 +string. See L</"The UTF-8 flag"> below. =item $string = decode(ENCODING, $octets[, CHECK]) @@ -365,16 +388,22 @@ For example, to convert ISO-8859-1 data to UTF-8: $utf8 = decode("iso-8859-1", $latin1); -=item [$length =] from_to($string, FROM_ENCODING, TO_ENCODING [,CHECK]) +B<CAVEAT>: When you C<$utf8 = encode("utf8", $octets)>, then $utf8 +B<may not be equal to> $utf8. Though they both contain the same data, +the utf8 flag for $utf8 is on unless $octets entirely conststs of +ASCII data (or EBCDIC on EBCDIC machines). See L</"The UTF-8 flag"> +below. -Converts B<in-place> data between two encodings. -For example, to convert ISO-8859-1 data to UTF-8: +=item [$length =] from_to($string, FROM_ENC, TO_ENC [, CHECK]) + +Converts B<in-place> data between two encodings. For example, to +convert ISO-8859-1 data to UTF-8: - from_to($data, "iso-8859-1", "utf-8"); + from_to($data, "iso-8859-1", "utf8"); and to convert it back: - from_to($data, "utf-8", "iso-8859-1"); + from_to($data, "utf8", "iso-8859-1"); Note that because the conversion happens in place, the data to be converted cannot be a string constant; it must be a scalar variable. @@ -382,32 +411,34 @@ converted cannot be a string constant; it must be a scalar variable. from_to() returns the length of the converted string on success, undef otherwise. -=back +B<CAVEAT>: The following operations look the same but not quite so; + + from_to($data, "iso-8859-1", "utf8"); #1 + $data = decode("iso-8859-1", $data); #2 -=head2 UTF-8 / utf8 +Both #1 and #2 makes $data consists of completely valid UTF-8 string +but only #2 turns utf8 flag on. #1 is equivalent to -The Unicode Consortium defines the UTF-8 transformation format as a -way of encoding the entire Unicode repertoire as sequences of octets. -This encoding is expected to become very widespread. Perl can use this -form internally to represent strings, so conversions to and from this -form are particularly efficient (as octets in memory do not have to -change, just the meta-data that tells Perl how to treat them). + $data = encode("utf8", decode("iso-8859-1", $data)); -=over 4 +See L</"The UTF-8 flag"> below. =item $octets = encode_utf8($string); -The characters that comprise $string are encoded in Perl's superset of -UTF-8 and the resulting octets are returned as a sequence of bytes. All -possible characters have a UTF-8 representation so this function cannot -fail. +Equivalent to C<$octets = encode("utf8", $string);> The characters +that comprise $string are encoded in Perl's superset of UTF-8 and the +resulting octets are returned as a sequence of bytes. All possible +characters have a UTF-8 representation so this function cannot fail. + =item $string = decode_utf8($octets [, CHECK]); -The sequence of octets represented by $octets is decoded from UTF-8 -into a sequence of logical characters. Not all sequences of octets -form valid UTF-8 encodings, so it is possible for this call to fail. -For CHECK, see L</"Handling Malformed Data">. +equivalent to C<$string = decode("utf8", $octets [, CHECK])>. +decode_utf8($octets [, CHECK]); The sequence of octets represented by +$octets is decoded from UTF-8 into a sequence of logical +characters. Not all sequences of octets form valid UTF-8 encodings, so +it is possible for this call to fail. For CHECK, see +L</"Handling Malformed Data">. =back @@ -493,7 +524,7 @@ For gory details, see L<Encode::PerlIO>. =head1 Handling Malformed Data -=over 4 +=over 2 The I<CHECK> argument is used as follows. When you omit it, the behaviour is the same as if you had passed a value of 0 for @@ -507,7 +538,7 @@ E<lt>subcharE<gt> will be used. For Unicode, "\x{FFFD}" is used. If the data is supposed to be UTF-8, an optional lexical warning (category utf8) is given. -=item I<CHECK> = Encode::DIE_ON_ERROR (== 1) +=item I<CHECK> = Encode::FB_CROAK ( == 1) If I<CHECK> is 1, methods will die immediately with an error message. Therefore, when I<CHECK> is set to 1, you should trap the @@ -539,6 +570,10 @@ you are debugging the mode above. =item perlqq mode (I<CHECK> = Encode::FB_PERLQQ) +=item HTML charref mode (I<CHECK> = Encode::FB_HTMLCREF) + +=item XML charref mode (I<CHECK> = Encode::FB_XMLCREF) + For encodings that are implemented by Encode::XS, CHECK == Encode::FB_PERLQQ turns (en|de)code into C<perlqq> fallback mode. @@ -548,6 +583,10 @@ decoded to utf8. And when you encode, '\x{I<xxxx>}' will be inserted, where I<xxxx> is the Unicode ID of the character that cannot be found in the character repertoire of the encoding. +HTML/XML character reference modes are about the same, in place of +\x{I<xxxx>}, HTML uses &#I<1234>; where I<1234> is a decimal digit and +XML uses &#xI<abcd>; where I<abcd> is the hexadecimal digit. + =item The bitmask These modes are actually set via a bitmask. Here is how the FB_XX @@ -561,6 +600,8 @@ constants via C<use Encode qw(:fallback_all)>. RETURN_ON_ERR 0x0004 X X LEAVE_SRC 0x0008 PERLQQ 0x0100 X + HTMLCREF 0x0200 + XMLCREF 0x0400 =head2 Unimplemented fallback schemes @@ -581,12 +622,84 @@ arguments are taken as aliases for I<$object>, as for C<define_alias>. See L<Encode::Encoding> for more details. -=head1 Messing with Perl's Internals +=head1 The UTF-8 flag + +Before the introduction of utf8 support in perl, The C<eq> operator +just compares internal data of the scalars. Now C<eq> means internal +data equality AND I<the utf8 flag>. To explain why we made it so, I +will quote page 402 of C<Programming Perl, 3rd ed.> + +=over 2 + +=item Goal #1: + +Old byte-oriented programs should not spontaneously break on the old +byte-oriented data they used to work on. + +=item Goal #2: + +Old byte-oriented programs should magically start working on the new +character-oriented data when appropriate. + +=item Goal #3: + +Programs should run just as fast in the new character-oriented mode +as in the old byte-oriented mode. + +=item Goal #4: + +Perl should remain one language, rather than forking into a +byte-oriented Perl and a character-oriented Perl. + +=back + +Back when C<Programming Perl, 3rd ed.> was written, not even Perl 5.6.0 +was born and many features documented in the book remained +unimplemented. Perl 5.8 hopefully correct this and the introduction +of UTF-8 flag is one of them. You can think this perl notion of +byte-oriented mode (utf8 flag off) and character-oriented mode (utf8 +flag on). + +Here is how Encode takes care of the utf8 flag. + +=over 2 + +=item * + +When you encode, the resulting utf8 flag is always off. + +=item + +When you decode, the resuting utf8 flag is on unless you can +unambiguously represent data. Here is the definition of +dis-ambiguity. + + After C<$utf8 = decode('foo', $octet);>, + + When $octet is... The utf8 flag in $utf8 is + --------------------------------------------- + In ASCII only (or EBCDIC only) OFF + In ISO-8859-1 ON + In any other Encoding ON + --------------------------------------------- + +As you see, there is one exception, In ASCII. That way you can assue +Goal #1. And with Encode Goal #2 is assumed but you still have to be +careful in such cases mentioned in B<CAVEAT> paragraphs. + +This utf8 flag is not visible in perl scripts, exactly for the same +reason you cannot (or you I<don't have to>) see if a scalar contains a +string, integer, or floating point number. But you can still peek +and poke these if you will. See the section below. + +=back + +=head2 Messing with Perl's Internals The following API uses parts of Perl's internals in the current implementation. As such, they are efficient but may change. -=over 4 +=over 2 =item is_utf8(STRING [, CHECK]) @@ -626,8 +739,8 @@ the Perl Unicode Mailing List E<lt>perl-unicode@perl.orgE<gt> =head1 MAINTAINER This project was originated by Nick Ing-Simmons and later maintained -by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full list -of people involved. For any questions, use -E<lt>perl-unicode@perl.orgE<gt> so others can share. +by Dan Kogai E<lt>dankogai@dan.co.jpE<gt>. See AUTHORS for a full +list of people involved. For any questions, use +E<lt>perl-unicode@perl.orgE<gt> so we can all share share. =cut diff --git a/ext/Encode/Encode.xs b/ext/Encode/Encode.xs index be69c33352..1311d8dacb 100644 --- a/ext/Encode/Encode.xs +++ b/ext/Encode/Encode.xs @@ -1,5 +1,5 @@ /* - $Id: Encode.xs,v 1.34 2002/04/22 20:27:30 dankogai Exp $ + $Id: Encode.xs,v 1.39 2002/04/26 03:02:04 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -141,10 +141,22 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src, goto ENCODE_SET_SRC; }else if (check & ENCODE_PERLQQ){ SV* perlqq = - sv_2mortal(newSVpvf("\\x{%04x}", ch)); + sv_2mortal(newSVpvf("\\x{%04"UVxf"}", ch)); sdone += slen + clen; ddone += dlen + SvCUR(perlqq); sv_catsv(dst, perlqq); + }else if (check & ENCODE_HTMLCREF){ + SV* htmlcref = + sv_2mortal(newSVpvf("&#%" UVuf ";", ch)); + sdone += slen + clen; + ddone += dlen + SvCUR(htmlcref); + sv_catsv(dst, htmlcref); + }else if (check & ENCODE_XMLCREF){ + SV* xmlcref = + sv_2mortal(newSVpvf("&#x%" UVxf ";", ch)); + sdone += slen + clen; + ddone += dlen + SvCUR(xmlcref); + sv_catsv(dst, xmlcref); } else { /* fallback char */ sdone += slen + clen; @@ -168,7 +180,8 @@ encode_method(pTHX_ encode_t * enc, encpage_t * dir, SV * src, enc->name[0], (U8) s[slen], code); } goto ENCODE_SET_SRC; - }else if (check & ENCODE_PERLQQ){ + }else if (check & + (ENCODE_PERLQQ|ENCODE_HTMLCREF|ENCODE_XMLCREF)){ SV* perlqq = sv_2mortal(newSVpvf("\\x%02X", s[slen])); sdone += slen + 1; @@ -441,9 +454,6 @@ CODE: OUTPUT: RETVAL -PROTOTYPES: DISABLE - - int DIE_ON_ERR() CODE: @@ -480,6 +490,20 @@ OUTPUT: RETVAL int +HTMLCREF() +CODE: + RETVAL = ENCODE_HTMLCREF; +OUTPUT: + RETVAL + +int +XMLCREF() +CODE: + RETVAL = ENCODE_XMLCREF; +OUTPUT: + RETVAL + +int FB_DEFAULT() CODE: RETVAL = ENCODE_FB_DEFAULT; @@ -514,6 +538,20 @@ CODE: OUTPUT: RETVAL +int +FB_HTMLCREF() +CODE: + RETVAL = ENCODE_FB_HTMLCREF; +OUTPUT: + RETVAL + +int +FB_XMLCREF() +CODE: + RETVAL = ENCODE_FB_XMLCREF; +OUTPUT: + RETVAL + BOOT: { #include "def_t.h" diff --git a/ext/Encode/Encode/encode.h b/ext/Encode/Encode/encode.h index 04df7f9b38..b860578f22 100644 --- a/ext/Encode/Encode/encode.h +++ b/ext/Encode/Encode/encode.h @@ -94,11 +94,15 @@ extern void Encode_DefineEncoding(encode_t *enc); #define ENCODE_RETURN_ON_ERR 0x0004 /* immediately returns on NOREP */ #define ENCODE_LEAVE_SRC 0x0008 /* $src updated unless set */ #define ENCODE_PERLQQ 0x0100 /* perlqq fallback string */ +#define ENCODE_HTMLCREF 0x0200 /* HTML character ref. fb mode */ +#define ENCODE_XMLCREF 0x0400 /* XML character ref. fb mode */ #define ENCODE_FB_DEFAULT 0x0000 #define ENCODE_FB_CROAK 0x0001 #define ENCODE_FB_QUIET ENCODE_RETURN_ON_ERR #define ENCODE_FB_WARN (ENCODE_RETURN_ON_ERR|ENCODE_WARN_ON_ERR) #define ENCODE_FB_PERLQQ ENCODE_PERLQQ +#define ENCODE_FB_HTMLCREF ENCODE_HTMLCREF +#define ENCODE_FB_XMLCREF ENCODE_XMLCREF #endif /* ENCODE_H */ diff --git a/ext/Encode/JP/Makefile.PL b/ext/Encode/JP/Makefile.PL index ce47d2fc97..a1df35d169 100644 --- a/ext/Encode/JP/Makefile.PL +++ b/ext/Encode/JP/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = ( euc_jp_t => ['euc-jp.ucm'], @@ -12,6 +13,20 @@ my %tables = ( ], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'JP'; WriteMakefile( diff --git a/ext/Encode/KR/Makefile.PL b/ext/Encode/KR/Makefile.PL index df0eeb68b2..4ba99ab82d 100644 --- a/ext/Encode/KR/Makefile.PL +++ b/ext/Encode/KR/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (euc_kr_t => ['euc-kr.ucm', 'macKorean.ucm', @@ -10,6 +11,20 @@ my %tables = (euc_kr_t => ['euc-kr.ucm', johab_t => ['johab.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'KR'; WriteMakefile( diff --git a/ext/Encode/MANIFEST b/ext/Encode/MANIFEST index 2a35d9f6ec..cc6a1414c9 100644 --- a/ext/Encode/MANIFEST +++ b/ext/Encode/MANIFEST @@ -42,12 +42,13 @@ lib/Encode/CN/HZ.pm Encode extension lib/Encode/Config.pm Encode configuration module lib/Encode/Encoder.pm OO Encoder lib/Encode/Encoding.pm Encode extension +lib/Encode/Guess.pm Encode Extension lib/Encode/JP/H2Z.pm Encode extension lib/Encode/JP/JIS7.pm Encode extension lib/Encode/KR/2022_KR.pm Encode extension +lib/Encode/MIME/Header.pm Encode extension lib/Encode/PerlIO.pod Documents for Encode & PerlIO lib/Encode/Supported.pod Documents for supported encodings -t/unibench.pl benchmark script t/Aliases.t test script t/CJKT.t test script t/Encode.t test script @@ -64,6 +65,7 @@ t/fallback.t test script t/gb2312.enc test data t/gb2312.utf test data t/grow.t test script +t/guess.t test script t/jisx0201.enc test data t/jisx0201.utf test data t/jisx0208.enc test data @@ -73,7 +75,9 @@ t/jisx0212.utf test data t/jperl.t test script t/ksc5601.enc test data t/ksc5601.utf test data +t/mime-header.t test script t/perlio.t test script +t/unibench.pl benchmark script ucm/8859-1.ucm Unicode Character Map ucm/8859-10.ucm Unicode Character Map ucm/8859-11.ucm Unicode Character Map diff --git a/ext/Encode/TW/Makefile.PL b/ext/Encode/TW/Makefile.PL index 4fdae9e3f5..8f12a81aee 100644 --- a/ext/Encode/TW/Makefile.PL +++ b/ext/Encode/TW/Makefile.PL @@ -1,6 +1,7 @@ use 5.7.2; use strict; use ExtUtils::MakeMaker; +use strict; my %tables = (big5_t => ['big5-eten.ucm', 'big5-hkscs.ucm', @@ -8,6 +9,20 @@ my %tables = (big5_t => ['big5-eten.ucm', 'cp950.ucm'], ); +unless ($ENV{AGGREGATE_TABLES}){ + my @ucm; + for my $k (keys %tables){ + push @ucm, @{$tables{$k}}; + } + %tables = (); + my $seq = 0; + for my $ucm (sort @ucm){ + # 8.3 compliance ! + my $t = sprintf ("%s_%02d_t", substr($ucm, 0, 2), $seq++); + $tables{$t} = [ $ucm ]; + } +} + my $name = 'TW'; WriteMakefile( diff --git a/ext/Encode/Unicode/Unicode.xs b/ext/Encode/Unicode/Unicode.xs index 4689b498e1..e3ad82c7f0 100644 --- a/ext/Encode/Unicode/Unicode.xs +++ b/ext/Encode/Unicode/Unicode.xs @@ -1,5 +1,5 @@ /* - $Id: Unicode.xs,v 1.3 2002/04/20 23:43:47 dankogai Exp $ + $Id: Unicode.xs,v 1.4 2002/04/26 03:02:04 dankogai Exp $ */ #define PERL_NO_GET_CONTEXT @@ -61,7 +61,7 @@ enc_pack(pTHX_ SV *result,STRLEN size,U8 endian,UV value) d += SvCUR(result); SvCUR_set(result,SvCUR(result)+size); while (size--) { - *d++ = value & 0xFF; + *d++ = (U8)(value & 0xFF); value >>= 8; } break; @@ -70,7 +70,7 @@ enc_pack(pTHX_ SV *result,STRLEN size,U8 endian,UV value) SvCUR_set(result,SvCUR(result)+size); d += SvCUR(result); while (size--) { - *--d = value & 0xFF; + *--d = (U8)(value & 0xFF); value >>= 8; } break; diff --git a/ext/Encode/lib/Encode/Config.pm b/ext/Encode/lib/Encode/Config.pm index dcbc524b7b..a834967a11 100644 --- a/ext/Encode/lib/Encode/Config.pm +++ b/ext/Encode/lib/Encode/Config.pm @@ -2,7 +2,7 @@ # Demand-load module list # package Encode::Config; -our $VERSION = do { my @r = (q$Revision: 1.5 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use strict; @@ -139,6 +139,11 @@ unless (ord("A") == 193){ #'big5plus' => 'Encode::HanExtra', #'euc-tw' => 'Encode::HanExtra', #'gb18030' => 'Encode::HanExtra', + + 'MIME-Header' => 'Encode::MIME::Header', + 'MIME-B' => 'Encode::MIME::Header', + 'MIME-Q' => 'Encode::MIME::Header', + ); } diff --git a/ext/Encode/lib/Encode/Guess.pm b/ext/Encode/lib/Encode/Guess.pm new file mode 100644 index 0000000000..d2aac44565 --- /dev/null +++ b/ext/Encode/lib/Encode/Guess.pm @@ -0,0 +1,297 @@ +package Encode::Guess; +use strict; +use Carp; + +use Encode qw(:fallbacks find_encoding); +our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +my $Canon = 'Guess'; +our $DEBUG = 0; +our %DEF_SUSPECTS = map { $_ => find_encoding($_) } qw(ascii utf8); +$Encode::Encoding{$Canon} = + bless { + Name => $Canon, + Suspects => { %DEF_SUSPECTS }, + } => __PACKAGE__; + +sub name { shift->{'Name'} } +sub new_sequence { $_[0] } +sub needs_lines { 1 } +sub perlio_ok { 0 } +sub DESTROY{} + +our @EXPORT = qw(guess_encoding); + +sub import { # Exporter not used so we do it on our own + my $callpkg = caller; + for my $item (@EXPORT){ + no strict 'refs'; + *{"$callpkg\::$item"} = \&{"$item"}; + } + set_suspects(@_); +} + +sub set_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + $self->{Suspects} = { %DEF_SUSPECTS }; + $self->add_suspects(@_); +} + +sub add_suspects{ + my $class = shift; + my $self = ref($class) ? $class : $Encode::Encoding{$Canon}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $self->{Suspects}{$e->name} = $e; + $DEBUG and warn "Added: ", $e->name; + } +} + +sub decode($$;$){ + my ($obj, $octet, $chk) = @_; + my $guessed = guess($obj, $octet); + ref($guessed) or croak $guessed; + my $utf8 = $guessed->decode($octet, $chk); + $_[1] = $octet if $chk; + return $utf8; +} + +sub encode{ + croak "Tsk, tsk, tsk. You can't be too lazy here!"; +} + +sub guess_encoding{ + guess($Encode::Encoding{$Canon}, @_); +} + +sub guess { + my $class = shift; + my $obj = ref($class) ? $class : $Encode::Encoding{$Canon}; + my $octet = shift; + # cheat 0: utf8 flag; + Encode::is_utf8($octet) and return find_encoding('utf8'); + # cheat 1: BOM + use Encode::Unicode; + my $BOM = unpack('n', $octet); + return find_encoding('UTF-16') + if ($BOM == 0xFeFF or $BOM == 0xFFFe); + $BOM = unpack('N', $octet); + return find_encoding('UTF-32') + if ($BOM == 0xFeFF or $BOM == 0xFFFe0000); + + my %try = %{$obj->{Suspects}}; + for my $c (@_){ + my $e = find_encoding($c) or die "Unknown encoding: $c"; + $try{$e->name} = $e; + $DEBUG and warn "Added: ", $e->name; + } + my $nline = 1; + for my $line (split /\r|\n|\r\n/, $octet){ + # cheat 2 -- \e in the string + if ($line =~ /\e/o){ + my @keys = keys %try; + delete @try{qw/utf8 ascii/}; + for my $k (@keys){ + ref($try{$k}) eq 'Encode::XS' and delete $try{$k}; + } + } + my %ok = %try; + # warn join(",", keys %try); + for my $k (keys %try){ + my $scratch = $line; + $try{$k}->decode($scratch, FB_QUIET); + if ($scratch eq ''){ + $DEBUG and warn sprintf("%4d:%-24s ok\n", $nline, $k); + }else{ + use bytes (); + $DEBUG and + warn sprintf("%4d:%-24s not ok; %d bytes left\n", + $nline, $k, bytes::length($scratch)); + delete $ok{$k}; + + } + } + %ok or return "No appropriate encodings found!"; + if (scalar(keys(%ok)) == 1){ + my ($retval) = values(%ok); + return $retval; + } + %try = %ok; $nline++; + } + $try{ascii} or + return "Encodings too ambiguous: ", join(" or ", keys %try); + return $try{ascii}; +} + + + +1; +__END__ + +=head1 NAME + +Encode::Guess -- Guesses encoding from data + +=head1 SYNOPSIS + + # if you are sure $data won't contain anything bogus + + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + my $utf8 = decode("Guess", $data); + my $data = encode("Guess", $utf8); # this doesn't work! + + # more elaborate way + use Encode::Guess, + my $enc = guess_encoding($data, qw/euc-jp shiftjis 7bit-jis/); + ref($enc) or die "Can't guess: $enc"; # trap error this way + $utf8 = $enc->decode($data); + # or + $utf8 = decode($enc->name, $data) + +=head1 ABSTRACT + +Encode::Guess enables you to guess in what encoding a given data is +encoded, or at least tries to. + +=head1 DESCRIPTION + +By default, it checks only ascii, utf8 and UTF-16/32 with BOM. + + use Encode::Guess; # ascii/utf8/BOMed UTF + +To use it more practically, you have to give the names of encodings to +check (I<suspects> as follows). The name of suspects can either be +canonical names or aliases. + + # tries all major Japanese Encodings as well + use Encode::Guess qw/euc-jp shiftjis 7bit-jis/; + +=over 4 + +=item Encode::Guess->set_suspects + +You can also change the internal suspects list via C<set_suspects> +method. + + use Encode::Guess; + Encode::Guess->set_suspects(qw/euc-jp shiftjis 7bit-jis/); + +=item Encode::Guess->add_suspects + +Or you can use C<add_suspects> method. The difference is that +C<set_suspects> flushes the current suspects list while +C<add_suspects> adds. + + use Encode::Guess; + Encode::Guess->add_suspects(qw/euc-jp shiftjis 7bit-jis/); + # now the suspects are euc-jp,shiftjis,7bit-jis, AND + # euc-kr,euc-cn, and big5-eten + Encode::Guess->add_suspects(qw/euc-kr euc-cn big5-eten/); + +=item Encode::decode("Guess" ...) + +When you are content with suspects list, you can now + + my $utf8 = Encode::decode("Guess", $data); + +=item Encode::Guess->guess($data) + +But it will croak if Encode::Guess fails to eliminate all other +suspects but the right one or no suspect was good. So you should +instead try this; + + my $decoder = Encode::Guess->guess($data); + +On success, $decoder is an object that is documented in +L<Encode::Encoding>. So you can now do this; + + my $utf8 = $decoder->decode($data); + +On failure, $decoder now contains an error message so the whole thing +would be as follows; + + my $decoder = Encode::Guess->guess($data); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + +=item guess_encoding($data, [, I<list of suspects>]) + +You can also try C<guess_encoding> function which is exported by +default. It takes $data to check and it also takes the list of +suspects by option. The optional suspect list is I<not reflected> to +the internal suspects list. + + my $decoder = guess_encoding($data, qw/euc-jp euc-kr euc-cn/); + die $decoder unless ref($decoder); + my $utf8 = $decoder->decode($data); + # check only ascii and utf8 + my $decoder = guess_encoding($data); + +=back + +=head1 CAVEATS + +=over 4 + +=item * + +Because of the algorithm used, ISO-8859 series and other single-byte +encodings do not work well unless either one of ISO-8859 is the only +one suspect (besides ascii and utf8). + + use Encode::Guess; + # perhaps ok + my $decoder = guess_encoding($data, 'latin1'); + # definitely NOT ok + my $decoder = guess_encoding($data, qw/latin1 greek/); + +The reason is that Encode::Guess guesses encoding by trial and error. +It first splits $data into lines and tries to decode the line for each +suspect. It keeps it going until all but one encoding was eliminated +out of suspects list. ISO-8859 series is just too successful for most +cases (because it fills almost all code points in \x00-\xff). + +=item * + +Do not mix national standard encodings and the corresponding vendor +encodings. + + # a very bad idea + my $decoder + = guess_encoding($data, qw/shiftjis MacJapanese cp932/); + +The reason is that vendor encoding is usually a superset of national +standard so it becomes too ambiguous for most cases. + +=item * + +On the other hand, mixing various national standard encodings +automagically works unless $data is too short to allow for guessing. + + # This is ok if $data is long enough + my $decoder = + guess_encoding($data, qw/euc-cn + euc-jp shiftjis 7bit-jis + euc-kr + big5-eten/); + +=item * + +DO NOT PUT TOO MANY SUSPECTS! Don't you try something like this! + + my $decoder = guess_encoding($data, + Encode->encodings(":all")); + +=back + +It is, after all, just a guess. You should alway be explicit when it +comes to encodings. But there are some, especially Japanese, +environment that guess-coding is a must. Use this module with care. + +=head1 SEE ALSO + +L<Encode>, L<Encode::Encoding> + +=cut + diff --git a/ext/Encode/lib/Encode/JP/JIS7.pm b/ext/Encode/lib/Encode/JP/JIS7.pm index c0a0d0622a..09ec94f9d6 100644 --- a/ext/Encode/lib/Encode/JP/JIS7.pm +++ b/ext/Encode/lib/Encode/JP/JIS7.pm @@ -1,7 +1,7 @@ package Encode::JP::JIS7; use strict; -our $VERSION = do { my @r = (q$Revision: 1.6 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; +our $VERSION = do { my @r = (q$Revision: 1.7 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; use Encode qw(:fallbacks); @@ -42,9 +42,13 @@ our $DEBUG = 0; sub decode($$;$) { - my ($obj,$str,$chk) = @_; - my $residue = jis_euc(\$str); - # This is for PerlIO + my ($obj, $str, $chk) = @_; + my $residue = ''; + if ($chk){ + $str =~ s/([^\x00-\x7f].*)$//so; + $1 and $residue = $1; + } + $residue .= jis_euc(\$str); $_[1] = $residue if $chk; return Encode::decode('euc-jp', $str, FB_PERLQQ); } diff --git a/ext/Encode/lib/Encode/MIME/Header.pm b/ext/Encode/lib/Encode/MIME/Header.pm new file mode 100644 index 0000000000..ce7b872876 --- /dev/null +++ b/ext/Encode/lib/Encode/MIME/Header.pm @@ -0,0 +1,212 @@ +package Encode::MIME::Header; +use strict; +# use warnings; +our $VERSION = do { my @r = (q$Revision: 1.2 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r }; + +use Encode qw(find_encoding encode_utf8); +use MIME::Base64; +use Carp; + +my %seed = + ( + decode_b => '1', # decodes 'B' encoding ? + decode_q => '1', # decodes 'Q' encoding ? + encode => 'B', # encode with 'B' or 'Q' ? + bpl => 75, # bytes per line + ); + +$Encode::Encoding{'MIME-Header'} = + bless { + %seed, + Name => 'MIME-Header', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-B'} = + bless { + %seed, + decode_q => 0, + Name => 'MIME-B', + } => __PACKAGE__; + +$Encode::Encoding{'MIME-Q'} = + bless { + %seed, + decode_q => 1, + encode => 'Q', + Name => 'MIME-Q', + } => __PACKAGE__; + +sub name { shift->{'Name'} } +sub new_sequence { $_[0] } +sub needs_lines { 1 } +sub perlio_ok{ 0 }; + +sub decode($$;$){ + use utf8; + my ($obj, $str, $chk) = @_; + # zap spaces between encoded words + $str =~ s/\?=\s+=\?/\?==\?/gos; + # multi-line header to single line + $str =~ s/(:?\r|\n|\r\n)[ \t]//gos; + $str =~ + s{ + =\? # begin encoded word + ([0-9A-Za-z\-]+) # charset (encoding) + \?([QqBb])\? # delimiter + (.*?) # Base64-encodede contents + \?= # end encoded word + }{ + if (uc($2) eq 'B'){ + $obj->{decode_b} or croak qq(MIME "B" unsupported); + decode_b($1, $3); + }elsif(uc($2) eq 'Q'){ + $obj->{decode_q} or croak qq(MIME "Q" unsupported); + decode_q($1, $3); + }else{ + croak qq(MIME "$2" encoding is nonexistent!); + } + }egox; + $_[1] = '' if $chk; + return $str; +} + +sub decode_b{ + my $enc = shift; + my $d = find_encoding($enc) or croak(Unknown encoding "$enc"); + my $db64 = decode_base64(shift); + return $d->decode($db64, Encode::FB_PERLQQ); +} + +sub decode_q{ + my ($enc, $q) = @_; + my $d = find_encoding($enc) or croak(Unknown encoding "$enc"); + $q =~ s/_/ /go; + $q =~ s/=([0-9A-Fa-f]{2})/pack("C", hex($1))/ego; + return $d->decode($q, Encode::FB_PERLQQ); +} + +my $especials = + join('|' => + map {quotemeta(chr($_))} + unpack("C*", qq{()<>@,;:\"\'/[]?.=})); + +my $re_especials = qr/$especials/o; + +sub encode($$;$){ + my ($obj, $str, $chk) = @_; + my @line = (); + for my $line (split /\r|\n|\r\n/o, $str){ + my (@word, @subline); + for my $word (split /($re_especials)/o, $line){ + if ($word =~ /[^\x00-\x7f]/o){ + push @word, $obj->_encode($word); + }else{ + push @word, $word; + } + } + my $subline = ''; + for my $word (@word){ + use bytes (); + if (bytes::length($subline) + bytes::length($word) > $obj->{bpl}){ + push @subline, $subline; + $subline = ''; + } + $subline .= $word; + } + $subline and push @subline, $subline; + push @line, join("\n " => @subline); + } + $_[1] = '' if $chk; + return join("\n", @line); +} + +use constant HEAD => '=?UTF-8?'; +use constant TAIL => '?='; +use constant SINGLE => { B => \&_encode_b, Q => \&_encode_q, }; + +sub _encode{ + my ($o, $str) = @_; + my $enc = $o->{encode}; + my $llen = ($o->{bpl} - length(HEAD) - 2 - length(TAIL)); + $llen *= $enc eq 'B' ? 3/4 : 1/3; + my @result = (); + my $chunk = ''; + while(my $chr = substr($str, 0, 1, '')){ + use bytes (); + if (bytes::length($chunk) + bytes::length($chr) > $llen){ + push @result, SINGLE->{$enc}($chunk); + $chunk = ''; + } + $chunk .= $chr; + } + $chunk and push @result, SINGLE->{$enc}($chunk); + return @result; +} + +sub _encode_b{ + HEAD . 'B?' . encode_base64(encode_utf8(shift), '') . TAIL; +} + +sub _encode_q{ + my $chunk = shift; + $chunk =~ s{ + ([^0-9A-Za-z]) + }{ + join("" => map {sprintf "=%02X", $_} unpack("C*", $1)) + }egox; + return HEAD . 'Q?' . $chunk . TAIL; +} + +1; +__END__ + +=head1 NAME + +Encode::MIME::Header -- MIME 'B' and 'Q' header encoding + +=head1 SYNOPSIS + + use Encode qw/encode decode/; + $utf8 = decode('MIME-Header', $header); + $header = encode('MIME-Header', $utf8); + +=head1 ABSTRACT + +This module implements RFC 2047 Mime Header Encoding. There are 3 +variant encoding names; C<MIME-Header>, C<MIME-B> and C<MIME-Q>. The +difference is described below + + decode() encode() + ---------------------------------------------- + MIME-Header Both B and Q =?UTF-8?B?....?= + MIME-B B only; Q croaks =?UTF-8?B?....?= + MIME-Q Q only; B croaks =?UTF-8?Q?....?= + +=head1 DESCRIPTION + +When you decode(=?I<encoding>?I<X>?I<ENCODED WORD>?=), I<ENCODED WORD> +is extracted and decoded for I<X> encoding (B for Base64, Q for +Quoted-Printable). Then the decoded chunk is fed to +decode(I<encoding>). So long as I<encoding> is supported by Encode, +any source encoding is fine. + +When you encode, it just encodes UTF-8 string with I<X> encoding then +quoted with =?UTF-8?I<X>?....?= . The parts that RFC 2047 forbids to +encode are left as is and long lines are folded within 76 bytes per +line. + +=head1 BUGS + +It would be nice to support encoding to non-UTF8, such as =?ISO-2022-JP? +and =?ISO-8859-1?= but that makes the implementation too complicated. +These days major mail agents all support =?UTF-8? so I think it is +just good enough. + +=head1 SEE ALSO + +L<Encode> + +RFC 2047, L<http://www.faqs.org/rfcs/rfc2047.html> and many other +locations. + +=cut diff --git a/ext/Encode/t/CJKT.t b/ext/Encode/t/CJKT.t index 4540034e55..31c0aa1916 100644 --- a/ext/Encode/t/CJKT.t +++ b/ext/Encode/t/CJKT.t @@ -55,7 +55,8 @@ for my $charset (sort keys %Charset){ open $src, "<$src_enc" or die "$src_enc : $!"; - binmode($src); + # binmode($src); # not needed! + $txt = join('',<$src>); close($src); diff --git a/ext/Encode/t/at-cn.t b/ext/Encode/t/at-cn.t index 893c29fa6d..6249feee38 100644 --- a/ext/Encode/t/at-cn.t +++ b/ext/Encode/t/at-cn.t @@ -19,9 +19,11 @@ use strict; use Test::More tests => 29; use Encode; +no utf8; # we have raw Chinese encodings here + use_ok('Encode::CN'); -# Since JP.t already test basic file IO, we will just focus on +# Since JP.t already tests basic file IO, we will just focus on # internal encode / decode test here. Unfortunately, to test # against all the UniHan characters will take a huge disk space, # not to mention the time it will take, and the fact that Perl diff --git a/ext/Encode/t/at-tw.t b/ext/Encode/t/at-tw.t index 830eb8686a..11abbf3807 100644 --- a/ext/Encode/t/at-tw.t +++ b/ext/Encode/t/at-tw.t @@ -21,9 +21,11 @@ use strict; use Test::More tests => 17; use Encode; +no utf8; # we have raw Chinese encodings here + use_ok('Encode::TW'); -# Since JP.t already test basic file IO, we will just focus on +# Since JP.t already tests basic file IO, we will just focus on # internal encode / decode test here. Unfortunately, to test # against all the UniHan characters will take a huge disk space, # not to mention the time it will take, and the fact that Perl diff --git a/ext/Encode/t/fallback.t b/ext/Encode/t/fallback.t index cf867beb01..3b6625851c 100644 --- a/ext/Encode/t/fallback.t +++ b/ext/Encode/t/fallback.t @@ -13,17 +13,18 @@ BEGIN { use strict; #use Test::More qw(no_plan); -use Test::More tests => 15; +use Test::More tests => 19; use Encode q(:all); my $original = ''; my $nofallback = ''; -my ($fallenback, $quiet, $perlqq); +my ($fallenback, $quiet, $perlqq, $htmlcref, $xmlcref); for my $i (0x20..0x7e){ $original .= chr($i); } -$fallenback = $quiet = $perlqq = $nofallback = $original; +$fallenback = $quiet = +$perlqq = $htmlcref = $xmlcref = $nofallback = $original; my $residue = ''; for my $i (0x80..0xff){ @@ -31,6 +32,8 @@ for my $i (0x80..0xff){ $residue .= chr($i); $fallenback .= '?'; $perlqq .= sprintf("\\x{%04x}", $i); + $htmlcref .= sprintf("&#%d;", $i); + $xmlcref .= sprintf("&#x%x;", $i); } utf8::upgrade($original); my $meth = find_encoding('ascii'); @@ -75,3 +78,13 @@ $src = $original; $dst = $meth->encode($src, FB_PERLQQ); is($dst, $perlqq, "FB_PERLQQ"); is($src, '', "FB_PERLQQ residue"); + +$src = $original; +$dst = $meth->encode($src, FB_HTMLCREF); +is($dst, $htmlcref, "FB_HTMLCREF"); +is($src, '', "FB_HTMLCREF residue"); + +$src = $original; +$dst = $meth->encode($src, FB_XMLCREF); +is($dst, $xmlcref, "FB_XMLCREF"); +is($src, '', "FB_XMLCREF residue"); diff --git a/ext/Encode/t/guess.t b/ext/Encode/t/guess.t new file mode 100644 index 0000000000..ace13ddec7 --- /dev/null +++ b/ext/Encode/t/guess.t @@ -0,0 +1,83 @@ +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bEncode\b/) { + print "1..0 # Skip: Encode was not built\n"; + exit 0; + } + $| = 1; +} + +use strict; +use File::Basename; +use File::Spec; +use Encode qw(decode encode find_encoding _utf8_off); + +#use Test::More qw(no_plan); +use Test::More tests => 17; +use_ok("Encode::Guess"); +{ + no warnings; + $Encode::Guess::DEBUG = shift || 0; +} + +my $ascii = join('' => map {chr($_)}(0x21..0x7e)); +my $latin1 = join('' => map {chr($_)}(0xa1..0xfe)); +my $utf8on = join('' => map {chr($_)}(0x3000..0x30fe)); +my $utf8off = $utf8on; _utf8_off($utf8off); +my $utf16 = encode('UTF-16', $utf8on); +my $utf32 = encode('UTF-32', $utf8on); + +is(guess_encoding($ascii)->name, 'ascii', 'ascii'); +like(guess_encoding($latin1), qr/No appropriate encoding/io, 'no ascii'); +is(guess_encoding($latin1, 'latin1')->name, 'iso-8859-1', 'iso-8859-1'); +is(guess_encoding($utf8on)->name, 'utf8', 'utf8 w/ flag'); +is(guess_encoding($utf8off)->name, 'utf8', 'utf8 w/o flag'); +is(guess_encoding($utf16)->name, 'UTF-16', 'UTF-16'); +is(guess_encoding($utf32)->name, 'UTF-32', 'UTF-32'); + +my $jisx0201 = File::Spec->catfile(dirname(__FILE__), 'jisx0201.utf'); +my $jisx0208 = File::Spec->catfile(dirname(__FILE__), 'jisx0208.utf'); +my $jisx0212 = File::Spec->catfile(dirname(__FILE__), 'jisx0212.utf'); + +open my $fh, $jisx0208 or die "$jisx0208: $!"; +$utf8off = join('' => <$fh>); +close $fh; +$utf8on = decode('utf8', $utf8off); + +my @jp = qw(7bit-jis shiftjis euc-jp); + +Encode::Guess->set_suspects(@jp); + +for my $jp (@jp){ + my $test = encode($jp, $utf8on); + is(guess_encoding($test)->name, $jp, "JP:$jp"); +} + +is (decode('Guess', encode('euc-jp', $utf8on)), $utf8on, "decode('Guess')"); +eval{ encode('Guess', $utf8on) }; +like($@, qr/lazy/io, "no encode()"); + +my %CJKT = + ( + 'euc-cn' => File::Spec->catfile(dirname(__FILE__), 'gb2312.utf'), + 'euc-jp' => File::Spec->catfile(dirname(__FILE__), 'jisx0208.utf'), + 'euc-kr' => File::Spec->catfile(dirname(__FILE__), 'ksc5601.utf'), + 'big5-eten' => File::Spec->catfile(dirname(__FILE__), 'big5-eten.utf'), +); + +Encode::Guess->set_suspects(keys %CJKT); + +for my $name (keys %CJKT){ + open my $fh, $CJKT{$name} or die "$CJKT{$name}: $!"; + $utf8off = join('' => <$fh>); + close $fh; + + my $test = encode($name, decode('utf8', $utf8off)); + is(guess_encoding($test)->name, $name, "CJKT:$name"); +} + +__END__; diff --git a/ext/Encode/t/jperl.t b/ext/Encode/t/jperl.t index faaf743f89..82f7a84dd6 100644 --- a/ext/Encode/t/jperl.t +++ b/ext/Encode/t/jperl.t @@ -1,5 +1,5 @@ # -# $Id: jperl.t,v 1.23 2002/04/22 09:48:07 dankogai Exp $ +# $Id: jperl.t,v 1.24 2002/04/26 03:02:04 dankogai Exp $ # # This script is written in euc-jp @@ -20,6 +20,8 @@ BEGIN { $| = 1; } +no utf8; # we have raw Japanese encodings here + use strict; use Test::More tests => 18; my $Debug = shift; diff --git a/ext/Encode/t/mime-header.t b/ext/Encode/t/mime-header.t new file mode 100644 index 0000000000..826efbfddd --- /dev/null +++ b/ext/Encode/t/mime-header.t @@ -0,0 +1,77 @@ +# +# $Id: mime-header.t,v 1.3 2002/04/26 03:07:59 dankogai Exp $ +# This script is written in utf8 +# +BEGIN { + if ($ENV{'PERL_CORE'}){ + chdir 't'; + unshift @INC, '../lib'; + } + require Config; import Config; + if ($Config{'extensions'} !~ /\bEncode\b/) { + print "1..0 # Skip: Encode was not built\n"; + exit 0; + } + $| = 1; +} + +use strict; +#use Test::More qw(no_plan); +use Test::More tests => 6; +use_ok("Encode::MIME::Header"); + +my $eheader =<<'EOS'; +From: =?US-ASCII?Q?Keith_Moore?= <moore@cs.utk.edu> +To: =?ISO-8859-1?Q?Keld_J=F8rn_Simonsen?= <keld@dkuug.dk> +CC: =?ISO-8859-1?Q?Andr=E9?= Pirard <PIRARD@vm1.ulg.ac.be> +Subject: =?ISO-8859-1?B?SWYgeW91IGNhbiByZWFkIHRoaXMgeW8=?= + =?ISO-8859-2?B?dSB1bmRlcnN0YW5kIHRoZSBleGFtcGxlLg==?= +EOS + +my $dheader=<<"EOS"; +From: Keith Moore <moore\@cs.utk.edu> +To: Keld J\xF8rn Simonsen <keld\@dkuug.dk> +CC: Andr\xE9 Pirard <PIRARD\@vm1.ulg.ac.be> +Subject: If you can read this you understand the example. +EOS + +is(Encode::decode('MIME-Header', $eheader), $dheader, "decode (RFC2047)"); + +use utf8; + +$dheader=<<'EOS'; +From: 小飼 弾 <dankogai@dan.co.jp> +To: dankogai@dan.co.jp (小飼=Kogai, 弾=Dan) +Subject: 漢字、カタカナ、ひらがなを含む、非常に長いタイトル行が一体全体どのようにしてEncodeされるのか? +EOS + +my $bheader =<<'EOS'; +From:=?UTF-8?B?IOWwj+mjvCDlvL4g?=<dankogai@dan.co.jp> +To: dankogai@dan.co.jp (=?UTF-8?B?5bCP6aO8?==Kogai,=?UTF-8?B?IOW8vg==?==Dan + ) +Subject: + =?UTF-8?B?IOa8ouWtl+OAgeOCq+OCv+OCq+ODiuOAgeOBsuOCieOBjOOBquOCkuWQq+OCgA==?= + =?UTF-8?B?44CB6Z2e5bi444Gr6ZW344GE44K/44Kk44OI44Or6KGM44GM5LiA5L2T5YWo?= + =?UTF-8?B?5L2T44Gp44Gu44KI44GG44Gr44GX44GmRW5jb2Rl44GV44KM44KL44Gu44GL?= + =?UTF-8?B?77yf?= +EOS + +my $qheader=<<'EOS'; +From:=?UTF-8?Q?=20=E5=B0=8F=E9=A3=BC=20=E5=BC=BE=20?=<dankogai@dan.co.jp> +To: dankogai@dan.co.jp (=?UTF-8?Q?=E5=B0=8F=E9=A3=BC?==Kogai, + =?UTF-8?Q?=20=E5=BC=BE?==Dan) +Subject: + =?UTF-8?Q?=20=E6=BC=A2=E5=AD=97=E3=80=81=E3=82=AB=E3=82=BF=E3=82=AB?= + =?UTF-8?Q?=E3=83=8A=E3=80=81=E3=81=B2=E3=82=89=E3=81=8C=E3=81=AA=E3=82=92?= + =?UTF-8?Q?=E5=90=AB=E3=82=80=E3=80=81=E9=9D=9E=E5=B8=B8=E3=81=AB=E9=95=B7?= + =?UTF-8?Q?=E3=81=84=E3=82=BF=E3=82=A4=E3=83=88=E3=83=AB=E8=A1=8C=E3=81=8C?= + =?UTF-8?Q?=E4=B8=80=E4=BD=93=E5=85=A8=E4=BD=93=E3=81=A9=E3=81=AE=E3=82=88?= + =?UTF-8?Q?=E3=81=86=E3=81=AB=E3=81=97=E3=81=A6Encode=E3=81=95?= + =?UTF-8?Q?=E3=82=8C=E3=82=8B=E3=81=AE=E3=81=8B=EF=BC=9F?= +EOS + +is(Encode::decode('MIME-Header', $bheader), $dheader, "decode B"); +is(Encode::decode('MIME-Header', $qheader), $dheader, "decode Q"); +is(Encode::encode('MIME-B', $dheader)."\n", $bheader, "encode B"); +is(Encode::encode('MIME-Q', $dheader)."\n", $qheader, "encode Q"); +__END__; |