else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
else if (PL_nomemok)
return Nullch;
else {
- PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH;
+ PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH;
my_exit(1);
return Nullch;
}
for (i = 0; i < 256; i++) {
if (isUPPER_LC(i))
- fold_locale[i] = toLOWER_LC(i);
+ PL_fold_locale[i] = toLOWER_LC(i);
else if (isLOWER_LC(i))
- fold_locale[i] = toUPPER_LC(i);
+ PL_fold_locale[i] = toUPPER_LC(i);
else
- fold_locale[i] = i;
+ PL_fold_locale[i] = i;
}
#endif /* USE_LOCALE_CTYPE */
void
fbm_compile(SV *sv, U32 flags /* not used yet */)
{
- register unsigned char *s;
- register unsigned char *table;
+ register U8 *s;
+ register U8 *table;
register U32 i;
STRLEN len;
I32 rarest = 0;
U32 frequency = 256;
- s = SvPV_force(sv, len);
+ s = (U8*)SvPV_force(sv, len);
sv_upgrade(sv, SVt_PVBM);
if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */
return; /* can't have offsets that big */
s = (unsigned char*)(SvPVX(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
- if (freq[s[i]] < frequency) {
+ if (PL_freq[s[i]] < frequency) {
rarest = i;
- frequency = freq[s[i]];
+ frequency = PL_freq[s[i]];
}
}
BmRARE(sv) = s[rarest];
register U8 *a = (U8 *)s1;
register U8 *b = (U8 *)s2;
while (len--) {
- if (*a != *b && *a != fold[*b])
+ if (*a != *b && *a != PL_fold[*b])
return 1;
a++,b++;
}
register U8 *a = (U8 *)s1;
register U8 *b = (U8 *)s2;
while (len--) {
- if (*a != *b && *a != fold_locale[*b])
+ if (*a != *b && *a != PL_fold_locale[*b])
return 1;
a++,b++;
}
(void)PerlIO_flush(PerlIO_stderr());
}
+void
+warner(U32 err, const char* pat,...)
+{
+ dTHR;
+ va_list args;
+ char *message;
+ HV *stash;
+ GV *gv;
+ CV *cv;
+
+ va_start(args, pat);
+ message = mess(pat, &args);
+ va_end(args);
+
+ if (ckDEAD(err)) {
+#ifdef USE_THREADS
+ DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message));
+#endif /* USE_THREADS */
+ if (PL_diehook) {
+ /* sv_2cv might call croak() */
+ SV *olddiehook = PL_diehook;
+ ENTER;
+ SAVESPTR(PL_diehook);
+ PL_diehook = Nullsv;
+ cv = sv_2cv(olddiehook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ }
+ }
+ if (PL_in_eval) {
+ PL_restartop = die_where(message);
+ JMPENV_JUMP(3);
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+ (void)PerlIO_flush(PerlIO_stderr());
+ my_failure_exit();
+
+ }
+ else {
+ if (PL_warnhook) {
+ /* sv_2cv might call warn() */
+ dTHR;
+ SV *oldwarnhook = PL_warnhook;
+ ENTER;
+ SAVESPTR(PL_warnhook);
+ PL_warnhook = Nullsv;
+ cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
+ LEAVE;
+ if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
+ dSP;
+ SV *msg;
+
+ ENTER;
+ msg = newSVpv(message, 0);
+ SvREADONLY_on(msg);
+ SAVEFREESV(msg);
+
+ PUSHMARK(sp);
+ XPUSHs(msg);
+ PUTBACK;
+ perl_call_sv((SV*)cv, G_DISCARD);
+
+ LEAVE;
+ return;
+ }
+ }
+ PerlIO_puts(PerlIO_stderr(),message);
+#ifdef LEAKTEST
+ DEBUG_L(xstat());
+#endif
+ (void)PerlIO_flush(PerlIO_stderr());
+ }
+}
+
#ifndef VMS /* VMS' my_setenv() is in VMS.c */
#ifndef WIN32
void
#endif
/* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
PerlIO *
my_popen(char *cmd, char *mode)
{
#endif /* !HAS_SIGACTION */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS)
+#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM)
I32
my_pclose(PerlIO *ptr)
{
}
}
-#ifndef CASTNEGFLOAT
U32
-cast_ulong(f)
-double f;
+cast_ulong(double f)
{
long along;
return (unsigned long)along;
}
# undef BIGDOUBLE
-#endif
-
-#ifndef CASTI32
/* Unfortunately, on some systems the cast_uv() function doesn't
work with the system-supplied definition of ULONG_MAX. The
#endif
I32
-cast_i32(f)
-double f;
+cast_i32(double f)
{
if (f >= I32_MAX)
return (I32) I32_MAX;
}
IV
-cast_iv(f)
-double f;
+cast_iv(double f)
{
if (f >= IV_MAX)
return (IV) IV_MAX;
}
UV
-cast_uv(f)
-double f;
+cast_uv(double f)
{
if (f >= MY_UV_MAX)
return (UV) MY_UV_MAX;
return (UV) f;
}
-#endif
-
#ifndef HAS_RENAME
I32
-same_dirent(a,b)
-char *a;
-char *b;
+same_dirent(char *a, char *b)
{
char *fa = strrchr(a,'/');
char *fb = strrchr(b,'/');
retval = n | (*s++ - '0');
len--;
}
- if (PL_dowarn && len && (*s == '8' || *s == '9'))
- warn("Illegal octal digit ignored");
+ if (len && (*s == '8' || *s == '9')) {
+ dTHR;
+ if (ckWARN(WARN_OCTAL))
+ warner(WARN_OCTAL, "Illegal octal digit ignored");
+ }
*retlen = s - start;
return retval;
}
register UV retval = 0;
bool overflowed = FALSE;
char *tmp = s;
+ register UV n;
- while (len-- && *s && (tmp = strchr((char *) PL_hexdigit, *s))) {
- register UV n = retval << 4;
+ while (len-- && *s) {
+ tmp = strchr((char *) PL_hexdigit, *s++);
+ if (!tmp) {
+ if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0))
+ continue;
+ else {
+ dTHR;
+ --s;
+ if (ckWARN(WARN_UNSAFE))
+ warner(WARN_UNSAFE,"Illegal hex digit ignored");
+ break;
+ }
+ }
+ n = retval << 4;
if (!overflowed && (n >> 4) != retval) {
warn("Integer overflow in hex number");
overflowed = TRUE;
}
retval = n | ((tmp - PL_hexdigit) & 15);
- s++;
- }
- if (PL_dowarn && !tmp) {
- warn("Illegal hex digit ignored");
}
*retlen = s - start;
return retval;
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (PerlLIO_stat(cur,&PL_statbuf) >= 0) {
+ if (PerlLIO_stat(cur,&PL_statbuf) >= 0
+ && !S_ISDIR(PL_statbuf.st_mode)) {
dosearch = 0;
scriptname = cur;
#ifdef SEARCH_EXTS
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
+ if (S_ISDIR(PL_statbuf.st_mode)) {
+ retval = -1;
+ }
#ifdef SEARCH_EXTS
} while ( retval < 0 /* not there */
&& extidx>=0 && ext[extidx] /* try an extension? */
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0))
+ if (!xfound && !seen_dot && !xfailed &&
+ (PerlLIO_stat(scriptname,&PL_statbuf) < 0
+ || S_ISDIR(PL_statbuf.st_mode)))
#endif
seen_dot = 1; /* Disable message. */
if (!xfound) {
}
void
-perl_cond_init(cp)
-perl_cond *cp;
+perl_cond_init(perl_cond *cp)
{
*cp = 0;
}
void
-perl_cond_signal(cp)
-perl_cond *cp;
+perl_cond_signal(perl_cond *cp)
{
perl_os_thread t;
perl_cond cond = *cp;
}
void
-perl_cond_broadcast(cp)
-perl_cond *cp;
+perl_cond_broadcast(perl_cond *cp)
{
perl_os_thread t;
perl_cond cond, cond_next;
}
void
-perl_cond_wait(cp)
-perl_cond *cp;
+perl_cond_wait(perl_cond *cp)
{
perl_cond cond;
}
#endif /* FAKE_THREADS */
-#ifdef OLD_PTHREADS_API
+#ifdef PTHREAD_GETSPECIFIC_INT
struct perl_thread *
getTHR _((void))
{
croak("panic: pthread_getspecific");
return (struct perl_thread *) t;
}
-#endif /* OLD_PTHREADS_API */
+#endif
MAGIC *
condpair_magic(SV *sv)
SvGROW(sv, sizeof(struct perl_thread) + 1);
SvCUR_set(sv, sizeof(struct perl_thread));
thr = (Thread) SvPVX(sv);
- /* debug */
+#ifdef DEBUGGING
memset(thr, 0xab, sizeof(struct perl_thread));
PL_markstack = 0;
PL_scopestack = 0;
PL_retstack = 0;
PL_dirty = 0;
PL_localizing = 0;
- /* end debug */
+ Zero(&PL_hv_fetch_ent_mh, 1, HE);
+#else
+ Zero(thr, 1, struct perl_thread);
+#endif
thr->oursv = sv;
init_stacks(ARGS);
char **
get_op_names(void)
{
- return op_name;
+ return PL_op_name;
}
char **
get_op_descs(void)
{
- return op_desc;
+ return PL_op_desc;
}
char *
get_no_modify(void)
{
- return (char*)no_modify;
+ return (char*)PL_no_modify;
}
U32 *
get_opargs(void)
{
- return opargs;
+ return PL_opargs;
}
-
SV **
get_specialsv_list(void)
{
projects / p5sagit/p5-mst-13.2.git / blobdiff