This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VERSIONize.
[perl5.git] / ext / Encode / lib / Encode / CN / HZ.pm
1 package Encode::CN::HZ;
2
3 use strict;
4 no warnings 'redefine'; # to quell the "use Encode" below
5
6 use vars qw($VERSION);
7 $VERSION = 0.01;
8
9 use Encode::CN;
10 use Encode qw|encode decode|;
11 use base 'Encode::Encoding';
12
13 # HZ is but escaped GB, so we implement it with the
14 # GB2312(raw) encoding here. Cf. RFC 1842 & 1843.
15
16 my $canon = 'hz';
17 my $obj = bless {name => $canon}, __PACKAGE__;
18 $obj->Define($canon);
19
20 sub decode
21 {
22     my ($obj,$str,$chk) = @_;
23     my $gb = Encode::find_encoding('gb2312');
24
25     $str =~ s{~                 # starting tilde
26         (?:
27             (~)                 # another tilde - escaped (set $1)
28                 |               #     or
29             \n                  # \n - output nothing
30                 |               #     or
31             \{                  # opening brace of GB data
32                 (               #  set $2 to any number of...
33                     (?: 
34                         [^~]    #  non-tilde GB character
35                             |   #     or
36                         ~(?!\}) #  tilde not followed by a closing brace
37                     )*
38                 )
39             ~\}                 # closing brace of GB data
40                 |               # XXX: invalid escape - maybe die on $chk?
41         )
42     }{
43         (defined $1)    ? '~'                   # two tildes make one tilde
44             :
45         (defined $2)    ? $gb->decode($2, $chk) # decode the characters
46             :
47         ''                                      # '' on ~\n and invalid escape
48     }egx;
49
50     return $str;
51 }
52
53 sub encode
54 {
55     my ($obj,$str,$chk) = @_;
56     my ($out, $in_gb);
57     my $gb = Encode::find_encoding('gb2312');
58
59     $str =~ s/~/~~/g;
60
61     # XXX: Since CHECK and partial decoding  has not been implemented yet,
62     #      we'll use a very crude way to test for GB2312ness.
63
64     for my $index (0 .. length($str) - 1) {
65         no warnings 'utf8';
66
67         my $char = substr($str, $index, 1);
68         my $try  = $gb->encode($char);  # try encode this char
69
70         if (defined($try)) {            # is a GB character
71             if ($in_gb) {
72                 $out .= $try;           # in GB mode - just append it
73             }
74             else {
75                 $out .= "~{$try";       # enter GB mode, then append it
76                 $in_gb = 1;
77             }
78         }
79         elsif ($in_gb) {
80             $out .= "~}$char";          # leave GB mode, then append it
81             $in_gb = 0;
82         }
83         else {
84             $out .= $char;              # not in GB mode - just append it
85         }
86     }
87
88     $out .= '~}' if $in_gb;             # add closing brace as needed
89
90     return $out;
91 }
92
93 1;
94 __END__