view release on metacpan or  search on metacpan

lib/BATsh/MB.pm  view on Meta::CPAN

    # Deliberately NOT /o: the classes change when the active encoding
    # changes, so the substitution must be recompiled per call.
    $s =~ s/([$LEAD])([$TRAIL])/
        do {
            my ($lb, $tb) = ($1, $2);
            $tb =~ m<\A[$DANGER]\z>
                ? "\x01" . $lb . chr(ord($tb) + 0x80)
                : $lb . $tb
        }
    /gex;
    return $s;
}

sub dec {
    my ($s) = @_;
    return $s unless $ACTIVE && defined $s;
    return $s unless index($s, "\x01") >= 0;
    $s =~ s/\x01(\x01|[$LEAD][\xc0-\xfe])/
        $1 eq "\x01"
            ? "\x01"
            : substr($1, 0, 1) . chr(ord(substr($1, 1, 1)) - 0x80)
    /gex;
    return $s;
}

# ----------------------------------------------------------------
# Character-oriented helpers, operating on GUARDED strings.
# While the guard is inactive they fall back to byte semantics, so
# existing ASCII behaviour is preserved bit-for-bit.
#
#   mb_length($guarded)             -> number of characters
#   mb_substr($guarded, $off, $len) -> guarded substring by characters
#       $off may be negative (counts back from the end, like substr);
#       $len may be omitted (rest of string).
# ----------------------------------------------------------------
sub mb_length {
    my ($s) = @_;
    return 0 unless defined $s;
    return length($s) unless $ACTIVE;
    my $chars = _mb_chars(dec($s));
    return scalar @{$chars};
}

sub mb_substr {
    my ($s, $off, $len) = @_;
    return '' unless defined $s;
    unless ($ACTIVE) {
        return defined $len ? substr($s, $off, $len) : substr($s, $off);
    }
    my $chars = _mb_chars(dec($s));
    my $n = scalar @{$chars};
    $off = $n + $off if $off < 0;
    $off = 0 if $off < 0;
    return '' if $off >= $n;
    my $end = defined $len ? $off + $len : $n;
    $end = $n if $end > $n;
    return '' if $end <= $off;
    return enc(join('', @{$chars}[$off .. $end - 1]));
}

# Split RAW (decoded) DBCS bytes into characters, forward-scanning:
# a lead byte followed by a valid trail byte forms one two-byte
# character; anything else is a single byte.
sub _mb_chars {
    my ($s) = @_;
    my @c = ();
    my $i = 0;
    my $n = length($s);
    while ($i < $n) {
        my $b = substr($s, $i, 1);
        if ($b =~ /[$LEAD]/ && $i + 1 < $n
            && substr($s, $i + 1, 1) =~ /[$TRAIL]/) {
            push @c, substr($s, $i, 2);
            $i += 2;
        }
        else {
            push @c, $b;
            $i++;
        }
    }
    return [ @c ];
}

# ----------------------------------------------------------------
# strip_bom: remove a UTF-8 byte-order mark from the head of the
# first script line (harmless everywhere, required for editors that
# save UTF-8-with-BOM).
# ----------------------------------------------------------------
sub strip_bom {
    my $s = defined $_[0] && $_[0] !~ /\ABATsh::MB\z/ ? $_[0] : $_[1];
    return $s unless defined $s;
    $s =~ s/\A\xef\xbb\xbf//;
    return $s;
}

1;

__END__

=head1 NAME

BATsh::MB - Multibyte (CP932/DBCS) script guard for BATsh

=head1 VERSION

Version 0.08

=head1 SYNOPSIS

  use BATsh;

  # Explicit encoding
  BATsh->run('nihongo.batsh', encoding => 'cp932');

  # Or rely on auto-detection (the default):
  # a non-UTF-8 script containing bytes >= 0x80 is treated as CP932
  BATsh->run('nihongo.batsh');

  # Environment-variable override
  #   set BATSH_ENCODING=cp932