Integrate encoding::warnings from Autrijus Tang.

[p5sagit/p5-mst-13.2.git] / gv.c

diff --git a/gv.c b/gv.c
index d84042d..83ec0ee 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1,7 +1,7 @@
 /*    gv.c
  *
  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- *    2000, 2001, 2002, 2003, 2004, by Larry Wall and others
+ *    2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -650,7 +650,21 @@ Perl_gv_stashsv(pTHX_ SV *sv, I32 create)
 
 
 GV *
-Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
+Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) {
+    STRLEN len = strlen (nambeg);
+    return gv_fetchpvn_flags(nambeg, len, add, sv_type);
+}
+
+GV *
+Perl_gv_fetchsv(pTHX_ SV *name, I32 flags, I32 sv_type) {
+    STRLEN len;
+    const char *nambeg = SvPV(name, len);
+    return gv_fetchpvn_flags(nambeg, len, flags | SvUTF8(name), sv_type);
+}
+
+GV *
+Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
+                      I32 sv_type)
 {
     register const char *name = nambeg;
     register GV *gv = 0;
@@ -658,6 +672,7 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     I32 len;
     register const char *namend;
     HV *stash = 0;
+    I32 add = flags & ~SVf_UTF8;
 
     if (*name == '*' && isALPHA(name[1])) /* accidental stringify on a GV? */
        name++;
@@ -837,12 +852,15 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
 
     /* set up magic where warranted */
     if (len > 1) {
+#ifndef EBCDIC
        if (*name > 'V' ) {
            /* Nothing else to do.
               The compiler will probably turn the switch statement into a
               branch table. Make sure we avoid even that small overhead for
               the common case of lower case variable names.  */
-       } else {
+       } else
+#endif
+       {
            const char *name2 = name + 1;
            switch (*name) {
            case 'A':
@@ -923,9 +941,11 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
                if (strEQ(name2, "AINT"))
                    goto ro_magicalize;
                break;
-           case '\025':        /* $^UNICODE */
+           case '\025':        /* ${^UNICODE}, ${^UTF8LOCALE} */
                if (strEQ(name2, "NICODE")) 
                    goto ro_magicalize;
+               if (strEQ(name2, "TF8LOCALE")) 
+                   goto ro_magicalize;
                break;
            case '\027':        /* $^WARNING_BITS */
                if (strEQ(name2, "ARNING_BITS"))
@@ -1814,6 +1834,22 @@ Perl_amagic_call(pTHX_ SV *left, SV *right, int method, int flags)
 /*
 =for apidoc is_gv_magical
 
+Returns C<TRUE> if given the name of a magical GV. Calls is_gv_magical.
+
+=cut
+*/
+
+bool
+Perl_is_gv_magical_sv(pTHX_ SV *name, U32 flags)
+{
+    STRLEN len;
+    char *temp = SvPV(name, len);
+    return is_gv_magical(temp, len, flags);
+}
+
+/*
+=for apidoc is_gv_magical
+
 Returns C<TRUE> if given the name of a magical GV.
 
 Currently only useful internally when determining if a GV should be
@@ -1832,36 +1868,39 @@ bool
 Perl_is_gv_magical(pTHX_ char *name, STRLEN len, U32 flags)
 {
     if (len > 1) {
+       const char *name1 = name + 1;
        switch (*name) {
        case 'I':
-           if (len == 3 && strEQ(name, "ISA"))
+           if (len == 3 && name1[1] == 'S' && name[2] == 'A')
                goto yes;
            break;
        case 'O':
-           if (len == 8 && strEQ(name, "OVERLOAD"))
+           if (len == 8 && strEQ(name1, "VERLOAD"))
                goto yes;
            break;
        case 'S':
-           if (len == 3 && strEQ(name, "SIG"))
+           if (len == 3 && name[1] == 'I' && name[2] == 'G')
                goto yes;
            break;
            /* Using ${^...} variables is likely to be sufficiently rare that
               it seems sensible to avoid the space hit of also checking the
               length.  */
        case '\017':   /* ${^OPEN} */
-           if (strEQ(name, "\017PEN"))
+           if (strEQ(name1, "PEN"))
                goto yes;
            break;
        case '\024':   /* ${^TAINT} */
-           if (strEQ(name, "\024AINT"))
+           if (strEQ(name1, "AINT"))
                goto yes;
            break;
        case '\025':    /* ${^UNICODE} */
-           if (strEQ(name, "\025NICODE"))
+           if (strEQ(name1, "NICODE"))
+               goto yes;
+           if (strEQ(name1, "TF8LOCALE")) 
                goto yes;
            break;
        case '\027':   /* ${^WARNING_BITS} */
-           if (strEQ(name, "\027ARNING_BITS"))
+           if (strEQ(name1, "ARNING_BITS"))
                goto yes;
            break;
        case '1':