Test::utf8 - handy utf8 tests

  is_valid_string($string);   # check the string is valid
  is_sane_utf8($string);      # check not double encoded
  is_flagged_utf8($string);   # has utf8 flag set
  is_within_latin_1($string); # but only has latin_1 chars in it

  Copyright Mark Fowler 2004.  All rights reserved.

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

package Test::utf8;

use 5.007003;

use strict;
use warnings;

use Encode;
use charnames ':full';

use vars qw(@ISA @EXPORT $VERSION %allowed $valid_utf8_regexp);
$VERSION = "0.02";

require Exporter;
@ISA = qw(Exporter);
@EXPORT = qw(is_valid_string is_dodgy_utf8 is_sane_utf8
	      is_within_ascii is_within_latin1 is_within_latin_1
              is_flagged_utf8 isnt_flagged_utf8);

# A Regexp string to match valid UTF8 bytes
# this info comes from page 78 of "The Unicode Standard 4.0"
# published by the Unicode Consortium
$valid_utf8_regexp = <<'.' ;
        [\x{00}-\x{7f}]
      | [\x{c2}-\x{df}][\x{80}-\x{bf}]
      |         \x{e0} [\x{a0}-\x{bf}][\x{80}-\x{bf}]
      | [\x{e1}-\x{ec}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{ed} [\x{80}-\x{9f}][\x{80}-\x{bf}]
      | [\x{ee}-\x{ef}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{f0} [\x{90}-\x{bf}][\x{80}-\x{bf}]
      | [\x{f1}-\x{f3}][\x{80}-\x{bf}][\x{80}-\x{bf}][\x{80}-\x{bf}]
      |         \x{f4} [\x{80}-\x{8f}][\x{80}-\x{bf}][\x{80}-\x{bf}]
.

sub is_valid_string($;$)
{
  my $string = shift;
  my $name = shift || "valid string test";

  # check we're a utf8 string - if not, we pass.
  unless (Encode::is_utf8($string))
    { return pass($name) }

  # work out at what byte (if any) we have an invalid byte sequence
  # and return the correct test result
  my $pos = _invalid_sequence_at_byte($string);
  ok(!defined($pos), $name)
    or diag("malformed byte sequence starting at byte $pos");
}

sub _invalid_sequence_at_byte($)
{
  my $string = shift;

  # examine the bytes that make up the string (not the chars)
  # by turning off the utf8 flag (no, use bytes doens't
  # work, we're dealing with a regexp)
  Encode::_utf8_off($string);

  # work out the index of the first non matching byte
  my $result = $string =~ m/^($valid_utf8_regexp)*/ogx;

  # if we matched all the string return the empty list
  my $pos = pos $string || 0;
  return if $pos == length($string);

  # otherwise return the position we found
  return $pos
}

# build my regular expression out of the latin-1 bytes
# NOTE: This won't work if our locale is nonstandard will it?
my $re_bit = join "|", map { Encode::encode("utf8",chr($_)) } (127..255);

#binmode STDERR, ":utf8";
#print STDERR $re_bit;

sub is_sane_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "sane utf8";

  # regexp in scalar context with 'g', meaning this loop will run for
  # each match.  Should only have to run it once, but will redo if
  # the failing case turns out to be allowed in %allowed.
  while ($string =~ /($re_bit)/o)
  {
    # work out what the double encoded string was
    my $bytes = $1;

    my $index = $+[0] - length($bytes);
    my $codes = join '', map { sprintf '<%00x>', ord($_) } split //, $bytes;

    # what charecter does that represent?
    my $char = Encode::decode("utf8",$bytes);
    my $ord  = ord($char);
    my $hex  = sprintf '%00x', $ord;
    $char = charnames::viacode($ord);

    # print out diagnostic messages
    fail($name);
    diag(qq{Found dodgy chars "$codes" at char $index\n});
    if (Encode::is_utf8($string))
      { diag("Chars in utf8 string look like utf8 byte sequence.") }
    else
      { diag("String not flagged as utf8...was it meant to be?\n") }
    diag("Probably originally a $char char - codepoint $ord (dec), $hex (hex)\n");

    return 0;
  }

  # got this far, must have passed.
  ok(1,$name);
  return 1;
}

# historic name of method; deprecated
sub is_dodgy_utf8
{
  # report errors not here but further up the calling stack
  local $Test::Builder::Level = $Test::Builder::Level + 1;

  # call without prototype with all args
  &is_sane_utf8(@_);
}

sub is_within_ascii($;$)
{
  my $string = shift;
  my $name   = shift || "within ascii";

  # look for anything that isn't ascii or pass
  $string =~ /([^\x{00}-\x{7f}])/ or return pass($name);

  # explain why we failed
  my $dec = ord($1);
  my $hex = sprintf '%02x', $dec;

  fail($name);
  diag("Char $+[0] not ASCII (it's $dec dec / $hex hex)");

  return 0;
}

sub is_within_latin_1($;$)
{
  my $string = shift;
  my $name   = shift || "within latin-1";

  # look for anything that isn't ascii or pass
  $string =~ /([^\x{00}-\x{ff}])/ or return pass($name);

  # explain why we failed
  my $dec = ord($1);
  my $hex = sprintf '%x', $dec;

  fail($name);
  diag("Char $+[0] not Latin-1 (it's $dec dec / $hex hex)");

  return 0;
}

sub is_within_latin1
{
  # report errors not here but further up the calling stack
  local $Test::Builder::Level = $Test::Builder::Level + 1;

  # call without prototype with all args
  &is_within_latin_1(@_);
}

sub is_flagged_utf8
{
  my $string = shift;
  my $name = shift || "flagged as utf8";
  return ok(Encode::is_utf8($string),$name);
}

sub isnt_flagged_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "not flagged as utf8";
  return ok(!Encode::is_utf8($string), $name);
}

sub isn::t_flagged_utf8($;$)
{
  my $string = shift;
  my $name   = shift || "not flagged as utf8";
  return ok(!Encode::is_utf8($string), $name);
}

##########

# shortcuts for Test::Builder.

use Test::Builder;
my $Tester = Test::Builder->new();

sub ok
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  $Tester->ok(@_)
}
sub diag
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
   $Tester->diag(@_)
}

sub fail
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  ok(0,@_)
}

sub pass
{
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  ok(1,@_)
}


1;