view release on metacpan or  search on metacpan

lib/PerlIO/via/PrepareCP1251.pm  view on Meta::CPAN

sub _init {

    # load cp1251 to unicode table
    while ( <DATA> ) {
        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 <liosha@cpan.org>

=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