lib/Vend/CharSet.pm

   1 # Vend::CharSet - utility methods for handling character encoding
   2 #
   3 # $Id: CharSet.pm,v 2.11 2009-03-22 19:32:31 mheins Exp $
   4 #
   5 # Copyright (C) 2008 Interchange Development Group
   6 # Copyright (C) 2008 Sonny Cook <sonny@endpoint.com>
   7 #
   8 # This program is free software; you can redistribute it and/or modify
   9 # it under the terms of the GNU General Public License as published by
  10 # the Free Software Foundation; either version 2 of the License, or
  11 # (at your option) any later version.
  12 #
  13 # This program is distributed in the hope that it will be useful,
  14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 # GNU General Public License for more details.
  17 #
  18 # You should have received a copy of the GNU General Public
  19 # License along with this program; if not, write to the Free
  20 # Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston,
  21 # MA  02110-1301  USA.
  22
  23 package Vend::CharSet;
  24
  25 @ISA = qw( Exporter );
  26
  27 @EXPORT_OK = qw(
  28                                 decode_urlencode
  29                                 default_charset
  30                                 to_internal
  31                                 );
  32
  33 use strict;
  34
  35 use utf8; eval "\$\343\201\257 = 42";  # attempt to automatically load the utf8 libraries.
  36 require "utf8_heavy.pl";
  37
  38 unless( $ENV{MINIVEND_DISABLE_UTF8} ) {
  39         require Encode;
  40         import Encode qw( decode is_utf8 find_encoding );
  41 }
  42
  43 sub decode_urlencode {
  44         my ($octets, $encoding) = (@_);
  45
  46 #::logDebug("decode_urlencode--octets: $octets, encoding: $encoding");
  47
  48         $$octets =~ tr/+/ /;
  49         $$octets =~ s/%([0-9a-fA-F][0-9a-fA-F])/chr(hex $1)/ge;
  50
  51         return $octets unless $encoding and $Global::UTF8 and validate_encoding($encoding);
  52
  53         to_internal($encoding, $octets);
  54
  55 #::logDebug("decoded string: " . display_chars($string)) if $string;
  56         return $octets;
  57 }
  58
  59 sub to_internal {
  60         my ($encoding, $octets) = @_;
  61
  62 #::logDebug("to_internal - no encoding specified"),
  63     return $octets unless $encoding;
  64 #::logDebug("to_internal - octets are already UTF-8 flagged"),
  65     return $octets if is_utf8($octets);
  66
  67 #::logDebug("to_internal - converting octets from $encoding to internal");
  68         $$octets = eval {       decode($encoding, $$octets, Encode::FB_CROAK()) };
  69         if ($@) {
  70                 ::logError("Unable to properly decode <%s> with encoding %s: %s", display_chars($octets), $encoding, $@);
  71                 return;
  72         }
  73         return $octets;
  74 }
  75
  76 # returns a true value (the normalized name of the encoding) if the
  77 # specified encoding is recognized by Encode.pm, otherwise return
  78 # nothing.
  79 sub validate_encoding {
  80         my $encoding = shift;
  81         my $enc = find_encoding($encoding);
  82
  83     return unless $enc;
  84         return $enc->can('mime_name') ? $enc->mime_name : mime_name($enc->name);
  85 }
  86
  87 # fallback routine to provide a pretty-style mime_name in versions of
  88 # Encode which predate the actual method.  The main use would be to
  89 # normalize "utf8-strict" to "utf8", but there are other cases where
  90 # this can/will come in handy.
  91 sub mime_name {
  92     my $encoding_name = shift;
  93
  94     $encoding_name =~ s/-strict//i;
  95     return lc $encoding_name;
  96 }
  97
  98 sub default_charset {
  99         my $c = $Global::Selector{$CGI::script_name};
 100         return $c->{Variable}{MV_HTTP_CHARSET} || $Global::Variable->{MV_HTTP_CHARSET};
 101 }
 102
 103 # this sub taken from the perluniintro man page, for diagnostic purposes
 104 sub display_chars {
 105         return unless $_[0];
 106         return join("",
 107                 map {
 108                         $_ > 255 ?                  # if wide character...
 109                         sprintf("\\x{%04X}", $_) :  # \x{...}
 110                         chr($_) =~ /[[:cntrl:]]/ ?  # else if control character ...
 111                         sprintf("\\x%02X", $_) :    # \x..
 112                         quotemeta(chr($_))          # else quoted or as themselves
 113                 } unpack("U*", $_[0]));                 # unpack Unicode characters
 114 }
 115
 116
 117 1;