File Coverage

blib/lib/LaTeX/Recode.pm

Criterion	Covered	Total	%
statement	155	175	88.5
branch	46	70	65.7
condition	2	4	50.0
subroutine	22	22	100.0
pod	2	2	100.0
total	227	273	83.1

package LaTeX::Recode;

use strict;
use warnings;
use parent qw(Exporter);
use re 'eval';
use Encode;
use File::Slurp;
use File::Spec;
use Unicode::Normalize;
use List::Util qw (first);
use XML::LibXML::Simple;
use utf8;

use File::ShareDir 'module_file';

our @EXPORT = qw(latex_encode latex_decode);

sub import {
     my ($self, %opts) = @_;

     my $sets = qr/^(?:null|base|full)$/i;
     my $encode_set = ($opts{encode_set}||"") =~ m!$sets! ? lc $opts{encode_set} : "base";
     my $decode_set = ($opts{decode_set}||"") =~ m!$sets! ? lc $opts{decode_set} : "base";

     _init_sets($decode_set, $encode_set);

     $self->export_to_level(1, undef, @EXPORT);
}

=encoding utf-8

=head1 NAME

LaTeX::Recode - Encode/Decode chars to/from UTF-8/macros in LaTeX

=head1 SYNOPSIS

    use LaTeX::Recode;

    my $string       = 'Muḥammad ibn Mūsā al-Khwārizmī';
    my $latex_string = latex_encode($string);
        # => 'Mu\d{h}ammad ibn M\=us\=a al-Khw\=arizm\={\i}'

    my $string = 'Mu\d{h}ammad ibn M\=us\=a al-Khw\=arizm\={\i}';
    my $utf8_string   = latex_decode($string);
        # => 'Muḥammad ibn Mūsā al-Khwārizmī'


    # if you want to define a different conversion set (either
    # for encoding or decoding):
    use LaTeX::Recode encode_set => 'full', decode_set => 'base';


=head1 DESCRIPTION

Allows conversion between Unicode chars and LaTeX macros.

=head1 GLOBAL OPTIONS

Possible values for the encoding/decoding set to use are 'null', 'base' and 'full';
default value is 'base'.

null  => No conversion

base  => Most common macros and diacritics (sufficient for Western languages
         and common symbols)

full  => Also converts punctuation, larger range of diacritics and macros
         (e.g. for IPA, Latin Extended Additional, etc.), symbols, Greek letters,
         dingbats, negated symbols, and superscript characters and symbols ...

=cut

our ($remap_d, $remap_e, $remap_e_raw, $set_d, $set_e);




=head2 latex_decode($text, @options)

Converts LaTeX macros in the $text to Unicode characters.

The function accepts a number of options:

    * normalize => $bool (default 1)
        whether the output string should be normalized with Unicode::Normalize

    * normalization =>  (default 'NFD')
        and if yes, the normalization form to use (see the Unicode::Normalize documentation)

=cut

sub latex_decode {
    my $text = shift;

    # Optimisation - if there are no macros, no point doing anything
    return $text unless $text =~ m/\\/;

    # Optimisation - if virtual null set was specified, do nothing
    return $text if $set_d eq 'null';

    my %opts = @_;
    my $norm = exists $opts{normalize} ? $opts{normalize} : 1;
    my $norm_form
        = exists $opts{normalization} ? $opts{normalization} : 'NFD';

    # Deal with raw TeX \char macros.
    $text =~ s/\\char"(\p{ASCII_Hex_Digit}+)/"chr(0x$1)"/gee;  # hex chars
    $text =~ s/\\char'(\d+)/"chr(0$1)"/gee;                    # octal chars
    $text =~ s/\\char(\d+)/"chr($1)"/gee;                      # decimal chars

    $text =~ s/(\\[a-zA-Z]+)\\(\s+)/$1\{\}$2/g;    # \foo\ bar -> \foo{} bar
    $text =~ s/([^{]\\\w)([;,.:%])/$1\{\}$2/g;     #} Aaaa\o,  -> Aaaa\o{},

    foreach my $type (
        'greek',           'dings',
        'punctuation',     'symbols',
        'negatedsymbols',  'superscripts',
        'cmdsuperscripts', 'letters',
        'diacritics'
        )
    {
        my $map = $remap_d->{$type}{map};
        my $re  = $remap_d->{$type}{re};
        next unless $re;    # Might not be present depending on set

        if ( $type eq 'negatedsymbols' ) {
            $text =~ s/\\not\\($re)/$map->{$1}/ge;
        }
        elsif ( $type eq 'superscripts' ) {
            $text =~ s/\\textsuperscript\{($re)\}/$map->{$1}/ge;
        }
        elsif ( $type eq 'cmdsuperscripts' ) {
            $text =~ s/\\textsuperscript\{\\($re)\}/$map->{$1}/ge;
        }
        elsif ( $type eq 'dings' ) {
            $text =~ s/\\ding\{([2-9AF][0-9A-F])\}/$map->{$1}/ge;
        }
        elsif ( $type eq 'letters' ) {
            $text =~ s/\\($re)(?:\{\}|\s+|\b)/$map->{$1}/ge;
        }
        elsif ( first { $type eq $_ } ( 'punctuation', 'symbols', 'greek' ) )
        {
            $text =~ s/\\($re)(?: \{\}|\s+|\b)/$map->{$1}/ge;
        }
        elsif ( $type eq 'diacritics' ) {
            $text =~ s/\\($re)\s*\{(\pL\pM*)\}/$2 . $map->{$1}/ge;

            # Conditional regexp with code-block condition
            # non letter macros for diacritics (e.g. \=) can be followed by any letter
            # but letter diacritic macros (e.g \c) can't (\cS) horribly Broken
            #
            # If the RE for the macro doesn't end with a basic LaTeX macro letter (\=), then
            #   next char can be any letter (\=d)
            # Else if it did end with a normal LaTeX macro letter (\c), then
            #   If this was followed by a space (\c )
            #     Any letter is allowed after the space (\c S)
            #   Else
            #     Only a non basic LaTeX letter is allowed (\c-)
            $text =~ s/\\# slash
                   ($re)# the diacritic
                   (\s*)# optional space
                   (# capture paren
                     (?(?{$1 !~ m:[A-Za-z]$:})# code block condition (is not a letter?)
                       \pL # yes pattern
                     | # no pattern
                       (?(?{$2}) # code block condition (space matched earlier after diacritic?)
                         \pL # yes pattern
                       | # no pattern
                         [^A-Za-z]
                       ) # close conditional
                     ) # close conditional
                     \pM* # optional marks
                   ) # capture paren
                   /$3 . $map->{$1}/gxe;
        }
    }

    # Now remove braces around single letters with diacritics (which the replace above
    # can result in). Things like '{á}'. Such things can break kerning. We can't do this in
    # the RE above as we can't determine if the braces are wrapping a phrase because this
    # match is on an entire file string. So we can't in one step tell the difference between:
    #
    # author = {Andr\'e}
    # and
    # author = {Andr\'{e}}
    #
    # when this is part of a (much) larger string
    #
    # We don't want to do this if it would result in a broken macro name like with
    # \textupper{é}
    #
    # Workaround perl's lack of variable-width negative look-behind -
    # Reverse string (and therefore some of the Re) and use variable width negative look-ahead
    $text = reverse $text;
    $text =~ s/}(\pM+\pL)\{(?!\pL+\\)/$1/g;
    $text = reverse $text;

    return $norm ? Unicode::Normalize::normalize( $norm_form, $text ) : $text;

}

=head2 latex_encode($text, @options)

Converts UTF-8 to LaTeX

=cut

sub latex_encode {
    my $text = shift;

    # Optimisation - if virtual null set was specified, do nothing
    return $text if $set_e eq 'null';

    $text = NFD($text);

    foreach my $type (
        qw'greek dings negatedsymbols superscripts cmdsuperscripts
           diacritics letters punctuation symbols'
        )
    {
        my $map = $remap_e->{$type}{map};
        my $re  = $remap_e->{$type}{re};
        next unless $re;    # Might not be present depending on set

        if ( $type eq 'negatedsymbols' ) {
            $text =~ s/($re)/"{\$\\not\\" . $map->{$1} . '$}'/ge;
        }
        elsif ( $type eq 'superscripts' ) {
            $text =~ s/($re)/'\textsuperscript{' . $map->{$1} . '}'/ge;
        }
        elsif ( $type eq 'cmdsuperscripts' ) {
            $text =~ s/($re)/"\\textsuperscript{\\" . $map->{$1} . "}"/ge;
        }
        elsif ( $type eq 'dings' ) {
            $text =~ s/($re)/'\ding{' . $map->{$1} . '}'/ge;
        }
        elsif ( $type eq 'letters' ) {

            # General macros (excluding special encoding excludes)
            $text
                =~ s/($re)/($remap_e_raw->{$1} ? '' : "\\") . $map->{$1} . ($remap_e_raw->{$1} ? '' : '{}')/ge;
        }
        elsif ( first { $type eq $_ } ( 'punctuation', 'symbols', 'greek' ) )
        {
            # Math mode macros (excluding special encoding excludes)
            $text
                =~ s/($re)/($remap_e_raw->{$1} ? '' : "{\$\\") . $map->{$1} . ($remap_e_raw->{$1} ? '' : '$}')/ge;
        }
        elsif ( $type eq 'diacritics' ) {

            # special case such as "i\x{304}" -> '\={\i}' -> "i" needs the dot removing for accents
            $text =~ s/i($re)/"\\" . $map->{$1} . '{\i}'/ge;

            $text =~ s/\{(\pL\pM*)\}($re)/"\\" . $map->{$2} . "{$1}"/ge;
            $text =~ s/(\pL\pM*)($re)/"\\" . $map->{$2} . "{$1}"/ge;

            $text =~ s{
                  (\PM)($re)($re)($re)
              }{
                "\\" . $map->{$4} . "{\\" . $map->{$3} . "{\\" . $map->{$2} . "{$1}" . '}}'
              }gex;
            $text =~ s{
                  (\PM)($re)($re)
              }{
                "\\" . $map->{$3} . "{\\" . $map->{$2} . "{$1}" . '}'
              }gex;
            $text =~ s{
                  (\PM)($re)
              }{
                "\\" . $map->{$2} . "{$1}"
              }gex;
        }
    }

    return $text;
}


=head2 _init_sets(, )

Initialise recoding sets.
This is a private method, and its direct usage should not be needed
in normal circunstances.

=cut


sub _init_sets {
    ( $set_d, $set_e ) = @_;
    no autovivification;

    # Reset these, mostly for tests which call init_sets more than once
    $remap_d     = {};
    $remap_e     = {};
    $remap_e_raw = {};

    my $mapdata = module_file( 'LaTeX::Recode' => "recode_data.xml" );

    # Read driver config file
    my $xml = File::Slurp::read_file($mapdata)
        or die("Can't read file $mapdata");
    my $doc = XML::LibXML->load_xml( string => decode( 'UTF-8', $xml ) );
    my $xpc = XML::LibXML::XPathContext->new($doc);

    my @types = qw(letters diacritics punctuation symbols negatedsymbols
                   superscripts cmdsuperscripts dings greek);

    # Have to have separate loops for decode/recode or you can't have independent
    # decode/recode sets

    # Construct decode set
    foreach my $type (@types) {
        foreach my $maps ( $xpc->findnodes("/texmap/maps[\@type='$type']") ) {
            my @set = split( /\s*,\s*/, $maps->getAttribute('set') );
            next unless first { $set_d eq $_ } @set;
            foreach my $map ( $maps->findnodes('map') ) {
                my $from = $map->findnodes('from')->shift();
                my $to   = $map->findnodes('to')->shift();
                $remap_d->{$type}{map}{ NFD( $from->textContent() ) }
                    = NFD( $to->textContent() );
            }
        }

        # Things we don't want to change when decoding as this breaks some things
        foreach my $d ( $xpc->findnodes('/texmap/decode_exclude/char') ) {
            delete( $remap_d->{$type}{map}{ NFD( $d->textContent() ) } );
        }
    }

    # Construct encode set
    foreach my $type (@types) {
        foreach my $maps ( $xpc->findnodes("/texmap/maps[\@type='$type']") ) {
            my @set = split( /\s*,\s*/, $maps->getAttribute('set') );
            next unless first { $set_e eq $_ } @set;
            foreach my $map ( $maps->findnodes('map') ) {
                my $from = $map->findnodes('from')->shift();
                my $to   = $map->findnodes('to')->shift();
                $remap_e->{$type}{map}{ NFD( $to->textContent() ) }
                    = NFD( $from->textContent() );
            }

            # There are some duplicates in the data to handle preferred encodings.
            foreach my $map ( $maps->findnodes('map[from[@preferred]]') ) {
                my $from = $map->findnodes('from')->shift();
                my $to   = $map->findnodes('to')->shift();
                $remap_e->{$type}{map}{ NFD( $to->textContent() ) }
                    = NFD( $from->textContent() );
            }

            # Some things might need to be inserted as is rather than wrapped
            # in some macro/braces
            foreach my $map ( $maps->findnodes('map[from[@raw]]') ) {
                my $from = $map->findnodes('from')->shift();
                my $to   = $map->findnodes('to')->shift();
                $remap_e_raw->{ NFD( $to->textContent() ) } = 1;
            }

        }

        # Things we don't want to change when encoding as this would break LaTeX
        foreach my $e ( $xpc->findnodes('/texmap/encode_exclude/char') ) {
            delete( $remap_e->{$type}{map}{ NFD( $e->textContent() ) } );
        }
    }

    # Populate the decode regexps
    # sort by descending length of macro name to avoid shorter macros which
    # are substrings of longer ones damaging the longer ones
    foreach my $type (@types) {
        next unless exists $remap_d->{$type};
        $remap_d->{$type}{re} = join( '|',
            map { /[\.\^\|\+\-\)\(]/ ? '\\' . $_ : $_ }
                sort { length($b) <=> length($a) }
                keys %{$remap_d->{$type}{map}} );
        $remap_d->{$type}{re} = qr|$remap_d->{$type}{re}|;
    }

    # Populate the encode regexps
    foreach my $type (@types) {
        next unless exists $remap_e->{$type};
        $remap_e->{$type}{re} = join( '|',
            map { /[\.\^\|\+\-\)\(]/ ? '\\' . $_ : $_ }
            sort keys %{ $remap_e->{$type}{map} } );
        $remap_e->{$type}{re} = qr|$remap_e->{$type}{re}|;
    }
}

1;

__END__