integrate changes#6252..6256,6259..6260

       Paranoia tweak on #6249.
       Subject: Re: [PATCH 5.6.0 IPC/Open3.pm] Allow the use of numeric fd's
       From: Ronald J Kimball <rjk@linguist.dartmouth.edu>
       Date: Sun, 25 Jun 2000 23:43:12 -0400
       Message-ID: <20000625234312.B74147@linguist.dartmouth.edu>

       Subject: tr///, help wanted.
       From: simon@brecon.co.uk (Simon Cozens)
       Date: 28 Jun 2000 11:29:04 GMT
       Message-ID: <slrn8ljoc0.fbd.simon@justanother.perlhacker.org>

       small thinko tweaks

       tweaks from Simon Conzes to further fix tr/// under utf8

       perlnewmod was missing from MANIFEST.

       Subject: Re: [PATCH] pack('U',$foo) doesn't UTF8
       From: simon@brecon.co.uk (Simon Cozens)
       Date: 17 Jun 2000 11:56:44 GMT
       Message-ID: <slrn8kmprs.8pl.simon@justanother.perlhacker.org>
       pack U0, pack C0

p4raw-link: @6260 on //depot/cfgperl: fc865a0069737312ca5ef9762fe8a9be7aa37747
p4raw-link: @6259 on //depot/cfgperl: db7b835c9e42b04aa9fc7b2a56a8dfdefbfa3897
p4raw-link: @6256 on //depot/cfgperl: 840fae749c0f73a5c45e749c3ffa2b8a76b2cb14
p4raw-link: @6252 on //depot/cfgperl: 0e4dedf1581344244dfa297db1d00c01c5f821aa

p4raw-id: //depot/maint-5.6/perl@7768
p4raw-integrated: from //depot/cfgperl@7767 'copy in' t/op/pack.t
	(@5996..) pp_proto.h (@6243..) t/op/my_stash.t (@6250..) 'edit
	in' lib/IPC/Open3.pm (@6253..) 'ignore' t/pragma/constant.t
	(@5717..) t/pragma/warn/op (@5996..) lib/Exporter.pm (@6251..)
p4raw-integrated: from //depot/cfgperl@6260 'copy in' pp.c (@6217..)
	pod/perlfunc.pod (@6248..)
p4raw-integrated: from //depot/cfgperl@6259 'merge in' MANIFEST
	(@6250..)
p4raw-integrated: from //depot/cfgperl@6257 'ignore' sv.c (@6244..)
	'merge in' op.c (@6228..)
p4raw-integrated: from //depot/cfgperl@6256 'edit in' doop.c (@6254..)
p4raw-integrated: from //depot/cfgperl@6254 'copy in' t/op/tr.t
	(@6192..) embed.h objXSUB.h (@6243..) embed.pl global.sym
	proto.h (@6250..) 'ignore' embedvar.h (@6243..)

diff --git a/MANIFEST b/MANIFEST
index 2a12a29..442787f 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -1162,6 +1162,7 @@ pod/perlmodinstall.pod    Installing CPAN Modules
 pod/perlmodlib.pod     Module policy info
 pod/perlmodlib.PL      Generate pod/perlmodlib.pod
 pod/perlnumber.pod     Semantics of numbers and numeric operations
+pod/perlnewmod.pod     Preparing a new module for distribution
 pod/perlobj.pod                Object info
 pod/perlop.pod         Operator info
 pod/perlopentut.pod    open() tutorial

diff --git a/doop.c b/doop.c
index 64521b8..6c96cbf 100644 (file)
--- a/doop.c
+++ b/doop.c
@@ -20,12 +20,13 @@
 #endif
 
 STATIC I32
-S_do_trans_CC_simple(pTHX_ SV *sv)
+S_do_trans_simple(pTHX_ SV *sv) /* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
     I32 ch;
@@ -38,11 +39,15 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
-       if ((ch = tbl[*s]) >= 0) {
-           matches++;
-           *s = ch;
-       }
+        if (hasutf && *s & 0x80)
+            s+=UTF8SKIP(s); /* Given that we're here because tbl is !UTF8...*/
+        else {
+           if ((ch = tbl[*s]) >= 0) {
+               matches++;
+               *s = ch;
+           }
        s++;
+        }
     }
     SvSETMAGIC(sv);
 
@@ -50,12 +55,13 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_CC_count(pTHX_ SV *sv)
+S_do_trans_count(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
 
@@ -67,21 +73,26 @@ S_do_trans_CC_count(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
-       if (tbl[*s] >= 0)
-           matches++;
-       s++;
+        if (hasutf && *s & 0x80)
+            s+=UTF8SKIP(s);
+        else {
+            if (tbl[*s] >= 0)
+                matches++;
+            s++;
+        }
     }
 
     return matches;
 }
 
 STATIC I32
-S_do_trans_CC_complex(pTHX_ SV *sv)
+S_do_trans_complex(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    I32 hasutf = SvUTF8(sv);
     I32 matches = 0;
     STRLEN len;
     short *tbl;
@@ -99,29 +110,37 @@ S_do_trans_CC_complex(pTHX_ SV *sv)
        U8* p = send;
 
        while (s < send) {
-           if ((ch = tbl[*s]) >= 0) {
-               *d = ch;
-               matches++;
-               if (p == d - 1 && *p == *d)
-                   matches--;
-               else
-                   p = d++;
-           }
-           else if (ch == -1)          /* -1 is unmapped character */
-               *d++ = *s;              /* -2 is delete character */
-           s++;
+            if (hasutf && *s & 0x80)
+                s+=UTF8SKIP(s);
+            else {
+               if ((ch = tbl[*s]) >= 0) {
+                   *d = ch;
+                   matches++;
+                   if (p == d - 1 && *p == *d)
+                       matches--;
+                   else
+                       p = d++;
+               }
+               else if (ch == -1)              /* -1 is unmapped character */
+                   *d++ = *s;          /* -2 is delete character */
+               s++;
+            }
        }
     }
     else {
        while (s < send) {
-           if ((ch = tbl[*s]) >= 0) {
-               *d = ch;
-               matches++;
-               d++;
-           }
-           else if (ch == -1)          /* -1 is unmapped character */
-               *d++ = *s;              /* -2 is delete character */
-           s++;
+            if (hasutf && *s & 0x80)
+                s+=UTF8SKIP(s);
+            else {
+               if ((ch = tbl[*s]) >= 0) {
+                   *d = ch;
+                   matches++;
+                   d++;
+               }
+               else if (ch == -1)              /* -1 is unmapped character */
+                   *d++ = *s;          /* -2 is delete character */
+               s++;
+            }
        }
     }
     matches += send - d;       /* account for disappeared chars */
@@ -133,12 +152,14 @@ S_do_trans_CC_complex(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_UU_simple(pTHX_ SV *sv)
+S_do_trans_simple_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    U8 *start;
+    U8 *dstart;
     I32 matches = 0;
     STRLEN len;
 
@@ -149,43 +170,83 @@ S_do_trans_UU_simple(pTHX_ SV *sv)
     UV extra = none + 1;
     UV final;
     UV uv;
+    I32 isutf; 
+    I32 howmany;
 
+    isutf = SvUTF8(sv);
     s = (U8*)SvPV(sv, len);
     send = s + len;
+    start = s;
 
     svp = hv_fetch(hv, "FINAL", 5, FALSE);
     if (svp)
        final = SvUV(*svp);
 
-    d = s;
+    /* d needs to be bigger than s, in case e.g. upgrading is required */
+    Newz(0, d, len*2+1, U8);
+    dstart = d;
     while (s < send) {
        if ((uv = swash_fetch(rv, s)) < none) {
            s += UTF8SKIP(s);
            matches++;
+        if (uv & 0x80 && !isutf) {  
+            /* Sneaky-upgrade dstart...d */
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
            d = uv_to_utf8(d, uv);
        }
        else if (uv == none) {
            int i;
-           for (i = UTF8SKIP(s); i; i--)
-               *d++ = *s++;
+        i = UTF8SKIP(s);
+        if (i > 1 && !isutf) {
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
+           while(i--)
+            *d++ = *s++;
        }
        else if (uv == extra) {
-           s += UTF8SKIP(s);
+           int i;
+        i = UTF8SKIP(s);
+           s += i;
            matches++;
+        if (i > 1 && !isutf) {
+            U8* new;
+            STRLEN len;
+            len = dstart - d;
+            new = bytes_to_utf8(dstart, &len);
+            Copy(new,dstart,len,U8*);
+            d = dstart + len;
+            isutf++;
+        }
            d = uv_to_utf8(d, final);
        }
        else
            s += UTF8SKIP(s);
     }
     *d = '\0';
-    SvCUR_set(sv, d - (U8*)SvPVX(sv));
+    SvPV_set(sv, dstart);
+    SvCUR_set(sv, d - dstart);
     SvSETMAGIC(sv);
+    if (isutf)
+        SvUTF8_on(sv);
 
     return matches;
 }
 
 STATIC I32
-S_do_trans_UU_count(pTHX_ SV *sv)
+S_do_trans_count_utf8(pTHX_ SV *sv)/* SPC - OK */
 {
     dTHR;
     U8 *s;
@@ -200,6 +261,8 @@ S_do_trans_UU_count(pTHX_ SV *sv)
     UV uv;
 
     s = (U8*)SvPV(sv, len);
+    if (!SvUTF8(sv))
+        s = bytes_to_utf8(s, &len);
     send = s + len;
 
     while (s < send) {
@@ -212,7 +275,7 @@ S_do_trans_UU_count(pTHX_ SV *sv)
 }
 
 STATIC I32
-S_do_trans_UU_complex(pTHX_ SV *sv)
+S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 {
     dTHR;
     U8 *s;
@@ -401,6 +464,8 @@ Perl_do_trans(pTHX_ SV *sv)
 {
     dTHR;
     STRLEN len;
+    I32 hasutf = (PL_op->op_private & 
+                    (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF));
 
     if (SvREADONLY(sv) && !(PL_op->op_private & OPpTRANS_IDENTICAL))
        Perl_croak(aTHX_ PL_no_modify);
@@ -415,24 +480,24 @@ Perl_do_trans(pTHX_ SV *sv)
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
-    switch (PL_op->op_private & 63) {
+    switch (PL_op->op_private & ~hasutf & 63) {
     case 0:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_simple(sv);
+    if (hasutf)
+        return do_trans_simple_utf8(sv);
     else
-        return do_trans_CC_simple(sv);
+        return do_trans_simple(sv);
 
     case OPpTRANS_IDENTICAL:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_count(sv);
+    if (hasutf)
+        return do_trans_count_utf8(sv);
     else
-        return do_trans_CC_count(sv);
+        return do_trans_count(sv);
 
     default:
-       if (SvUTF8(sv))
-           return do_trans_UU_complex(sv); /* could be UC or CU too */
+    if (hasutf)
+           return do_trans_complex_utf8(sv);
        else
-           return do_trans_CC_complex(sv);
+           return do_trans_complex(sv);
     }
 }
 

diff --git a/embed.h b/embed.h
index fa199fb..f419792 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -846,14 +846,12 @@
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define do_trans_CC_simple     S_do_trans_CC_simple
-#define do_trans_CC_count      S_do_trans_CC_count
-#define do_trans_CC_complex    S_do_trans_CC_complex
-#define do_trans_UU_simple     S_do_trans_UU_simple
-#define do_trans_UU_count      S_do_trans_UU_count
-#define do_trans_UU_complex    S_do_trans_UU_complex
-#define do_trans_UC_trivial    S_do_trans_UC_trivial
-#define do_trans_CU_trivial    S_do_trans_CU_trivial
+#define do_trans_simple                S_do_trans_simple
+#define do_trans_count         S_do_trans_count
+#define do_trans_complex       S_do_trans_complex
+#define do_trans_simple_utf8   S_do_trans_simple_utf8
+#define do_trans_count_utf8    S_do_trans_count_utf8
+#define do_trans_complex_utf8  S_do_trans_complex_utf8
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv             S_gv_init_sv
@@ -1105,6 +1103,7 @@
 #define sublex_push            S_sublex_push
 #define sublex_start           S_sublex_start
 #define filter_gets            S_filter_gets
+#define find_in_my_stash       S_find_in_my_stash
 #define new_constant           S_new_constant
 #define ao                     S_ao
 #define depcom                 S_depcom
@@ -2289,14 +2288,12 @@
 #define avhv_index(a,b,c)      S_avhv_index(aTHX_ a,b,c)
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define do_trans_CC_simple(a)  S_do_trans_CC_simple(aTHX_ a)
-#define do_trans_CC_count(a)   S_do_trans_CC_count(aTHX_ a)
-#define do_trans_CC_complex(a) S_do_trans_CC_complex(aTHX_ a)
-#define do_trans_UU_simple(a)  S_do_trans_UU_simple(aTHX_ a)
-#define do_trans_UU_count(a)   S_do_trans_UU_count(aTHX_ a)
-#define do_trans_UU_complex(a) S_do_trans_UU_complex(aTHX_ a)
-#define do_trans_UC_trivial(a) S_do_trans_UC_trivial(aTHX_ a)
-#define do_trans_CU_trivial(a) S_do_trans_CU_trivial(aTHX_ a)
+#define do_trans_simple(a)     S_do_trans_simple(aTHX_ a)
+#define do_trans_count(a)      S_do_trans_count(aTHX_ a)
+#define do_trans_complex(a)    S_do_trans_complex(aTHX_ a)
+#define do_trans_simple_utf8(a)        S_do_trans_simple_utf8(aTHX_ a)
+#define do_trans_count_utf8(a) S_do_trans_count_utf8(aTHX_ a)
+#define do_trans_complex_utf8(a)       S_do_trans_complex_utf8(aTHX_ a)
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv(a,b)                S_gv_init_sv(aTHX_ a,b)
@@ -2547,6 +2544,7 @@
 #define sublex_push()          S_sublex_push(aTHX)
 #define sublex_start()         S_sublex_start(aTHX)
 #define filter_gets(a,b,c)     S_filter_gets(aTHX_ a,b,c)
+#define find_in_my_stash(a,b)  S_find_in_my_stash(aTHX_ a,b)
 #define new_constant(a,b,c,d,e,f)      S_new_constant(aTHX_ a,b,c,d,e,f)
 #define ao(a)                  S_ao(aTHX_ a)
 #define depcom()               S_depcom(aTHX)
@@ -4479,22 +4477,18 @@
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-#define S_do_trans_CC_simple   CPerlObj::S_do_trans_CC_simple
-#define do_trans_CC_simple     S_do_trans_CC_simple
-#define S_do_trans_CC_count    CPerlObj::S_do_trans_CC_count
-#define do_trans_CC_count      S_do_trans_CC_count
-#define S_do_trans_CC_complex  CPerlObj::S_do_trans_CC_complex
-#define do_trans_CC_complex    S_do_trans_CC_complex
-#define S_do_trans_UU_simple   CPerlObj::S_do_trans_UU_simple
-#define do_trans_UU_simple     S_do_trans_UU_simple
-#define S_do_trans_UU_count    CPerlObj::S_do_trans_UU_count
-#define do_trans_UU_count      S_do_trans_UU_count
-#define S_do_trans_UU_complex  CPerlObj::S_do_trans_UU_complex
-#define do_trans_UU_complex    S_do_trans_UU_complex
-#define S_do_trans_UC_trivial  CPerlObj::S_do_trans_UC_trivial
-#define do_trans_UC_trivial    S_do_trans_UC_trivial
-#define S_do_trans_CU_trivial  CPerlObj::S_do_trans_CU_trivial
-#define do_trans_CU_trivial    S_do_trans_CU_trivial
+#define S_do_trans_simple      CPerlObj::S_do_trans_simple
+#define do_trans_simple                S_do_trans_simple
+#define S_do_trans_count       CPerlObj::S_do_trans_count
+#define do_trans_count         S_do_trans_count
+#define S_do_trans_complex     CPerlObj::S_do_trans_complex
+#define do_trans_complex       S_do_trans_complex
+#define S_do_trans_simple_utf8 CPerlObj::S_do_trans_simple_utf8
+#define do_trans_simple_utf8   S_do_trans_simple_utf8
+#define S_do_trans_count_utf8  CPerlObj::S_do_trans_count_utf8
+#define do_trans_count_utf8    S_do_trans_count_utf8
+#define S_do_trans_complex_utf8        CPerlObj::S_do_trans_complex_utf8
+#define do_trans_complex_utf8  S_do_trans_complex_utf8
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define S_gv_init_sv           CPerlObj::S_gv_init_sv
@@ -4953,6 +4947,8 @@
 #define sublex_start           S_sublex_start
 #define S_filter_gets          CPerlObj::S_filter_gets
 #define filter_gets            S_filter_gets
+#define S_find_in_my_stash     CPerlObj::S_find_in_my_stash
+#define find_in_my_stash       S_find_in_my_stash
 #define S_new_constant         CPerlObj::S_new_constant
 #define new_constant           S_new_constant
 #define S_ao                   CPerlObj::S_ao

diff --git a/embed.pl b/embed.pl
index c4cb705..bf41a0a 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -2199,14 +2199,12 @@ s       |I32    |avhv_index     |AV* av|SV* sv|U32 hash
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-s      |I32    |do_trans_CC_simple     |SV *sv
-s      |I32    |do_trans_CC_count      |SV *sv
-s      |I32    |do_trans_CC_complex    |SV *sv
-s      |I32    |do_trans_UU_simple     |SV *sv
-s      |I32    |do_trans_UU_count      |SV *sv
-s      |I32    |do_trans_UU_complex    |SV *sv
-s      |I32    |do_trans_UC_trivial    |SV *sv
-s      |I32    |do_trans_CU_trivial    |SV *sv
+s      |I32    |do_trans_simple        |SV *sv
+s      |I32    |do_trans_count         |SV *sv
+s      |I32    |do_trans_complex       |SV *sv
+s      |I32    |do_trans_simple_utf8   |SV *sv
+s      |I32    |do_trans_count_utf8    |SV *sv
+s      |I32    |do_trans_complex_utf8  |SV *sv
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)

diff --git a/lib/IPC/Open3.pm b/lib/IPC/Open3.pm
index 6d91c81..5c9c69a 100644 (file)
--- a/lib/IPC/Open3.pm
+++ b/lib/IPC/Open3.pm
@@ -44,6 +44,9 @@ by an autogenerated filehandle.  If so, you must pass a valid lvalue
 in the parameter slot so it can be overwritten in the caller, or 
 an exception will be raised.
 
+The filehandles may also be integers, in which case they are understood
+as file descriptors.
+
 open3() returns the process ID of the child process.  It doesn't return on
 failure: it just raises an exception matching C</^open3:/>.  However,
 C<exec> failures in the child are not detected.  You'll have to 
@@ -137,14 +140,13 @@ sub xclose {
     close $_[0] or croak "$Me: close($_[0]) failed: $!";
 }
 
-sub xfileno {
-    my ($fh) = @_;
-    return $1 if $fh =~ /^=?(\d+)$/;  # deal with $fh just being an fd
-    return fileno $fh;
+sub fh_is_fd {
+    return $_[0] =~ /\A=?(\d+)\z/;
 }
 
-sub fh_is_fd {
-    return $_[0] =~ /^=?\d+$/;
+sub xfileno {
+    return $1 if $_[0] =~ /\A=?(\d+)\z/;  # deal with fh just being an fd
+    return fileno $_[0];
 }
 
 my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';

diff --git a/op.c b/op.c
index 85fea36..8098b38 100644 (file)
--- a/op.c
+++ b/op.c
@@ -2573,6 +2573,12 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
     complement = o->op_private & OPpTRANS_COMPLEMENT;
     del                = o->op_private & OPpTRANS_DELETE;
     squash     = o->op_private & OPpTRANS_SQUASH;
+    
+    if (SvUTF8(tstr))
+        o->op_private |= OPpTRANS_FROM_UTF;
+    
+    if (SvUTF8(rstr)) 
+        o->op_private |= OPpTRANS_TO_UTF;
 
     if (o->op_private & (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF)) {
        SV* listsv = newSVpvn("# comment\n",10);
@@ -2644,15 +2650,9 @@ Perl_pmtrans(pTHX_ OP *o, OP *expr, OP *repl)
            r = t; rlen = tlen; rend = tend;
        }
        if (!squash) {
-           if (to_utf && from_utf) {   /* only counting characters */
-               if (t == r || (tlen == rlen && memEQ(t, r, tlen)))
+               if (t == r ||
+                   (tlen == rlen && memEQ((char *)t, (char *)r, tlen)))
                    o->op_private |= OPpTRANS_IDENTICAL;
-           }
-           else {      /* straight latin-1 translation */
-               if (tlen == 4 && memEQ(t, "\0\377\303\277", 4) &&
-                   rlen == 4 && memEQ(r, "\0\377\303\277", 4))
-                   o->op_private |= OPpTRANS_IDENTICAL;
-           }
        }
 
        while (t < tend || tfirst <= tlast) {

diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod
index 6b4e971..00fc860 100644 (file)
--- a/pod/perlfunc.pod
+++ b/pod/perlfunc.pod
@@ -3202,6 +3202,15 @@ equal $foo).
 
 =item *
 
+If the pattern begins with a C<U>, the resulting string will be treated
+as Unicode-encoded. You can force UTF8 encoding on in a string with an
+initial C<U0>, and the bytes that follow will be interpreted as Unicode
+characters. If you don't want this to happen, you can begin your pattern
+with C<C0> (or anything else) to force Perl not to UTF8 encode your
+string, and then follow this with a C<U*> somewhere in your pattern.
+
+=item *
+
 You must yourself do any alignment or padding by inserting for example
 enough C<'x'>es while packing.  There is no way to pack() and unpack()
 could know where the bytes are going to or coming from.  Therefore

diff --git a/pp.c b/pp.c
index 428b2e4..efea0c1 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4375,6 +4375,7 @@ PP(pp_pack)
     register I32 items;
     STRLEN fromlen;
     register char *pat = SvPVx(*++MARK, fromlen);
+    char *patcopy;
     register char *patend = pat + fromlen;
     register I32 len;
     I32 datumtype;
@@ -4405,6 +4406,7 @@ PP(pp_pack)
     items = SP - MARK;
     MARK++;
     sv_setpvn(cat, "", 0);
+    patcopy = pat;
     while (pat < patend) {
        SV *lengthcode = Nullsv;
 #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *MARK++ : &PL_sv_no)
@@ -4412,8 +4414,12 @@ PP(pp_pack)
 #ifdef PERL_NATINT_PACK
        natint = 0;
 #endif
-       if (isSPACE(datumtype))
+       if (isSPACE(datumtype)) {
+           patcopy++;
            continue;
+        }
+       if (datumtype == 'U' && pat==patcopy+1) 
+           SvUTF8_on(cat);
        if (datumtype == '#') {
            while (pat < patend && *pat != '\n')
                pat++;

diff --git a/proto.h b/proto.h
index d46179a..0d70332 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -959,14 +959,12 @@ STATIC I32        S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash);
 #endif
 
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
-STATIC I32     S_do_trans_CC_simple(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CC_count(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CC_complex(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_simple(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_count(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UU_complex(pTHX_ SV *sv);
-STATIC I32     S_do_trans_UC_trivial(pTHX_ SV *sv);
-STATIC I32     S_do_trans_CU_trivial(pTHX_ SV *sv);
+STATIC I32     S_do_trans_simple(pTHX_ SV *sv);
+STATIC I32     S_do_trans_count(pTHX_ SV *sv);
+STATIC I32     S_do_trans_complex(pTHX_ SV *sv);
+STATIC I32     S_do_trans_simple_utf8(pTHX_ SV *sv);
+STATIC I32     S_do_trans_count_utf8(pTHX_ SV *sv);
+STATIC I32     S_do_trans_complex_utf8(pTHX_ SV *sv);
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)

diff --git a/t/op/my_stash.t b/t/op/my_stash.t
index ba266bf..79f3f28 100644 (file)
--- a/t/op/my_stash.t
+++ b/t/op/my_stash.t
@@ -2,6 +2,10 @@
 
 package Foo;
 
+BEGIN {
+    unshift @INC, "../lib";
+}
+
 use Test;
 
 plan tests => 7;

diff --git a/t/op/pack.t b/t/op/pack.t
index dda1cc7..5c215c6 100755 (executable)
--- a/t/op/pack.t
+++ b/t/op/pack.t
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
-print "1..156\n";
+print "1..159\n";
 
 $format = "c2 x5 C C x s d i l a6";
 # Need the expression in here to force ary[5] to be numeric.  This avoids
@@ -406,3 +406,13 @@ $z = pack <<EOP,'string','etc';
   w/A*                 # Count a  BER integer
 EOP
 print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+
+print 'not ' unless "1.20.300.4000" eq sprintf "%vd", pack("U*",1,20,300,4000); 
+print "ok $test\n"; $test++;
+print 'not ' unless "1.20.300.4000" eq 
+                    sprintf "%vd", pack("  U*",1,20,300,4000); 
+print "ok $test\n"; $test++;
+print 'not ' unless v1.20.300.4000 ne 
+                    sprintf "%vd", pack("C0U*",1,20,300,4000); 
+print "ok $test\n"; $test++;
+

diff --git a/t/op/tr.t b/t/op/tr.t
index e9a1b4c..100dcfe 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
-print "1..8\n";
+print "1..15\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
@@ -61,3 +61,50 @@ print "ok 7\n";
 $x =~ tr/A/B/;
 print "not " if $x ne 256.66.258 or length $x != 3;
 print "ok 8\n";
+
+{
+use utf8;
+
+# 9 - changing UTF8 characters in a UTF8 string, same length.
+$l = chr(300); $r = chr(400);
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 200.400.400 or length $x != 3;
+print "ok 9\n";
+
+# 10 - changing UTF8 characters in UTF8 string, more bytes.
+$x = 200.300.400;
+$x =~ tr/\x{12c}/\x{be8}/;
+printf "not (%vd) ", $x if $x ne 200.3048.400 or length $x != 3;
+print "ok 10\n";
+
+# 11 - introducing UTF8 characters to non-UTF8 string.
+$x = 100.125.60;
+$x =~ tr/\x{64}/\x{190}/;
+printf "not (%vd) ", $x if $x ne 400.125.60 or length $x != 3;
+print "ok 11\n";
+
+# 12 - removing UTF8 characters from UTF8 string
+$x = 400.125.60;
+$x =~ tr/\x{190}/\x{64}/;
+printf "not (%vd) ", $x if $x ne 100.125.60 or length $x != 3;
+print "ok 12\n";
+
+# 13 - counting UTF8 chars in UTF8 string
+$x = 400.125.60.400;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 2;
+print "ok 13\n";
+
+# 14 - counting non-UTF8 chars in UTF8 string
+$x = 60.400.125.60.400;
+$y = $x =~ tr/\x{3c}/\x{3c}/;
+print "not " if $y != 2;
+print "ok 14\n";
+
+# 15 - counting UTF8 chars in non-UTF8 string
+$x = 200.125.60;
+$y = $x =~ tr/\x{190}/\x{190}/;
+print "not " if $y != 0;
+print "ok 15\n";
+}