File Coverage

blib/lib/TeX/XDV/Parse.pm

Criterion	Covered	Total	%
statement	67	87	77.0
branch	7	16	43.7
condition	1	3	33.3
subroutine	16	19	84.2
pod	2	7	28.5
total	93	132	70.4

package TeX::XDV::Parse;
use strict;
use warnings;
use Exporter 'import';

require TeX::DVI::Parse;

$TeX::XDV::Parse::VERSION = '0.02';

@TeX::XDV::Parse::ISA = qw/TeX::DVI::Parse/;

@TeX::XDV::Parse::EXPORT_OK = qw(
    XDV_FLAG_FONTTYPE_ATSUI
    XDV_FLAG_FONTTYPE_ICU
    XDV_FLAG_VERTICAL
    XDV_FLAG_COLORED
    XDV_FLAG_FEATURES
    XDV_FLAG_VARIATIONS
    XDV_FLAG_EXTEND
    XDV_FLAG_SLANT
    XDV_FLAG_EMBOLDEN
);

%TeX::XDV::Parse::EXPORT_TAGS = (
    'constants' => [qw/
        XDV_FLAG_FONTTYPE_ATSUI
        XDV_FLAG_FONTTYPE_ICU
        XDV_FLAG_VERTICAL
        XDV_FLAG_COLORED
        XDV_FLAG_FEATURES
        XDV_FLAG_VARIATIONS
        XDV_FLAG_EXTEND
        XDV_FLAG_SLANT
        XDV_FLAG_EMBOLDEN
    /],
);

# from xdvipdfmx
# no hash interface before 5.8 for constant
use constant XDV_FLAG_FONTTYPE_ATSUI => 0x0001;
use constant XDV_FLAG_FONTTYPE_ICU   => 0x0002;
use constant XDV_FLAG_VERTICAL       => 0x0100;
use constant XDV_FLAG_COLORED        => 0x0200;
use constant XDV_FLAG_FEATURES       => 0x0400;
use constant XDV_FLAG_VARIATIONS     => 0x0800;
use constant XDV_FLAG_EXTEND         => 0x1000;
use constant XDV_FLAG_SLANT          => 0x2000;
use constant XDV_FLAG_EMBOLDEN       => 0x4000;

# Hmm.. either way we do this, the dispatcher in DVI::Parse
# sees the same thing. Either way, it ends up calling either
# DVI's handler or the one here. Since we're not trying to
# override anything, it doesn't really matter. The end result
# is the same as seen from the superclassing module.

#our @COMMANDS;
#*COMMANDS = *TeX::DVI::Parse::COMMANDS;

push @TeX::DVI::Parse::COMMANDS, (
    # opcode 250 is still unused, as in TeX::DVI::Parse
    [ 'pic_file',        \&make_pic_file ],         # 251
    [ 'native_font_def', \&make_native_font_def ],  # 252
    [ 'glyph_array',     \&make_glyph_array ],      # 253
    [ 'glyph_string',    \&make_glyph_string ],     # 254
    [ 'dir',             \&dir ],                   # 255
    'undefined_command'                             # 256, not possible
);

sub make_glyph_thingy {
    my $is_array = shift;
    my $buff = pop @_;

    # width, count
    my @list =
        unpack "lna*",
        pack   "Lna*",
        unpack "Nna*",
        $buff;
    $buff = pop @list;

    # locations, glyphs
    my $c = $list[-1];
    my $z = $is_array ? $c<<1 : $c;
    push @list,
        unpack "l${z}n${c}a*",
        pack   "L${z}n${c}a*",
        unpack "N${z}n${c}a*",
        $buff;
    $buff = pop @list;

    return @_, @list, $buff;
}

sub make_glyph_string { make_glyph_thingy( 0, @_ ) }
sub make_glyph_array  { make_glyph_thingy( 1, @_ ) }

sub make_pic_file {
    my $buff = pop @_;
    my @list =
        unpack "CllllllsSa*",
        pack   "CLLLLLLSSa*",
        unpack "CNNNNNNnna*",
        $buff;
    $buff = pop @list;
    my $file;
    ($file,$buff) = unpack "A$list[-1]a*", $buff;
    return @_, @list, $file , $buff;
}

sub make_native_font_def {
    my $buff = pop @_;

    # font_id, point_size, flags
    my @list =
        unpack "lLna*",
        pack   "LLna*",
        unpack "NNna*",
        $buff;
    $buff = pop @list;

    my $f = $list[-1];

    die "invalid signature"
        unless $f & XDV_FLAG_FONTTYPE_ICU || $f & XDV_FLAG_FONTTYPE_ATSUI;

    # plen, flen, slen
    push @list, unpack "CCCa*", $buff;
    $buff = pop @list;

    # font_name, family_name, style_name
    push @list, unpack "A$list[-3]A$list[-2]A$list[-1]a*", $buff;
    $buff = pop @list;

    # rgba_color
    if ($f & XDV_FLAG_COLORED) {
        push @list, unpack "Na*", $buff;
        $buff = pop @list;
    }

    # variations
    if ($f & XDV_FLAG_VARIATIONS) {
        push @list, unpack "na*", $buff;
        $buff = pop @list;
        my $n = $list[-1];
        push @list,
            unpack "l${n}N${n}a*", # need to make sure first is signed
            pack   "L${n}N${n}a*",
            unpack "N${n}N${n}a*",
            $buff;
        $buff = pop @list;
    }

    # extend ?
    if ($f & XDV_FLAG_EXTEND) {
        push @list,
            unpack "la*",
            pack   "La*",
            unpack "Na*",
            $buff;
        $buff = pop @list;
    }

    # slant ?
    if ($f & XDV_FLAG_SLANT) {
        push @list,
            unpack "la*",
            pack   "La*",
            unpack "Na*",
            $buff;
        $buff = pop @list;
    }

    # bold ?
    if ($f & XDV_FLAG_EMBOLDEN) {
        push @list,
            unpack "la*",
            pack   "La*",
            unpack "Na*",
            $buff;
        $buff = pop @list;
    }

    return @_, @list, $buff;
}

sub dir {
    my $buff = pop @_;
    my @list = unpack "Ca*", $buff;
    $buff = pop @list;
    $list[-1] = $list[-1] ? 1 : 0;  # 0=horizontal 1=vertical
    return @_, @list, $buff;
}

sub undefined_command {
    die "undefined_command: @_\n";
}

1;

__END__