lib/Encode/HZ.pm

package Encode::HZ;
use strict;

use vars qw($VERSION);
$VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };

use Encode ();
require Encode::CN;
use base qw(Encode::Encoding);
__PACKAGE__->Define(qw/hz hz-gb-2312/);

sub needs_lines  { 1 }

sub perlio_ok { 
    return 0; # for the time being
}

sub decode
{
    my ($obj,$str,$chk) = @_;
    my $gb = Encode::find_encoding('gb2312-raw');

    $str =~ s{~                 # starting tilde
        (?:
            (~)                 # another tilde - escaped (set $1)
                |               #     or
            \x0D?\x0A                   # \n - output nothing
                |               #     or
            \{                  # opening brace of GB data
                (               #  set $2 to any number of...
                    (?: 
                        [^~]    #  non-tilde GB character
                            |   #     or
                        ~(?!\}) #  tilde not followed by a closing brace
                    )*
                )
            ~\}                 # closing brace of GB data
                |               # XXX: invalid escape - maybe die on $chk?
        )
    }{
      my ($t, $c) = ($1, $2);
      if (defined $t) { # two tildes make one tilde
        '~';
      } elsif (defined $c) {    # decode the characters
        $c =~ tr/\xA1-\xFE/\x21-\x7E/;
        $gb->decode($c, $chk);
      } else {  # ~\n and invalid escape = ''
        '';
      }
    }egx;
    
    return $str;
}

sub encode ($$;$) {
  my ($obj,$str,$chk) = @_;
  $_[1] = '';
  my $gb = Encode::find_encoding('euc-cn');
  
  $str =~ s/~/~~/g;
  $str = $gb->encode ($str, 1);
  
  $str =~ s{ ((?:[\xA1-\xFE][\xA1-\xFE])+) }{
    my $c = $1;
    $c =~ tr/\xA1-\xFE/\x21-\x7E/;
    sprintf q(~{%s~}), $c;
  }goex;
  $str;
}

package Encode::HZ::HZ8;

use base qw(Encode::HZ);
__PACKAGE__->Define(qw/hz8/);

sub encode ($$;$) {
  my ($obj,$str,$chk) = @_;
  $_[1] = '';
  my $gb = Encode::find_encoding('euc-cn');
  
  $str =~ s/~/~~/g;
  $str = $gb->encode ($str, 1);
  
  $str =~ s{ ((?:[\xA1-\xFE][\xA1-\xFE])+) }{
    sprintf q(~{%s~}), $1;
  }goex;
  $str;
}

1;
__END__


=head1 NAME

Encode::HZ --- Encode module for HZ (HZ-GB-2312), HZ8

=head1 DESCRIPTION

This module make the module Encode of Perl (5.7.3 or later)
to be able to encode/decode HZ and its variant coding systems.

Note that Encode::CN::HZ, standard module of Perl, can encode/decode
HZ (HZ-GB-2312 in IANA name), but other variants such as
HZ8 can't be encoded/decode.

=head1 ACKNOWLEDGEMENTS

Most part of this module is taken from Encode::CN::HZ.

=head1 COPYRIGHT

Copyright 2002 Wakaba <w@suika.fam.cx>

This library is free software; you can redistribute it
and/or modify it under the same terms as Perl itself.

=cut
1	wakaba	1.1	package Encode::HZ;
2			use strict;
3
4			use vars qw($VERSION);
5			$VERSION = do { my @r = (q$Revision: 1.4 $ =~ /\d+/g); sprintf "%d."."%02d" x $#r, @r };
6
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			__PACKAGE__->Define(qw/hz8/);
75
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
96			Encode::HZ --- Encode module for HZ (HZ-GB-2312), HZ8
97
98			=head1 DESCRIPTION
99
100			This module make the module Encode of Perl (5.7.3 or later)
101			to be able to encode/decode HZ and its variant coding systems.
102
103			Note that Encode::CN::HZ, standard module of Perl, can encode/decode
104			HZ (HZ-GB-2312 in IANA name), but other variants such as
105			HZ8 can't be encoded/decode.
106
107			=head1 ACKNOWLEDGEMENTS
108
109			Most part of this module is taken from Encode::CN::HZ.
110
111			=head1 COPYRIGHT
112
113			Copyright 2002 Wakaba <w@suika.fam.cx>
114
115			This library is free software; you can redistribute it
116			and/or modify it under the same terms as Perl itself.
117
118			=cut