File Coverage

blib/lib/PerlIO/via/PrepareCP1251.pm

Criterion	Covered	Total	%
statement	45	46	97.8
branch	19	22	86.3
condition			n/a
subroutine	11	11	100.0
pod	2	2	100.0
total	77	81	95.0

package PerlIO::via::PrepareCP1251;
$PerlIO::via::PrepareCP1251::VERSION = '0.02';
# $Id$
# ABSTRACT: prepare unicode stream to be encoded as cp1251

use 5.010;
use strict;
use warnings;
use utf8;

use charnames ':full';

use Unicode::Normalize;




our $INCOMPATIBLE_CHAR_MODE = 'default_char';
our $DEFAULT_CHAR = q{?};


our %CMAP = (

    # Kazakh

    "\x{04D8}" => "\x{0410}",       # SCHWA
    "\x{04D9}" => "\x{0430}",
    "\x{0492}" => "\x{0413}",       # GHE WITH STROKE
    "\x{0493}" => "\x{0433}",
    "\x{04A2}" => "\x{041D}",       # EN WITH DESCENDER
    "\x{04A3}" => "\x{043D}",
    "\x{04AE}" => "\x{0423}",       # STRAIGHT U
    "\x{04AF}" => "\x{0443}",
    "\x{04B0}" => "\x{0423}",       # STRAIGHT U WITH STROKE
    "\x{04B1}" => "\x{0443}",
    "\x{04BA}" => "\x{0425}",       # SHHA
    "\x{04BB}" => "\x{0445}",
    "\x{049A}" => "\x{041A}",       # KA WITH DESCENDER
    "\x{049B}" => "\x{043A}",
    "\x{04E8}" => "\x{041E}",       # BARRED O
    "\x{04E9}" => "\x{043E}",
);


_init();
1;


{
my %codepage;

sub _init {

    # load cp1251 to unicode table
    while (  ) {
        next unless my ( $code, $ucode ) = m{ 0x ([0-9A-F]{2}) \s+ 0x ([0-9A-F]{4}) }xms;
        $codepage{ chr hex $ucode } = chr hex $code;
    }

    # remove diacritics
    for my $codepoint ( 0x000 .. 0x2FFF ) {
        my $chr = chr $codepoint;
        next if exists $codepage{$chr};
        next if exists $CMAP{$chr};

        my $nfd = substr NFD( $chr ), 0, 1;
        next unless exists $codepage{$nfd};

        $CMAP{$chr} = $nfd;
    }

    return;
}


sub _convert_symbol {
    my ($char) = @_;

    return $char            if exists $codepage{$char};
    return $CMAP{$char}     if exists $CMAP{$char};
    return q{}              if $INCOMPATIBLE_CHAR_MODE eq 'skip';
    return $DEFAULT_CHAR    if $INCOMPATIBLE_CHAR_MODE eq 'default_char';
    return $char            if $INCOMPATIBLE_CHAR_MODE eq 'pass';

    if ( my $name = charnames::viacode(ord $char) ) {
        return "\\N{$name}";
    }
    return sprintf '\x{%04x}', ord $char;
}
}



sub PUSHED {
    my ($class) = @_;
    return bless \*PUSHED, $class;
};



sub UTF8 {
    1;
}



sub WRITE {
    my ( undef, $line, $handle ) = @_;
    utf8::decode $line;
    my $out = join q{},
        map { _convert_symbol($_) }
        split m//, $line;
    return ( print {$handle} $out ) ? length($line) : -1;
}

=pod

=encoding UTF-8

=head1 NAME

PerlIO::via::PrepareCP1251 - prepare unicode stream to be encoded as cp1251

=head1 VERSION

version 0.02

=head1 SYNOPSIS

    require PerlIO::via::PrepareCP1251;

    # note the filter order
    open my $fh, '>:encoding(cp1251):via(PrepareCP1251)', $filename;
    print {$fh} $unicode_string;
    close $fh;

=head2 $INCOMPATIBLE_CHAR_MODE

Behaviour for incompatible chars:

    pass            - put original symbol
    default_char    - put $DEFAULT_CHAR
    skip            - don't put anything
    charname        - put \N{charname}

=head1 PerlIO::via interface

=head2 PUSHED

Constructor

=head2 UTF8

Require utf8 stream

=head2 WRITE

Filter text

=head1 AUTHOR

liosha

=head1 COPYRIGHT AND LICENSE

This software is copyright (c) 2015 by liosha.

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

=cut

__DATA__