#include "perl.h"
#include "reentr.h"
-#ifdef USE_PERLIO
+#if defined(USE_PERLIO)
#include "perliol.h" /* For PerlIOUnix_refcnt */
#endif
#endif
#endif
+#include <math.h>
+#include <stdlib.h>
+
#ifdef __Lynx__
/* Missing protos on LynxOS */
int putenv(char *);
# endif
#endif
+#ifdef PERL_DEBUG_READONLY_COW
+# include <sys/mman.h>
+#endif
+
#define FLUSH
#if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
# define ALWAYS_NEED_THX
#endif
+#if defined(PERL_TRACK_MEMPOOL) && defined(PERL_DEBUG_READONLY_COW)
+static void
+S_maybe_protect_rw(pTHX_ struct perl_memory_debug_header *header)
+{
+ if (header->readonly
+ && mprotect(header, header->size, PROT_READ|PROT_WRITE))
+ Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d",
+ header, header->size, errno);
+}
+
+static void
+S_maybe_protect_ro(pTHX_ struct perl_memory_debug_header *header)
+{
+ if (header->readonly
+ && mprotect(header, header->size, PROT_READ))
+ Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d",
+ header, header->size, errno);
+}
+# define maybe_protect_rw(foo) S_maybe_protect_rw(aTHX_ foo)
+# define maybe_protect_ro(foo) S_maybe_protect_ro(aTHX_ foo)
+#else
+# define maybe_protect_rw(foo) NOOP
+# define maybe_protect_ro(foo) NOOP
+#endif
+
/* paranoid version of system's malloc() */
Malloc_t
dTHX;
#endif
Malloc_t ptr;
-#ifdef HAS_64K_LIMIT
- if (size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
-#ifdef PERL_TRACK_MEMPOOL
size += sTHX;
-#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
Perl_croak_nocontext("panic: malloc, size=%"UVuf, (UV) size);
#endif
- ptr = (Malloc_t)PerlMem_malloc(size?size:1); /* malloc(0) is NASTY on our system */
+ if (!size) size = 1; /* malloc(0) is NASTY on our system */
+#ifdef PERL_DEBUG_READONLY_COW
+ if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+#else
+ ptr = (Malloc_t)PerlMem_malloc(size?size:1);
+#endif
PERL_ALLOC_CHECK(ptr);
if (ptr != NULL) {
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
#endif
header->prev = &PL_memory_debug_header;
header->next = PL_memory_debug_header.next;
PL_memory_debug_header.next = header;
+ maybe_protect_rw(header->next);
header->next->prev = header;
-# ifdef PERL_POISON
- header->size = size;
+ maybe_protect_ro(header->next);
+# ifdef PERL_DEBUG_READONLY_COW
+ header->readonly = 0;
# endif
- ptr = (Malloc_t)((char*)ptr+sTHX);
#endif
+#if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+ || defined(PERL_DEBUG_READONLY_COW)
+ header->size = size;
+#endif
+ ptr = (Malloc_t)((char*)ptr+sTHX);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
return ptr;
}
dTHX;
#endif
Malloc_t ptr;
+#ifdef PERL_DEBUG_READONLY_COW
+ const MEM_SIZE oldsize = where
+ ? ((struct perl_memory_debug_header *)((char *)where - sTHX))->size
+ : 0;
+#endif
#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
Malloc_t PerlMem_realloc();
#endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
-#ifdef HAS_64K_LIMIT
- if (size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Reallocation too large: %lx\n", size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
if (!size) {
safesysfree(where);
return NULL;
if (!where)
return safesysmalloc(size);
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
where = (Malloc_t)((char*)where-sTHX);
size += sTHX;
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)where;
+# ifdef PERL_TRACK_MEMPOOL
if (header->interpreter != aTHX) {
Perl_croak_nocontext("panic: realloc from wrong pool, %p!=%p",
header->interpreter, aTHX);
char *start_of_freed = ((char *)where) + size;
PoisonFree(start_of_freed, freed_up, char);
}
- header->size = size;
# endif
+# endif
+# if defined(PERL_POISON) || defined(PERL_DEBUG_READONLY_COW)
+ header->size = size;
+# endif
}
#endif
#ifdef DEBUGGING
if ((SSize_t)size < 0)
Perl_croak_nocontext("panic: realloc, size=%"UVuf, (UV)size);
#endif
+#ifdef PERL_DEBUG_READONLY_COW
+ if ((ptr = mmap(0, size, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+ Copy(where,ptr,oldsize < size ? oldsize : size,char);
+ if (munmap(where, oldsize)) {
+ perror("munmap failed");
+ abort();
+ }
+#else
ptr = (Malloc_t)PerlMem_realloc(where,size);
+#endif
PERL_ALLOC_CHECK(ptr);
/* MUST do this fixup first, before doing ANYTHING else, as anything else
might allocate memory/free/move memory, and until we do the fixup, it
may well be chasing (and writing to) free memory. */
-#ifdef PERL_TRACK_MEMPOOL
if (ptr != NULL) {
+#ifdef PERL_TRACK_MEMPOOL
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
}
# endif
+ maybe_protect_rw(header->next);
header->next->prev = header;
+ maybe_protect_ro(header->next);
+ maybe_protect_rw(header->prev);
header->prev->next = header;
-
+ maybe_protect_ro(header->prev);
+#endif
ptr = (Malloc_t)((char*)ptr+sTHX);
}
-#endif
/* In particular, must do that fixup above before logging anything via
*printf(), as it can reallocate memory, which can cause SEGVs. */
#endif
DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
if (where) {
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
where = (Malloc_t)((char*)where-sTHX);
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)where;
+# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+ || defined(PERL_DEBUG_READONLY_COW)
+ const MEM_SIZE size = header->size;
+# endif
+# ifdef PERL_TRACK_MEMPOOL
if (header->interpreter != aTHX) {
Perl_croak_nocontext("panic: free from wrong pool, %p!=%p",
header->interpreter, aTHX);
header->prev->next);
}
/* Unlink us from the chain. */
+ maybe_protect_rw(header->next);
header->next->prev = header->prev;
+ maybe_protect_ro(header->next);
+ maybe_protect_rw(header->prev);
header->prev->next = header->next;
+ maybe_protect_ro(header->prev);
+ maybe_protect_rw(header);
# ifdef PERL_POISON
- PoisonNew(where, header->size, char);
+ PoisonNew(where, size, char);
# endif
/* Trigger the duplicate free warning. */
header->next = NULL;
+# endif
+# ifdef PERL_DEBUG_READONLY_COW
+ if (munmap(where, size)) {
+ perror("munmap failed");
+ abort();
+ }
+# endif
}
#endif
+#ifndef PERL_DEBUG_READONLY_COW
PerlMem_free(where);
+#endif
}
}
dTHX;
#endif
Malloc_t ptr;
-#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
+#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) \
+ || defined(PERL_DEBUG_READONLY_COW)
MEM_SIZE total_size = 0;
#endif
/* Even though calloc() for zero bytes is strange, be robust. */
if (size && (count <= MEM_SIZE_MAX / size)) {
-#if defined(PERL_TRACK_MEMPOOL) || defined(HAS_64K_LIMIT) || defined(DEBUGGING)
+#if defined(PERL_TRACK_MEMPOOL) || defined(DEBUGGING) \
+ || defined(PERL_DEBUG_READONLY_COW)
total_size = size * count;
#endif
}
else
croak_memory_wrap();
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
if (sTHX <= MEM_SIZE_MAX - (MEM_SIZE)total_size)
total_size += sTHX;
else
croak_memory_wrap();
#endif
-#ifdef HAS_64K_LIMIT
- if (total_size > 0xffff) {
- PerlIO_printf(Perl_error_log,
- "Allocation too large: %lx\n", total_size) FLUSH;
- my_exit(1);
- }
-#endif /* HAS_64K_LIMIT */
#ifdef DEBUGGING
if ((SSize_t)size < 0 || (SSize_t)count < 0)
Perl_croak_nocontext("panic: calloc, size=%"UVuf", count=%"UVuf,
(UV)size, (UV)count);
#endif
-#ifdef PERL_TRACK_MEMPOOL
+#ifdef PERL_DEBUG_READONLY_COW
+ if ((ptr = mmap(0, total_size ? total_size : 1, PROT_READ|PROT_WRITE,
+ MAP_ANON|MAP_PRIVATE, -1, 0)) == MAP_FAILED) {
+ perror("mmap failed");
+ abort();
+ }
+#elif defined(PERL_TRACK_MEMPOOL)
/* Have to use malloc() because we've added some space for our tracking
header. */
/* malloc(0) is non-portable. */
PERL_ALLOC_CHECK(ptr);
DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)total_size));
if (ptr != NULL) {
-#ifdef PERL_TRACK_MEMPOOL
+#if defined(PERL_TRACK_MEMPOOL) || defined(PERL_DEBUG_READONLY_COW)
{
struct perl_memory_debug_header *const header
= (struct perl_memory_debug_header *)ptr;
+# ifndef PERL_DEBUG_READONLY_COW
memset((void*)ptr, 0, total_size);
+# endif
+# ifdef PERL_TRACK_MEMPOOL
header->interpreter = aTHX;
/* Link us into the list. */
header->prev = &PL_memory_debug_header;
header->next = PL_memory_debug_header.next;
PL_memory_debug_header.next = header;
+ maybe_protect_rw(header->next);
header->next->prev = header;
-# ifdef PERL_POISON
+ maybe_protect_ro(header->next);
+# ifdef PERL_DEBUG_READONLY_COW
+ header->readonly = 0;
+# endif
+# endif
+# if (defined(PERL_POISON) && defined(PERL_TRACK_MEMPOOL)) \
+ || defined(PERL_DEBUG_READONLY_COW)
header->size = total_size;
# endif
ptr = (Malloc_t)((char*)ptr+sTHX);
=for apidoc savepv
-Perl's version of C<strdup()>. Returns a pointer to a newly allocated
-string which is a duplicate of C<pv>. The size of the string is
-determined by C<strlen()>. The memory allocated for the new string can
+Perl's version of C<strdup()>. Returns a pointer to a newly allocated
+string which is a duplicate of C<pv>. The size of the string is
+determined by C<strlen()>. The memory allocated for the new string can
be freed with the C<Safefree()> function.
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpv>>.
+
=cut
*/
/*
=for apidoc savepvn
-Perl's version of what C<strndup()> would be if it existed. Returns a
+Perl's version of what C<strndup()> would be if it existed. Returns a
pointer to a newly allocated string which is a duplicate of the first
-C<len> bytes from C<pv>, plus a trailing NUL byte. The memory allocated for
+C<len> bytes from C<pv>, plus a trailing
+NUL byte. The memory allocated for
the new string can be freed with the C<Safefree()> function.
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedpvn>>.
+
=cut
*/
=for apidoc savesharedpvn
A version of C<savepvn()> which allocates the duplicate string in memory
-which is shared between threads. (With the specific difference that a NULL
+which is shared between threads. (With the specific difference that a NULL
pointer is not acceptable)
=cut
A version of C<savepv()>/C<savepvn()> which gets the string to duplicate from
the passed in SV using C<SvPV()>
+On some platforms, Windows for example, all allocated memory owned by a thread
+is deallocated when that thread ends. So if you need that not to happen, you
+need to use the shared memory functions, such as C<L</savesharedsvpv>>.
+
=cut
*/
return retval;
}
-STATIC const COP*
-S_closest_cop(pTHX_ const COP *cop, const OP *o)
+const COP*
+Perl_closest_cop(pTHX_ const COP *cop, const OP *o, const OP *curop,
+ bool opnext)
{
dVAR;
- /* Look for PL_op starting from o. cop is the last COP we've seen. */
+ /* Look for curop starting from o. cop is the last COP we've seen. */
+ /* opnext means that curop is actually the ->op_next of the op we are
+ seeking. */
PERL_ARGS_ASSERT_CLOSEST_COP;
- if (!o || o == PL_op)
+ if (!o || !curop || (
+ opnext ? o->op_next == curop && o->op_type != OP_SCOPE : o == curop
+ ))
return cop;
if (o->op_flags & OPf_KIDS) {
/* Keep searching, and return when we've found something. */
- new_cop = closest_cop(cop, kid);
+ new_cop = closest_cop(cop, kid, curop, opnext);
if (new_cop)
return new_cop;
}
* from the sibling of PL_curcop.
*/
- const COP *cop = closest_cop(PL_curcop, PL_curcop->op_sibling);
+ const COP *cop =
+ closest_cop(PL_curcop, PL_curcop->op_sibling, PL_op, FALSE);
if (!cop)
cop = PL_curcop;
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
- /* SFIO can really mess with your errno */
- dSAVED_ERRNO;
-#endif
PerlIO * const serr = Perl_error_log;
do_print(msv, serr);
(void)PerlIO_flush(serr);
-#ifdef USE_SFIO
- RESTORE_ERRNO;
-#endif
}
}
=for apidoc Am|void|croak_no_modify
Exactly equivalent to C<Perl_croak(aTHX_ "%s", PL_no_modify)>, but generates
-terser object code than using C<Perl_croak>. Less code used on exception code
+terser object code than using C<Perl_croak>. Less code used on exception code
paths reduces CPU cache pressure.
=cut
Perl_croak_no_mem()
{
dTHX;
+ int rc;
/* Can't use PerlIO to write as it allocates memory */
- PerlLIO_write(PerlIO_fileno(Perl_error_log),
+ rc = PerlLIO_write(PerlIO_fileno(Perl_error_log),
PL_no_mem, sizeof(PL_no_mem)-1);
+ /* silently ignore failures */
+ PERL_UNUSED_VAR(rc);
my_exit(1);
}
#endif /* HAS_FORK */
}
-#ifdef DUMP_FDS
-void
-Perl_dump_fds(pTHX_ const char *const s)
-{
- int fd;
- Stat_t tmpstatbuf;
-
- PERL_ARGS_ASSERT_DUMP_FDS;
-
- PerlIO_printf(Perl_debug_log,"%s", s);
- for (fd = 0; fd < 32; fd++) {
- if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
- PerlIO_printf(Perl_debug_log," %d",fd);
- }
- PerlIO_printf(Perl_debug_log,"\n");
- return;
-}
-#endif /* DUMP_FDS */
-
#ifndef HAS_DUP2
int
dup2(int oldfd, int newfd)
bool close_failed;
dSAVEDERRNO;
const int fd = PerlIO_fileno(ptr);
+ bool should_wait;
-#ifdef USE_PERLIO
+ svp = av_fetch(PL_fdpid,fd,TRUE);
+ pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
+ SvREFCNT_dec(*svp);
+ *svp = NULL;
+
+#if defined(USE_PERLIO)
/* Find out whether the refcount is low enough for us to wait for the
child proc without blocking. */
- const bool should_wait = PerlIOUnix_refcnt(fd) == 1;
+ should_wait = PerlIOUnix_refcnt(fd) == 1 && pid > 0;
#else
- const bool should_wait = 1;
+ should_wait = pid > 0;
#endif
- svp = av_fetch(PL_fdpid,fd,TRUE);
- pid = (SvTYPE(*svp) == SVt_IV) ? SvIVX(*svp) : -1;
- SvREFCNT_dec(*svp);
- *svp = &PL_sv_undef;
#ifdef OS2
if (pid == -1) { /* Opened by popen. */
return my_syspclose(ptr);
dVAR;
I32 result = 0;
PERL_ARGS_ASSERT_WAIT4PID;
- if (!pid)
- return -1;
#ifdef PERL_USES_PL_PIDSTATUS
+ if (!pid) {
+ /* PERL_USES_PL_PIDSTATUS is only defined when neither
+ waitpid() nor wait4() is available, or on OS/2, which
+ doesn't appear to support waiting for a progress group
+ member, so we can only treat a 0 pid as an unknown child.
+ */
+ errno = ECHILD;
+ return -1;
+ }
{
if (pid > 0) {
/* The keys in PL_pidstatus are now the raw 4 (or 8) bytes of the
goto finish;
#endif
#if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
- result = wait4((pid==-1)?0:pid,statusp,flags,NULL);
+ result = wait4(pid,statusp,flags,NULL);
goto finish;
#endif
#ifdef PERL_USES_PL_PIDSTATUS
I32
Perl_my_fflush_all(pTHX)
{
-#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
+#if defined(USE_PERLIO) || defined(FFLUSH_NULL)
return PerlIO_flush(NULL);
#else
# if defined(HAS__FWALK)
(const char *)(OP_IS_FILETEST(op) ? "" : "()");
const char * const func =
(const char *)
- (op == OP_READLINE ? "readline" : /* "<HANDLE>" not nice */
+ (op == OP_READLINE || op == OP_RCATLINE
+ ? "readline" : /* "<HANDLE>" not nice */
op == OP_LEAVEWRITE ? "write" : /* "write exit" not nice */
PL_op_desc[op]);
const char * const type =
*
*/
-#ifdef HAS_GNULIBC
+#ifdef __GLIBC__
# ifndef STRUCT_TM_HASZONE
# define STRUCT_TM_HASZONE
# endif
#endif
buflen = 64;
Newx(buf, buflen, char);
+
+ GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
len = strftime(buf, buflen, fmt, &mytm);
+ GCC_DIAG_RESTORE;
+
/*
** The following is needed to handle to the situation where
** tmpbuf overflows. Basically we want to allocate a buffer
Renew(buf, bufsize, char);
while (buf) {
+
+ GCC_DIAG_IGNORE(-Wformat-nonliteral); /* fmt checked by caller */
buflen = strftime(buf, bufsize, fmt, &mytm);
+ GCC_DIAG_RESTORE;
+
if (buflen > 0 && buflen < bufsize)
break;
/* heuristic to prevent out-of-memory errors */
{
#ifndef PERL_MICRO
dVAR;
-#ifndef INCOMPLETE_TAINTS
SvTAINTED_on(sv);
-#endif
PERL_ARGS_ASSERT_GETCWD_SV;
#endif
}
-#define VERSION_MAX 0x7FFFFFFF
-
-/*
-=for apidoc prescan_version
-
-Validate that a given string can be parsed as a version object, but doesn't
-actually perform the parsing. Can use either strict or lax validation rules.
-Can optionally set a number of hint variables to save the parsing code
-some time when tokenizing.
-
-=cut
-*/
-const char *
-Perl_prescan_version(pTHX_ const char *s, bool strict,
- const char **errstr,
- bool *sqv, int *ssaw_decimal, int *swidth, bool *salpha) {
- bool qv = (sqv ? *sqv : FALSE);
- int width = 3;
- int saw_decimal = 0;
- bool alpha = FALSE;
- const char *d = s;
-
- PERL_ARGS_ASSERT_PRESCAN_VERSION;
-
- if (qv && isDIGIT(*d))
- goto dotted_decimal_version;
-
- if (*d == 'v') { /* explicit v-string */
- d++;
- if (isDIGIT(*d)) {
- qv = TRUE;
- }
- else { /* degenerate v-string */
- /* requires v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
-
-dotted_decimal_version:
- if (strict && d[0] == '0' && isDIGIT(d[1])) {
- /* no leading zeros allowed */
- BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
- }
-
- while (isDIGIT(*d)) /* integer part */
- d++;
-
- if (*d == '.')
- {
- saw_decimal++;
- d++; /* decimal point */
- }
- else
- {
- if (strict) {
- /* require v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- else {
- goto version_prescan_finish;
- }
- }
-
- {
- int i = 0;
- int j = 0;
- while (isDIGIT(*d)) { /* just keep reading */
- i++;
- while (isDIGIT(*d)) {
- d++; j++;
- /* maximum 3 digits between decimal */
- if (strict && j > 3) {
- BADVERSION(s,errstr,"Invalid version format (maximum 3 digits between decimals)");
- }
- }
- if (*d == '_') {
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- if ( alpha ) {
- BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
- }
- d++;
- alpha = TRUE;
- }
- else if (*d == '.') {
- if (alpha) {
- BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
- }
- saw_decimal++;
- d++;
- }
- else if (!isDIGIT(*d)) {
- break;
- }
- j = 0;
- }
-
- if (strict && i < 2) {
- /* requires v1.2.3 */
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions require at least three parts)");
- }
- }
- } /* end if dotted-decimal */
- else
- { /* decimal versions */
- int j = 0; /* may need this later */
- /* special strict case for leading '.' or '0' */
- if (strict) {
- if (*d == '.') {
- BADVERSION(s,errstr,"Invalid version format (0 before decimal required)");
- }
- if (*d == '0' && isDIGIT(d[1])) {
- BADVERSION(s,errstr,"Invalid version format (no leading zeros)");
- }
- }
-
- /* and we never support negative versions */
- if ( *d == '-') {
- BADVERSION(s,errstr,"Invalid version format (negative version number)");
- }
-
- /* consume all of the integer part */
- while (isDIGIT(*d))
- d++;
-
- /* look for a fractional part */
- if (*d == '.') {
- /* we found it, so consume it */
- saw_decimal++;
- d++;
- }
- else if (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') {
- if ( d == s ) {
- /* found nothing */
- BADVERSION(s,errstr,"Invalid version format (version required)");
- }
- /* found just an integer */
- goto version_prescan_finish;
- }
- else if ( d == s ) {
- /* didn't find either integer or period */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
- else if (*d == '_') {
- /* underscore can't come after integer part */
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- else if (isDIGIT(d[1])) {
- BADVERSION(s,errstr,"Invalid version format (alpha without decimal)");
- }
- else {
- BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
- }
- }
- else {
- /* anything else after integer part is just invalid data */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
-
- /* scan the fractional part after the decimal point*/
-
- if (!isDIGIT(*d) && (strict || ! (!*d || *d == ';' || isSPACE(*d) || *d == '{' || *d == '}') )) {
- /* strict or lax-but-not-the-end */
- BADVERSION(s,errstr,"Invalid version format (fractional part required)");
- }
-
- while (isDIGIT(*d)) {
- d++; j++;
- if (*d == '.' && isDIGIT(d[-1])) {
- if (alpha) {
- BADVERSION(s,errstr,"Invalid version format (underscores before decimal)");
- }
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (dotted-decimal versions must begin with 'v')");
- }
- d = (char *)s; /* start all over again */
- qv = TRUE;
- goto dotted_decimal_version;
- }
- if (*d == '_') {
- if (strict) {
- BADVERSION(s,errstr,"Invalid version format (no underscores)");
- }
- if ( alpha ) {
- BADVERSION(s,errstr,"Invalid version format (multiple underscores)");
- }
- if ( ! isDIGIT(d[1]) ) {
- BADVERSION(s,errstr,"Invalid version format (misplaced underscore)");
- }
- width = j;
- d++;
- alpha = TRUE;
- }
- }
- }
-
-version_prescan_finish:
- while (isSPACE(*d))
- d++;
-
- if (!isDIGIT(*d) && (! (!*d || *d == ';' || *d == '{' || *d == '}') )) {
- /* trailing non-numeric data */
- BADVERSION(s,errstr,"Invalid version format (non-numeric data)");
- }
-
- if (sqv)
- *sqv = qv;
- if (swidth)
- *swidth = width;
- if (ssaw_decimal)
- *ssaw_decimal = saw_decimal;
- if (salpha)
- *salpha = alpha;
- return d;
-}
-
-/*
-=for apidoc scan_version
-
-Returns a pointer to the next character after the parsed
-version string, as well as upgrading the passed in SV to
-an RV.
-
-Function must be called with an already existing SV like
-
- sv = newSV(0);
- s = scan_version(s, SV *sv, bool qv);
-
-Performs some preprocessing to the string to ensure that
-it has the correct characteristics of a version. Flags the
-object if it contains an underscore (which denotes this
-is an alpha version). The boolean qv denotes that the version
-should be interpreted as if it had multiple decimals, even if
-it doesn't.
-
-=cut
-*/
-
-const char *
-Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv)
-{
- const char *start = s;
- const char *pos;
- const char *last;
- const char *errstr = NULL;
- int saw_decimal = 0;
- int width = 3;
- bool alpha = FALSE;
- bool vinf = FALSE;
- AV * av;
- SV * hv;
-
- PERL_ARGS_ASSERT_SCAN_VERSION;
-
- while (isSPACE(*s)) /* leading whitespace is OK */
- s++;
-
- last = prescan_version(s, FALSE, &errstr, &qv, &saw_decimal, &width, &alpha);
- if (errstr) {
- /* "undef" is a special case and not an error */
- if ( ! ( *s == 'u' && strEQ(s,"undef")) ) {
- Safefree(start);
- Perl_croak(aTHX_ "%s", errstr);
- }
- }
-
- start = s;
- if (*s == 'v')
- s++;
- pos = s;
-
- /* Now that we are through the prescan, start creating the object */
- av = newAV();
- hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
- if ( qv )
- (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(qv));
- if ( alpha )
- (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(alpha));
- if ( !qv && width < 3 )
- (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
-
- while (isDIGIT(*pos))
- pos++;
- if (!isALPHA(*pos)) {
- I32 rev;
-
- for (;;) {
- rev = 0;
- {
- /* this is atoi() that delimits on underscores */
- const char *end = pos;
- I32 mult = 1;
- I32 orev;
-
- /* the following if() will only be true after the decimal
- * point of a version originally created with a bare
- * floating point number, i.e. not quoted in any way
- */
- if ( !qv && s > start && saw_decimal == 1 ) {
- mult *= 100;
- while ( s < end ) {
- orev = rev;
- rev += (*s - '0') * mult;
- mult /= 10;
- if ( (PERL_ABS(orev) > PERL_ABS(rev))
- || (PERL_ABS(rev) > VERSION_MAX )) {
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version %d",VERSION_MAX);
- s = end - 1;
- rev = VERSION_MAX;
- vinf = 1;
- }
- s++;
- if ( *s == '_' )
- s++;
- }
- }
- else {
- while (--end >= s) {
- orev = rev;
- rev += (*end - '0') * mult;
- mult *= 10;
- if ( (PERL_ABS(orev) > PERL_ABS(rev))
- || (PERL_ABS(rev) > VERSION_MAX )) {
- Perl_ck_warner(aTHX_ packWARN(WARN_OVERFLOW),
- "Integer overflow in version");
- end = s - 1;
- rev = VERSION_MAX;
- vinf = 1;
- }
- }
- }
- }
-
- /* Append revision */
- av_push(av, newSViv(rev));
- if ( vinf ) {
- s = last;
- break;
- }
- else if ( *pos == '.' )
- s = ++pos;
- else if ( *pos == '_' && isDIGIT(pos[1]) )
- s = ++pos;
- else if ( *pos == ',' && isDIGIT(pos[1]) )
- s = ++pos;
- else if ( isDIGIT(*pos) )
- s = pos;
- else {
- s = pos;
- break;
- }
- if ( qv ) {
- while ( isDIGIT(*pos) )
- pos++;
- }
- else {
- int digits = 0;
- while ( ( isDIGIT(*pos) || *pos == '_' ) && digits < 3 ) {
- if ( *pos != '_' )
- digits++;
- pos++;
- }
- }
- }
- }
- if ( qv ) { /* quoted versions always get at least three terms*/
- I32 len = av_len(av);
- /* This for loop appears to trigger a compiler bug on OS X, as it
- loops infinitely. Yes, len is negative. No, it makes no sense.
- Compiler in question is:
- gcc version 3.3 20030304 (Apple Computer, Inc. build 1640)
- for ( len = 2 - len; len > 0; len-- )
- av_push(MUTABLE_AV(sv), newSViv(0));
- */
- len = 2 - len;
- while (len-- > 0)
- av_push(av, newSViv(0));
- }
-
- /* need to save off the current version string for later */
- if ( vinf ) {
- SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1);
- (void)hv_stores(MUTABLE_HV(hv), "original", orig);
- (void)hv_stores(MUTABLE_HV(hv), "vinf", newSViv(1));
- }
- else if ( s > start ) {
- SV * orig = newSVpvn(start,s-start);
- if ( qv && saw_decimal == 1 && *start != 'v' ) {
- /* need to insert a v to be consistent */
- sv_insert(orig, 0, 0, "v", 1);
- }
- (void)hv_stores(MUTABLE_HV(hv), "original", orig);
- }
- else {
- (void)hv_stores(MUTABLE_HV(hv), "original", newSVpvs("0"));
- av_push(av, newSViv(0));
- }
-
- /* And finally, store the AV in the hash */
- (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
-
- /* fix RT#19517 - special case 'undef' as string */
- if ( *s == 'u' && strEQ(s,"undef") ) {
- s += 5;
- }
-
- return s;
-}
-
-/*
-=for apidoc new_version
-
-Returns a new version object based on the passed in SV:
-
- SV *sv = new_version(SV *ver);
-
-Does not alter the passed in ver SV. See "upg_version" if you
-want to upgrade the SV.
-
-=cut
-*/
-
-SV *
-Perl_new_version(pTHX_ SV *ver)
-{
- dVAR;
- SV * const rv = newSV(0);
- PERL_ARGS_ASSERT_NEW_VERSION;
- if ( sv_isobject(ver) && sv_derived_from(ver, "version") )
- /* can just copy directly */
- {
- I32 key;
- AV * const av = newAV();
- AV *sav;
- /* This will get reblessed later if a derived class*/
- SV * const hv = newSVrv(rv, "version");
- (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */
-#ifndef NODEFAULT_SHAREKEYS
- HvSHAREKEYS_on(hv); /* key-sharing on by default */
-#endif
-
- if ( SvROK(ver) )
- ver = SvRV(ver);
-
- /* Begin copying all of the elements */
- if ( hv_exists(MUTABLE_HV(ver), "qv", 2) )
- (void)hv_stores(MUTABLE_HV(hv), "qv", newSViv(1));
-
- if ( hv_exists(MUTABLE_HV(ver), "alpha", 5) )
- (void)hv_stores(MUTABLE_HV(hv), "alpha", newSViv(1));
-
- if ( hv_exists(MUTABLE_HV(ver), "width", 5 ) )
- {
- const I32 width = SvIV(*hv_fetchs(MUTABLE_HV(ver), "width", FALSE));
- (void)hv_stores(MUTABLE_HV(hv), "width", newSViv(width));
- }
-
- if ( hv_exists(MUTABLE_HV(ver), "original", 8 ) )
- {
- SV * pv = *hv_fetchs(MUTABLE_HV(ver), "original", FALSE);
- (void)hv_stores(MUTABLE_HV(hv), "original", newSVsv(pv));
- }
-
- sav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(ver), "version", FALSE)));
- /* This will get reblessed later if a derived class*/
- for ( key = 0; key <= av_len(sav); key++ )
- {
- const I32 rev = SvIV(*av_fetch(sav, key, FALSE));
- av_push(av, newSViv(rev));
- }
-
- (void)hv_stores(MUTABLE_HV(hv), "version", newRV_noinc(MUTABLE_SV(av)));
- return rv;
- }
-#ifdef SvVOK
- {
- const MAGIC* const mg = SvVSTRING_mg(ver);
- if ( mg ) { /* already a v-string */
- const STRLEN len = mg->mg_len;
- char * const version = savepvn( (const char*)mg->mg_ptr, len);
- sv_setpvn(rv,version,len);
- /* this is for consistency with the pure Perl class */
- if ( isDIGIT(*version) )
- sv_insert(rv, 0, 0, "v", 1);
- Safefree(version);
- }
- else {
-#endif
- sv_setsv(rv,ver); /* make a duplicate */
-#ifdef SvVOK
- }
- }
-#endif
- return upg_version(rv, FALSE);
-}
-
-/*
-=for apidoc upg_version
-
-In-place upgrade of the supplied SV to a version object.
-
- SV *sv = upg_version(SV *sv, bool qv);
-
-Returns a pointer to the upgraded SV. Set the boolean qv if you want
-to force this SV to be interpreted as an "extended" version.
-
-=cut
-*/
-
-SV *
-Perl_upg_version(pTHX_ SV *ver, bool qv)
-{
- const char *version, *s;
-#ifdef SvVOK
- const MAGIC *mg;
-#endif
-
- PERL_ARGS_ASSERT_UPG_VERSION;
-
- if ( SvNOK(ver) && !( SvPOK(ver) && sv_len(ver) == 3 ) )
- {
- STRLEN len;
-
- /* may get too much accuracy */
- char tbuf[64];
- SV *sv = SvNVX(ver) > 10e50 ? newSV(64) : 0;
- char *buf;
-#ifdef USE_LOCALE_NUMERIC
- 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 = SvPV(sv, len);
- }
- else {
- len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVff, SvNVX(ver));
- buf = tbuf;
- }
-#ifdef USE_LOCALE_NUMERIC
- 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 */
- version = savepvn(buf, len);
- SvREFCNT_dec(sv);
- }
-#ifdef SvVOK
- else if ( (mg = SvVSTRING_mg(ver)) ) { /* already a v-string */
- version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
- qv = TRUE;
- }
-#endif
- else /* must be a string or something like a string */
- {
- STRLEN len;
- version = savepv(SvPV(ver,len));
-#ifndef SvVOK
-# if PERL_VERSION > 5
- /* This will only be executed for 5.6.0 - 5.8.0 inclusive */
- if ( len >= 3 && !instr(version,".") && !instr(version,"_")) {
- /* may be a v-string */
- char *testv = (char *)version;
- STRLEN tlen = len;
- for (tlen=0; tlen < len; tlen++, testv++) {
- /* if one of the characters is non-text assume v-string */
- if (testv[0] < ' ') {
- SV * const nsv = sv_newmortal();
- const char *nver;
- const char *pos;
- int saw_decimal = 0;
- sv_setpvf(nsv,"v%vd",ver);
- pos = nver = savepv(SvPV_nolen(nsv));
-
- /* scan the resulting formatted string */
- pos++; /* skip the leading 'v' */
- while ( *pos == '.' || isDIGIT(*pos) ) {
- if ( *pos == '.' )
- saw_decimal++ ;
- pos++;
- }
-
- /* is definitely a v-string */
- if ( saw_decimal >= 2 ) {
- Safefree(version);
- version = nver;
- }
- break;
- }
- }
- }
-# endif
-#endif
- }
-
- s = scan_version(version, ver, qv);
- if ( *s != '\0' )
- Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
- "Version string '%s' contains invalid data; "
- "ignoring: '%s'", version, s);
- Safefree(version);
- return ver;
-}
-
-/*
-=for apidoc vverify
-
-Validates that the SV contains valid internal structure for a version object.
-It may be passed either the version object (RV) or the hash itself (HV). If
-the structure is valid, it returns the HV. If the structure is invalid,
-it returns NULL.
-
- SV *hv = vverify(sv);
-
-Note that it only confirms the bare minimum structure (so as not to get
-confused by derived classes which may contain additional hash entries):
-
-=over 4
-
-=item * The SV is an HV or a reference to an HV
-
-=item * The hash contains a "version" key
-
-=item * The "version" key has a reference to an AV as its value
-
-=back
-
-=cut
-*/
-
-SV *
-Perl_vverify(pTHX_ SV *vs)
-{
- SV *sv;
-
- PERL_ARGS_ASSERT_VVERIFY;
-
- if ( SvROK(vs) )
- vs = SvRV(vs);
-
- /* see if the appropriate elements exist */
- if ( SvTYPE(vs) == SVt_PVHV
- && hv_exists(MUTABLE_HV(vs), "version", 7)
- && (sv = SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)))
- && SvTYPE(sv) == SVt_PVAV )
- return vs;
- else
- return NULL;
-}
-
-/*
-=for apidoc vnumify
-
-Accepts a version object and returns the normalized floating
-point representation. Call like:
-
- sv = vnumify(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnumify(pTHX_ SV *vs)
-{
- I32 i, len, digit;
- int width;
- bool alpha = FALSE;
- SV *sv;
- AV *av;
-
- PERL_ARGS_ASSERT_VNUMIFY;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- /* see if various flags exist */
- if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
- alpha = TRUE;
- if ( hv_exists(MUTABLE_HV(vs), "width", 5 ) )
- width = SvIV(*hv_fetchs(MUTABLE_HV(vs), "width", FALSE));
- else
- width = 3;
-
-
- /* attempt to retrieve the version array */
- if ( !(av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE))) ) ) {
- return newSVpvs("0");
- }
-
- len = av_len(av);
- if ( len == -1 )
- {
- return newSVpvs("0");
- }
-
- digit = SvIV(*av_fetch(av, 0, 0));
- sv = Perl_newSVpvf(aTHX_ "%d.", (int)PERL_ABS(digit));
- for ( i = 1 ; i < len ; i++ )
- {
- digit = SvIV(*av_fetch(av, i, 0));
- if ( width < 3 ) {
- const int denom = (width == 2 ? 10 : 100);
- const div_t term = div((int)PERL_ABS(digit),denom);
- Perl_sv_catpvf(aTHX_ sv, "%0*d_%d", width, term.quot, term.rem);
- }
- else {
- Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
- }
- }
-
- if ( len > 0 )
- {
- digit = SvIV(*av_fetch(av, len, 0));
- if ( alpha && width == 3 ) /* alpha version */
- sv_catpvs(sv,"_");
- Perl_sv_catpvf(aTHX_ sv, "%0*d", width, (int)digit);
- }
- else /* len == 0 */
- {
- sv_catpvs(sv, "000");
- }
- return sv;
-}
-
-/*
-=for apidoc vnormal
-
-Accepts a version object and returns the normalized string
-representation. Call like:
-
- sv = vnormal(rv);
-
-NOTE: you can pass either the object directly or the SV
-contained within the RV.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vnormal(pTHX_ SV *vs)
-{
- I32 i, len, digit;
- bool alpha = FALSE;
- SV *sv;
- AV *av;
-
- PERL_ARGS_ASSERT_VNORMAL;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- if ( hv_exists(MUTABLE_HV(vs), "alpha", 5 ) )
- alpha = TRUE;
- av = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(vs), "version", FALSE)));
-
- len = av_len(av);
- if ( len == -1 )
- {
- return newSVpvs("");
- }
- digit = SvIV(*av_fetch(av, 0, 0));
- sv = Perl_newSVpvf(aTHX_ "v%"IVdf, (IV)digit);
- for ( i = 1 ; i < len ; i++ ) {
- digit = SvIV(*av_fetch(av, i, 0));
- Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
- }
-
- if ( len > 0 )
- {
- /* handle last digit specially */
- digit = SvIV(*av_fetch(av, len, 0));
- if ( alpha )
- Perl_sv_catpvf(aTHX_ sv, "_%"IVdf, (IV)digit);
- else
- Perl_sv_catpvf(aTHX_ sv, ".%"IVdf, (IV)digit);
- }
-
- if ( len <= 2 ) { /* short version, must be at least three */
- for ( len = 2 - len; len != 0; len-- )
- sv_catpvs(sv,".0");
- }
- return sv;
-}
-
-/*
-=for apidoc vstringify
-
-In order to maintain maximum compatibility with earlier versions
-of Perl, this function will return either the floating point
-notation or the multiple dotted notation, depending on whether
-the original version contained 1 or more dots, respectively.
-
-The SV returned has a refcount of 1.
-
-=cut
-*/
-
-SV *
-Perl_vstringify(pTHX_ SV *vs)
-{
- PERL_ARGS_ASSERT_VSTRINGIFY;
-
- /* extract the HV from the object */
- vs = vverify(vs);
- if ( ! vs )
- Perl_croak(aTHX_ "Invalid version object");
-
- if (hv_exists(MUTABLE_HV(vs), "original", sizeof("original") - 1)) {
- SV *pv;
- pv = *hv_fetchs(MUTABLE_HV(vs), "original", FALSE);
- if ( SvPOK(pv) )
- return newSVsv(pv);
- else
- return &PL_sv_undef;
- }
- else {
- if ( hv_exists(MUTABLE_HV(vs), "qv", 2) )
- return vnormal(vs);
- else
- return vnumify(vs);
- }
-}
-
-/*
-=for apidoc vcmp
-
-Version object aware cmp. Both operands must already have been
-converted into version objects.
-
-=cut
-*/
-
-int
-Perl_vcmp(pTHX_ SV *lhv, SV *rhv)
-{
- I32 i,l,m,r,retval;
- bool lalpha = FALSE;
- bool ralpha = FALSE;
- I32 left = 0;
- I32 right = 0;
- AV *lav, *rav;
-
- PERL_ARGS_ASSERT_VCMP;
-
- /* extract the HVs from the objects */
- lhv = vverify(lhv);
- rhv = vverify(rhv);
- if ( ! ( lhv && rhv ) )
- Perl_croak(aTHX_ "Invalid version object");
-
- /* get the left hand term */
- lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(lhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(lhv), "alpha", 5 ) )
- lalpha = TRUE;
-
- /* and the right hand term */
- rav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(rhv), "version", FALSE)));
- if ( hv_exists(MUTABLE_HV(rhv), "alpha", 5 ) )
- ralpha = TRUE;
-
- l = av_len(lav);
- r = av_len(rav);
- m = l < r ? l : r;
- retval = 0;
- i = 0;
- while ( i <= m && retval == 0 )
- {
- left = SvIV(*av_fetch(lav,i,0));
- right = SvIV(*av_fetch(rav,i,0));
- if ( left < right )
- retval = -1;
- if ( left > right )
- retval = +1;
- i++;
- }
-
- /* tiebreaker for alpha with identical terms */
- if ( retval == 0 && l == r && left == right && ( lalpha || ralpha ) )
- {
- if ( lalpha && !ralpha )
- {
- retval = -1;
- }
- else if ( ralpha && !lalpha)
- {
- retval = +1;
- }
- }
-
- if ( l != r && retval == 0 ) /* possible match except for trailing 0's */
- {
- if ( l < r )
- {
- while ( i <= r && retval == 0 )
- {
- if ( SvIV(*av_fetch(rav,i,0)) != 0 )
- retval = -1; /* not a match after all */
- i++;
- }
- }
- else
- {
- while ( i <= l && retval == 0 )
- {
- if ( SvIV(*av_fetch(lav,i,0)) != 0 )
- retval = +1; /* not a match after all */
- i++;
- }
- }
- }
- return retval;
-}
+#include "vutil.c"
#if !defined(HAS_SOCKETPAIR) && defined(HAS_SOCKET) && defined(AF_INET) && defined(PF_INET) && defined(SOCK_DGRAM) && defined(HAS_SELECT)
# define EMULATE_SOCKETPAIR_UDP
=for apidoc sv_nosharing
Dummy routine which "shares" an SV when there is no sharing module present.
-Or "locks" it. Or "unlocks" it. In other words, ignores its single SV argument.
+Or "locks" it. Or "unlocks" it. In other
+words, ignores its single SV argument.
Exists to avoid test for a NULL function pointer and because it could
potentially warn under some level of strict-ness.
=for apidoc my_sprintf
The C library C<sprintf>, wrapped if necessary, to ensure that it will return
-the length of the string written to the buffer. Only rare pre-ANSI systems
+the length of the string written to the buffer. Only rare pre-ANSI systems
need the wrapper function - usually this is a direct call to C<sprintf>.
=cut
Perl_croak_sv(aTHX_ xpt);
}
+/*
+=for apidoc my_strlcat
+
+The C library C<strlcat> if available, or a Perl implementation of it.
+This operates on C NUL-terminated strings.
+
+C<my_strlcat()> appends string C<src> to the end of C<dst>. It will append at
+most S<C<size - strlen(dst) - 1>> characters. It will then NUL-terminate,
+unless C<size> is 0 or the original C<dst> string was longer than C<size> (in
+practice this should not happen as it means that either C<size> is incorrect or
+that C<dst> is not a proper NUL-terminated string).
+
+Note that C<size> is the full size of the destination buffer and
+the result is guaranteed to be NUL-terminated if there is room. Note that room
+for the NUL should be included in C<size>.
+
+=cut
+
+Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcat
+*/
#ifndef HAS_STRLCAT
Size_t
Perl_my_strlcat(char *dst, const char *src, Size_t size)
}
#endif
+
+/*
+=for apidoc my_strlcpy
+
+The C library C<strlcpy> if available, or a Perl implementation of it.
+This operates on C NUL-terminated strings.
+
+C<my_strlcpy()> copies up to S<C<size - 1>> characters from the string C<src>
+to C<dst>, NUL-terminating the result if C<size> is not 0.
+
+=cut
+
+Description stolen from http://www.openbsd.org/cgi-bin/man.cgi?query=strlcpy
+*/
#ifndef HAS_STRLCPY
Size_t
Perl_my_strlcpy(char *dst, const char *src, Size_t size)
}
/*
+ * This code is derived from drand48() implementation from FreeBSD,
+ * found in lib/libc/gen/_rand48.c.
+ *
+ * The U64 implementation is original, based on the POSIX
+ * specification for drand48().
+ */
+
+/*
+* Copyright (c) 1993 Martin Birgmeier
+* All rights reserved.
+*
+* You may redistribute unmodified or modified versions of this source
+* code provided that the above copyright notice and this and the
+* following conditions are retained.
+*
+* This software is provided ``as is'', and comes with no warranties
+* of any kind. I shall in no event be liable for anything that happens
+* to anyone/anything when using this software.
+*/
+
+#define FREEBSD_DRAND48_SEED_0 (0x330e)
+
+#ifdef PERL_DRAND48_QUAD
+
+#define DRAND48_MULT U64_CONST(0x5deece66d)
+#define DRAND48_ADD 0xb
+#define DRAND48_MASK U64_CONST(0xffffffffffff)
+
+#else
+
+#define FREEBSD_DRAND48_SEED_1 (0xabcd)
+#define FREEBSD_DRAND48_SEED_2 (0x1234)
+#define FREEBSD_DRAND48_MULT_0 (0xe66d)
+#define FREEBSD_DRAND48_MULT_1 (0xdeec)
+#define FREEBSD_DRAND48_MULT_2 (0x0005)
+#define FREEBSD_DRAND48_ADD (0x000b)
+
+const unsigned short _rand48_mult[3] = {
+ FREEBSD_DRAND48_MULT_0,
+ FREEBSD_DRAND48_MULT_1,
+ FREEBSD_DRAND48_MULT_2
+};
+const unsigned short _rand48_add = FREEBSD_DRAND48_ADD;
+
+#endif
+
+void
+Perl_drand48_init_r(perl_drand48_t *random_state, U32 seed)
+{
+ PERL_ARGS_ASSERT_DRAND48_INIT_R;
+
+#ifdef PERL_DRAND48_QUAD
+ *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
+#else
+ random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
+ random_state->seed[1] = (U16) seed;
+ random_state->seed[2] = (U16) (seed >> 16);
+#endif
+}
+
+double
+Perl_drand48_r(perl_drand48_t *random_state)
+{
+ PERL_ARGS_ASSERT_DRAND48_R;
+
+#ifdef PERL_DRAND48_QUAD
+ *random_state = (*random_state * DRAND48_MULT + DRAND48_ADD)
+ & DRAND48_MASK;
+
+ return ldexp((double)*random_state, -48);
+#else
+ {
+ U32 accu;
+ U16 temp[2];
+
+ accu = (U32) _rand48_mult[0] * (U32) random_state->seed[0]
+ + (U32) _rand48_add;
+ temp[0] = (U16) accu; /* lower 16 bits */
+ accu >>= sizeof(U16) * 8;
+ accu += (U32) _rand48_mult[0] * (U32) random_state->seed[1]
+ + (U32) _rand48_mult[1] * (U32) random_state->seed[0];
+ temp[1] = (U16) accu; /* middle 16 bits */
+ accu >>= sizeof(U16) * 8;
+ accu += _rand48_mult[0] * random_state->seed[2]
+ + _rand48_mult[1] * random_state->seed[1]
+ + _rand48_mult[2] * random_state->seed[0];
+ random_state->seed[0] = temp[0];
+ random_state->seed[1] = temp[1];
+ random_state->seed[2] = (U16) accu;
+
+ return ldexp((double) random_state->seed[0], -48) +
+ ldexp((double) random_state->seed[1], -32) +
+ ldexp((double) random_state->seed[2], -16);
+ }
+#endif
+}
+
+
+/*
* Local variables:
* c-indentation-style: bsd
* c-basic-offset: 4
https://perl5.git.perl.org / perl5.git / blobdiff