File Coverage

blib/lib/Text/Sprintf/Zenkaku.pm

Criterion	Covered	Total	%
statement	140	140	100.0
branch	54	54	100.0
condition	2	2	100.0
subroutine	9	9	100.0
pod	2	2	100.0
total	207	207	100.0

package Text::Sprintf::Zenkaku;
use 5.008001;
use strict;
use warnings;
use utf8;
use Carp;
use Encode;

our $VERSION = "0.07";

use Exporter 'import';
our @EXPORT_OK = qw(sprintf);

our $cp932 = Encode::find_encoding("cp932");

our $conversions = $] lt 5.022000 ? qr/\A[cduoxefgXEGbBpn]\Z/ : qr/\A[cduoxefgXEGbBpnaA]\Z/;

sub calc_width {
    my ($w, $s) = @_;

    my $ofs;
    if ($w >= 0) {
        $ofs = $w - ((length $cp932->encode($s)) - (length $s));
    } else {
        $ofs = (abs $w) - ((length $cp932->encode($s)) - (length $s));
        $ofs *= -1;
    }

    return $ofs;
}

sub sprintf {
    my @argv = @_;
    my $fmt  = $argv[0] // "";

    my $ofs   = 0;
    my $state = "IDL";

    my $index   = 1;
    my $tmp     = "";
    my $fmt_new = "";
    my $length  = length $fmt;
    my $is_uniq = {};

    while ($ofs < $length) {
        my $s = substr $fmt, $ofs, 1;
        if ($state eq "IDL") {
            if ($s eq "%") {
                $tmp   = $s;
                $state = "READ_FORMAT";
            } else {
                $fmt_new .= $s;
            }
        } elsif ($state eq "READ_FORMAT") {
            if ($s eq "%") {
                # 'a percent sign' literal
                $fmt_new .= $tmp . $s;
                $tmp = "";
                $state = "IDL";

            } elsif ($s eq "s") {
                # %s
                $tmp .= $s;

                if ($tmp =~ /^%([1-9][0-9]*)\$( *)\*([1-9][0-9]*)\$s$/) {
                    my $s_index = int $1;
                    my $space   = $2;
                    my $w_index = int $3;

                    my $s = $_[$s_index];
                    my $w = $_[$w_index];

                    my $width = calc_width($w, $s);
                    if (not exists $is_uniq->{$w_index}) {
                        $argv[$w_index] = $width;
                        $is_uniq->{$w_index}++;
                    } else {
                        $tmp = '%' . $s_index . '$' . $space . $width . 's';
                    }

                } elsif ($tmp =~ /^%([1-9][0-9]*)\$( *)\*s$/) {
                    my $s_index = int $1;
                    my $space   = $2;
                    my $w_index = $index;

                    my $s = $_[$s_index];
                    my $w = $_[$w_index];

                    my $width = calc_width($w, $s);
                    if (not exists $is_uniq->{$w_index}) {
                        $argv[$w_index] = $width;
                        $is_uniq->{$w_index}++;
                    } else {
                        $tmp = '%' . $s_index . '$' . $space . $width . 's';
                    }
                    $index++;

                } elsif ($tmp =~ /^%([1-9][0-9]*)\$( *)(-?[0-9]+)s$/) {
                    my $s_index = int $1;
                    my $space   = $2;

                    my $s = $_[$s_index];
                    my $w = $3;

                    $w = calc_width($w, $s);

                    $tmp = '%' . $s_index . '$' . $space . $w . 's';
                    $index++;

                } elsif ($tmp =~ /^%([1-9][0-9]*)\$( *)s$/) {
                    # do nothing
                    $index++;

                } elsif ($tmp =~ /^%( *)\*([1-9][0-9]*)\$s$/) {
                    my $s_index = $index;
                    my $space   = $1;
                    my $w_index = int $2;

                    my $s = $_[$s_index];
                    my $w = $_[$w_index];

                    my $width = calc_width($w, $s);
                    if (not exists $is_uniq->{$w_index}) {
                        $argv[$w_index] = $width;
                        $is_uniq->{$w_index}++;
                    } else {
                        $tmp = '%' . $space . $width . 's';
                    }
                    $index++;

                } elsif ($tmp =~ /^%( *)\*s$/) {
                    my $s_index = $index + 1;
                    my $space   = $1;
                    my $w_index = $index;
                    $index++;

                    my $s = $_[$s_index];
                    my $w = $_[$w_index];

                    my $width = calc_width($w, $s);

                    if (not exists $is_uniq->{$w_index}) {
                        $argv[$w_index] = $width;
                        $is_uniq->{$w_index}++;
                    } else {
                        #$tmp = '%' . $space . $width . 's';
                        $argv[$w_index] = $width;
                        $is_uniq->{$w_index}++;
                    }
                    $index++;

                } elsif ($tmp =~ /^%( *)(-?[0-9]+)s$/) {
                    my $space   = $1;

                    my $s = $_[$index];
                    my $w = int $2;

                    $w = calc_width($w, $s);

                    $tmp = '%' . $space . $w . 's';
                    $index++;

                } else {
                    # do nothing
                    $index++;

                }

                $fmt_new .= $tmp;
                $tmp = "";
                $state = "IDL";
            } elsif ($s =~ /$conversions/) {
                # %c, %d, %u, %o, %x, %e, %f, %g, ...
                $fmt_new .= $tmp . $s;
                $tmp = "";
                $index++;
                $state = "IDL";
            } elsif ($s eq "*") {
                $tmp .= $s;
                $state = "READ_ARGUMENT_NUMBER";
            } elsif ($s =~ /\A[0-9]\Z/) {
                $tmp .= $s;
                $state = "READ_FORMAT_OR_ARGUMENT_NUMBER";
            } elsif ($s =~ /\A[-+ #\.v]\Z/) {
                $tmp .= $s;
                if ($tmp =~ /\*v/) {
                    $index++;
                }
            } else {
                croak "not supported : $fmt";
            }
        } elsif ($state eq "READ_ARGUMENT_NUMBER") {
            if ($s =~ /\A[0-9]\Z/) {
                $tmp .= $s;
            } elsif ($s eq '$') {
                $tmp .= $s;
                $state = "READ_FORMAT";
            } else {
                $state = "READ_FORMAT";
                #$index++;
                next;
            }
        } else {
            # $state eq "READ_FORMAT_OR_ARGUMENT_NUMBER"
            if ($s =~ /\A[0-9]\Z/) {
                $tmp .= $s;
            } elsif ($s eq '$') {
                $tmp .= $s;
                $state = "READ_FORMAT";
            } else {
                $state = "READ_FORMAT";
                next;
            }
        }
        $ofs++;
    }

    $fmt_new .= $tmp;

    shift @argv;
    return CORE::sprintf $fmt_new, @argv;
}

1;
__END__