File Coverage

blib/lib/Encoding/HandleUtf8.pm

Criterion	Covered	Total	%
statement	60	64	93.7
branch	24	32	75.0
condition	10	17	58.8
subroutine	12	13	92.3
pod	2	2	100.0
total	108	128	84.3

package Encoding::HandleUtf8;
# ABSTRACT: Fix the encoding for Perl value store (input) and general output (output) to a console or the web.
#
# This file is part of Encoding-HandleUtf8
#
# This software is Copyright (c) 2014 by BURNERSK .
#
# This is free software, licensed under:
#
#   The MIT (X11) License
#
use strict;
use warnings FATAL => 'all';

BEGIN {
  our $VERSION = '0.004'; # VERSION: generated by Dist::Zilla
}

use Carp qw( carp croak );
use Encoding::FixLatin qw( fix_latin );
use Clone 'clone';
use List::Util qw( first );

############################################################################
# Prototype definition - required for the recursion, otherwise it will not
# find itself because it is not already in the internal symbol list.

sub fix_encoding ($\[$@%];$);
sub fix_encoding_return ($$;$);

############################################################################
# Setup exporter.

our @EXPORT_OK;
our @IGNORE_LIST;

BEGIN {
  use base 'Exporter';
  @EXPORT_OK = qw( &fix_encoding &fix_encoding_return );
  @IGNORE_LIST = qw( Cpanel::JSON::XS::Boolean JSON::XS::Boolean JSON::PP::Boolean JSON::Boolean )
    unless scalar @IGNORE_LIST;
}

############################################################################
# Utility function to fix the encoding for Perl value store (input) and
# general output (output) to a console or the web.
# Second parameter is the object indended which should be fixed. Due to
# prototypes it automatically turns into an reference.
sub fix_encoding ($\[$@%];$) {
  my ( $direction, $obj, $skip_latin ) = @_;

  my $ref = ref $obj;
  my $obj_ref = $ref eq 'REF' ? ref ${$obj} : $ref;

  # Check encoding direction.
  croak sprintf q{invalid direction '%s' (input or output)}, $direction
    if !$direction || ( $direction ne 'input' && $direction ne 'output' );

  # If $obj is just a string everything is very basic.
  if ( $ref eq 'SCALAR' ) {

    # Fix possible mixed encodings.
    ${$obj} = fix_latin ${$obj} unless $skip_latin;

    # Final encoding it to UTF-8 (output) or Unicode (input).
    if ( $direction eq 'output' ) {
      utf8::encode ${$obj} if defined ${$obj} && utf8::is_utf8 ${$obj};
    }
    else {
      utf8::decode ${$obj} if defined ${$obj} && !utf8::is_utf8 ${$obj};
    }
  }

  # Iterate over an array reference.
  elsif ( $ref eq 'ARRAY' ) {
    fix_encoding $direction, $_ for ( @{$obj} );
  }

  # Iterate over the keys of a hash reference.
  elsif ( $ref eq 'HASH' ) {
    fix_encoding $direction, $obj->{$_} for ( keys %{$obj} );
  }

  # Otherwise if $obj is a reference we have to use some recursive magic.
  elsif ( $ref eq 'REF' ) {

    # Iterate over an array reference.
    if ( $obj_ref eq 'ARRAY' ) {
      fix_encoding $direction, $_ for ( @{ ${$obj} } );
    }

    # Iterate over the keys of a hash reference.
    elsif ( $obj_ref eq 'HASH' ) {
      fix_encoding $direction, ${$obj}->{$_} for ( keys %{ ${$obj} } );
    }

    # Everything else is not supported.
    else {
      carp sprintf q{unsupported reference '%s'}, $obj_ref
        unless first { $_ eq $obj_ref } @IGNORE_LIST;
    }

  }

  # w00t - this shouldn't ever happen!
  else {
    carp sprintf q{unknown object reference '%s'}, $ref
      unless first { $_ eq $ref } @IGNORE_LIST;
  }

  return $ref eq 'REF' || $ref eq 'SCALAR' ? ${$obj} : $obj;
}


############################################################################
# Does the same like fix_encoding but do not touches original reference.
sub fix_encoding_return ($$;$) {
  my ( $direction, $obj, $skip_latin ) = @_;
  my $obj_cloned = clone $obj;
  fix_encoding $direction, $obj_cloned, $skip_latin // 0;
  return $obj_cloned;
}



############################################################################
1;
############################################################################

__END__