#endif
#endif
-/* XXX If this causes problems, set i_unistd=undef in the hint file. */
-#ifdef I_UNISTD
-# include <unistd.h>
-#endif
-
#ifdef I_VFORK
# include <vfork.h>
#endif
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
-#ifdef HAS_64K_LIMIT
+#ifdef HAS_64K_LIMIT
if (size > 0xffff) {
PerlIO_printf(Perl_error_log,
"Reallocation too large: %lx\n", size) FLUSH;
#endif
ptr = (Malloc_t)PerlMem_realloc(where,size);
PERL_ALLOC_CHECK(ptr);
-
+
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
if (!wh)
return safexmalloc(0,size);
-
+
{
MEM_SIZE old = sizeof_chunk(where - ALIGN);
int t = typeof_chunk(where - ALIGN);
register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
-
+
xycount[t][SIZE_TO_Y(old)]--;
xycount[t][SIZE_TO_Y(size)]++;
xcount[t] += size - old;
I32 x;
char *where = (char*)wh;
MEM_SIZE size;
-
+
if (!where)
return;
where -= ALIGN;
for (j = 0; j < MAXYCOUNT; j++) {
subtot[j] = 0;
}
-
+
PerlIO_printf(Perl_debug_log, " Id subtot 4 8 12 16 20 24 28 32 36 40 48 56 64 72 80 80+\n", total);
for (i = 0; i < MAXXCOUNT; i++) {
total += xcount[i];
}
if (flag == 0
? xcount[i] /* Have something */
- : (flag == 2
+ : (flag == 2
? xcount[i] != lastxcount[i] /* Changed */
: xcount[i] > lastxcount[i])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
+ PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100,
flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
lastxcount[i] = xcount[i];
for (j = 0; j < MAXYCOUNT; j++) {
- if ( flag == 0
+ if ( flag == 0
? xycount[i][j] /* Have something */
- : (flag == 2
+ : (flag == 2
? xycount[i][j] != lastxycount[i][j] /* Changed */
: xycount[i][j] > lastxycount[i][j])) { /* Growed */
- PerlIO_printf(Perl_debug_log,"%3ld ",
- flag == 2
- ? xycount[i][j] - lastxycount[i][j]
+ PerlIO_printf(Perl_debug_log,"%3ld ",
+ flag == 2
+ ? xycount[i][j] - lastxycount[i][j]
: xycount[i][j]);
lastxycount[i][j] = xycount[i][j];
} else {
if (setlocale_failure) {
char *p;
- bool locwarn = (printwarn > 1 ||
+ bool locwarn = (printwarn > 1 ||
(printwarn &&
(!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
if (locwarn) {
#ifdef LC_ALL
-
+
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed.\n");
#else /* !LC_ALL */
-
+
PerlIO_printf(Perl_error_log,
"perl: warning: Setting locale failed for the categories:\n\t");
#ifdef USE_LOCALE_CTYPE
register I32 multiline = flags & FBMrf_MULTILINE;
if (bigend - big < littlelen) {
- if ( SvTAIL(littlestr)
+ if ( SvTAIL(littlestr)
&& (bigend - big == littlelen - 1)
- && (littlelen == 1
+ && (littlelen == 1
|| (*big == *little &&
memEQ((char *)big, (char *)little, littlelen - 1))))
return (char*)big;
}
if (SvTAIL(littlestr) && !multiline) { /* tail anchored? */
s = bigend - littlelen;
- if (s >= big && bigend[-1] == '\n' && *s == *little
+ if (s >= big && bigend[-1] == '\n' && *s == *little
/* Automatically of length > 2 */
&& memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
{
}
return b;
}
-
+
{ /* Do actual FBM. */
register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
register unsigned char *oldlittle;
of ends of some substring of bigstr.
If `last' we want the last occurence.
old_posp is the way of communication between consequent calls if
- the next call needs to find the .
+ the next call needs to find the .
The initial *old_posp should be -1.
Note that we take into account SvTAIL, so one can get extra
? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
: (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
cant_find:
- if ( BmRARE(littlestr) == '\n'
+ if ( BmRARE(littlestr) == '\n'
&& BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
little = (unsigned char *)(SvPVX(littlestr));
littleend = little + SvCUR(littlestr);
found = 1;
}
} while ( pos += PL_screamnext[pos] );
- if (last && found)
+ if (last && found)
return (char *)(big+(*old_posp));
#endif /* POINTERRIGOR */
check_tail:
SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
- line_mode ? "line" : "chunk",
+ line_mode ? "line" : "chunk",
(IV)IoLINES(GvIOp(PL_last_in_gv)));
}
#ifdef USE_THREADS
PerlIO_write(serr, message, msglen);
#ifdef LEAKTEST
- DEBUG_L(*message == '!'
+ DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
? (message[2]=='!' ? 2 : 1)
: 0)
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
SV *msg;
-
+
ENTER;
save_re_context();
msg = newSVpvn(message, msglen);
SvREADONLY_on(msg);
SAVEFREESV(msg);
-
+
PUSHSTACKi(PERLSI_DIEHOOK);
PUSHMARK(sp);
XPUSHs(msg);
if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
dSP;
SV *msg;
-
+
ENTER;
save_re_context();
msg = newSVpvn(message, msglen);
SvREADONLY_on(msg);
SAVEFREESV(msg);
-
+
PUSHSTACKi(PERLSI_WARNHOOK);
PUSHMARK(sp);
XPUSHs(msg);
PerlIO *serr = Perl_error_log;
PerlIO_write(serr, message, msglen);
#ifdef LEAKTEST
- DEBUG_L(*message == '!'
+ DEBUG_L(*message == '!'
? (xstat(message[1]=='!'
? (message[2]=='!' ? 2 : 1)
: 0)
if (doexec) {
return my_syspopen(aTHX_ cmd,mode);
}
-#endif
+#endif
This = (*mode == 'w');
that = !This;
if (doexec && PL_tainting) {
PerlIO *
Perl_my_popen(pTHX_ char *cmd, char *mode)
{
- /* Needs work for PerlIO ! */
- /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
PERL_FLUSHALL_FOR_CHILD;
- return popen(PerlIO_exportFILE(cmd, 0), mode);
+ /* Call system's popen() to get a FILE *, then import it.
+ used 0 for 2nd parameter to PerlIO_importFILE;
+ apparently not used
+ */
+ return PerlIO_importFILE(popen(cmd, mode), 0);
}
#endif
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
}
-#endif
+#endif
if ((close_failed = (PerlIO_close(ptr) == EOF))) {
saved_errno = errno;
#ifdef VMS
#else
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
-#endif
+#endif
{
/* Needs work for PerlIO ! */
FILE *f = PerlIO_findFILE(ptr);
/* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
of LONG_(MIN/MAX).
-- Kenneth Albanowski <kjahds@kjahds.com>
-*/
+*/
#ifndef MY_UV_MAX
# define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
+ ) {
dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
register char *s = start;
register NV rnv = 0.0;
register UV ruv = 0;
- register bool seenx = FALSE;
register bool overflowed = FALSE;
char *hexdigit;
+ if (len > 2) {
+ if (s[0] == 'x') {
+ s++;
+ len--;
+ }
+ else if (len > 3 && s[0] == '0' && s[1] == 'x') {
+ s+=2;
+ len-=2;
+ }
+ }
+
for (; len-- && *s; s++) {
hexdigit = strchr((char *) PL_hexdigit, *s);
if (!hexdigit) {
--len;
++s;
}
- else if (seenx == FALSE && *s == 'x' && ruv == 0) {
- /* Disallow 0xxx0x0xxx... */
- seenx = TRUE;
- continue;
- }
else {
dTHR;
if (ckWARN(WARN_DIGIT))
#if UVSIZE > 4
|| (!overflowed && ruv > 0xffffffff )
#endif
- ) {
+ ) {
dTHR;
if (ckWARN(WARN_PORTABLE))
Perl_warner(aTHX_ WARN_PORTABLE,
}
#ifndef DOSISH
if (!xfound && !seen_dot && !xfailed &&
- (PerlLIO_stat(scriptname,&PL_statbuf) < 0
+ (PerlLIO_stat(scriptname,&PL_statbuf) < 0
|| S_ISDIR(PL_statbuf.st_mode)))
#endif
seen_dot = 1; /* Disable message. */
{
perl_os_thread t;
perl_cond cond = *cp;
-
+
if (!cond)
return;
t = cond->thread;
{
perl_os_thread t;
perl_cond cond, cond_next;
-
+
for (cond = *cp; cond; cond = cond_next) {
t = cond->thread;
/* Insert t in the runnable queue just ahead of us */
if (thr->i.next_run == thr)
Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
-
+
New(666, cond, 1, struct perl_wait_queue);
cond->thread = thr;
cond->next = *cp;
Perl_condpair_magic(pTHX_ SV *sv)
{
MAGIC *mg;
-
+
SvUPGRADE(sv, SVt_PVMG);
mg = mg_find(sv, 'm');
if (!mg) {
"new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
(IV)i, t, thr));
}
- }
+ }
thr->threadsvp = AvARRAY(thr->threadsv);
MUTEX_LOCK(&PL_threads_mutex);
#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL))
/*
* This hack is to force load of "huge" support from libm.a
- * So it is in perl for (say) POSIX to use.
+ * So it is in perl for (say) POSIX to use.
* Needed for SunOS with Sun's 'acc' for example.
*/
-NV
+NV
Perl_huge(void)
{
# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)
I32
Perl_my_fflush_all(pTHX)
{
-#ifdef FFLUSH_NULL
+#if defined(FFLUSH_NULL)
return PerlIO_flush(NULL);
#else
+# if defined(HAS__FWALK)
+ /* undocumented, unprototyped, but very useful BSDism */
+ extern void _fwalk(int (*)(FILE *));
+ _fwalk(&fflush);
+ return 0;
+# else
long open_max = -1;
-# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
-# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
+# if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
+# ifdef PERL_FFLUSH_ALL_FOPEN_MAX
open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
-# else
-# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
+# else
+# if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
open_max = sysconf(_SC_OPEN_MAX);
-# else
-# ifdef FOPEN_MAX
- open_max = FOPEN_MAX;
# else
-# ifdef OPEN_MAX
- open_max = OPEN_MAX;
+# ifdef FOPEN_MAX
+ open_max = FOPEN_MAX;
# else
-# ifdef _NFILE
+# ifdef OPEN_MAX
+ open_max = OPEN_MAX;
+# else
+# ifdef _NFILE
open_max = _NFILE;
+# endif
# endif
# endif
# endif
-# endif
-# endif
+# endif
if (open_max > 0) {
long i;
for (i = 0; i < open_max; i++)
PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
return 0;
}
-# endif
+# endif
SETERRNO(EBADF,RMS$_IFI);
return EOF;
+# endif
#endif
}