package Prima::Bidi;
use strict;
use warnings;
use base 'Exporter';
our $available;
our $enabled = 0;
our $failure_text;
our $default_direction_rtl = 0;
our @methods = qw(
paragraph
map
revmap
visual
selection_map
selection_diff
selection_walk
selection_chunks
edit_insert
edit_delete
map_find
);
our @EXPORT_OK = ( qw(
is_bidi
), map { "bidi_$_" } @methods);
{ local $_; eval "sub bidi_$_ { shift; goto &$_ }" for @methods; }
enabled(1);
sub import
{
my $package = shift;
my @other;
for my $p ( @_ ) {
if ( $p eq ':require' ) {
my $error = enabled(1);
die $error if $error;
} elsif ( $p eq ':rtl') {
$default_direction_rtl = 1;
} elsif ( $p eq ':ltr') {
$default_direction_rtl = 0;
} elsif ( $p eq ':locale') {
# http://stackoverflow.com/questions/18996183/identifyng-rtl-language-in-android
$default_direction_rtl = ( $ENV{LANG} =~ /^(
ar| # arabic
dv| # divehi
fa| # persian (farsi)
ha| # hausa
he| # hebrew
iw| # hebrew (old code)
ji| # yiddish (old code)
ps| # pashto, pushto
ur| # urdu
yi # yiddish
)/x ? 1 : 0)
if defined $ENV{LANG};
} elsif ( $p eq ':methods') {
$package->export_to_level(1, __PACKAGE__, qw(is_bidi), map { "bidi_$_" } @methods);
} else {
push @other, $p;
}
}
if ( @other ) {
@_ = ($package, @other);
goto &Exporter::import;
}
}
sub enabled
{
return $enabled unless @_;
return $enabled = 0 unless $_[0];
unless ( defined $available ) {
eval "use Text::Bidi::Paragraph; use Text::Bidi::Constants;";
if ( $@ ) {
$failure_text = "Bi-directional text services not available: $@\n";
$available = $enabled = 0;
return $failure_text;
}
$available = 1;
}
return ( $enabled = $available ) ? undef : $failure_text;
}
sub visual { scalar paragraph(@_) }
sub paragraph
{
my ( $text, $rtl, $flags ) = @_;
my $p = Text::Bidi::Paragraph->new( $text,
defined($rtl) ? (
dir => $rtl ? $Text::Bidi::Par::RTL : $Text::Bidi::Par::LTR
) : ()
);
my $off = 0;
my $width = $p->len;
my @text;
while ( $off < $width ) {
my $v = $p->visual($off, $width, $flags);
my $l = length($v);
$off += $l;
push @text, $v;
}
return ($p, join("\n", @text));
}
sub map_find
{
my ($map, $index) = @_;
for ( my $i = 0; $i < @$map; $i++) {
return $i if $map->[$i] == $index;
}
return undef;
}
sub _par
{
my ( $text, @opt ) = @_;
my $p = Text::Bidi::Paragraph->new( $text, @opt );
my $off = 0;
my $width = $p->len;
while ( $off < $width ) {
my $v = $p->visual($off, $width);
my $l = length($v);
$off += $l;
}
return $p;
}
sub map { _par(@_)->map }
sub revmap
{
my $map = shift;
return $map unless ref $map;
my @newmap = (0) x @$map;
for (my $i = 0; $i < @$map; $i++) { $newmap[ $map->[$i] ] = $i }
return \@newmap;
}
sub selection_map
{
my $text = shift;
return is_bidi($text) ? _par($text)->map : length($text);
}
sub selection_chunks
{
my ( $map, $start, $end, $offset ) = @_;
$offset //= 0;
my @selection_map;
return [0] if $start > $end || $offset > $end;
unless ( ref $map ) {
for ( my $i = $offset; $i < $map; $i++) {
push @selection_map, ( $i >= $start && $i <= $end ) ? 1 : 0;
}
return _map2chunks( \@selection_map );
}
return [0] if $offset > @$map;
$start = 0 if $start < 0;
$end = 0 if $end < 0;
$start = $#$map if $start > $#$map;
$end = $#$map if $end > $#$map;
my ($text_start, $text_end) = @$map[$start, $end];
($text_start, $text_end) = ($text_end, $text_start) if $text_start > $text_end;
for ( my $i = $offset; $i < @$map; $i++) {
push @selection_map, ($map->[$i] >= $text_start && $map->[$i] <= $text_end) ? 1 : 0;
}
# warn "$start:$end > $text_start:$text_end > @selection_map\n";
return _map2chunks( \@selection_map );
}
sub _map2chunks
{
my $selection_map = shift;
my @chunks;
push @chunks, 0 if $selection_map->[0];
my $last_selected = -1;
for my $selected ( @$selection_map ) {
if ( $selected == $last_selected ) {
$chunks[-1]++;
} else {
push @chunks, 1;
$last_selected = $selected;
}
}
return \@chunks;
}
sub _chunks2map
{
my @map;
selection_walk( shift, 0, undef, sub {
my ( $offset, $length, $selected ) = @_;
push @map, ($selected) x $length;
});
return \@map;
}
sub selection_diff
{
my ( $old, $new) = map { _chunks2map($_) } @_;
my @diff;
my $max = ( @$old > @$new ) ? @$old : @$new;
for ( my $i = 0; $i < $max; $i++) {
$diff[$i] = (($old->[$i] // 0) == ($new->[$i] // 0) ) ? 0 : 1 ;
}
return _map2chunks( \@diff );
}
sub selection_walk
{
my ( $selection_chunks, $from, $to, $sub ) = @_;
my ( $ptr, $selected ) = (0,1);
for my $chunk ( @$selection_chunks ) {
$selected = not $selected;
my $offset = $ptr - $from;
$ptr += $chunk;
my $length = $chunk;
if ( $offset < 0 ) {
$length += $offset;
$offset = 0;
}
if ( defined $to ) {
last if $offset >= $to;
$length = $from - $offset if $offset + $length > $to;
}
next if $length <= 0;
$sub->( $offset, $length, $selected );
}
}
sub is_bidi { $enabled && $_[-1] =~ /[\p{bc=R}\p{bc=AL}\p{bc=AN}\p{bc=RLE}\p{bc=RLO}]/ }
sub is_strong($) { $_[0] & $Text::Bidi::Mask::STRONG }
sub is_weak($) { !($_[0] & $Text::Bidi::Mask::STRONG) }
sub is_rtl($) { $_[0] & $Text::Bidi::Mask::RTL }
sub is_ltr($) { !($_[0] & $Text::Bidi::Mask::RTL) }
sub edit_insert
{
my ( $src_p, $visual_pos, $new_str ) = @_;
return $visual_pos, 0 unless length $new_str;
unless ($src_p) {
# empty string or non-bidi
my $rtl = $enabled && is_bidi($new_str);
return $visual_pos, $rtl ? 0 : length($new_str);
}
my $new_p = _par($new_str);
my $map = $src_p->map;
my $t = $src_p->types;
my $new_map = $new_p->map;
my $new_types = $new_p->types;
my $new_type = 0;
my $limit = $#$map;
my ($tl,$tr,$pl,$pr);
if ( $visual_pos > 0 ) {
$tl = $t->[$pl = $map->[$visual_pos - 1]];
}
if ( $visual_pos <= $limit ) {
$tr = $t->[$pr = $map->[$visual_pos]];
}
# Cursor between two strongs
if ( defined($tl) && defined($tr) && is_strong $tl && is_strong $tr ) {
if ( is_ltr $tl ) {
if ( is_ltr $tr ) {
# normal LTR
return $pl + 1, 1;
} else {
# Cursor between R and L - the rightmost wins
return ( $pl > $pr ) ?
($pl + 1, 1) :
($pr + 1, 0);
}
} else {
if ( is_rtl $tr) {
# normal RTL
return $pr + 1, 0;
} else {
# Cursor between L and R - the leftmost wins
return ( $pl < $pr ) ?
($pl + 1, 1) :
($pr + 1, 0);
}
}
}
# Cursor next to a strong
if ( defined($tl) && is_strong $tl) {
return (is_ltr $tl) ?
# LTR append
( $pl + 1, 1 ) :
# RTL prepend
( $pl, 0 );
}
if ( defined($tr) && is_strong $tr) {
return (is_ltr $tr) ?
# LTR prepend
( $pr, 0 ) :
# RTL append
( $pr + 1, 0 );
}
# find out dominant directions by scanning to the first strong at each direction, if any
if ( defined $tl ) {
my $vp = $visual_pos - 1;
$vp-- while $vp >= 0 && is_weak($tl = $t->[$map->[$vp]]);
# right to a weak, adjacent to a strong LTR further right
return $pl + 1, 1 if is_strong $tl && is_ltr $tl;
}
if ( defined $tr ) {
my $vp = $visual_pos;
$vp++ while $vp < $limit && is_weak($tr = $t->[$map->[$vp]]);
# left to a weak, adjacent to a strong LTR further left
return $pr, 0 if is_strong $tr && is_ltr $tr;
}
# cursor at the end
return is_ltr $tr ? (0, 0) : ($limit + 1, 0) unless defined $tl;
return is_ltr $tl ? ($limit + 1, 1) : (0, 0) unless defined $tr;
# XXX this is too complex, give up
return $visual_pos, is_bidi($new_str) ? 0 : length($new_str);
}
sub edit_delete
{
my ( $p, $visual_pos, $backspace ) = @_;
# non-bidi compatibility
unless (ref $p) {
if ( $backspace ) {
return ($visual_pos > 0) ? (1, $visual_pos - 1, -1) : (0, 0, 0);
} else {
return ($visual_pos < $p) ? (1, $visual_pos, 0) : (0, 0, 0);
}
}
my $map = $p->map;
my $t = $p->types;
my $limit = $#$map;
my ($il,$ir,$l,$r,$pl,$pr) = (0,0,0,0,$limit,0);
if ( $visual_pos > 0 ) {
$il = $t->[$map->[$pl = $visual_pos - 1]];
$pl-- while is_weak($l = $t->[$map->[$pl]]) && $pl > 0;
}
if ( $visual_pos <= $limit ) {
$ir = $t->[$map->[$pr = $visual_pos]];
$pr++ while is_weak($r = $t->[$map->[$pr]]) && $pr < $limit;
}
#warn "il: ", (is_strong($il) ? 'strong' : 'weak'), ' ', (is_rtl($il) ? 'rtl' : 'ltr'), " at ", $visual_pos - 1, "\n";
#warn "ir: ", (is_strong($ir) ? 'strong' : 'weak'), ' ', (is_rtl($ir) ? 'rtl' : 'ltr'), " at ", $visual_pos, "\n";
#warn "l: ", (is_strong($l) ? 'strong' : 'weak'), ' ', (is_rtl($l) ? 'rtl' : 'ltr'), " at $pl\n";
#warn "r: ", (is_strong($r) ? 'strong' : 'weak'), ' ', (is_rtl($r) ? 'rtl' : 'ltr'), " at $pr\n";
#warn "vp: $visual_pos, limit: $limit\n";
if ( $backspace ) {
# strong ltr immediately left, kill immediately left
return 1, $map->[$visual_pos - 1], -1 if $visual_pos > 0 && is_strong $il && is_ltr $il;
# strong rtl immediately right, kill immediately right
return 1, $map->[$visual_pos], 0 if $visual_pos <= $limit && is_strong $ir && is_rtl $ir;
# any ltr immediately left, kill immediately left
return 1, $map->[$visual_pos - 1], -1 if $visual_pos > 0 && is_ltr $il;
# any rtl on right, kill immediately right
return 1, $map->[$visual_pos], 0 if $visual_pos <= $limit && is_rtl $r;
# any rtl on left, kill greedy leftmost
if ($visual_pos > 0 && is_rtl $l) {
my $L = $l;
$pl-- while !(is_strong($L = $t->[$map->[$pl]]) && is_ltr $L) && $pl > 0;
return 1, $map->[$pl], $pl - $visual_pos
}
} else {
# strong ltr immediately right, kill immediately right
return 1, $map->[$visual_pos], 0 if $visual_pos <= $limit && is_strong $il && is_ltr $il;
# strong rtl immediately left, kill immediately left
return 1, $map->[$visual_pos - 1], 0 if $visual_pos > 0 && is_strong $ir && is_rtl $ir;
# any ltr immediately right, kill immediately right
return 1, $map->[$visual_pos], 0 if $visual_pos <= $limit && is_ltr $ir;
# any rtl on left, kill immediately left
return 1, $map->[$visual_pos - 1], -1 if $visual_pos > 0 && is_rtl $l;
# any ltr on right, kill greedy rightmost
if ($visual_pos <= $limit && is_ltr $r) {
my $R = $r;
$pr-- while !(is_strong($R = $t->[$map->[$pr]]) && is_rtl $R) && $pr > 0;
return 1, $map->[$pr], $pr - $visual_pos
}
}
# nothing
return 0, 0, 0;
}
sub debug_str
{
return unless $enabled;
my $str = shift;
my $p = _par($str);
my $t = $p->types;
my $b = $p->bd;
for ( my $i = 0; $i < length($str); $i++) {
my $chr = ord( substr( $str, $i, 1));
my $typ = $t->[$i];
my $tn = $b->get_bidi_type_name($typ);
my @mas;
no strict 'refs';
for my $name ( keys %Text::Bidi::Mask::) {
my $value = ${"Text::Bidi::Mask::$name"};
next unless $typ & $value;
push @mas, $name;
}
printf("$i: %03x: %06x / %s\n", $chr, $typ, join(',', @mas));
}
}
1;
=pod
=head1 NAME
Prima::Bidi - helper routines for bi-directional text input and output
=head1 SYNOPSIS
use Prima::Bidi qw(:enable is_bidi);
say Prima::Bidi::visual( $bidi_text ) if is_bidi($bidi_text);
or same, for classes
use Prima::Bidi qw(:methods);
say $self->bidi_visual( $bidi_text ) if $self-> is_bidi($bidi_text);
=head1 API
The API follows closely L<Text::Bidi> api, with view to serve as a loose set of
helper routines for input and output in Prima widgets. It also makes use of
installations without C<Text::Bidi> safe. Exports set of C<bidi_XXX> names,
available as method calls.
=over
=item is_bidi $TEXT
Returns boolean flags whether the text contains any bidirectional characters.
=item bidi_map $TEXT, ...
Shortcut for C<< Text::Bidi::Paragraph->new($TEXT, ...)->map >>.
Returns a set of integer indices, showing placement of where in original bidi
text a corresponding character can be found, i.e. C<$map[0]> contains the index of
the character to be displayed leftmost, etc.
This function could be useful f.ex. for translating screen position to text position.
See L<Text::Bidi::Paragraph/map> for more.
=item bidi_paragraph $TEXT, $RTL, $FLAGS
Returns a C<Text::Bidi::Paragraph(dir => $RTL)> object together with result of
call to C<visual($FLAGS)>.
=item bidi_revmap $MAP
Returns an inverse array of result of C<map>, i.e. showing where, if any, a
bidi character is to be displayed in visual text, so that f.ex. C<$revmap[0]>
contains visual position of character #0, etc.
=item bidi_edit_delete $PARAGRAPH, $VISUAL_POSITION, $DELETE
Handles bidirectional deletion, emulating user hitting a backspace (C<$DELETE =
0>) or delete (C<$DELETE = 1>) key at C<$VISUAL_POSITION> in text represented
by a C<Text::Bidi::Paragraph> object.
Returns three integers, showing 1) how many characters are to be deleted, 2) at
which text offset, and 3) how many characters to the right the cursor has to
move.
C<$PARAGRAPH> can be a non-object, in which case the text is considered to be non-bidi.
=item bidi_edit_insert $PARAGRAPH, $VISUAL_POSITION, $NEW_STRING
Handles typing of bidirectional text C<$NEW_STRING>, inside an existing
C<$PARAGRAPH> represented by a C<Text::Bidi::Paragraph> object, where cursor is
a C<$VISUAL_POSITION>.
C<$PARAGRAPH> can be a non-object, in which case the text is considered to be non-bidi.
=item bidi_map_find $MAP, $INDEX
Searches thround C<$MAP> (returned by C<bidi_map>) for integer C<$INDEX>, returns
its position if found.
=item bidi_selection_chunks $MAP, $START, $END, $OFFSET = 0
Calculates a set of chunks of texts, that, given a text selection from
positions C<$START> to C<$END>, represent each either a set of selected and non-selected
visual characters. The text is represented by a result of C<bidi_map>.
Returns array of integers, RLE-encoding the chunks, where the first integer
signifies number of non-selected characters to display, the second - number
of selected characters, the third the non-selected again, etc. If the first
character belongs to the selected chunk, the first integer in the result is set
to 0.
C<$MAP> can be also an integer length of text (i.e. shortcut for an identity
array (0,1,2,3...) in which case the text is considered to be non-bidi, and
selection result will contain max 3 chunks).
C<$OFFSET> may be greater that 0, but less than C<$START>, if that information
is not needed.
Example: consider embedded number in a bidi text. For the sake of clarity I'll use
latin characters here. For example, we have a text scalar containing these characters:
ABC123
where I<ABC> is right-to-left text, and which, when rendered on screen, should be
displayed as
123CBA
(and C<$MAP> will be (3,4,5,2,1,0) ).
Next, the user clicks the mouse between A and B (in text offset 1), drags the
mouse then to the left, and finally stops between characters 2 and 3 (text
offset 4). The resulting selection then should not be, as one might naively expect,
this:
123CBA
__^^^_
but this instead:
123CBA
^^_^^_
because the next character after C is 1, and the I<range> of the selected sub-text is from
characters 1 to 4.
In this case, the result of call to C<bidi_selection_chunks( $MAP, 1, 4 )> will be C<0,2,1,2,1> .
=item bidi_selection_diff $OLD, $NEW
Given set of two chunk lists, in format as returned by C<bidi_selection_chunks>, calculates
the list of chunks affected by the selection change. Can be used for efficient repaints when
the user interactively changes text selection, to redraw only the changed regions.
=item bidi_selection_map $TEXT
Same as C<bidi_map>, except when C<$TEXT> is not bidi, returns just the length of
it. Such format can be used to pass the result further to
C<bidi_selection_chunks> efficiently where operations are performed on a
non-bidi text.
=item bidi_selection_walk $CHUNKS, $FROM, $TO = length, $SUB
Walks the selection chunks array, returned by C<bidi_selection_chunks>, between
C<$FROM> and C<$TO> visual positions, and for each chunk calls the provided
C<< $SUB->($offset, $length, $selected) >>, where each call contains 2 integers to
chunk offset and length, and a boolean flag whether the chunk is selected or
not.
Can be also used on a result of C<bidi_selection_walk>, in which case
C<$selected> flag is irrelevant.
=item bidi_visual $TEXT, $RTL, $FLAGS
Same as C<bidi_paragraph> but returns only the rendered text, omitting the
paragraph object.
=back
=head1 AUTHOR
Dmitry Karasik, E<lt>dmitry@karasik.eu.orgE<gt>.
=head1 SEE ALSO
F<examples/bidi.pl>, L<Text::Bidi>
=cut