Parent Directory
| 
Revision Log
2002-09-15 Wakaba <w@suika.fam.cx> * ISO2022.pm: New module.
| 1 | wakaba | 1.1 | package Encode::HZ; |
| 2 | use strict; | ||
| 3 | |||
| 4 | use vars qw($VERSION); | ||
| 5 | wakaba | 1.2 | $VERSION = do {my @r =(q$Revision: 1.1 $ =~ /\d+/g);sprintf "%d."."%02d" x $#r, @r}; |
| 6 | wakaba | 1.1 | |
| 7 | use Encode (); | ||
| 8 | require Encode::CN; | ||
| 9 | use base qw(Encode::Encoding); | ||
| 10 | __PACKAGE__->Define(qw/hz hz-gb-2312/); | ||
| 11 | |||
| 12 | sub needs_lines { 1 } | ||
| 13 | |||
| 14 | sub perlio_ok { | ||
| 15 | return 0; # for the time being | ||
| 16 | } | ||
| 17 | |||
| 18 | sub decode | ||
| 19 | { | ||
| 20 | my ($obj,$str,$chk) = @_; | ||
| 21 | my $gb = Encode::find_encoding('gb2312-raw'); | ||
| 22 | |||
| 23 | $str =~ s{~ # starting tilde | ||
| 24 | (?: | ||
| 25 | (~) # another tilde - escaped (set $1) | ||
| 26 | | # or | ||
| 27 | \x0D?\x0A # \n - output nothing | ||
| 28 | | # or | ||
| 29 | \{ # opening brace of GB data | ||
| 30 | ( # set $2 to any number of... | ||
| 31 | (?: | ||
| 32 | [^~] # non-tilde GB character | ||
| 33 | | # or | ||
| 34 | ~(?!\}) # tilde not followed by a closing brace | ||
| 35 | )* | ||
| 36 | ) | ||
| 37 | ~\} # closing brace of GB data | ||
| 38 | | # XXX: invalid escape - maybe die on $chk? | ||
| 39 | ) | ||
| 40 | }{ | ||
| 41 | my ($t, $c) = ($1, $2); | ||
| 42 | if (defined $t) { # two tildes make one tilde | ||
| 43 | '~'; | ||
| 44 | } elsif (defined $c) { # decode the characters | ||
| 45 | $c =~ tr/\xA1-\xFE/\x21-\x7E/; | ||
| 46 | $gb->decode($c, $chk); | ||
| 47 | } else { # ~\n and invalid escape = '' | ||
| 48 | ''; | ||
| 49 | } | ||
| 50 | }egx; | ||
| 51 | |||
| 52 | return $str; | ||
| 53 | } | ||
| 54 | |||
| 55 | sub encode ($$;$) { | ||
| 56 | my ($obj,$str,$chk) = @_; | ||
| 57 | $_[1] = ''; | ||
| 58 | my $gb = Encode::find_encoding('euc-cn'); | ||
| 59 | |||
| 60 | $str =~ s/~/~~/g; | ||
| 61 | $str = $gb->encode ($str, 1); | ||
| 62 | |||
| 63 | $str =~ s{ ((?:[\xA1-\xFE][\xA1-\xFE])+) }{ | ||
| 64 | my $c = $1; | ||
| 65 | $c =~ tr/\xA1-\xFE/\x21-\x7E/; | ||
| 66 | sprintf q(~{%s~}), $c; | ||
| 67 | }goex; | ||
| 68 | $str; | ||
| 69 | } | ||
| 70 | |||
| 71 | package Encode::HZ::HZ8; | ||
| 72 | |||
| 73 | use base qw(Encode::HZ); | ||
| 74 | wakaba | 1.2 | __PACKAGE__->Define(qw/hz8 x-hz8/); |
| 75 | wakaba | 1.1 | |
| 76 | sub encode ($$;$) { | ||
| 77 | my ($obj,$str,$chk) = @_; | ||
| 78 | $_[1] = ''; | ||
| 79 | my $gb = Encode::find_encoding('euc-cn'); | ||
| 80 | |||
| 81 | $str =~ s/~/~~/g; | ||
| 82 | $str = $gb->encode ($str, 1); | ||
| 83 | |||
| 84 | $str =~ s{ ((?:[\xA1-\xFE][\xA1-\xFE])+) }{ | ||
| 85 | sprintf q(~{%s~}), $1; | ||
| 86 | }goex; | ||
| 87 | $str; | ||
| 88 | } | ||
| 89 | |||
| 90 | 1; | ||
| 91 | __END__ | ||
| 92 | |||
| 93 | |||
| 94 | =head1 NAME | ||
| 95 |