—

              
##---------------------------------------------------------------------------##
##  File:
##      $Id: MhaEncode.pm,v 1.3 2003/03/05 22:17:15 ehood Exp $
##  Author:
##      Earl Hood       earl@earlhood.com
##  Description:
##      POD after __END__.
##---------------------------------------------------------------------------##
##    Copyright (C) 2002        Earl Hood, earl@earlhood.com
##
##    This program is free software; you can redistribute it and/or modify
##    it under the terms of the GNU General Public License as published by
##    the Free Software Foundation; either version 2 of the License, or
##    (at your option) any later version.
##
##    This program is distributed in the hope that it will be useful,
##    but WITHOUT ANY WARRANTY; without even the implied warranty of
##    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
##    GNU General Public License for more details.
##
##    You should have received a copy of the GNU General Public License
##    along with this program; if not, write to the Free Software
##    Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
##    02111-1307, USA
##---------------------------------------------------------------------------##
package MHonArc::UTF8::MhaEncode;
use strict;
use MHonArc::CharMaps;
use MHonArc::Char;
my %CharsetMaps = (
    'iso-8859-1'     =>      'MHonArc/UTF8/ISO8859_1.pm',
    'iso-8859-2'     =>      'MHonArc/UTF8/ISO8859_2.pm',
    'iso-8859-3'     =>      'MHonArc/UTF8/ISO8859_3.pm',
    'iso-8859-4'     =>      'MHonArc/UTF8/ISO8859_4.pm',
    'iso-8859-5'     =>      'MHonArc/UTF8/ISO8859_5.pm',
    'iso-8859-6'     =>      'MHonArc/UTF8/ISO8859_6.pm',
    'iso-8859-7'     =>      'MHonArc/UTF8/ISO8859_7.pm',
    'iso-8859-8'     =>      'MHonArc/UTF8/ISO8859_8.pm',
    'iso-8859-9'     =>      'MHonArc/UTF8/ISO8859_9.pm',
    'iso-8859-10'    =>      'MHonArc/UTF8/ISO8859_10.pm',
    'iso-8859-11'    =>      'MHonArc/UTF8/ISO8859_11.pm',
    'iso-8859-13'    =>      'MHonArc/UTF8/ISO8859_13.pm',
    'iso-8859-14'    =>      'MHonArc/UTF8/ISO8859_14.pm',
    'iso-8859-15'    =>      'MHonArc/UTF8/ISO8859_15.pm',
    'iso-8859-16'    =>      'MHonArc/UTF8/ISO8859_16.pm',
    'cp866'          =>      'MHonArc/UTF8/CP866.pm',
    'cp949'          =>      'MHonArc/UTF8/CP949.pm', # euc-kr
    'cp932'          =>      'MHonArc/UTF8/CP932.pm', # shiftjis
    'cp936'          =>      'MHonArc/UTF8/CP936.pm', # GBK
    'cp950'          =>      'MHonArc/UTF8/CP950.pm',
    'cp1250'         =>      'MHonArc/UTF8/CP1250.pm',
    'cp1251'         =>      'MHonArc/UTF8/CP1251.pm',
    'cp1252'         =>      'MHonArc/UTF8/CP1252.pm',
    'cp1253'         =>      'MHonArc/UTF8/CP1253.pm',
    'cp1254'         =>      'MHonArc/UTF8/CP1254.pm',
    'cp1255'         =>      'MHonArc/UTF8/CP1255.pm',
    'cp1256'         =>      'MHonArc/UTF8/CP1256.pm',
    'cp1257'         =>      'MHonArc/UTF8/CP1257.pm',
    'cp1258'         =>      'MHonArc/UTF8/CP1258.pm',
    'koi-0'          =>      'MHonArc/UTF8/KOI_0.pm',
    'koi-7'          =>      'MHonArc/UTF8/KOI_7.pm',
    'koi8-a'         =>      'MHonArc/UTF8/KOI8_A.pm',
    'koi8-b'         =>      'MHonArc/UTF8/KOI8_B.pm',
    'koi8-e'         =>      'MHonArc/UTF8/KOI8_E.pm',
    'koi8-f'         =>      'MHonArc/UTF8/KOI8_F.pm',
    'koi8-r'         =>      'MHonArc/UTF8/KOI8_R.pm',
    'koi8-u'         =>      'MHonArc/UTF8/KOI8_U.pm',
    'gost19768-87'   =>      'MHonArc/UTF8/GOST19768_87.pm',
    'viscii'         =>      'MHonArc/UTF8/VISCII.pm',
    'macarabic'      =>      'MHonArc/UTF8/AppleArabic.pm',
    'maccentraleurroman' => 'MHonArc/UTF8/AppleCenteuro.pm',
    'maccroatian'    =>      'MHonArc/UTF8/AppleCroatian.pm',
    'maccyrillic'    =>      'MHonArc/UTF8/AppleCyrillic.pm',
    'macgreek'       =>      'MHonArc/UTF8/AppleGreek.pm',
    'machebrew'      =>      'MHonArc/UTF8/AppleHebrew.pm',
    'macicelandic'   =>      'MHonArc/UTF8/AppleIceland.pm',
    'macromanian'    =>      'MHonArc/UTF8/AppleRomanian.pm',
    'macroman'       =>      'MHonArc/UTF8/AppleRoman.pm',
    'macthai'        =>      'MHonArc/UTF8/AppleThai.pm',
    'macturkish'     =>      'MHonArc/UTF8/AppleTurkish.pm',
    'big5-eten'      =>      'MHonArc/UTF8/BIG5_ETEN.pm',
    'big5-hkscs'     =>      'MHonArc/UTF8/BIG5_HKSCS.pm',
    'gb2312'         =>      'MHonArc/UTF8/GB2312.pm',
    'euc-jp'         =>      'MHonArc/UTF8/EUC_JP.pm',
    'hp-roman8'      =>      'MHonArc/UTF8/HP_ROMAN8.pm',
);
my $char_maps = MHonArc::CharMaps->new(\%CharsetMaps);
##---------------------------------------------------------------------------##
# We do not care for valid sequences, just that we catch everything
my $utf8_re = q/[\x00-\x7F]|
                [\xC0-\xDF][\x00-\xFF]|
                [\xE0-\xEF][\x00-\xFF]{2}|
                [\xF0-\xF7][\x00-\xFF]{3}|
                [\xF8-\xFB][\x00-\xFF]{4}|
                [\xFC\xFD][\x00-\xFF]{5}|
                [\x80-\xFF]/;
# Return the length of an utf-8 string
sub utf8_length {
    my $n = 0;
    while ($_[0] =~ m/($utf8_re)/gox) { ++$n; };
    $n;
}
##---------------------------------------------------------------------------##
## Version of TEXTCLIPFUNC for utf8 strings for versions of Perl without
## decent utf8 support (Perl <= 5.6.x).
sub clip {
    my $str      = shift;   # Unfortunately, it is much easier to make a copy
    my $len      = shift;   # Clip length
    my $is_html  = shift;   # If entity references should be considered
    my $has_tags = shift;   # If html tags should be stripped
    # If not HTML text, things are alot easier
    if (!$is_html) {
        # do nothing if we know for sure there is nothing to do
        return $str
            if length($str) <= $len;
        # Get $len utf8 chars
        $str =~ m/^((?:$utf8_re){1,$len})/x;
        return $1;
    }
    $str =~ s/<[^>]*>//g  if $has_tags;
    return $str  if length($str) <= $len; # nothing to do
    my($utf8_len, $er_len);
    my $text = "";
    my $subtext = "";
    my $sub_len = $len;
    my $real_len = 0;
     
    while ($str ne '') {
        if (!($str =~ s/^((?:$utf8_re){1,$sub_len})//x)) {
            # pattern should always match, but just in-case...
            warn qq/Warning: MHonArc::UTF8::MhaEncode::clip:/,
                         qq/ Internal error/;
            return $text . $str;
        }
        $subtext = $1;
        # check for clipped entity reference
        if (($str ne '') && ($subtext =~ /\&[^;]*\Z/)) {
            if ($str =~ s/^([^;]*;)//) {
                $subtext .= $1;
            } else {
                warn qq/Warning: MHonArc::UTF8::MhaEncode::clip: malformed/,
                             qq/ entity reference detected\n/;
                $subtext .= $str;
                $str = '';
            }
        }
        # compute entity reference lengths to determine "real" character
        # count and not raw character count.
        $er_len = 0;
        while ($subtext =~ /(\&[^;]+);/g) {
            $er_len += length($1);
        }
        # done if we have enough
        $utf8_len  = utf8_length($subtext);
        $real_len += $utf8_len - $er_len;
        $text     .= $subtext;
        last       if ($real_len >= $len);
        $sub_len   = $len - $real_len;
    }
    $text;
}
sub to_utf8 {
    my $data    = shift;
    my $charset = lc shift;
    my $data_r  = ref($data) ? $data : \$data;
    return $$data_r  if ($charset eq 'us-ascii' ||
                         $charset eq 'utf-8' ||
                         $charset eq 'utf8');
    MHonArc::Char::map_conv($data_r, $charset, $char_maps);
}
sub str2sgml {
    my $data    = shift;
    my $charset = lc shift;
    my $data_r  = ref($data) ? $data : \$data;
    if ($charset eq 'us-ascii') {
        if ($$data_r =~ /[\x80-\xFF]/) {
            $charset = 'iso-8859-1';
        } else {
            $$data_r =~ s/([$HTMLSpecials])/$HTMLSpecials{$1}/go;
            return $$data_r;
        }
    }
    if ($charset eq 'utf-8' || $charset eq 'utf8') {
        $$data_r =~ s/([$HTMLSpecials])/$HTMLSpecials{$1}/go;
        return $$data_r;
    }
    MHonArc::Char::map_conv($data_r, $charset, $char_maps);
    $$data_r =~ s/([$HTMLSpecials])/$HTMLSpecials{$1}/go;
    $$data_r;
}
##---------------------------------------------------------------------------##
1;
__END__
HideShow 66 lines of Pod
=head1 NAME
MHonArc::UTF8::MhaEncode - UTF-8 based routines for MHonArc
=head1 SYNOPSIS
  use MHonArc::UTF8::MhaEncode;
=head1 DESCRIPTION
MHonArc::UTF8::MhaEncode provides UTF-8 related routines for use in MHonArc.
Implementation of routines are designed to work with non-Unicode aware versions
of Perl 5.
This module is generally not accessed directly since it is used by
MHonArc::UTF8 when determining what encoding routines it can use based
on your perl installation.  However, the following shows you how to use
it directly:
  <CharsetConverters override>
  plain;   mhonarc::htmlize;
  default; MHonArc::UTF8::MhaEncode::str2sgml; MHonArc/UTF8/MhaEncode.pm
  </CharsetConverters>
  <TextClipFunc>
  MHonArc::UTF8::MhaEncode::clip; MHonArc/UTF8/MhaEncode.pm
  </TextClipFunc>
=head1 FUNCTIONS
=over
=item C<to_utf8($data, $from_charset, $to_charset)>
Converts C<$data> encoded in C<$from_charset> into UTF-8.
C<$to_charset> is ignored since it assumed to be C<utf-8>.
=item C<str2sgml($data, $charset)>
All data passed in is converted to utf-8 with HTML specials
converted into entity references.
=item C<clip($text, $clip_len, $is_html, $has_tags)>
Clip C<$text> to C<$clip_len> number of characters.
=back
=head1 SEE ALSO
L<MHonArc::UTF8|MHonArc::UTF8>
=head1 VERSION
C<$Id: MhaEncode.pm,v 1.3 2003/03/05 22:17:15 ehood Exp $>
=head1 AUTHOR
Earl Hood, earl@earlhood.com
MHonArc comes with ABSOLUTELY NO WARRANTY and MHonArc may be copied only
under the terms of the GNU General Public License, which may be found in
the MHonArc distribution.
=cut