File Coverage

blib/lib/Unicode/Lite.pm

Criterion	Covered	Total	%
statement	72	156	46.1
branch	16	108	14.8
condition	21	109	19.2
subroutine	16	19	84.2
pod	3	3	100.0
total	128	395	32.4

package Unicode::Lite;

use 5.005_62;
use strict;
use warnings;
use base qw/Exporter/;
use Carp qw/croak carp/;


our $VERSION = '0.12';
our @EXPORT  = qw/convert convertor addequal UL_CHR UL_ENT UL_EQV UL_SEQ UL_7BT UL_ALL/;
our %EXPORT_TAGS = (
	utils => [grep{!/^UL_/}@EXPORT],
	flags => [grep{ /^UL_/}@EXPORT]
);


use enum qw/BITMASK: RP_CHR RP_ENT EQ_CHR EQ_SEQ EQ_7BT/;
use enum qw/nil src dst all/;
use constant uni => qr/^(?:utf16|utf8|utf7|ucs4|uchr|uhex|latin1)$/;
use constant UL_CHR => RP_CHR;          # REPLACE TO CHAR   (default )
use constant UL_ENT => RP_CHR | RP_ENT; # REPLACE TO ENTITY (like �)
use constant UL_EQV => EQ_CHR;          # EQUIVALENT char
use constant UL_SEQ => EQ_CHR | EQ_SEQ; # EQUIVALENT sequence of chars
use constant UL_7BT => EQ_7BT | UL_SEQ; # EQUIVALENT sequence of 7bit chars
use constant UL_ALL => UL_CHR | UL_ENT | UL_EQV | UL_SEQ;
our (%MAPPING, %CONVERT, %EQUIVAL, $REGISTR, $TEST);

sub convertor($$;$$)
{
	my ($src, $dst, $mod, $chr) = (lc shift, lc shift, shift||0, shift||'');

	return $CONVERT{$src}{$dst}{$mod}{$chr} if exists
		   $CONVERT{$src}{$dst}{$mod}{$chr};
	require Unicode::String unless defined %Unicode::String::;

	my  ($SRC, $DST) = ($src, $dst);
	for ($SRC, $DST){
		next if $_=~uni or s/^(?:ucs2|unicode)$/utf16/o or s/^iso-8859-1$/latin1/o;
		next if exists $MAPPING{$_};
		unless ($REGISTR){ require Unicode::Map; local $_;
				$REGISTR = new Unicode::Map() }
		$_ = lc $REGISTR->id(uc $_) || croak "Character Set '$_' not defined!";
		$_ = 'latin1' if $_ eq 'iso-8859-1';
	}

	return $CONVERT{$src}{$dst}{$mod}{$chr} =
		   $CONVERT{$SRC}{$DST}{$mod}{$chr} if exists
		   $CONVERT{$SRC}{$DST}{$mod}{$chr};

	my $map = ($SRC !~ uni) | ($DST !~ uni) << 1;

	for ([$src, $SRC, $map&src], [$dst, $DST, $map&dst]){
		next unless $$_[2] and !$MAPPING{$$_[0]};
		$MAPPING{$$_[0]} = $MAPPING{$$_[1]} ||
	   ($MAPPING{$$_[1]} = new Unicode::Map(uc $$_[1])) ||
		croak "Can't create Unicode::Map object for '$$_[1]' charset!";
	}

	$map = all if
		$map == src && $DST eq 'latin1' or
		$map == dst && $SRC eq 'latin1' or
		$map == nil && $SRC eq 'latin1' && $DST eq 'latin1';

	# Situation checking
	croak "FLAG param can be only for SBCS->SBCS!" if $map != all and $mod;
	croak "CHAR param can be only for SBCS->SBCS!" if $map != all and length $chr;
	croak "Can't convert to the same codepage!"    if $SRC eq $DST and
													  $map != all || not $mod & EQ_7BT;
	my ($mut);
	if ($map != all)
	{
		my ($uni, $utf) = ($map^all, 0);
		$utf |= src if $uni & src and $SRC ne 'utf16';
		$utf |= dst if $uni & dst and $DST ne 'utf16';

		$mut = '$_';

		$mut = "\$MAPPING{'$SRC'}->to_unicode($mut)"   if $map & src;
		$mut = "Unicode::String::$SRC($mut)"           if $uni & src && not
														  $map & dst &&!($utf&src);
		$mut = "\$MAPPING{'$DST'}->from_unicode($mut)" if $map & dst;
		$mut = "Unicode::String::utf16($mut)"          if $utf & dst && $map & src;
		$mut = "$mut->$DST"                            if $uni & dst && $uni & src or
														  $utf & dst && $map & src;
		$mut = '$_='.$mut;
	}
	else{ $mut = __sbcs_convertor($SRC, $DST, $mod, $chr) }
	warn "MUTATOR: $SRC -> $DST [$mod]\t$mut\n" if $TEST;

	return
		$CONVERT{$src}{$dst}{$mod}{$chr} =
		$CONVERT{$SRC}{$DST}{$mod}{$chr} = eval 'sub(;$){
		my $str = @_ ? $_[0] : defined wantarray ? $_ : \$_;
		for( ref$str?$$str:$str ){ if($_){'.$mut.'}
		return $_ if defined wantarray}
		$_ = $str if defined $_[0] and not ref $str }';
}

sub convert($$;$$$){
	my $fn = convertor( shift, shift, $_[1], $_[2] );
	&$fn;
}

sub addequal(@)
{
	return unless
	my @chr = map{
		my @a = map hex, split /\+/;
		$#a ? \@a : $a[0];
	}$#_ ? @_ : split /\s+/, shift;

	$EQUIVAL{shift @chr} = \@chr;

	@chr = map{
		(ref || !exists $EQUIVAL{$_}) ? $_ :
		($_, @{$EQUIVAL{$_}})
	}@chr;
}

sub __sbcs_convertor($$$$)
{
	my ($src, $dst, $mod, $chr) = (shift, shift, shift, shift);
	my (@src, %src, @dst, %dst, @dif, %dif);

	croak "Unknown flags: $mod!"      if $mod & ~(UL_ALL|UL_7BT);
	croak "CHAR and UL_ENT together!" if length $chr and $mod & RP_ENT;

	$chr = length($chr) ? substr($chr,0,1) : '?' if
		$mod & RP_CHR and not $mod & RP_ENT;

	# fill charsets arrays with U+0000
	@dst = (0) x 0x80 if $mod & EQ_7BT;
	for ([$src, \@src], ($mod & EQ_7BT)?():[$dst, \@dst]){
		my $conv = convertor( $$_[0], 'utf16' );
		@{$$_[1]} = map {&$conv(); $_ ? unpack 'n', $_ : 0} map chr, 0x80..0xff;
	}

	@src{@src} = 0x80..0xff  if $mod & ~RP_CHR;
	@dst{@dst} = 0x80..0xff;

	# collect positions of unused chars
	if ($mod & ~RP_CHR){                # if need indirect replace
		for (0 .. $#dst){
		push @dif, $_ + 0x80 if
			!$dst[$_] or                # char not used in dst codepage
			!exists $src{$dst[$_]}      # char not used in src codepage
		}
	}

	# read equivalent rules
	if ($mod & UL_EQV and not %EQUIVAL){
		local $_;
		while (){ s/\s*#.*//so; addequal($_); }
	}

	my $find = sub(){
		my $chr = $src[$_];
		return undef unless exists $EQUIVAL{$chr};
		LOOP:
		for (@{$EQUIVAL{$chr}}){
			if (!ref){ next LOOP unless $_ < 0x80 or exists $dst{$_}; return $_ }
			next unless $mod & EQ_SEQ;
			for (@$_){ next LOOP unless $_ < 0x80 or exists $dst{$_}} return $_;
		}
		return undef;
	};

	my (@map, @eqv, @ent, @chr, @del);

	for (0 .. $#src)
	{
		next if !$src[$_] or            # char not used in src codepage
				 $src[$_] == $dst[$_];  # chars in src and dst maps are equal

		if( exists $dst{$src[$_]} ){
			push @map, [$_, $src[$_]];

		}elsif( $mod & EQ_CHR and my $uni = &$find ){
			next if     ref $uni and
			push @eqv, [$_, $uni];
			next if not ($dst{$uni} and $_ == $dst{$uni} - 0x80) and
			push @map, [$_, $uni];
            @dif = grep{ $_ != $dst{$uni} }@dif;

		}elsif( $mod & RP_ENT ){
			push @ent, [$_, $src[$_]];

		}elsif( $mod & RP_CHR ){
			push @chr, $_;

		}else{
			push @del, $_;

		}
	}

	croak "Internal ERROR: not enough additional chars!\n" if @ent+@eqv > @dif;

	($src, $dst) = ('') x 2;

	$src .= chr $$_[0] + 0x80,
	$dst .= chr($$_[1] < 0x80 ? $$_[1] : $dst{$$_[1]})
								for @map;
	for (@ent){
		$src .= chr $$_[0] + 0x80;
		$dst .= $$_[0] = chr shift @dif;
	}

	for (@eqv){
		$src .= chr $$_[0] + 0x80;
		$dst .= $$_[0] = chr shift @dif;
		$$_[1] = join '', map{
			chr( $_ < 0x80 ? $_ : $dst{$_} )
		}@{$$_[1]};
		$$_[1] =~ s/([\-\\\/\$])/\\$1/gso;
	}
	$src .= chr $_ + 0x80       for @chr;
	$dst .= $chr x(@del?@chr:1) if  @chr;
	$src .= chr $_ + 0x80       for @del;

	s/(?=[-\\\[\]])/\\/gso      for $src, $dst;

	my
	$res = "tr\n[$src]\n[$dst]" . (@del?'d':'');
	$res.= ";s/$$_[0]/&#$$_[1];/g" for @ent;
	$res.= ";s/$$_[0]/$$_[1]/g"    for @eqv;

	return $res;
}

1;

=head1 NAME

Unicode::Lite - Easy conversion between encodings

=head1 SYNOPSIS

 use Unicode::Lite;

 print convert( 'latin1', 'unicode', "hello world!" );

 local *lat2uni = convertor( 'latin1', 'unicode' );
 print lat2uni( "hello world!" );

 my $lat2uni = convertor( 'latin1', 'unicode' );
 print &$lat2uni( "hello world!" );

=head1 DESCRIPTION

This module includes string converting function from one and to another
charset. Requires installed Unicode::String and Unicode::Map packages.

Supported unicode charsets: unicode, utf16, ucs2, utf8, utf7, ucs4,
uchr, uhex.

Supported Single-Byte Charsets (SBCS): latin1 and all installed maps in
Unicode::Map package.

=head1 FUNCTIONS

=over 4

=item B SRC_CP DST_CP [FLGS] [CHAR]

Creates convertor function and returns reference to her, for further
fast direct call.

The param FLGS operates replacing by SBCS->SBCS converting if any char
from SRC_CP is absent at DST_CP. The order of search of substitution:

 UL_7BT - to equivalent 7bit char or sequence of 7bit chars
 UL_SEQ - to equivalent char or sequence of chars
 UL_EQV - to equivalent char

 UL_ENT - to entity - �
 UL_CHR - to [CHAR].
 UL_ALL - UL_SEQ or UL_EQV and UL_ENT or UL_CHR

If flag UL_CHR or UL_ENT is not specified, absent chars will be deleted.
Param CHAR used for replacing of absent chars. If CHAR is not specified,
will be used '?' char.

If you are getting message "Character Set '' not defined!", run the
script test.pl from distribution.

=item B SRC_CP DST_CP [VAR] [FLGS] [CHAR]

Convert VAR from SRC_CP codepage to DST_CP codepage and returns
converted string.

=item B UNICODES...

The function adds a rule for equivalent char finding. Params is a list of
hex unicodes of chars. For substitution on a sequence of characters,
the codes of characters need to be connected in character '+'.

 addequal( qw/2026 2E+2E+2E 3A/ ); # ELLIPSIS ... :

Note! Work of rules for finding of equivalent char is cascade:

 2500 002D      # - -
 2550 2500      # = -

 2550 2500 002D # = - -

=back

 The following rules are correct for converting functions:

 VAR may be SCALAR or REF to SCALAR.
 If VAR is REF to SCALAR then SCALAR will be converted.
 If VAR is omitted, uses $_.
 If function called to void context and VAR is not REF then result placed to $_.

=head1 EXAMPLES

 $_ = "drüben, Straße";
 convert 'latin1', 'latin1', $_, UL_7BT;
 convert 'latin1', 'latin2', $_, UL_SEQ|UL_CHR, '?';
 convert 'latin1', 'latin2', $_, UL_SEQ|UL_ENT, '?';

 # EQVIVALENT CALLS:

 local *lat2uni = convertor( 'latin1', 'unicode' );

 lat2uni( $str );        # called to void context -> result placed to $_
 $_ = lat2uni( $str );

 lat2uni( \$str );       # called with REF to string -> direct converting
 $str = lat2uni( $str );

 lat2uni();              # with omitted param called -> $_ converted
 lat2uni( \$_ );
 $_ = lat2uni( $_ );

=head1 AUTHOR

Albert MICHEEV

=head1 COPYRIGHT

Copyright (C) 2000, Albert MICHEEV

This module is free software; you can redistribute it or modify it
under the same terms as Perl itself.

=head1 AVAILABILITY

The latest version of this library is likely to be available from:

http://www.perl.com/CPAN

=head1 SEE ALSO

Unicode::String, Unicode::Map, map

=cut

__DATA__