const U8 *s;
STRLEN i;
STRLEN len;
- STRLEN rarest = 0;
U32 frequency = 256;
MAGIC *mg;
+ PERL_DEB( STRLEN rarest = 0 );
PERL_ARGS_ASSERT_FBM_COMPILE;
- if (isGV_with_GP(sv))
+ if (isGV_with_GP(sv) || SvROK(sv))
return;
if (SvVALID(sv))
if (mg && mg->mg_len >= 0)
mg->mg_len++;
}
- s = (U8*)SvPV_force_mutable(sv, len);
+ if (!SvPOK(sv) || SvNIOKp(sv) || SvIsCOW(sv))
+ s = (U8*)SvPV_force_mutable(sv, len);
+ else s = (U8 *)SvPV_mutable(sv, len);
if (len == 0) /* TAIL might be on a zero-length string. */
return;
SvUPGRADE(sv, SVt_PVMG);
s = (const unsigned char*)(SvPVX_const(sv)); /* deeper magic */
for (i = 0; i < len; i++) {
if (PL_freq[s[i]] < frequency) {
- rarest = i;
+ PERL_DEB( rarest = i );
frequency = PL_freq[s[i]];
}
}
- BmRARE(sv) = s[rarest];
- BmPREVIOUS(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 %"UVuf"\n",
- BmRARE(sv), BmPREVIOUS(sv)));
+ s[rarest], rarest));
}
/* If SvTAIL(littlestr), it has a fake '\n' at end. */
if (PL_stderrgv && SvREFCNT(PL_stderrgv)
&& (io = GvIO(PL_stderrgv))
&& (mg = SvTIED_mg((const SV *)io, PERL_MAGIC_tiedscalar)))
- Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, "PRINT",
+ Perl_magic_methcall(aTHX_ MUTABLE_SV(io), mg, SV_CONST(PRINT),
G_SCALAR | G_DISCARD | G_WRITING_TO_STDERR, 1, msv);
else {
#ifdef USE_SFIO
#endif /* HAS_VPRINTF */
-#ifdef MYSWAP
-#if BYTEORDER != 0x4321
-short
-Perl_my_swap(pTHX_ short s)
-{
-#if (BYTEORDER & 1) == 0
- short result;
-
- result = ((s & 255) << 8) + ((s >> 8) & 255);
- return result;
-#else
- return s;
-#endif
-}
-
-long
-Perl_my_htonl(pTHX_ long l)
-{
- union {
- long result;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234 || BYTEORDER == 0x12345678
-#if BYTEORDER == 0x12345678
- u.result = 0;
-#endif
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.result;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- I32 o;
- I32 s;
-
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- u.c[o & 0xf] = (l >> s) & 255;
- }
- return u.result;
-#endif
-#endif
-}
-
-long
-Perl_my_ntohl(pTHX_ long l)
-{
- union {
- long l;
- char c[sizeof(long)];
- } u;
-
-#if BYTEORDER == 0x1234
- u.c[0] = (l >> 24) & 255;
- u.c[1] = (l >> 16) & 255;
- u.c[2] = (l >> 8) & 255;
- u.c[3] = l & 255;
- return u.l;
-#else
-#if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
- Perl_croak(aTHX_ "Unknown BYTEORDER\n");
-#else
- I32 o;
- I32 s;
-
- u.l = l;
- l = 0;
- for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
- l |= (u.c[o & 0xf] & 255) << s;
- }
- return l;
-#endif
-#endif
-}
-
-#endif /* BYTEORDER != 0x4321 */
-#endif /* MYSWAP */
-
-/*
- * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
- * If these functions are defined,
- * the BYTEORDER is neither 0x1234 nor 0x4321.
- * However, this is not assumed.
- * -DWS
- */
-
-#define HTOLE(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- u.c[i] = (n >> s) & 0xFF; \
- } \
- return u.value; \
- }
-
-#define LETOH(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 0; \
- u.value = n; \
- n = 0; \
- for (i = 0; i < sizeof(u.c); i++, s += 8) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * Big-endian byte order functions.
- */
-
-#define HTOBE(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 8*(sizeof(u.c)-1); \
- for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
- u.c[i] = (n >> s) & 0xFF; \
- } \
- return u.value; \
- }
-
-#define BETOH(name,type) \
- type \
- name (type n) \
- { \
- union { \
- type value; \
- char c[sizeof(type)]; \
- } u; \
- U32 i; \
- U32 s = 8*(sizeof(u.c)-1); \
- u.value = n; \
- n = 0; \
- for (i = 0; i < sizeof(u.c); i++, s -= 8) { \
- n |= ((type)(u.c[i] & 0xFF)) << s; \
- } \
- return n; \
- }
-
-/*
- * If we just can't do it...
- */
-
-#define NOT_AVAIL(name,type) \
- type \
- name (type n) \
- { \
- Perl_croak_nocontext(#name "() not available"); \
- return n; /* not reached */ \
- }
-
-
-#if defined(HAS_HTOVS) && !defined(htovs)
-HTOLE(htovs,short)
-#endif
-#if defined(HAS_HTOVL) && !defined(htovl)
-HTOLE(htovl,long)
-#endif
-#if defined(HAS_VTOHS) && !defined(vtohs)
-LETOH(vtohs,short)
-#endif
-#if defined(HAS_VTOHL) && !defined(vtohl)
-LETOH(vtohl,long)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE16
-# if U16SIZE == 2
-HTOLE(Perl_my_htole16,U16)
-# else
-NOT_AVAIL(Perl_my_htole16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH16
-# if U16SIZE == 2
-LETOH(Perl_my_letoh16,U16)
-# else
-NOT_AVAIL(Perl_my_letoh16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE16
-# if U16SIZE == 2
-HTOBE(Perl_my_htobe16,U16)
-# else
-NOT_AVAIL(Perl_my_htobe16,U16)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH16
-# if U16SIZE == 2
-BETOH(Perl_my_betoh16,U16)
-# else
-NOT_AVAIL(Perl_my_betoh16,U16)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE32
-# if U32SIZE == 4
-HTOLE(Perl_my_htole32,U32)
-# else
-NOT_AVAIL(Perl_my_htole32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH32
-# if U32SIZE == 4
-LETOH(Perl_my_letoh32,U32)
-# else
-NOT_AVAIL(Perl_my_letoh32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE32
-# if U32SIZE == 4
-HTOBE(Perl_my_htobe32,U32)
-# else
-NOT_AVAIL(Perl_my_htobe32,U32)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH32
-# if U32SIZE == 4
-BETOH(Perl_my_betoh32,U32)
-# else
-NOT_AVAIL(Perl_my_betoh32,U32)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLE64
-# if U64SIZE == 8
-HTOLE(Perl_my_htole64,U64)
-# else
-NOT_AVAIL(Perl_my_htole64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_LETOH64
-# if U64SIZE == 8
-LETOH(Perl_my_letoh64,U64)
-# else
-NOT_AVAIL(Perl_my_letoh64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_HTOBE64
-# if U64SIZE == 8
-HTOBE(Perl_my_htobe64,U64)
-# else
-NOT_AVAIL(Perl_my_htobe64,U64)
-# endif
-#endif
-#ifdef PERL_NEED_MY_BETOH64
-# if U64SIZE == 8
-BETOH(Perl_my_betoh64,U64)
-# else
-NOT_AVAIL(Perl_my_betoh64,U64)
-# endif
-#endif
-
-#ifdef PERL_NEED_MY_HTOLES
-HTOLE(Perl_my_htoles,short)
-#endif
-#ifdef PERL_NEED_MY_LETOHS
-LETOH(Perl_my_letohs,short)
-#endif
-#ifdef PERL_NEED_MY_HTOBES
-HTOBE(Perl_my_htobes,short)
-#endif
-#ifdef PERL_NEED_MY_BETOHS
-BETOH(Perl_my_betohs,short)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEI
-HTOLE(Perl_my_htolei,int)
-#endif
-#ifdef PERL_NEED_MY_LETOHI
-LETOH(Perl_my_letohi,int)
-#endif
-#ifdef PERL_NEED_MY_HTOBEI
-HTOBE(Perl_my_htobei,int)
-#endif
-#ifdef PERL_NEED_MY_BETOHI
-BETOH(Perl_my_betohi,int)
-#endif
-
-#ifdef PERL_NEED_MY_HTOLEL
-HTOLE(Perl_my_htolel,long)
-#endif
-#ifdef PERL_NEED_MY_LETOHL
-LETOH(Perl_my_letohl,long)
-#endif
-#ifdef PERL_NEED_MY_HTOBEL
-HTOBE(Perl_my_htobel,long)
-#endif
-#ifdef PERL_NEED_MY_BETOHL
-BETOH(Perl_my_betohl,long)
-#endif
-
-void
-Perl_my_swabn(void *ptr, int n)
-{
- char *s = (char *)ptr;
- char *e = s + (n-1);
- char tc;
-
- PERL_ARGS_ASSERT_MY_SWABN;
-
- for (n /= 2; n > 0; s++, e--, n--) {
- tc = *s;
- *s = *e;
- *e = tc;
- }
-}
-
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
dVAR;
- Sigsave_t hstat, istat, qstat;
int status;
SV **svp;
Pid_t pid;
#endif
close_failed = (PerlIO_close(ptr) == EOF);
SAVE_ERRNO;
-#ifndef PERL_MICRO
- rsignal_save(SIGHUP, (Sighandler_t) SIG_IGN, &hstat);
- rsignal_save(SIGINT, (Sighandler_t) SIG_IGN, &istat);
- rsignal_save(SIGQUIT, (Sighandler_t) SIG_IGN, &qstat);
-#endif
if (should_wait) do {
pid2 = wait4pid(pid, &status, 0);
} while (pid2 == -1 && errno == EINTR);
-#ifndef PERL_MICRO
- rsignal_restore(SIGHUP, &hstat);
- rsignal_restore(SIGINT, &istat);
- rsignal_restore(SIGQUIT, &qstat);
-#endif
if (close_failed) {
RESTORE_ERRNO;
return -1;
SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
char *buf;
#ifdef USE_LOCALE_NUMERIC
- char *loc = savepv(setlocale(LC_NUMERIC, NULL));
- setlocale(LC_NUMERIC, "C");
+ char *loc = NULL;
+ if (! PL_numeric_standard) {
+ loc = savepv(setlocale(LC_NUMERIC, NULL));
+ setlocale(LC_NUMERIC, "C");
+ }
#endif
if (sv) {
Perl_sv_setpvf(aTHX_ sv, "%.9"NVff, SvNVX(ver));
buf = tbuf;
}
#ifdef USE_LOCALE_NUMERIC
- setlocale(LC_NUMERIC, loc);
- Safefree(loc);
+ if (loc) {
+ setlocale(LC_NUMERIC, loc);
+ Safefree(loc);
+ }
#endif
while (buf[len-1] == '0' && len > 0) len--;
if ( buf[len-1] == '.' ) len--; /* eat the trailing decimal */
(void)clearenv();
# elif defined(HAS_UNSETENV)
int bsiz = 80; /* Most envvar names will be shorter than this. */
- int bufsiz = bsiz * sizeof(char); /* sizeof(char) paranoid? */
- char *buf = (char*)safesysmalloc(bufsiz);
+ char *buf = (char*)safesysmalloc(bsiz);
while (*environ != NULL) {
char *e = strchr(*environ, '=');
int l = e ? e - *environ : (int)strlen(*environ);
if (bsiz < l + 1) {
(void)safesysfree(buf);
bsiz = l + 1; /* + 1 for the \0. */
- bufsiz = bsiz * sizeof(char); /* keep bsiz and bufsiz in sync */
- buf = (char*)safesysmalloc(bufsiz);
+ buf = (char*)safesysmalloc(bsiz);
}
memcpy(buf, *environ, l);
buf[l] = '\0';
{
dVAR;
SV * const dbsv = GvSVn(PL_DBsub);
- const bool save_taint = TAINT_get; /* Accepted unused var warning under NO_TAINT_SUPPORT */
+ const bool save_taint = TAINT_get;
/* When we are called from pp_goto (svp is null),
* we do not care about using dbsv to call CV;
SvIV_set(dbsv, PTR2IV(cv)); /* Do it the quickest way */
}
TAINT_IF(save_taint);
+#ifdef NO_TAINT_SUPPORT
+ PERL_UNUSED_VAR(save_taint);
+#endif
}
int
https://perl5.git.perl.org / perl5.git / blobdiff