return NULL;
}
-#define FBM_TABLE_OFFSET 2 /* Number of bytes between EOS and table*/
-
/* As a space optimization, we do not compile tables for strings of length
0 and 1, and for strings of length 2 unless FBMcf_TAIL. These are
special-cased in fbm_instr().
mg->mg_len++;
}
s = (U8*)SvPV_force_mutable(sv, len);
- SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
+ SvUPGRADE(sv, SVt_PVGV);
+ SvIOK_off(sv);
+ SvNOK_off(sv);
+ SvVALID_on(sv);
if (len > 2) {
const unsigned char *sb;
const U8 mlen = (len>255) ? 255 : (U8)len;
register U8 *table;
- Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
- table = (unsigned char*)(SvPVX_mutable(sv) + len + FBM_TABLE_OFFSET);
- s = table - 1 - FBM_TABLE_OFFSET; /* last char */
+ Sv_Grow(sv, len + 256 + PERL_FBM_TABLE_OFFSET);
+ table
+ = (unsigned char*)(SvPVX_mutable(sv) + len + PERL_FBM_TABLE_OFFSET);
+ s = table - 1 - PERL_FBM_TABLE_OFFSET; /* last char */
memset((void*)table, mlen, 256);
- table[-1] = (U8)flags;
+ BmFLAGS(sv) = (U8)flags;
i = 0;
sb = s - mlen + 1; /* first char (maybe) */
while (s >= sb) {
table[*s] = (U8)i;
s--, i++;
}
+ } else {
+ Sv_Grow(sv, len + PERL_FBM_TABLE_OFFSET);
}
sv_magic(sv, NULL, PERL_MAGIC_bm, NULL, 0); /* deep magic */
- SvVALID_on(sv);
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
}
}
BmRARE(sv) = s[rarest];
- BmPREVIOUS(sv) = (U16)rarest;
+ BmPREVIOUS_set(sv, rarest);
BmUSEFUL(sv) = 100; /* Initial value */
if (flags & FBMcf_TAIL)
SvTAIL_on(sv);
- DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
- BmRARE(sv),BmPREVIOUS(sv)));
+ DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %lu\n",
+ BmRARE(sv),(unsigned long)BmPREVIOUS(sv)));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
}
return NULL;
}
- if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
+ if (!SvVALID(littlestr)) {
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
return b;
}
- { /* Do actual FBM. */
- register const unsigned char * const table = little + littlelen + FBM_TABLE_OFFSET;
+ /* Do actual FBM. */
+ if (littlelen > (STRLEN)(bigend - big))
+ return NULL;
+
+ {
+ register const unsigned char * const table
+ = little + littlelen + PERL_FBM_TABLE_OFFSET;
register const unsigned char *oldlittle;
- if (littlelen > (STRLEN)(bigend - big))
- return NULL;
--littlelen; /* Last char found by table lookup */
s = big + littlelen;
}
}
check_end:
- if ( s == bigend && (table[-1] & FBMcf_TAIL)
+ if ( s == bigend
+ && (BmFLAGS(littlestr) & FBMcf_TAIL)
&& memEQ((char *)(bigend - littlelen),
(char *)(oldlittle - littlelen), littlelen) )
return (char*)bigend - littlelen;
register const unsigned char *littleend;
I32 found = 0;
+ assert(SvTYPE(littlestr) == SVt_PVGV);
+ assert(SvVALID(littlestr));
+
if (*old_posp == -1
? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
cant_find:
if ( BmRARE(littlestr) == '\n'
- && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
+ && BmPREVIOUS(littlestr) == (U8)SvCUR(littlestr) - 1) {
little = (const unsigned char *)(SvPVX_const(littlestr));
littleend = little + SvCUR(littlestr);
first = *little++;
else {
char *newaddr;
const STRLEN pvlen = strlen(pv)+1;
- Newx(newaddr,pvlen,char);
- return memcpy(newaddr,pv,pvlen);
+ Newx(newaddr, pvlen, char);
+ return (char*)memcpy(newaddr, pv, pvlen);
}
}
if (!newaddr) {
return write_no_mem();
}
- return memcpy(newaddr,pv,pvlen);
+ return (char*)memcpy(newaddr, pv, pvlen);
}
/*
const MEM_SIZE len_wanted = sizeof(STRLEN) + size;
PERL_UNUSED_CONTEXT;
- buffer = specialWARN(buffer) ? PerlMemShared_malloc(len_wanted)
- : PerlMemShared_realloc(buffer, len_wanted);
+ buffer = (STRLEN*)
+ (specialWARN(buffer) ?
+ PerlMemShared_malloc(len_wanted) :
+ PerlMemShared_realloc(buffer, len_wanted));
buffer[0] = size;
Copy(bits, (buffer + 1), size, char);
return buffer;
#ifndef PERL_USE_SAFE_PUTENV
if (!PL_use_safe_putenv) {
/* most putenv()s leak, so we manipulate environ directly */
- register I32 i=setenv_getix(nam); /* where does it go? */
+ register I32 i=setenv_getix(nam); /* where does it go? */
int nlen, vlen;
- if (environ == PL_origenviron) { /* need we copy environment? */
- I32 j;
- I32 max;
- char **tmpenv;
-
- max = i;
- while (environ[max])
- max++;
- tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
- for (j=0; j<max; j++) { /* copy environment */
- const int len = strlen(environ[j]);
- tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
- Copy(environ[j], tmpenv[j], len+1, char);
- }
- tmpenv[max] = NULL;
- environ = tmpenv; /* tell exec where it is now */
+ if (environ == PL_origenviron) { /* need we copy environment? */
+ I32 j;
+ I32 max;
+ char **tmpenv;
+
+ max = i;
+ while (environ[max])
+ max++;
+ tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
+ for (j=0; j<max; j++) { /* copy environment */
+ const int len = strlen(environ[j]);
+ tmpenv[j] = (char*)safesysmalloc((len+1)*sizeof(char));
+ Copy(environ[j], tmpenv[j], len+1, char);
+ }
+ tmpenv[max] = NULL;
+ environ = tmpenv; /* tell exec where it is now */
}
if (!val) {
- safesysfree(environ[i]);
- while (environ[i]) {
- environ[i] = environ[i+1];
- i++;
+ safesysfree(environ[i]);
+ while (environ[i]) {
+ environ[i] = environ[i+1];
+ i++;
}
- return;
+ return;
}
- if (!environ[i]) { /* does not exist yet */
- environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
- environ[i+1] = NULL; /* make sure it's null terminated */
+ if (!environ[i]) { /* does not exist yet */
+ environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
+ environ[i+1] = NULL; /* make sure it's null terminated */
}
else
- safesysfree(environ[i]);
- nlen = strlen(nam);
- vlen = strlen(val);
+ safesysfree(environ[i]);
+ nlen = strlen(nam);
+ vlen = strlen(val);
- environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
- /* all that work just for this */
- my_setenv_format(environ[i], nam, nlen, val, vlen);
+ environ[i] = (char*)safesysmalloc((nlen+vlen+2) * sizeof(char));
+ /* all that work just for this */
+ my_setenv_format(environ[i], nam, nlen, val, vlen);
} else {
# endif
# if defined(__CYGWIN__) || defined(EPOC) || defined(__SYMBIAN32__) || defined(__riscos__)
int vlen;
if (!val) {
- val = "";
+ val = "";
}
vlen = strlen(val);
Newx(envstr, nlen+vlen+2, char);
PerlLIO_close(pp[0]);
return PerlIO_fdopen(p[This], mode);
#else
+# ifdef OS2 /* Same, without fork()ing and all extra overhead... */
+ return my_syspopen4(aTHX_ Nullch, mode, n, args);
+# else
Perl_croak(aTHX_ "List form of piped open not implemented");
return (PerlIO *) NULL;
+# endif
#endif
}
PerlProc__exit(1);
}
#endif /* defined OS2 */
+
+#ifdef PERLIO_USING_CRLF
+ /* Since we circumvent IO layers when we manipulate low-level
+ filedescriptors directly, need to manually switch to the
+ default, binary, low-level mode; see PerlIOBuf_open(). */
+ PerlLIO_setmode((*mode == 'r'), O_BINARY);
+#endif
+
if ((tmpgv = gv_fetchpvs("$", GV_ADD|GV_NOTQUAL, SVt_PV))) {
SvREADONLY_off(GvSV(tmpgv));
sv_setiv(GvSV(tmpgv), PerlProc_getpid());
#if defined(atarist) || defined(EPOC)
FILE *popen();
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen((pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
#if defined(DJGPP)
FILE *djgpp_popen();
PerlIO *
-Perl_my_popen(pTHX_ char *cmd, char *mode)
+Perl_my_popen((pTHX_ const char *cmd, const char *mode)
{
PERL_FLUSHALL_FOR_CHILD;
/* Call system's popen() to get a FILE *, then import it.
if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
if (ckWARN(WARN_IO)) {
- const char * const direction = (op == OP_phoney_INPUT_ONLY) ? "in" : "out";
+ const char * const direction =
+ (const char *)((op == OP_phoney_INPUT_ONLY) ? "in" : "out");
if (name && *name)
Perl_warner(aTHX_ packWARN(WARN_IO),
"Filehandle %s opened only for %sput",
}
if (ckWARN(warn_type)) {
- const char * const pars = OP_IS_FILETEST(op) ? "" : "()";
+ const char * const pars =
+ (const char *)(OP_IS_FILETEST(op) ? "" : "()");
const char * const func =
- op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
- op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
- op < 0 ? "" : /* handle phoney cases */
- PL_op_desc[op];
- const char * const type = OP_IS_SOCKET(op)
- || (gv && io && IoTYPE(io) == IoTYPE_SOCKET)
- ? "socket" : "filehandle";
+ (const char *)
+ (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
+ op < 0 ? "" : /* handle phoney cases */
+ PL_op_desc[op]);
+ const char * const type =
+ (const char *)
+ (OP_IS_SOCKET(op) ||
+ (gv && io && IoTYPE(io) == IoTYPE_SOCKET) ?
+ "socket" : "filehandle");
if (name && *name) {
Perl_warner(aTHX_ packWARN(warn_type),
"%s%s on %s %s %s", func, pars, vile, type, name);
else {
/* Possibly buf overflowed - try again with a bigger buf */
const int fmtlen = strlen(fmt);
- const int bufsize = fmtlen + buflen;
+ int bufsize = fmtlen + buflen;
Newx(buf, bufsize, char);
while (buf) {
buf = NULL;
break;
}
- Renew(buf, bufsize*2, char);
+ bufsize *= 2;
+ Renew(buf, bufsize, char);
}
return buf;
}
if ( SvNOK(ver) ) /* may get too much accuracy */
{
char tbuf[64];
+#ifdef USE_LOCALE_NUMERIC
+ char *loc = setlocale(LC_NUMERIC, "C");
+#endif
STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
+#ifdef USE_LOCALE_NUMERIC
+ setlocale(LC_NUMERIC, loc);
+#endif
while (tbuf[len-1] == '0' && len > 0) len--;
version = savepvn(tbuf, len);
}
char *buf = (char*)safesysmalloc(bufsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
- int l = e ? e - *environ : strlen(*environ);
+ int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
- bsiz = l + 1;
+ bsiz = l + 1; /* + 1 for the \0. */
buf = (char*)safesysmalloc(bufsiz);
}
- my_strlcpy(buf, bufsiz, *environ, l);
- *(buf + l) = '\0';
+ my_strlcpy(buf, *environ, l + 1);
(void)unsetenv(buf);
}
(void)safesysfree(buf);
}
#endif
+void
+Perl_get_db_sub(pTHX_ SV **svp, CV *cv)
+{
+ dVAR;
+ SV * const dbsv = GvSVn(PL_DBsub);
+ /* We do not care about using sv to call CV;
+ * it's for informational purposes only.
+ */
+
+ save_item(dbsv);
+ if (!PERLDB_SUB_NN) {
+ GV * const gv = CvGV(cv);
+
+ if ( svp && ((CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
+ || strEQ(GvNAME(gv), "END")
+ || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
+ !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv) )))) {
+ /* Use GV from the stack as a fallback. */
+ /* GV is potentially non-unique, or contain different CV. */
+ SV * const tmp = newRV((SV*)cv);
+ sv_setsv(dbsv, tmp);
+ SvREFCNT_dec(tmp);
+ }
+ else {
+ gv_efullname3(dbsv, gv, NULL);
+ }
+ }
+ else {
+ const int type = SvTYPE(dbsv);
+ if (type < SVt_PVIV && type != SVt_IV)
+ sv_upgrade(dbsv, SVt_PVIV);
+ (void)SvIOK_on(dbsv);
+ SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
+ }
+}
+
/*
* Local variables:
* c-indentation-style: bsd
https://perl5.git.perl.org / perl5.git / blobdiff