static void
S_init_tls_and_interp(PerlInterpreter *my_perl)
{
+ dVAR;
if (!PL_curinterp) {
PERL_SET_INTERP(my_perl);
#if defined(USE_ITHREADS)
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
- return ZeroD(my_perl, 1, PerlInterpreter);
+ return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
}
#endif /* PERL_IMPLICIT_SYS */
void
perl_construct(pTHXx)
{
+ dVAR;
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
/* Use sysconf(_SC_CLK_TCK) if available, if not
* available or if the sysconf() fails, use the HZ.
- * BeOS has those, but returns the wrong value. */
+ * BeOS has those, but returns the wrong value.
+ * The HZ if not originally defined has been by now
+ * been defined as CLK_TCK, if available. */
#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
PL_clocktick = sysconf(_SC_CLK_TCK);
if (PL_clocktick <= 0)
(int)PERL_SUBVERSION ), 0
);
+#ifdef HAS_MMAP
+ if (!PL_mmap_page_size) {
+#if defined(HAS_SYSCONF) && (defined(_SC_PAGESIZE) || defined(_SC_MMAP_PAGE_SIZE))
+ {
+ SETERRNO(0, SS_NORMAL);
+# ifdef _SC_PAGESIZE
+ PL_mmap_page_size = sysconf(_SC_PAGESIZE);
+# else
+ PL_mmap_page_size = sysconf(_SC_MMAP_PAGE_SIZE);
+# endif
+ if ((long) PL_mmap_page_size < 0) {
+ if (errno) {
+ SV *error = ERRSV;
+ char *msg;
+ STRLEN n_a;
+ (void) SvUPGRADE(error, SVt_PV);
+ msg = SvPVx(error, n_a);
+ Perl_croak(aTHX_ "panic: sysconf: %s", msg);
+ }
+ else
+ Perl_croak(aTHX_ "panic: sysconf: pagesize unknown");
+ }
+ }
+#else
+# ifdef HAS_GETPAGESIZE
+ PL_mmap_page_size = getpagesize();
+# else
+# if defined(I_SYS_PARAM) && defined(PAGESIZE)
+ PL_mmap_page_size = PAGESIZE; /* compiletime, bad */
+# endif
+# endif
+#endif
+ if (PL_mmap_page_size <= 0)
+ Perl_croak(aTHX_ "panic: bad pagesize %" IVdf,
+ (IV) PL_mmap_page_size);
+ }
+#endif /* HAS_MMAP */
+
+#if defined(HAS_TIMES) && defined(PERL_NEED_TIMESBASE)
+ PL_timesbase.tms_utime = 0;
+ PL_timesbase.tms_stime = 0;
+ PL_timesbase.tms_cutime = 0;
+ PL_timesbase.tms_cstime = 0;
+#endif
+
ENTER;
}
int
perl_destruct(pTHXx)
{
+ dVAR;
volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */
HV *hv;
destruct_level = PL_perl_destruct_level;
#ifdef DEBUGGING
{
- char *s;
+ const char *s;
if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
const int i = atoi(s);
if (destruct_level < i)
}
#endif
-
- if(PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
+ if (PL_exit_flags & PERL_EXIT_DESTRUCT_END) {
dJMPENV;
int x = 0;
while (i) {
SV *resv = ary[--i];
- REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
if (SvFLAGS(resv) & SVf_BREAK) {
/* this is PL_reg_curpm, already freed
else if(SvREPADTMP(resv)) {
SvREPADTMP_off(resv);
}
- else {
+ else if(SvIOKp(resv)) {
+ REGEXP *re = INT2PTR(REGEXP *,SvIVX(resv));
ReREFCNT_dec(re);
}
}
for (sv = sva + 1; sv < svend; ++sv) {
if (SvTYPE(sv) != SVTYPEMASK) {
PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
- " flags=0x08%"UVxf
- " refcnt=%"UVuf pTHX__FORMAT "\n",
- sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
+ " flags=0x%"UVxf
+ " refcnt=%"UVuf pTHX__FORMAT "\n"
+ "\tallocated at %s:%d %s %s%s\n",
+ sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE,
+ sv->sv_debug_file ? sv->sv_debug_file : "(unknown)",
+ sv->sv_debug_line,
+ sv->sv_debug_inpad ? "for" : "by",
+ sv->sv_debug_optype ?
+ PL_op_name[sv->sv_debug_optype]: "(none)",
+ sv->sv_debug_cloned ? " (cloned)" : ""
+ );
}
}
}
/* As the absolutely last thing, free the non-arena SV for mess() */
if (PL_mess_sv) {
+ /* we know that type == SVt_PVMG */
+
/* it could have accumulated taint magic */
- if (SvTYPE(PL_mess_sv) >= SVt_PVMG) {
- MAGIC* mg;
- MAGIC* moremagic;
- for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
- moremagic = mg->mg_moremagic;
- if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
- && mg->mg_len >= 0)
- Safefree(mg->mg_ptr);
- Safefree(mg);
- }
+ MAGIC* mg;
+ MAGIC* moremagic;
+ for (mg = SvMAGIC(PL_mess_sv); mg; mg = moremagic) {
+ moremagic = mg->mg_moremagic;
+ if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global
+ && mg->mg_len >= 0)
+ Safefree(mg->mg_ptr);
+ Safefree(mg);
}
+
/* we know that type >= SVt_PV */
- SvOOK_off(PL_mess_sv);
- Safefree(SvPVX(PL_mess_sv));
+ SvPV_free(PL_mess_sv);
Safefree(SvANY(PL_mess_sv));
Safefree(PL_mess_sv);
PL_mess_sv = Nullsv;
#pragma fini "perl_fini"
#endif
-#if defined(__GNUC__) && defined(__attribute__)
-/* want to make sure __attribute__ works here even
- * for -Dd_attribut=undef builds.
- */
-#undef __attribute__
+static void
+#if defined(__GNUC__)
+__attribute__((destructor))
#endif
-
-static void __attribute__((destructor))
-perl_fini()
+perl_fini(void)
{
+ dVAR;
if (PL_curinterp)
FREE_THREAD_KEY;
}
int
perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
{
+ dVAR;
I32 oldscope;
int ret;
dJMPENV;
STATIC void *
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
+ dVAR;
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
if (!PL_do_undump)
init_postdump_symbols(argc,argv,env);
- /* PL_unicode is turned on by -C or by $ENV{PERL_UNICODE}.
- * PL_utf8locale is conditionally turned on by
+ /* PL_unicode is turned on by -C, or by $ENV{PERL_UNICODE},
+ * or explicitly in some platforms.
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
+#if defined(SYMBIAN)
+ PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
+#endif
if (PL_unicode) {
/* Requires init_predump_symbols(). */
if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) {
PL_op = PL_main_start;
CALLRUNOPS(aTHX);
}
-
my_exit(0);
/* NOTREACHED */
}
Perl_call_sv(pTHX_ SV *sv, I32 flags)
/* See G_* flags in cop.h */
{
- dSP;
+ dVAR; dSP;
LOGOP myop; /* fake syntax tree node */
UNOP method_op;
I32 oldmark;
/* we're trying to emulate pp_entertry() here */
{
register PERL_CONTEXT *cx;
- I32 gimme = GIMME_V;
+ const I32 gimme = GIMME_V;
ENTER;
SAVETMPS;
if (flags & G_KEEPERR)
PL_in_eval |= EVAL_KEEPERR;
else
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
}
PL_markstack_ptr++;
call_body((OP*)&myop, FALSE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
call_body((OP*)&myop,TRUE);
retval = PL_stack_sp - (PL_stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(ERRSV,"");
+ sv_setpvn(ERRSV,"",0);
break;
case 1:
STATUS_ALL_FAILURE;
/* This message really ought to be max 23 lines.
* Removed -h because the user already knows that option. Others? */
- static const char *usage_msg[] = {
+ static const char * const usage_msg[] = {
"-0[octal] specify record separator (\\0, if no argument)",
+"-A[name] activate all/given assertions",
"-a autosplit mode with -n or -p (splits $_ into @F)",
"-C[number/list] enables the listed Unicode features",
"-c check syntax only (runs BEGIN and CHECK blocks)",
"-d[:debugger] run program under debugger",
"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
"-e program one line of program (several -e's allowed, omit programfile)",
+#ifdef USE_SITECUSTOMIZE
"-f don't do $sitelib/sitecustomize.pl at startup",
+#endif
"-F/pattern/ split() pattern for -a switch (//'s are optional)",
"-i[extension] edit <> files in place (makes backup if extension supplied)",
"-Idirectory specify @INC/#include directory (several -I's allowed)",
"\n",
NULL
};
- const char **p = usage_msg;
+ const char * const *p = usage_msg;
PerlIO_printf(PerlIO_stdout(),
"\nUsage: %s [switches] [--] [programfile] [arguments]",
int
Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
{
- static const char *usage_msgd[] = {
+ static const char * const usage_msgd[] = {
" Debugging flag values: (see also -d)",
" p Tokenizing and parsing (with v, displays parse stack)",
" s Stack snapshots (with v, displays all stacks)",
for (; isALNUM(**s); (*s)++) ;
}
else if (givehelp) {
- const char **p = usage_msgd;
+ char **p = (char **)usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
char *
Perl_moreswitches(pTHX_ char *s)
{
- STRLEN numlen;
+ dVAR;
UV rschar;
switch (*s) {
case '0':
{
I32 flags = 0;
+ STRLEN numlen;
SvREFCNT_dec(PL_rs);
if (s[1] == 'x' && s[2]) {
- char *e;
+ const char *e = s+=2;
U8 *tmps;
- for (s += 2, e = s; *e; e++);
+ while (*e)
+ e++;
numlen = e - s;
flags = PERL_SCAN_SILENT_ILLDIGIT;
rschar = (U32)grok_hex(s, &numlen, &flags, NULL);
/* The following permits -d:Mod to accepts arguments following an =
in the fashion that -MSome::Mod does. */
if (*s == ':' || *s == '=') {
- char *start;
+ const char *start;
SV *sv;
sv = newSVpv("use Devel::", 0);
start = ++s;
}
if (isDIGIT(*s)) {
I32 flags = 0;
+ STRLEN numlen;
PL_ors_sv = newSVpvn("\n",1);
numlen = 3 + (*s == '0');
*SvPVX(PL_ors_sv) = (char)grok_oct(s, &numlen, &flags, NULL);
PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
+#ifdef SYMBIAN
+ PerlIO_printf(PerlIO_stdout(),
+ "Symbian port by Nokia, 2004-2005\n");
+#endif
#ifdef BINARY_BUILD_NOTICE
BINARY_BUILD_NOTICE;
#endif
# if defined(PERL_IMPLICIT_CONTEXT)
# if defined(USE_5005THREADS)
# define PERLVARI(var,type,init) PERL_GET_INTERP->var = init;
-# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
+# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# else /* !USE_5005THREADS */
# define PERLVARI(var,type,init) aTHX->var = init;
# define PERLVARIC(var,type,init) aTHX->var = init;
SvREFCNT_dec(GvHV(gv));
GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
SvREADONLY_on(gv);
- HvNAME(PL_defstash) = savepvn("main", 4);
+ Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0);
PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
GvMULTI_on(PL_incgv);
PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
const char *cpp_discard_flag;
const char *perl;
#endif
+ dVAR;
PL_fdscript = -1;
PL_suidscript = -1;
STATIC void
S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
{
+ dVAR;
#ifdef IAMSUID
/* int which; */
#endif /* IAMSUID */
int euid = PerlProc_geteuid();
int gid = PerlProc_getgid();
int egid = PerlProc_getegid();
+ (void)envp;
#ifdef VMS
uid |= gid << 16;
&& (argv[1][1] == 't' || argv[1][1] == 'T') )
return 1;
return 0;
- (void)envp;
}
STATIC void
PL_DBgv = gv_fetchpv("DB::DB", GV_ADDMULTI, SVt_PVGV);
PL_DBline = gv_fetchpv("DB::dbline", GV_ADDMULTI, SVt_PVAV);
PL_DBsub = gv_HVadd(gv_fetchpv("DB::sub", GV_ADDMULTI, SVt_PVHV));
- sv_upgrade(GvSV(PL_DBsub), SVt_IV); /* IVX accessed if PERLDB_SUB_NN */
PL_DBsingle = GvSV((gv_fetchpv("DB::single", GV_ADDMULTI, SVt_PV)));
sv_setiv(PL_DBsingle, 0);
PL_DBtrace = GvSV((gv_fetchpv("DB::trace", GV_ADDMULTI, SVt_PV)));
STATIC void
S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
{
- char *s;
- SV *sv;
+ dVAR;
GV* tmpgv;
PL_toptarget = NEWSV(0,0);
}
if (env) {
char** origenv = environ;
+ char *s;
+ SV *sv;
for (; *env; env++) {
if (!(s = strchr(*env,'=')) || s == *env)
continue;
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC)
+#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
SvFLAGS(PL_thrsv) = SVt_PV;
SvANY(PL_thrsv) = (void*)xpv;
SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */
- SvPVX(PL_thrsv) = (char*)thr;
+ SvPV_set(PL_thrsvr, (char*)thr);
SvCUR_set(PL_thrsv, sizeof(thr));
SvLEN_set(PL_thrsv, sizeof(thr));
*SvEND(PL_thrsv) = '\0'; /* in the trailing_nul field */
void
Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
{
+ dVAR;
SV *atsv;
const line_t oldline = CopLINE(PL_curcop);
CV *cv;
#else
int exitstatus;
if (errno & 255)
- STATUS_POSIX_SET(errno);
+ STATUS_UNIX_SET(errno);
else {
- exitstatus = STATUS_POSIX >> 8;
+ exitstatus = STATUS_UNIX >> 8;
if (exitstatus & 255)
- STATUS_POSIX_SET(exitstatus);
+ STATUS_UNIX_SET(exitstatus);
else
- STATUS_POSIX_SET(255);
+ STATUS_UNIX_SET(255);
}
#endif
my_exit_jump();
STATIC void
S_my_exit_jump(pTHX)
{
+ dVAR;
register PERL_CONTEXT *cx;
I32 gimme;
SV **newsp;
sv_chop(PL_e_script, nl);
return 1;
}
+
+/*
+ * Local variables:
+ * c-indentation-style: bsd
+ * c-basic-offset: 4
+ * indent-tabs-mode: t
+ * End:
+ *
+ * ex: set ts=8 sts=4 sw=4 noet:
+ */
projects / p5sagit/p5-mst-13.2.git / blobdiff