/* perl.c
*
* Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999,
- * 2000, 2001, 2002, 2003, 2004, 2005, by Larry Wall and others
+ * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 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.
*/
sv_clean_objs();
PL_sv_objcount = 0;
+ if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
+ PL_defoutgv = Nullgv; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
/* Yell and reset the HeVAL() slots that are still holding refcounts,
* so that sv_free() won't fail on them.
*/
- I32 riter;
- I32 max;
- HE *hent;
- HE **array;
-
- riter = 0;
- max = HvMAX(PL_strtab);
- array = HvARRAY(PL_strtab);
- hent = array[0];
+ I32 riter = 0;
+ const I32 max = HvMAX(PL_strtab);
+ HE ** const array = HvARRAY(PL_strtab);
+ HE *hent = array[0];
+
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
- "Unbalanced string table refcount: (%d) for \"%s\"",
- HeVAL(hent) - Nullsv, HeKEY(hent));
+ "Unbalanced string table refcount: (%ld) for \"%s\"",
+ (long)(HeVAL(hent) - Nullsv), HeKEY(hent));
HeVAL(hent) = Nullsv;
hent = HeNEXT(hent);
}
#endif
opts = SvCUR(opts_prog);
- sv_catpv(opts_prog,"\" Compile-time options:");
+ Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
# ifdef DEBUGGING
- sv_catpv(opts_prog," DEBUGGING");
+ " DEBUGGING"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS
+ " DEBUG_LEAKING_SCALARS"
# endif
# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
- sv_catpv(opts_prog," DEBUG_LEAKING_SCALARS_FORK_DUMP");
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
# endif
# ifdef FAKE_THREADS
- sv_catpv(opts_prog," FAKE_THREADS");
+ " FAKE_THREADS"
# endif
# ifdef MULTIPLICITY
- sv_catpv(opts_prog," MULTIPLICITY");
+ " MULTIPLICITY"
# endif
# ifdef MYMALLOC
- sv_catpv(opts_prog," MYMALLOC");
+ " MYMALLOC"
+# endif
+# ifdef NO_MATHOMS
+ " NO_MATHOMS"
# endif
# ifdef PERL_DONT_CREATE_GVSV
- sv_catpv(opts_prog," PERL_DONT_CREATE_GVSV");
+ " PERL_DONT_CREATE_GVSV"
# endif
# ifdef PERL_GLOBAL_STRUCT
- sv_catpv(opts_prog," PERL_GLOBAL_STRUCT");
+ " PERL_GLOBAL_STRUCT"
# endif
# ifdef PERL_IMPLICIT_CONTEXT
- sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT");
+ " PERL_IMPLICIT_CONTEXT"
# endif
# ifdef PERL_IMPLICIT_SYS
- sv_catpv(opts_prog," PERL_IMPLICIT_SYS");
+ " PERL_IMPLICIT_SYS"
# endif
# ifdef PERL_MALLOC_WRAP
- sv_catpv(opts_prog," PERL_MALLOC_WRAP");
+ " PERL_MALLOC_WRAP"
# endif
# ifdef PERL_NEED_APPCTX
- sv_catpv(opts_prog," PERL_NEED_APPCTX");
+ " PERL_NEED_APPCTX"
# endif
# ifdef PERL_NEED_TIMESBASE
- sv_catpv(opts_prog," PERL_NEED_TIMESBASE");
+ " PERL_NEED_TIMESBASE"
# endif
# ifdef PERL_OLD_COPY_ON_WRITE
- sv_catpv(opts_prog," PERL_OLD_COPY_ON_WRITE");
+ " PERL_OLD_COPY_ON_WRITE"
+# endif
+# ifdef PERL_TRACK_MEMPOOL
+ " PERL_TRACK_MEMPOOL"
+# endif
+# ifdef PERL_USE_SAFE_PUTENV
+ " PERL_USE_SAFE_PUTENV"
# endif
# ifdef PL_OP_SLAB_ALLOC
- sv_catpv(opts_prog," PL_OP_SLAB_ALLOC");
+ " PL_OP_SLAB_ALLOC"
# endif
# ifdef THREADS_HAVE_PIDS
- sv_catpv(opts_prog," THREADS_HAVE_PIDS");
+ " THREADS_HAVE_PIDS"
# endif
# ifdef USE_5005THREADS
- sv_catpv(opts_prog," USE_5005THREADS");
+ " USE_5005THREADS"
# endif
# ifdef USE_64_BIT_ALL
- sv_catpv(opts_prog," USE_64_BIT_ALL");
+ " USE_64_BIT_ALL"
# endif
# ifdef USE_64_BIT_INT
- sv_catpv(opts_prog," USE_64_BIT_INT");
+ " USE_64_BIT_INT"
# endif
# ifdef USE_ITHREADS
- sv_catpv(opts_prog," USE_ITHREADS");
+ " USE_ITHREADS"
# endif
# ifdef USE_LARGE_FILES
- sv_catpv(opts_prog," USE_LARGE_FILES");
+ " USE_LARGE_FILES"
# endif
# ifdef USE_LONG_DOUBLE
- sv_catpv(opts_prog," USE_LONG_DOUBLE");
+ " USE_LONG_DOUBLE"
# endif
# ifdef USE_PERLIO
- sv_catpv(opts_prog," USE_PERLIO");
+ " USE_PERLIO"
# endif
# ifdef USE_REENTRANT_API
- sv_catpv(opts_prog," USE_REENTRANT_API");
+ " USE_REENTRANT_API"
# endif
# ifdef USE_SFIO
- sv_catpv(opts_prog," USE_SFIO");
+ " USE_SFIO"
# endif
# ifdef USE_SITECUSTOMIZE
- sv_catpv(opts_prog," USE_SITECUSTOMIZE");
+ " USE_SITECUSTOMIZE"
# endif
# ifdef USE_SOCKS
- sv_catpv(opts_prog," USE_SOCKS");
+ " USE_SOCKS"
# endif
+ );
while (SvCUR(opts_prog) > opts+76) {
/* find last space after "options: " and before col 76
if (!PL_restartop) {
DEBUG_x(dump_all());
+#ifdef DEBUGGING
PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n"));
+#endif
DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n",
PTR2UV(thr)));
}
else if (flags & 1) {
/* Give help. */
- const char **p = usage_msgd;
+ const char *const *p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
#endif
PerlIO_printf(PerlIO_stdout(),
- "\n\nCopyright 1987-2005, Larry Wall\n");
+ "\n\nCopyright 1987-2006, Larry Wall\n");
#ifdef MACOS_TRADITIONAL
PerlIO_printf(PerlIO_stdout(),
"\nMac OS port Copyright 1991-2002, Matthias Neeracher;\n"
#endif /* IAMSUID */
if (!PL_rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
+ if (PL_e_script)
+ Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ else
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
cmplen = sizeof(fsd.fd_req.path);
if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
- }
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
}
}
}
PL_doswitches = FALSE; /* -s is insecure in suid */
/* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
+ if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch)
+ Perl_croak(aTHX_ "No #! line");
linestr = SvPV_nolen_const(PL_linestr);
- if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(linestr,"#!",2) ) /* required even on Sys V */
+ /* required even on Sys V */
+ if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
- linestr+=2;
+ linestr += 2;
s = linestr;
/* PSz 27 Feb 04 */
/* Sanity check on line length */
if (!PL_tainting) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (s && *s != '\0')
+#else
if (s)
+#endif
incpush(s, TRUE, TRUE, TRUE);
else
incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE);
SvFLAGS(PL_thrsv) = SVt_PV;
SvANY(PL_thrsv) = (void*)xpv;
SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPV_set(PL_thrsvr, (char*)thr);
+ SvPV_set(PL_thrsv, (char*)thr);
SvCUR_set(PL_thrsv, sizeof(thr));
SvLEN_set(PL_thrsv, sizeof(thr));
*SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
https://perl5.git.perl.org / perl5.git / blobdiff