This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
integrate changes#6252..6256,6259..6260
authorGurusamy Sarathy <gsar@cpan.org>
Mon, 20 Nov 2000 11:13:44 +0000 (11:13 +0000)
committerGurusamy Sarathy <gsar@cpan.org>
Mon, 20 Nov 2000 11:13:44 +0000 (11:13 +0000)
       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..)

12 files changed:
MANIFEST
doop.c
embed.h
embed.pl
lib/IPC/Open3.pm
op.c
pod/perlfunc.pod
pp.c
proto.h
t/op/my_stash.t
t/op/pack.t
t/op/tr.t

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/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
 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
 #endif
 
 STATIC I32
 #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;
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
     I32 ch;
     STRLEN len;
     short *tbl;
     I32 ch;
@@ -38,11 +39,15 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
     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++;
        s++;
+        }
     }
     SvSETMAGIC(sv);
 
     }
     SvSETMAGIC(sv);
 
@@ -50,12 +55,13 @@ S_do_trans_CC_simple(pTHX_ SV *sv)
 }
 
 STATIC I32
 }
 
 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;
 {
     dTHR;
     U8 *s;
     U8 *send;
     I32 matches = 0;
+    I32 hasutf = SvUTF8(sv);
     STRLEN len;
     short *tbl;
 
     STRLEN len;
     short *tbl;
 
@@ -67,21 +73,26 @@ S_do_trans_CC_count(pTHX_ SV *sv)
     send = s + len;
 
     while (s < send) {
     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
     }
 
     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;
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    I32 hasutf = SvUTF8(sv);
     I32 matches = 0;
     STRLEN len;
     short *tbl;
     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) {
        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) {
        }
     }
     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 */
        }
     }
     matches += send - d;       /* account for disappeared chars */
@@ -133,12 +152,14 @@ S_do_trans_CC_complex(pTHX_ SV *sv)
 }
 
 STATIC I32
 }
 
 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;
 {
     dTHR;
     U8 *s;
     U8 *send;
     U8 *d;
+    U8 *start;
+    U8 *dstart;
     I32 matches = 0;
     STRLEN len;
 
     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;
     UV extra = none + 1;
     UV final;
     UV uv;
+    I32 isutf; 
+    I32 howmany;
 
 
+    isutf = SvUTF8(sv);
     s = (U8*)SvPV(sv, len);
     send = s + len;
     s = (U8*)SvPV(sv, len);
     send = s + len;
+    start = s;
 
     svp = hv_fetch(hv, "FINAL", 5, FALSE);
     if (svp)
        final = SvUV(*svp);
 
 
     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++;
     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;
            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) {
        }
        else if (uv == extra) {
-           s += UTF8SKIP(s);
+           int i;
+        i = UTF8SKIP(s);
+           s += i;
            matches++;
            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';
            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);
     SvSETMAGIC(sv);
+    if (isutf)
+        SvUTF8_on(sv);
 
     return matches;
 }
 
 STATIC I32
 
     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;
 {
     dTHR;
     U8 *s;
@@ -200,6 +261,8 @@ S_do_trans_UU_count(pTHX_ SV *sv)
     UV uv;
 
     s = (U8*)SvPV(sv, len);
     UV uv;
 
     s = (U8*)SvPV(sv, len);
+    if (!SvUTF8(sv))
+        s = bytes_to_utf8(s, &len);
     send = s + len;
 
     while (s < send) {
     send = s + len;
 
     while (s < send) {
@@ -212,7 +275,7 @@ S_do_trans_UU_count(pTHX_ SV *sv)
 }
 
 STATIC I32
 }
 
 STATIC I32
-S_do_trans_UU_complex(pTHX_ SV *sv)
+S_do_trans_complex_utf8(pTHX_ SV *sv) /* SPC - NOT OK */
 {
     dTHR;
     U8 *s;
 {
     dTHR;
     U8 *s;
@@ -401,6 +464,8 @@ Perl_do_trans(pTHX_ SV *sv)
 {
     dTHR;
     STRLEN len;
 {
     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);
 
     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"));
 
 
     DEBUG_t( Perl_deb(aTHX_ "2.TBL\n"));
 
-    switch (PL_op->op_private & 63) {
+    switch (PL_op->op_private & ~hasutf & 63) {
     case 0:
     case 0:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_simple(sv);
+    if (hasutf)
+        return do_trans_simple_utf8(sv);
     else
     else
-        return do_trans_CC_simple(sv);
+        return do_trans_simple(sv);
 
     case OPpTRANS_IDENTICAL:
 
     case OPpTRANS_IDENTICAL:
-    if (SvUTF8(sv)) 
-        return do_trans_UU_count(sv);
+    if (hasutf)
+        return do_trans_count_utf8(sv);
     else
     else
-        return do_trans_CC_count(sv);
+        return do_trans_count(sv);
 
     default:
 
     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
        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
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
 #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
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv             S_gv_init_sv
 #define sublex_push            S_sublex_push
 #define sublex_start           S_sublex_start
 #define filter_gets            S_filter_gets
 #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
 #define new_constant           S_new_constant
 #define ao                     S_ao
 #define depcom                 S_depcom
 #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 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)
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define gv_init_sv(a,b)                S_gv_init_sv(aTHX_ a,b)
 #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 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)
 #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)
 #define avhv_index             S_avhv_index
 #endif
 #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT)
 #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
 #endif
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
 #define S_gv_init_sv           CPerlObj::S_gv_init_sv
 #define sublex_start           S_sublex_start
 #define S_filter_gets          CPerlObj::S_filter_gets
 #define filter_gets            S_filter_gets
 #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
 #define S_new_constant         CPerlObj::S_new_constant
 #define new_constant           S_new_constant
 #define S_ao                   CPerlObj::S_ao
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)
 #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)
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
index 6d91c81..5c9c69a 100644 (file)
@@ -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.
 
 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 
 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: $!";
 }
 
     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';
 }
 
 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;
     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);
 
     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) {
            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;
                    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) {
        }
 
        while (t < tend || tfirst <= tlast) {
index 6b4e971..00fc860 100644 (file)
@@ -3202,6 +3202,15 @@ equal $foo).
 
 =item *
 
 
 =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
 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);
     register I32 items;
     STRLEN fromlen;
     register char *pat = SvPVx(*++MARK, fromlen);
+    char *patcopy;
     register char *patend = pat + fromlen;
     register I32 len;
     I32 datumtype;
     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);
     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)
     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
 #ifdef PERL_NATINT_PACK
        natint = 0;
 #endif
-       if (isSPACE(datumtype))
+       if (isSPACE(datumtype)) {
+           patcopy++;
            continue;
            continue;
+        }
+       if (datumtype == 'U' && pat==patcopy+1) 
+           SvUTF8_on(cat);
        if (datumtype == '#') {
            while (pat < patend && *pat != '\n')
                pat++;
        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)
 #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)
 #endif
 
 #if defined(PERL_IN_GV_C) || defined(PERL_DECL_PROT)
index ba266bf..79f3f28 100644 (file)
@@ -2,6 +2,10 @@
 
 package Foo;
 
 
 package Foo;
 
+BEGIN {
+    unshift @INC, "../lib";
+}
+
 use Test;
 
 plan tests => 7;
 use Test;
 
 plan tests => 7;
index dda1cc7..5c215c6 100755 (executable)
@@ -6,7 +6,7 @@ BEGIN {
     require Config; import Config;
 }
 
     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
 
 $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++;
   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++;
+
index e9a1b4c..100dcfe 100755 (executable)
--- a/t/op/tr.t
+++ b/t/op/tr.t
@@ -5,7 +5,7 @@ BEGIN {
     unshift @INC, "../lib";
 }
 
     unshift @INC, "../lib";
 }
 
-print "1..8\n";
+print "1..15\n";
 
 $_ = "abcdefghijklmnopqrstuvwxyz";
 
 
 $_ = "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";
 $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";
+}