view release on metacpan or  search on metacpan

Jcode.pm  view on Meta::CPAN

    elsif ($$r_str =~ 
	   m[
	     $RE{JIS_0208}|$RE{JIS_0212}|$RE{JIS_ASC}|$RE{JIS_KANA}
	   ]ox)
    {
	($code, $nmatch) = ('jis', 1);
    } 
    else { # should be euc|sjis|utf8
	# use of (?:) by Hiroki Ohzaki <ohzaki@iod.ricoh.co.jp>
	$sjis += length($1) 
	    while $$r_str =~ /((?:$RE{SJIS_C})+)/go;
	$euc  += length($1) 
	    while $$r_str =~ /((?:$RE{EUC_C}|$RE{EUC_KANA}|$RE{EUC_0212})+)/go;
	$utf8 += length($1) 
	    while $$r_str =~ /((?:$RE{UTF8})+)/go;
	# $utf8 *= 1.5; # M. Takahashi's suggestion
	$nmatch = _max($utf8, $sjis, $euc);
	carp ">DEBUG:sjis = $sjis, euc = $euc, utf8 = $utf8" if $DEBUG >= 3;
	$code = 
	    ($euc > $sjis and $euc > $utf8) ? 'euc' :
		($sjis > $euc and $sjis > $utf8) ? 'sjis' :
		    ($utf8 > $euc and $utf8 > $sjis) ? 'utf8' : undef;
    }
    return wantarray ? ($code, $nmatch) : $code;
}

sub convert{
    my $r_str = (ref $_[0]) ? $_[0] : \$_[0];
    my (undef,$ocode,$icode,$opt) = @_;
    Encode::is_utf8($$r_str) and utf8::encode($$r_str);
    defined $icode or $icode = getcode($r_str) or return;
    $icode eq 'binary' and return $$r_str;

    $jname2e{$icode} and $icode = $jname2e{$icode};
    $jname2e{$ocode} and $ocode = $jname2e{$ocode};

    if ($opt){
	return $opt eq 'z' 
	    ? jcode($r_str, $icode)->h2z->$ocode
		: jcode($r_str, $icode)->z2h->$ocode ;
	    
    }else{
	if (Scalar::Util::readonly($$r_str)){
	    my $tmp = $$r_str;
	    Encode::from_to($tmp, $icode, $ocode);
	    return $tmp;
	}else{
	    Encode::from_to($$r_str, $icode, $ocode);
	    return $$r_str;
	}
    }
}

#######################################
# Constructors
#######################################

sub new{
    my $class = shift;
    my $self  = {};
    bless $self => $class;
    defined $_[0] or $_[0] = '';
    $self->set(@_);
}

sub set{
    my $self  = shift;
    my $str   = $_[0];
    my $r_str = (ref $str) ? $str : \$str;
    my $code  = $_[1] if(defined $_[1]);
    my $icode =  $code || getcode($r_str) || 'euc';
    $self->{icode}  = $jname2e{$icode} || $icode;
    # binary and flagged utf8 are stored as-is
    unless (Encode::is_utf8($$r_str) || $icode eq 'binary'){
	$$r_str = decode($self->{icode}, $$r_str);
    }
    $self->{r_str}  = $r_str;
    $self->{nmatch} = 0;
    $self->{method} = 'Encode';
    $self->{fallback} = $FALLBACK;
    $self;
}

sub append{
    my $self  = shift;
    my $str   = $_[0];
    my $r_str = (ref $str) ? $str : \$str;
    my $code  = $_[1] if(defined $_[1]);
    my $icode =  $code || getcode($r_str) || 'euc';
    $self->{icode}  = $jname2e{$icode} || $icode;
    # binary and flagged utf8 are stored as-is
    unless (Encode::is_utf8($$r_str) || $icode eq 'binary'){
	$$r_str = decode($self->{icode}, $$r_str);
    }
    ${ $self->{r_str} }  .= $$r_str;
    $self->{nmatch} = 0;
    $self->{method} = 'internal';
    $self;
}

#######################################
# Accessors
#######################################

for my $method (qw/r_str icode nmatch error_m error_r error_tr/){
    no strict 'refs';
    *{$method} = sub { $_[0]->{$method} };
}

sub fallback{
    my $self = shift;
    @_ or return $self->{fallback};
    $self->{fallback} =  $_[0]|Encode::LEAVE_SRC;
    return $self;
}

#######################################
# Converters
#######################################

sub utf8 { encode_utf8( ${$_[0]->{r_str}} ) }