File Coverage

blib/lib/Termbox/PP/WCWidth.pm

Criterion	Covered	Total	%
statement	17	46	36.9
branch	0	26	0.0
condition	0	39	0.0
subroutine	6	9	66.6
pod	2	2	100.0
total	25	122	20.4

# ------------------------------------------------------------------------
#
#   WCWidth - determine columns needed for a wide character
#
#   Code based on Terminal::WCWidth (a Raku port), 2026
#
#   Copyright (c) 2007 Markus Kuhn (Unicode 5.0)
#                 2014 Jeff Quast
#                 2015 bluebear94
#                 2026 Elizabeth Mattijsen
#
# ------------------------------------------------------------------------
#   Author: 2024-2026 J. Schneider
# ------------------------------------------------------------------------

package Termbox::PP::WCWidth;

# ------------------------------------------------------------------------
# Boilerplate ------------------------------------------------------------
# ------------------------------------------------------------------------

use 5.010;
use strict;
use warnings;

# version '...'
use version;
our $version = version->declare('v0.1.5');
our $VERSION = version->declare('v0.4.0');

# authority '...'
our $authority = 'github:raku-community-modules';
our $AUTHORITY = 'github:brickpool';

# ------------------------------------------------------------------------
# Imports ----------------------------------------------------------------
# ------------------------------------------------------------------------

use Termbox::PP::WCWidth::Tables;

# ------------------------------------------------------------------------
# Exports ----------------------------------------------------------------
# ------------------------------------------------------------------------

=head1 EXPORTS

Nothing per default, but can export the following per request:

  :all
    wcwidth
    wcswidth

=cut

use Exporter qw( import );

our @EXPORT_OK = qw(
  wcwidth
  wcswidth
);

our %EXPORT_TAGS = (
  all => \@EXPORT_OK,
);

# ------------------------------------------------------------------------
# Functions --------------------------------------------------------------
# ------------------------------------------------------------------------

# Auxiliary function for binary search in interval table
sub _bisearch {    # $result ($ucs, \@table)
  my ($ucs, $table) = @_;
  my $lower = 0;
  my $upper = scalar(@$table) - 1;
  return 0 if $ucs < $table->[0][0] || $ucs > $table->[$upper][1];
  while ($upper >= $lower) {
    my $mid = ($lower + $upper) >> 1;
    if ($ucs > $table->[$mid][1]) {
      $lower = $mid + 1;
    } elsif ($ucs < $table->[$mid][0]) {
      $upper = $mid - 1;
    } else {
      return 1;
    }
  }
  return 0;
}

my %cache = ();

sub wcwidth {    # $result ($ucs)
  my ($ucs) = @_;

  return -1 unless defined $ucs && !ref $ucs;
  return -1 unless $ucs =~ /\A[0-9]+\z/;

  return -1 if $ucs < 0 || $ucs > 0x10ffff;
  return -1 if $ucs >= 0xD800 && $ucs <= 0xDFFF;

  return $cache{$ucs} if exists $cache{$ucs};

  return ($cache{$ucs} = 0)
    if $ucs == 0
    || $ucs == 0x034f
    || (0x200b <= $ucs && $ucs <= 0x200f)
    || (0x202a <= $ucs && $ucs <= 0x202e)
    || (0x2060 <= $ucs && $ucs <= 0x2063);

  return ($cache{$ucs} = -1)
    if $ucs < 32 || (0x07f <= $ucs && $ucs < 0x0a0);

  return ($cache{$ucs} = 0) if _bisearch($ucs, ZERO_WIDTH);
  return ($cache{$ucs} = 2) if _bisearch($ucs, WIDE_EASTASIAN);

  return ($cache{$ucs} = 1);
}

sub wcswidth {    # $result ($str)
  my ($str) = @_;

  my $res = 0;
  for (split //, $str) {
    my $w = wcwidth(ord $_);
    return -1 if $w < 0;
    $res += $w;
  }
  return $res;
}

1;

__END__