view release on metacpan or  search on metacpan

perl.c  view on Meta::CPAN

                   * processed as the IRS specified in hexadecimal if all
                   * characters are valid hex digits. */
                   rschar = 0;
                   numlen = 0;
                   s--;
              }
              PL_rs = newSV((STRLEN)(UVCHR_SKIP(rschar) + 1));
              tmps = (U8*)SvPVCLEAR_FRESH(PL_rs);
              uv_to_utf8(tmps, rschar);
              SvCUR_set(PL_rs, UVCHR_SKIP(rschar));
              SvUTF8_on(PL_rs);
         }
         else {
              numlen = 4;
              rschar = (U32)grok_oct(s, &numlen, &flags, NULL);
              if (rschar & ~((U8)~0))
                   PL_rs = &PL_sv_undef;
              else if (!rschar && numlen >= 2)
                   PL_rs = newSVpvs("");
              else {
                   char ch = (char)rschar;
                   PL_rs = newSVpvn(&ch, 1);
              }
         }
         sv_setsv(get_sv("/", GV_ADD), PL_rs);
         return s + numlen;
    }
    case 'C':
        s++;
        PL_unicode = parse_unicode_opts( (const char **)&s );
        if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
            PL_utf8cache = -1;
        return s;
    case 'F':
        PL_minus_a = TRUE;
        PL_minus_F = TRUE;
        PL_minus_n = TRUE;
        {
            const char *start = ++s;
            while (*s && !isSPACE(*s)) ++s;
            Safefree(PL_splitstr);
            PL_splitstr = savepvn(start, s - start);
        }
        return s;
    case 'a':
        PL_minus_a = TRUE;
        PL_minus_n = TRUE;
        s++;
        return s;
    case 'c':
        PL_minus_c = TRUE;
        s++;
        return s;
    case 'd':
        forbid_setid('d', FALSE);
        s++;

        /* -dt indicates to the debugger that threads will be used */
        if (*s == 't' && !isWORDCHAR(s[1])) {
            ++s;
            my_setenv("PERL5DB_THREADED", "1");
        }

        /* The following permits -d:Mod to accepts arguments following an =
           in the fashion that -MSome::Mod does. */
        if (*s == ':' || *s == '=') {
            const char *start;
            const char *end;
            SV *sv;

            if (*++s == '-') {
                ++s;
                sv = newSVpvs("no Devel::");
            } else {
                sv = newSVpvs("use Devel::");
            }

            start = s;
            end = s + strlen(s);

            /* We now allow -d:Module=Foo,Bar and -d:-Module */
            while(isWORDCHAR(*s) || *s==':') ++s;
            if (*s != '=')
                sv_catpvn(sv, start, end - start);
            else {
                sv_catpvn(sv, start, s-start);
                /* Don't use NUL as q// delimiter here, this string goes in the
                 * environment. */
                sv_catpvf(sv, " split(/,/,q{%s});", ++s);
            }
            s = end;
            my_setenv("PERL5DB", SvPV_nolen_const(sv));
            SvREFCNT_dec(sv);
        }
        if (!PL_perldb) {
            PL_perldb = PERLDB_ALL;
            init_debugger();
        }
        return s;
    case 'D':
    {
#ifdef DEBUGGING
        forbid_setid('D', FALSE);
        s++;
        PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
        ck_warner_d(packWARN(WARN_DEBUGGING),
                    "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
        for (s++; isWORDCHAR(*s); s++) ;
#endif
        return s;
        NOT_REACHED; /* NOTREACHED */
    }
    case 'g':
        SvREFCNT_dec(PL_rs);
        PL_rs = &PL_sv_undef;
        sv_setsv(get_sv("/", GV_ADD), PL_rs);
        return ++s;

    case '?':
        /* FALLTHROUGH */
    case 'h':
        usage();
        NOT_REACHED; /* NOTREACHED */

    case 'i':
        Safefree(PL_inplace);
        {
            const char * const start = ++s;
            while (*s && !isSPACE(*s))
                ++s;

            PL_inplace = savepvn(start, s - start);
        }
        return s;
    case 'I':	/* -I handled both here and in parse_body() */
        forbid_setid('I', FALSE);
        ++s;
        while (*s && isSPACE(*s))
            ++s;
        if (*s) {
            const char *e, *p;
            p = s;
            /* ignore trailing spaces (possibly followed by other switches) */
            do {
                for (e = p; *e && !isSPACE(*e); e++) ;
                p = e;
                while (isSPACE(*p))
                    p++;
            } while (*p && *p != '-');
            incpush(s, e-s,
                    INCPUSH_ADD_SUB_DIRS|INCPUSH_ADD_OLD_VERS|INCPUSH_UNSHIFT);

perl.c  view on Meta::CPAN

          for (; *env; env++) {
              char *old_var = *env;
              char *s = strchr(old_var, '=');
              STRLEN nlen;
              SV *sv;

              if (!s || s == old_var)
                  continue;

              nlen = s - old_var;

              /* It's tempting to think that this hv_exists/hv_store pair should
               * be replaced with a single hv_fetch with the LVALUE flag true.
               * However, hv has magic, and if you follow the code in hv_common
               * then for LVALUE fetch it recurses once, whereas exists and
               * store do not recurse. Hence internally there would be no
               * difference in the complexity of the code run. Moreover, all
               * calls pass through "is there magic?" special case code, which
               * in turn has its own #ifdef ENV_IS_CASELESS special case special
               * case. Hence this code shouldn't change, as doing so won't give
               * any meaningful speedup, and might well add bugs. */

            if (hv_exists(hv, old_var, nlen)) {
                SV **dup;
                const char *name = savepvn(old_var, nlen);

                /* make sure we use the same value as getenv(), otherwise code that
                   uses getenv() (like setlocale()) might see a different value to %ENV
                 */
                sv = newSVpv(PerlEnv_getenv(name), 0);

                /* keep a count of the dups of this name so we can de-dup environ later */
                dup = hv_fetch(dups, name, nlen, TRUE);
                if (*dup) {
                    sv_inc(*dup);
                }

                Safefree(name);
            }
            else {
                sv = newSVpv(s+1, 0);
            }
            (void)hv_store(hv, old_var, nlen, sv, 0);
            if (env_is_not_environ)
                mg_set(sv);
          }
          if (HvTOTALKEYS(dups)) {
              /* environ has some duplicate definitions, remove them */
              HE *entry;
              hv_iterinit(dups);
              while ((entry = hv_iternext_flags(dups, 0))) {
                  STRLEN nlen;
                  const char *name = HePV(entry, nlen);
                  IV count = SvIV(HeVAL(entry));
                  IV i;
                  SV **valp = hv_fetch(hv, name, nlen, 0);

                  assert(valp);

                  /* try to remove any duplicate names, depending on the
                   * implementation used in my_setenv() the iteration might
                   * not be necessary, but let's be safe.
                   */
                  for (i = 0; i < count; ++i)
                      my_setenv(name, 0);

                  /* and set it back to the value we set $ENV{name} to */
                  my_setenv(name, SvPV_nolen(*valp));
              }
          }
          SvREFCNT_dec_NN(dups);
      }
#endif /* USE_ENVIRON_ARRAY */
    }
    TAINT_NOT;

    /* touch @F array to prevent spurious warnings 20020415 MJD */
    if (PL_minus_a) {
      (void) get_av("main::F", GV_ADD | GV_ADDMULTI);
    }
}

STATIC void
S_init_perllib(pTHX)
{
#ifndef VMS
    const char *perl5lib = NULL;
#endif
    const char *s;
#if defined(WIN32) && !defined(PERL_IS_MINIPERL)
    STRLEN len;
#endif

    if (!TAINTING_get) {
#ifndef VMS
        perl5lib = PerlEnv_getenv("PERL5LIB");
        if (perl5lib && *perl5lib != '\0')
            incpush_use_sep(perl5lib, 0, INCPUSH_ADD_SUB_DIRS);
        else {
            s = PerlEnv_getenv("PERLLIB");
            if (s)
                incpush_use_sep(s, 0, 0);
        }
#else /* VMS */
        /* Treat PERL5?LIB as a possible search list logical name -- the
         * "natural" VMS idiom for a Unix path string.  We allow each
         * element to be a set of |-separated directories for compatibility.
         */
        char buf[256];
        int idx = 0;
        if (vmstrnenv("PERL5LIB",buf,0,NULL,0))
            do {
                incpush_use_sep(buf, 0, INCPUSH_ADD_SUB_DIRS);
            } while (vmstrnenv("PERL5LIB",buf,++idx,NULL,0));
        else {
            while (vmstrnenv("PERLLIB",buf,idx++,NULL,0))
                incpush_use_sep(buf, 0, 0);
        }
#endif /* VMS */
    }

#ifndef PERL_IS_MINIPERL
    /* miniperl gets just -I..., the split of $ENV{PERL5LIB}, and "." in @INC
       (and not the architecture specific directories from $ENV{PERL5LIB}) */

#include "perl_inc_macro.h"
/* Use the ~-expanded versions of APPLLIB (undocumented),
    SITEARCH, SITELIB, VENDORARCH, VENDORLIB, ARCHLIB and PRIVLIB