Perlの正規表現のバグ? (前編)

「鬼車の[[:print:]]はPOSIX流じゃないらしい」でid:ockeghemさんやid:nihenさんと先週いろいろやりとりしてた中で、一つだけ解決していない問題があった。

utf8フラグが立っているかどうかでPOSIX文字クラスのマッチの挙動が変わるという件。

大変詳しい調査をありがとうございます。トラックバックのブログに書いたように、[:print:]の挙動は、Perlでもutf8フラグの有無でも変わってくるようです。[:print:]は実用できないなと思いました

え?まじ?と思うも、一応Perlのコード例も出していたので検証しないわけにはいかない。以下のようなコードで試してみたが、utf8フラグが立っていない場合と同じ結果となり、再現しないのだ。

use encoding 'utf8';

for (split //, "\t\r\n a") {
    printf("%d:%d:%d\n", ord($_), utf8::is_utf8($_), /[[:print:]]/);
}

結果 (5.10.0):

9:1:0
13:1:0
10:1:0
32:1:1
97:1:1

再現しないよーと言っていたら、id:ockeghemさんがテストコードを示してくれた (一部コメントをつける都合で改変)。

use utf8;

# LATIN SMALL LETEERのabc (U+0061, U+0062 and U+0063)
print "abc" =~ /^[[:print:]]+\z/ ? 'm' : 'u', "\n";
print "abc\t" =~ /^[[:print:]]+\z/ ? 'm' : 'u', "\n";

# FULLWIDTH LATIN SMALL LETTERのabc (U+FF41, U+FF42 and U+FF43)
print "ａｂｃ" =~ /^[[:print:]]+\z/ ? 'm' : 'u', "\n";
print "ａｂｃ\t" =~ /^[[:print:]]+\z/ ? 'm' : 'u', "\n";

なんで文字種を変えているかは、下記を参照。

確かにこれの結果は

m
u
m
m

となる。

ところで、utf8フラグが立っているときの正規表現マッチの挙動についてドキュメントを参照してみると、次のように書いてあった。

Regular Expressions

The regular expression compiler produces polymorphic opcodes. That is, the pattern adapts to the data and automatically switches to the Unicode character scheme when presented with data that is internally encoded in UTF-8 -- or instead uses a traditional byte scheme when presented with byte data.

perlunicode - perldoc

まあつまりパタン自体は文字コード中立なOPコードとして表現されるらしいのだけど、これは誤解を招く表現だ。というのは、パタン文字列自体がどう解釈されるかは別らしいから。実際 perlre を見ると、

The following equivalences to Unicode \p{} constructs and equivalent backslash character classes (if available), will hold:
           [[:...:]]   \p{...}         backslash

           alpha       IsAlpha
           alnum       IsAlnum
           ascii       IsASCII
           blank
           cntrl       IsCntrl
           digit       IsDigit        \d
           graph       IsGraph
           lower       IsLower
           print       IsPrint
           punct       IsPunct
           space       IsSpace
                       IsSpacePerl    \s
           upper       IsUpper
           word        IsWord
           xdigit      IsXDigit
For example ":lower:" and "\p{IsLower}" are equivalent.
If the "utf8" pragma is not used but the "locale" pragma is, the classes correlate with the usual isalpha(3) interface (except for "word" and "blank").
perlre - perldoc

もし utf8 プラグマではなく locale プラグマが使われている場合は、isalpha インターフェイスが使われます。

なぬ…。これは実際パタンがどのように解釈されてOPコードに変換されるのかを見てみるほかない。

re プラグマを使った正規表現のデバッグ

perldoc re してみると、

'Debug' mode
Similarly use re 'Debug' produces debugging output, the difference being that it allows the fine tuning of what debugging output will be emitted. Options are divided into three groups, those related to compilation, those related to execution and those related to special purposes. The options are as follows:
Compile related options

COMPILE Turns on all compile related debug options.

PARSE Turns on debug output related to the process of parsing the pattern.

OPTIMISE Enables output related to the optimisation phase of compilation.

TRIEC Detailed info about trie compilation.

DUMP Dump the final program out after it is compiled and optimised.

Execute related options

EXECUTE Turns on all execute related debug options.

MATCH Turns on debugging of the main matching loop.

TRIEE Extra debugging of how tries execute.

INTUIT Enable debugging of start point optimisations.

Extra debugging options

EXTRA Turns on all "extra" debugging options.

BUFFERS Enable debugging the capture buffer storage during match. Warning, this can potentially produce extremely large output.

TRIEM Enable enhanced TRIE debugging. Enhances both TRIEE and TRIEC.

STATE Enable debugging of states in the engine.

STACK Enable debugging of the recursion stack in the engine. Enabling or disabling this option automatically does the same for debugging states as well. This output from this can be quite large.

OPTIMISEM Enable enhanced optimisation debugging and start point optimisations. Probably not useful except when debugging the regex engine itself.
OFFSETS
Dump offset information. This can be used to see how regops correlate to the pattern. Output format is
NODENUM:POSITION[LENGTH]
Where 1 is the position of the first char in the string. Note that position can be 0, or larger than the actual length of the pattern, likewise length can be zero.
OFFSETSDBG Enable debugging of offsets information. This emits copious amounts of trace information and doesn't mesh well with other debug options. Almost definitely only useful to people hacking on the offsets part of the debug engine.

Other useful flags. These are useful shortcuts to save on the typing.

ALL Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
All
Enable DUMP and all execute options. Equivalent to:
use re 'debug';
MORE / More Enable TRIEM and all execute compile and execute options.
As of 5.9.5 the directive use re 'debug' and its equivalents are lexically scoped, as the other directives are. However they have both compile-time and run-time effects.
re - perldoc

Compile related options
COMPILE	Turns on all compile related debug options.
PARSE	Turns on debug output related to the process of parsing the pattern.
OPTIMISE	Enables output related to the optimisation phase of compilation.
TRIEC	Detailed info about trie compilation.
DUMP	Dump the final program out after it is compiled and optimised.
Execute related options
EXECUTE	Turns on all execute related debug options.
MATCH	Turns on debugging of the main matching loop.
TRIEE	Extra debugging of how tries execute.
INTUIT	Enable debugging of start point optimisations.
Extra debugging options
EXTRA	Turns on all "extra" debugging options.
BUFFERS	Enable debugging the capture buffer storage during match. Warning, this can potentially produce extremely large output.
TRIEM	Enable enhanced TRIE debugging. Enhances both TRIEE and TRIEC.
STATE	Enable debugging of states in the engine.
STACK	Enable debugging of the recursion stack in the engine. Enabling or disabling this option automatically does the same for debugging states as well. This output from this can be quite large.
OPTIMISEM	Enable enhanced optimisation debugging and start point optimisations. Probably not useful except when debugging the regex engine itself.
OFFSETS	Dump offset information. This can be used to see how regops correlate to the pattern. Output format is NODENUM:POSITION[LENGTH] Where 1 is the position of the first char in the string. Note that position can be 0, or larger than the actual length of the pattern, likewise length can be zero.
OFFSETSDBG	Enable debugging of offsets information. This emits copious amounts of trace information and doesn't mesh well with other debug options. Almost definitely only useful to people hacking on the offsets part of the debug engine.
Other useful flags. These are useful shortcuts to save on the typing.
ALL	Enable all options at once except OFFSETS, OFFSETSDBG and BUFFERS
All	Enable DUMP and all execute options. Equivalent to: use re 'debug';
MORE / More	Enable TRIEM and all execute compile and execute options.

とあるように

use re 'Debug', 'COMPILE';
qr(aho);

などとして実行してみると…

Compiling REx "aho"
Starting first pass (sizing)
 >aho<          |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
Required size 3 nodes
Starting second pass (creation)
 >aho<          |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 ><             |   4|    tail~ EXACT <aho> (1) -> END
first:>  1: EXACT <aho> (3)
first at 1
Peep>  1: EXACT <aho> (3)
  join>  1: EXACT <aho> (3)
minlen: 3 r->minlen:0
Final program:
   1: EXACT <aho> (3)
   3: END (0)
anchored "aho" at 0 (checking anchored isall) minlen 3 
r->extflags: CHECK_ALL USE_INTUIT_NOML USE_INTUIT_ML 
Freeing REx: "aho"

見事上のような出力が生成され、Perl 内部でどのように正規表現がコンパイルされているのかを目で追うことができるようになる。

じゃあ、というわけで、以下の3つを比較。

パタン1

use utf8;
qr([[:print:]]);
qr(\p{IsPrint});

パタン2

use bytes;
qr([[:print:]]);
qr(\p{IsPrint});

パタン3

use utf8;
use locale;
qr([[:print:]]);
qr(\p{IsPrint});

パタン4

use bytes;
use locale;
qr([[:print:]]);
qr(\p{IsPrint});

結果:

パタン1

Compiling REx "[[:print:]]"
Starting first pass (sizing)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
 ><             |  14|    tail~ ANYOF[ -~+utf8::IsPrint] (1) -> END
first:>  1: ANYOF[ -~+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF[ -~+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF[ -~+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF[ -~+utf8::IsPrint] minlen 1 
r->extflags: [none-set]
Compiling REx "\p{IsPrint}"
Starting first pass (sizing)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
 ><             |  14|    tail~ ANYOF[{unicode}+utf8::IsPrint] (1) -> END
first:>  1: ANYOF[{unicode}+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF[{unicode}+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF[{unicode}+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF[{unicode}+utf8::IsPrint] minlen 1 
r->extflags: [none-set]
Freeing REx: "[[:print:]]"
Freeing REx: "\p{IsPrint}"

パタン2

Compiling REx "[[:print:]]"
Starting first pass (sizing)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
 ><             |  14|    tail~ ANYOF[ -~+utf8::IsPrint] (1) -> END
first:>  1: ANYOF[ -~+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF[ -~+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF[ -~+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF[ -~+utf8::IsPrint] minlen 1 
r->extflags: [none-set]
Compiling REx "\p{IsPrint}"
Starting first pass (sizing)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
 ><             |  14|    tail~ ANYOF[{unicode}+utf8::IsPrint] (1) -> END
first:>  1: ANYOF[{unicode}+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF[{unicode}+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF[{unicode}+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF[{unicode}+utf8::IsPrint] minlen 1 
r->extflags: [none-set]
Freeing REx: "[[:print:]]"

パタン3

Compiling REx "[[:print:]]"
Starting first pass (sizing)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
 ><             |  14|    tail~ ANYOF{loc}[[:print:]+utf8::IsPrint] (1) -> END
first:>  1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF{loc}[[:print:]+utf8::IsPrint] minlen 1 
r->extflags: LOCALE 
Compiling REx "\p{IsPrint}"
Starting first pass (sizing)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
 ><             |  14|    tail~ ANYOF{loc}[{unicode}+utf8::IsPrint] (1) -> END
first:>  1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF{loc}[{unicode}+utf8::IsPrint] minlen 1 
r->extflags: LOCALE 
Freeing REx: "[[:print:]]"
Freeing REx: "\p{IsPrint}"

パタン4

Compiling REx "[[:print:]]"
Starting first pass (sizing)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >[[:print:]... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
 >[:print:]]<   |    |          clas   
 ><             |  14|    tail~ ANYOF{loc}[[:print:]+utf8::IsPrint] (1) -> END
first:>  1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF{loc}[[:print:]+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF{loc}[[:print:]+utf8::IsPrint] minlen 1 
r->extflags: LOCALE 
Compiling REx "\p{IsPrint}"
Starting first pass (sizing)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
Required size 13 nodes
Starting second pass (creation)
 >\p{IsPrint... |   1|  reg    
                |    |    brnc   
                |    |      piec   
                |    |        atom   
                |    |          clas   
 ><             |  14|    tail~ ANYOF{loc}[{unicode}+utf8::IsPrint] (1) -> END
first:>  1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
first at 1
Peep>  1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
minlen: 1 r->minlen:0
Final program:
   1: ANYOF{loc}[{unicode}+utf8::IsPrint] (13)
  13: END (0)
stclass ANYOF{loc}[{unicode}+utf8::IsPrint] minlen 1 
r->extflags: LOCALE 
Freeing REx: "[[:print:]]"
Freeing REx: "\p{IsPrint}"

分かったこと:

このケースでは少なくとも :print: と \p{IsPrint} は同じ OP コードにはならない
use bytes しても use utf8 してもコンパイル結果は一緒
use locale すると確かに {loc} がついた ANYOF コードが生成される
実は use locale と use utf8 は互いに排他的に働くわけではない

実際にマッチさせるとどうなるか。

use utf8;
my $a = "\t";
utf8::upgrade(my $b = $a);

print 0 + ($a =~ /[[:print:]]/), "\n";
print 0 + ($a =~ /\p{IsPrint}/), "\n";
print 0 + ($b =~ /[[:print:]]/), "\n";
print 0 + ($b =~ /\p{IsPrint}/), "\n";

use locale;
print 0 + ($a =~ /[[:print:]]/), "\n";
print 0 + ($a =~ /\p{IsPrint}/), "\n";
print 0 + ($b =~ /[[:print:]]/), "\n";
print 0 + ($b =~ /\p{IsPrint}/), "\n";

結果:

分かったこと:

このパタンでは少なくともutf8フラグの有無はマッチの結果に影響しない
locale プラグマがあっても結果は同じ
なんと :print: と \p{IsPrint} とではマッチの仕方が違う

うーん、というわけで最初のサンプルを、パタンを \p{IsPrint} にして試してみた。

use encoding 'utf8';

for (split //, "\t\r\n a") {
    printf("%d:%d:%d\n", ord($_), utf8::is_utf8($_), /\p{IsPrint}/);
}

結果:

9:1:1
13:1:1
10:1:1
32:1:1
97:1:1

確かに言われた通りの結果が得られたが、そもそも Unicode 的にタブ文字とかは IsPrint ではないのでは? と思うので、Unicode property のチェックを行っている箇所を調べてみる。ドキュメントに書いてなさげなのでソースに潜っていくしかないようだ。

ソースに潜っていく - 正規表現のコンパイラ編

regcomp.c が正規表現コンパイラのソースで、文字クラスをハンドルしている関数は S_regclass() だ。

まずは文字列を大まかにパースする処理が入る。

    while (RExC_parse < RExC_end && UCHARAT(RExC_parse) != ']') {
    charclassloop:
	namedclass = OOB_NAMEDCLASS; /* initialize as illegal */

        if (!range)
            rangebegin = RExC_parse;
        if (UTF) {
            value = utf8n_to_uvchr((U8*)RExC_parse,
                                   RExC_end - RExC_parse,
                                   &numlen, UTF8_ALLOW_DEFAULT);
            RExC_parse += numlen;
        }
        else
            value = UCHARAT(RExC_parse++);

        nextvalue = RExC_parse < RExC_end ? UCHARAT(RExC_parse) : 0;
        if (value == '[' && POSIXCC(nextvalue))
            namedclass = regpposixcc(pRExC_state, value);
        else if (value == '\\') {

            ... (略) ...

            switch ((I32)value) {
            case 'p':
            case 'P':
                {
                char *e;
                if (RExC_parse >= RExC_end)
                    vFAIL2("Empty \\%c{}", (U8)value);
                if (*RExC_parse == '{') {
                    const U8 c = (U8)value;
                    e = strchr(RExC_parse++, '}');
                    if (!e)
                        vFAIL2("Missing right brace on \\%c{}", c);
                    while (isSPACE(UCHARAT(RExC_parse)))
                        RExC_parse++;
                    if (e == RExC_parse)
                        vFAIL2("Empty \\%c{}", c);
                    n = e - RExC_parse;
                    while (isSPACE(UCHARAT(RExC_parse + n - 1)))
                        n--;
                }
                else {
                    e = RExC_parse;
                    n = 1;
                }
                if (!SIZE_ONLY) {
                    if (UCHARAT(RExC_parse) == '^') {
                         RExC_parse++;
                         n--;
                         value = value == 'p' ? 'P' : 'p'; /* toggle */
                         while (isSPACE(UCHARAT(RExC_parse))) {
                              RExC_parse++;
                              n--;
                         }
                    }
                    Perl_sv_catpvf(aTHX_ listsv, "%cutf8::%.*s\n",
                        (value=='p' ? '+' : '!'), (int)n, RExC_parse);
                }
                RExC_parse = e + 1;
                ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
                namedclass = ANYOF_MAX;  /* no official name, but it's named */
                }

                ... (略) ...
        }

ここで変数 ret の ANYOF_FLAGS と namedclass がセットされた後で、次のような後処理が行われている。

        if (namedclass > OOB_NAMEDCLASS) { /* this is a named class \blah */

            if (!SIZE_ONLY && !need_class)
                ANYOF_CLASS_ZERO(ret);

            need_class = 1;

            /* a bad range like a-\d, a-[:digit:] ? */
            if (range) {
                if (!SIZE_ONLY) {
                    if (ckWARN(WARN_REGEXP)) {
                        const int w =
                            RExC_parse >= rangebegin ?
                            RExC_parse - rangebegin : 0;
                        vWARN4(RExC_parse,
                               "False [] range \"%*.*s\"",
                               w, w, rangebegin);
                    }
                    if (prevvalue < 256) {
                        ANYOF_BITMAP_SET(ret, prevvalue);
                        ANYOF_BITMAP_SET(ret, '-');
                    }
                    else {
                        ANYOF_FLAGS(ret) |= ANYOF_UNICODE;
                        Perl_sv_catpvf(aTHX_ listsv,
                                       "%04"UVxf"\n%04"UVxf"\n", (UV)prevvalue, (UV) '-');
                    }
                }

                range = 0; /* this was not a true range */
            }


    
            if (!SIZE_ONLY) {
                const char *what = NULL;
                char yesno = 0;

                if (namedclass > OOB_NAMEDCLASS)
                    optimize_invert = FALSE;
                /* Possible truncation here but in some 64-bit environments
                 * the compiler gets heartburn about switch on 64-bit values.
                 * A similar issue a little earlier when switching on value.
                 * --jhi */
                switch ((I32)namedclass) {
                case _C_C_T_(ALNUM, isALNUM(value), "Word");
                case _C_C_T_(ALNUMC, isALNUMC(value), "Alnum");
                case _C_C_T_(ALPHA, isALPHA(value), "Alpha");
                case _C_C_T_(BLANK, isBLANK(value), "Blank");
                case _C_C_T_(CNTRL, isCNTRL(value), "Cntrl");
                case _C_C_T_(GRAPH, isGRAPH(value), "Graph");
                case _C_C_T_(LOWER, isLOWER(value), "Lower");
                case _C_C_T_(PRINT, isPRINT(value), "Print");
                case _C_C_T_(PSXSPC, isPSXSPC(value), "Space");
                case _C_C_T_(PUNCT, isPUNCT(value), "Punct");
                case _C_C_T_(SPACE, isSPACE(value), "SpacePerl");
                case _C_C_T_(UPPER, isUPPER(value), "Upper");
                case _C_C_T_(XDIGIT, isXDIGIT(value), "XDigit");
                case _C_C_T_NOLOC_(VERTWS, is_VERTWS_latin1(&value), "VertSpace");
                case _C_C_T_NOLOC_(HORIZWS, is_HORIZWS_latin1(&value), "HorizSpace");

                ... (略) ...

                case ANYOF_MAX:
                    /* this is to handle \p and \P */
                    break;
                default:
                    vFAIL("Invalid [::] class");
                    break;
                }
                if (what) {
                    /* Strings such as "+utf8::isWord\n" */
                    Perl_sv_catpvf(aTHX_ listsv, "%cutf8::Is%s\n", yesno, what);
                }
                if (LOC)
                    ANYOF_FLAGS(ret) |= ANYOF_CLASS;
                continue;
            }
        } /* end of namedclass \blah */
        ... (略) ...
    }

最後に listav の中身 ("+utf8:Print" のようになっているはず) を S_add_data() で作られたスロットに格納し、struct regnode_charclass_class の arg1 フィールドに、それへの参照となるスロット ID を格納して return する。なんで regnode に直接 AV を突っ込まないのかはよく分からないけど、このようにハンドルを経由した弱参照を使うというのは循環参照を防止するテクニックの一つなので、そういう理由があるのだと思われる。

    {
	AV * const av = newAV();
	SV *rv;
	/* The 0th element stores the character class description
	 * in its textual form: used later (regexec.c:Perl_regclass_swash())
	 * to initialize the appropriate swash (which gets stored in
	 * the 1st element), and also useful for dumping the regnode.
	 * The 2nd element stores the multicharacter foldings,
	 * used later (regexec.c:S_reginclass()). */
	av_store(av, 0, listsv);
	av_store(av, 1, NULL);
	av_store(av, 2, (SV*)unicode_alternate);
	rv = newRV_noinc((SV*)av);
	n = add_data(pRExC_state, 1, "s");
	RExC_rxi->data->data[n] = (void*)rv;
	ARG_SET(ret, n);
    }
    return ret;
}

ちなみに _C_C_T_ マクロの中身。

#define _C_C_T_(NAME,TEST,WORD)                         \
ANYOF_##NAME:                                           \
    if (LOC)                                            \
        ANYOF_CLASS_SET(ret, ANYOF_##NAME);             \
    else {                                              \
        for (value = 0; value < 256; value++)           \
            if (TEST)                                   \
                ANYOF_BITMAP_SET(ret, value);           \
    }                                                   \
    yesno = '+';                                        \
    what = WORD;                                        \
    break;                                              \
case ANYOF_N##NAME:                                     \
    if (LOC)                                            \
        ANYOF_CLASS_SET(ret, ANYOF_N##NAME);            \
    else {                                              \
        for (value = 0; value < 256; value++)           \
            if (!TEST)                                  \
                ANYOF_BITMAP_SET(ret, value);           \
    }                                                   \
    yesno = '!';                                        \
    what = WORD;                                        \
    break

そして is* の定義は handy.h に。

#define isALNUM(c)	(isALPHA(c) || isDIGIT(c) || (c) == '_')
#define isIDFIRST(c)	(isALPHA(c) || (c) == '_')
#define isALPHA(c)	(isUPPER(c) || isLOWER(c))
#define isSPACE(c) \
	((c) == ' ' || (c) == '\t' || (c) == '\n' || (c) =='\r' || (c) == '\f')
#define isPSXSPC(c)	(isSPACE(c) || (c) == '\v')
#define isBLANK(c)	((c) == ' ' || (c) == '\t')
#define isDIGIT(c)	((c) >= '0' && (c) <= '9')
#ifdef EBCDIC
    /* In EBCDIC we do not do locales: therefore() isupper() is fine. */
#   define isUPPER(c)	isupper(c)
#   define isLOWER(c)	islower(c)
#   define isALNUMC(c)	isalnum(c)
#   define isASCII(c)	isascii(c)
#   define isCNTRL(c)	iscntrl(c)
#   define isGRAPH(c)	isgraph(c)
#   define isPRINT(c)	isprint(c)
#   define isPUNCT(c)	ispunct(c)
#   define isXDIGIT(c)	isxdigit(c)
#   define toUPPER(c)	toupper(c)
#   define toLOWER(c)	tolower(c)
#else
#   define isUPPER(c)	((c) >= 'A' && (c) <= 'Z')
#   define isLOWER(c)	((c) >= 'a' && (c) <= 'z')
#   define isALNUMC(c)	(isALPHA(c) || isDIGIT(c))
#   define isASCII(c)	((c) <= 127)
#   define isCNTRL(c)	((c) < ' ' || (c) == 127)
#   define isGRAPH(c)	(isALNUM(c) || isPUNCT(c))
#   define isPRINT(c)	(((c) >= 32 && (c) < 127))
#   define isPUNCT(c)	(((c) >= 33 && (c) <= 47) || ((c) >= 58 && (c) <= 64)  || ((c) >= 91 && (c) <= 96) || ((c) >= 123 && (c) <= 126))
#   define isXDIGIT(c)  (isDIGIT(c) || ((c) >= 'a' && (c) <= 'f') || ((c) >= 'A' && (c) <= 'F'))
#   define toUPPER(c)	(isLOWER(c) ? (c) - ('a' - 'A') : (c))
#   define toLOWER(c)	(isUPPER(c) ? (c) + ('a' - 'A') : (c))
#endif

とりあえず以上から分かることは

少なくともコンパイル時には :print: と \p{IsPrint} は全く別モノとして処理される。
- :print:
  - locale プラグマが無効
    1. struct regnode_charclass の文字クラスに含まれる文字コードに対応するbitmapがセットされる。
  - locale プラグマが有効
    1. struct regnode_charclass_class の classflags の文字クラスに対応するフラグがセットされる。(コンパイル時には文字クラスと文字の対応が分からないから、rangeで指定された文字の集合とは別扱いする)
    2. struct regnode_charclass_class の classflags の flags に ANYOF_CLASS と ANYOF_LOCALE がセットされる。
- \p{IsPrint}
  - locale プラグマが無効
    - struct regnode_charclass_class の classflags の flags に ANYOF_UNICODE がセットされる。
  - locale プラグマが有効
    - struct regnode_charclass_class の classflags の flags に ANYOF_UNICODE と ANYOF_LOCALE がセットされる。
Unicode property の文字クラスで表された文字の集合は、locale 指定があったときと同様、ランタイムに処理される。

なので、実際どのように struct regnode が評価されているかを見ていく必要もありそうだ。それを行う関数群は regexec.c にある。

ソースに潜っていく - 正規表現マッチャー編

まずはプロローグを見てみる。

/*
 - regexec_flags - match a regexp against a string
 */
I32
Perl_regexec_flags(pTHX_ REGEXP * const prog, char *stringarg, register char *strend,
	      char *strbeg, I32 minend, SV *sv, void *data, U32 flags)
/* strend: pointer to null at end of string */
/* strbeg: real beginning of string */
/* minend: end of match must be >=minend after stringarg. */
/* data: May be used for some additional optimizations. 
         Currently its only used, with a U32 cast, for transmitting 
         the ganch offset when doing a /g match. This will change */
/* nosave: For optimizations. */
{
    ... (略) ...

    const bool do_utf8 = (bool)DO_UTF8(sv);
    I32 multiline;
    RXi_GET_DECL(prog,progi);

    ... (略) ...

    RX_MATCH_UTF8_set(prog, do_utf8);

この DO_UTF8 マクロの定義は utf8.h にある。

#define DO_UTF8(sv) (SvUTF8(sv) && !IN_BYTES)

SvUTF8(sv) は SV の utf8 フラグを示していて、IN_BYTES は use bytes; プラグマが有効なスコープにいるときに true となるフラグ。

また、RX_MATCH_UTF8_set と PL_reg_match_utf8 は regexp.h で下記のように定義されている。

#define RX_MATCH_UTF8_set(prog, t)      ((t) \
                        ? (RX_MATCH_UTF8_on(prog), (PL_reg_match_utf8 = 1)) \
                        : (RX_MATCH_UTF8_off(prog), (PL_reg_match_utf8 = 0)))

... (略) ...

#define PL_reg_match_utf8	PL_reg_state.re_state_reg_match_utf8

次に中身を見ていく。

    /* Simplest case:  anchored match need be tried only once. */
    /*  [unless only anchor is BOL and multiline is set] */
    if (prog->extflags & (RXf_ANCH & ~RXf_ANCH_GPOS)) {

        ... (略) ...

    } else if (RXf_GPOS_CHECK == (prog->extflags & RXf_GPOS_CHECK)) {

        ... (略) ...

    }

    /* Messy cases:  unanchored match. */
    if ((prog->anchored_substr || prog->anchored_utf8) && prog->intflags & PREGf_SKIP) {

        ... (略) ...

    } else if (prog->anchored_substr != NULL
	      || prog->anchored_utf8 != NULL
	      || ((prog->float_substr != NULL || prog->float_utf8 != NULL)
		  && prog->float_max_offset < strend - s)) {

        ... (略) ...

    } else if ( (c = progi->regstclass) ) {

        ... (略) ...

    } else {

        ... (略) ...

    }

なにやらいろいろなケース (アンカーがあるない等) で最適化のためにマッチの方法を変えているようだけど、ここでは深追いしないでとっとと先に進みたいので、各条件のブロックの先頭に printf() を仕込んでどこに飛ぶのかを見てみよう。

と、その前に待った。printf() などは nostdio.h で無効化されているのでそのままは使えない。他でデバッグ出力を行っている箇所を見ると

PerlIO_printf(Perl_debug_log, ...)

と書いてあるのでこれを真似する。

で、試してみたら

    } else if ( (c = progi->regstclass) ) {
        if (minlen) {
            const OPCODE op = OP(progi->regstclass);
            /* don't bother with what can't match */
            if (PL_regkind[op] != EXACT && op != CANY && PL_regkind[op] != TRIE)
                strend = HOPc(strend, -(minlen - 1));
        }
        DEBUG_EXECUTE_r({
            SV * const prop = sv_newmortal();
            regprop(prog, prop, c);
            {
                RE_PV_QUOTED_DECL(quoted,do_utf8,PERL_DEBUG_PAD_ZERO(1),
                    s,strend-s,60);
                PerlIO_printf(Perl_debug_log,
                    "Matching stclass %.*s against %s (%d chars)\n",
                    (int)SvCUR(prop), SvPVX_const(prop),
                     quoted, (int)(strend - s));
            }
        });
        if (find_byclass(prog, c, s, strend, &reginfo))
            goto got_it;
        DEBUG_EXECUTE_r(PerlIO_printf(Perl_debug_log, "Contradicts stclass... [regexec_flags]\n"));
    }

ここが呼ばれていて、見ると、最終的な処理は find_byclass() が担当しているようだ。ちなみに regprop() は Perl_regprop() として regcomp.c の中で定義されている、デバッグ出力用に OP コードを文字列にダンプするという関数だ。

今度は find_byclass() を見る。

STATIC char *
S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, 
    const char *strend, regmatch_info *reginfo)
{
    ... (略) ....
    register const bool do_utf8 = PL_reg_match_utf8;
    ... (略) ....

    /* We know what class it must start with. */
    switch (OP(c)) {
    case ANYOF:
        if (do_utf8) {
             REXEC_FBC_UTF8_CLASS_SCAN((ANYOF_FLAGS(c) & ANYOF_UNICODE) ||
                      !UTF8_IS_INVARIANT((U8)s[0]) ?
                      reginclass(prog, c, (U8*)s, 0, do_utf8) :
                      REGINCLASS(prog, c, (U8*)s));
        }
        else {
            while (s < strend) {
                STRLEN skip = 1;

                if (REGINCLASS(prog, c, (U8*)s) ||
                    (ANYOF_FOLD_SHARP_S(c, s, strend) &&
                    /* The assignment of 2 is intentional:
                     * for the folded sharp s, the skip is 2. */
                    (skip = SHARP_S_SKIP))) {
                    if (tmp && (!reginfo || regtry(reginfo, &s)))
                        goto got_it;
                    else
                        tmp = doevery;
                }
                else 
                    tmp = 1;
                s += skip;
            }
        }
        break;

    ... (略) ....

    }

    ... (略) ....
}

utf8モードのときとそうでないときで処理を変えている。今知りたいのはutf8モードの場合でかつ \p{...} がある場合なので reginclass(prog, c, (U8*)s, 0, do_utf8) の方をを見る必要があるようだ。

S_reginclass(pTHX_ const regexp *prog, register const regnode *n, register const U8* p, STRLEN* lenp, register bool do_utf8)
{
    dVAR;
    const char flags = ANYOF_FLAGS(n);
    bool match = FALSE;
    UV c = *p;
    STRLEN len = 0;
    STRLEN plen;

    if (do_utf8 && !UTF8_IS_INVARIANT(c)) {
	c = utf8n_to_uvchr(p, UTF8_MAXBYTES, &len,
		(UTF8_ALLOW_DEFAULT & UTF8_ALLOW_ANYUV) | UTF8_CHECK_ONLY);
		/* see [perl #37836] for UTF8_ALLOW_ANYUV */
	if (len == (STRLEN)-1) 
	    Perl_croak(aTHX_ "Malformed UTF-8 character (fatal)");
    }

まずは utf8n_to_uvchr() で UTF-8 の文字列の最初の文字を Unicode 文字コードに変換する。

で、utf8モードか文字クラスのフラグが ANYOF_UNICODE だった場合の処理:

    plen = lenp ? *lenp : UNISKIP(NATIVE_TO_UNI(c));
    if (do_utf8 || (flags & ANYOF_UNICODE)) {
        if (lenp)
	    *lenp = 0;
	if (do_utf8 && !ANYOF_RUNTIME(n)) {
	    if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
		match = TRUE;
	}
	if (!match && do_utf8 && (flags & ANYOF_UNICODE_ALL) && c >= 256)
	    match = TRUE;
	if (!match) {
	    AV *av;
	    SV * const sw = regclass_swash(prog, n, TRUE, 0, (SV**)&av);
	
	    if (sw) {
		if (swash_fetch(sw, p, do_utf8))
		    match = TRUE;
		else if (flags & ANYOF_FOLD) {
		    if (!match && lenp && av) {
		        I32 i;
			for (i = 0; i <= av_len(av); i++) {
			    SV* const sv = *av_fetch(av, i, FALSE);
			    STRLEN len;
			    const char * const s = SvPV_const(sv, len);
			
			    if (len <= plen && memEQ(s, (char*)p, len)) {
			        *lenp = len;
				match = TRUE;
				break;
			    }
			}
		    }
		    if (!match) {
		        U8 tmpbuf[UTF8_MAXBYTES_CASE+1];
			STRLEN tmplen;

		        to_utf8_fold(p, tmpbuf, &tmplen);
			if (swash_fetch(sw, tmpbuf, do_utf8))
			    match = TRUE;
		    }
		}
	    }
	}
	if (match && lenp && *lenp == 0)
	    *lenp = UNISKIP(NATIVE_TO_UNI(c));
    }

あれ?

	if (do_utf8 && !ANYOF_RUNTIME(n)) {
	    if (len != (STRLEN)-1 && c < 256 && ANYOF_BITMAP_TEST(n, c))
		match = TRUE;
	}

これって… ANYOF_CLASS や ANYOF_LOCALE フラグが立ってない場合は utf8 モードでも普通の bitmap マッチを行っちゃうのか。あちゃー。てことは、もし bitmap の示す文字の集合と Unicode property の示す文字の集合が異なる場合はバグということになる。でも、今回は Unicode property の方が大きな集合であることが問題なので関係ない。

さて、どこで文字クラスを判別するかだけど、regclass_swash() で regcomp の最後の方で arg1 に設定した AV から sw を取り出して、 swash_fetch() で実際にマッチするかどうかをチェックすることでそれを行っている。

regclass_swash() を見る。

SV *
Perl_regclass_swash(pTHX_ const regexp *prog, register const regnode* node, bool doinit, SV** listsvp, SV **altsvp)
{
    dVAR;
    SV *sw  = NULL;
    SV *si  = NULL;
    SV *alt = NULL;
    RXi_GET_DECL(prog,progi);
    const struct reg_data * const data = prog ? progi->data : NULL;

    if (data && data->count) {
	const U32 n = ARG(node);

	if (data->what[n] == 's') {
	    SV * const rv = (SV*)data->data[n];
	    AV * const av = (AV*)SvRV((SV*)rv);
	    SV **const ary = AvARRAY(av);
	    SV **a, **b;
	
	    /* See the end of regcomp.c:S_regclass() for
	     * documentation of these array elements. */

	    si = *ary;
	    a  = SvROK(ary[1]) ? &ary[1] : NULL;
	    b  = SvTYPE(ary[2]) == SVt_PVAV ? &ary[2] : NULL;

	    if (a)
		sw = *a;
	    else if (si && doinit) {
		sw = swash_init("utf8", "", si, 1, 0);
		(void)av_store(av, 1, sw);
	    }
	    if (b)
	        alt = *b;
	}
    }
	
    if (listsvp)
	*listsvp = si;
    if (altsvp)
	*altsvp  = alt;

    return sw;
}

swash_init() で sw を取り出していた。swash_init() は utf8.c にある。

/* Note:
 * A "swash" is a swatch hash.
 * A "swatch" is a bit vector generated by utf8.c:S_swash_get().
 * C<pkg> is a pointer to a package name for SWASHNEW, should be "utf8".
 * For other parameters, see utf8::SWASHNEW in lib/utf8_heavy.pl.
 */
SV*
Perl_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 minbits, I32 none)
{
    dVAR;
    SV* retval;
    dSP;
    const size_t pkg_len = strlen(pkg);
    const size_t name_len = strlen(name);
    HV * const stash = gv_stashpvn(pkg, pkg_len, 0);
    SV* errsv_save;

    PUSHSTACKi(PERLSI_MAGIC);
    ENTER;
    SAVEI32(PL_hints);
    PL_hints = 0;
    save_re_context();
    if (!gv_fetchmeth(stash, "SWASHNEW", 8, -1)) {	/* demand load utf8 */
	ENTER;
	errsv_save = newSVsv(ERRSV);
	/* It is assumed that callers of this routine are not passing in any
	   user derived data.  */
	/* Need to do this after save_re_context() as it will set PL_tainted to
	   1 while saving $1 etc (see the code after getrx: in Perl_magic_get).
	   Even line to create errsv_save can turn on PL_tainted.  */
	SAVEBOOL(PL_tainted);
	PL_tainted = 0;
	Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len),
			 NULL);
	if (!SvTRUE(ERRSV))
	    sv_setsv(ERRSV, errsv_save);
	SvREFCNT_dec(errsv_save);
	LEAVE;
    }
    SPAGAIN;
    PUSHMARK(SP);
    EXTEND(SP,5);
    PUSHs(sv_2mortal(newSVpvn(pkg, pkg_len)));
    PUSHs(sv_2mortal(newSVpvn(name, name_len)));
    PUSHs(listsv);
    PUSHs(sv_2mortal(newSViv(minbits)));
    PUSHs(sv_2mortal(newSViv(none)));
    PUTBACK;
    errsv_save = newSVsv(ERRSV);
    if (call_method("SWASHNEW", G_SCALAR))
	retval = newSVsv(*PL_stack_sp--);
    else
	retval = &PL_sv_undef;
    if (!SvTRUE(ERRSV))
	sv_setsv(ERRSV, errsv_save);
    SvREFCNT_dec(errsv_save);
    LEAVE;
    POPSTACK;
    if (IN_PERL_COMPILETIME) {
	CopHINTS_set(PL_curcop, PL_hints);
    }
    if (!SvROK(retval) || SvTYPE(SvRV(retval)) != SVt_PVHV) {
        if (SvPOK(retval))
	    Perl_croak(aTHX_ "Can't find Unicode property definition \"%"SVf"\"",
		       SVfARG(retval));
	Perl_croak(aTHX_ "SWASHNEW didn't return an HV ref");
    }
    return retval;
}

gv_stashpvn()で取得する stash というのは、「404 Blog Not Found: perl - package と stash を理解する」にあるように、pkg が表すパッケージの名前空間だ。そこに含まれる (かあるいは @ISA / UNIVERSAL スコープチェインで辿れる stash に含まれる) SWASHNEW という glob が表す関数を呼び出している。

で、ここでいうパッケージというのは "utf8" なので、utf8::SWASHNEW の戻り値が sw の正体ということになる。じゃあこの utf8::SWASHNEW はどこで定義されているかという話になるけども、これは utf8.c を perldoc で眺めると分かる通り

Both the special and normal mappings are stored lib/unicore/To/Foo.pl, and loaded by SWASHNEW, using lib/utf8_heavy.pl. The special (usually, but not always, a multicharacter mapping), is tried first.

lib/utf8_heavy.pl で定義されている、ってことはつまりここは C ではなくスクリプトでハンドルされているってことだ。lib/utf8.pm を見ると、確かに

sub AUTOLOAD {
    require "utf8_heavy.pl";
    goto &$AUTOLOAD if defined &$AUTOLOAD;
    require Carp;
    Carp::croak("Undefined subroutine $AUTOLOAD called");
}

で autoload されている。

SWASHNEW - lib/utf8_heavy.pl

で、lib/utf8_heavy.pl の中身。

sub SWASHNEW {
    my ($class, $type, $list, $minbits, $none) = @_;
    local $^D = 0 if $^D;

    if ($type)
    {
        $type =~ s/^\s+//;
        $type =~ s/\s+$//;

        print STDERR "type = $type\n" if DEBUG;

      GETFILE:
        {
            ... (略) ...
        }

	if (defined $file) {
	    print STDERR "found it (file='$file')\n" if DEBUG;

	    ##
	    ## If we reach here, it was due to a 'last GETFILE' above
	    ## (exception: user-defined properties and mappings), so we
	    ## have a filename, so now we load it if we haven't already.
	    ## If we have, return the cached results. The cache key is the
	    ## class and file to load.
	    ##
	    my $found = $Cache{$class, $file};
	    if ($found and ref($found) eq $class) {
		print STDERR "Returning cached '$file' for \\p{$type}\n" if DEBUG;
		return $found;
	    }

	    $list = do $file; die $@ if $@;
	}

        $ListSorted = 1; ## we know that these lists are sorted
    }

    ... (略) ...

    my $SWASH = bless {
	TYPE => $type,
	BITS => $bits,
	EXTRAS => $extras,
	LIST => $list,
	NONE => $none,
	@extras,
    } => $class;

    if ($file) {
        $Cache{$class, $file} = $SWASH;
    }

    return $SWASH;
}

まあつまり GETFILE とラベルづけされたブロックの中で $file を決定してそれを読み込んだ結果を swash の LIST という要素の中に突っ込んでるわけですな。

で、まあ実際デバッグ出力を仕込んだりして試してみると、最終的に lib/unicore/lib/gc_sc/Print.pl が読み込まれているということが分かり、

lib/unicode/lib/gc_sc/Print.pl:

# !!!!!!!   DO NOT EDIT THIS FILE   !!!!!!! 
# This file is built by mktables from e.g. UnicodeData.txt.
# Any changes made here will be lost!

#
# This file supports:
# 	\p{Print}
# 
# Meaning: [[:Print:]]
#
return <<'END';
0009	000D	
0020	007E	

... (略) ...

U+0009 (HT)
U+000A (LF)
U+000B (VT)
U+000C (FF)
U+000D (CR)

とまあ、これらすべて Print 文字クラスに含まれていることが明らかになりましたと。

って TR #18 に準拠してないじゃん!

まあ、前も書いた通り、してないからだめってわけでもないんですが。

(もう息切れしたので後編に続く)

Appendix: use utf8 プラグマが指定された時の文字列リテラルとutf8フラグ

「わざわざそんなこと書かれなくても知ってるよ!」と言われてしまいそうだけど、一応perldoc utf8の次の部分に書いてある挙動によるものだ。

Enabling the "utf8" pragma has the following effect:

Bytes in the source text that have their high-bit set will be
treated as being part of a literal UTF-X sequence. This includes
most literals such as identifier names, string constants, and
constant regular expression patterns.

On EBCDIC platforms characters in the Latin 1 character set are
treated as being part of a literal UTF-EBCDIC character.

utf8 - perldoc

まあつまり high-bit (8ビット目) が 1 であるようなバイト列を持つ文字列リテラルは UTF-8 シーケンス (EBCDIC プラットフォームの場合は UTF-EBCDIC) と判断され、utf8 フラグが 1 にセットされるけど、それ以外の場合は utf8 フラグはセットされず、従来どおりのバイト列として扱われますよ、ということ。
似たようなことが utf8::upgrade() と utf8::decode() の違いにも現れてくる。utf8::decode() は、引数に与えられたバイト列に UTF-8 のマルチバイトシーケンスが含まれている場合にのみ utf8 フラグをセットする一方、utf8::upgrade() は、与えられたバイト列が ISO-8859-1 (EBCDIC) でエンコードされているとみなし、これを UTF-8 文字列に変換した上で utf8 フラグをセットする。
my $a = "This is an UTF-8 encoded string if this doesn't look like that.";
utf8::decode($a);
printf("%d\n", utf8::is_utf8($a));

my $b = "Hey, this is an UTF-8 encoded string if this... Come on man.";
utf8::upgrade($b);
printf("%d\n", utf8::is_utf8($b));
結果:
0
1
ただし、utf8::decode() の場合は、ただ8ビット目が 1 であるだけではだめで、正しい UTF-8 (UTF-EBCDIC) 文字列でないといけないところが違う。
print eval "use utf8; my \$a = qq(\xffabc); utf8::is_utf8(\$a);", "\n";

my $a = qq(\xffabc);
print 0 + utf8::decode($a);
print 0 + utf8::is_utf8($a), "\n";

my $b = qq(\xef\xbd\x81);
print 0 + utf8::decode($b), "\n";
print 0 + utf8::is_utf8($b), "\n";
結果:
Malformed UTF-8 character (byte 0xff) at (eval 1) line 1.
1
0
0
1
1