int putenv(char *);
#endif
+#ifdef __amigaos__
+# include "amigaos4/amigaio.h"
+#endif
+
#ifdef HAS_SELECT
# ifdef I_SYS_SELECT
# include <sys/select.h>
=for apidoc fbm_compile
-Analyses the string in order to make fast searches on it using fbm_instr()
+Analyses the string in order to make fast searches on it using C<fbm_instr()>
-- the Boyer-Moore algorithm.
=cut
s[rarest], (UV)rarest));
}
-/* If SvTAIL(littlestr), it has a fake '\n' at end. */
-/* If SvTAIL is actually due to \Z or \z, this gives false positives
- if multiline */
/*
=for apidoc fbm_instr
Returns the location of the SV in the string delimited by C<big> and
-C<bigend>. It returns C<NULL> if the string can't be found. The C<sv>
-does not have to be fbm_compiled, but the search will not be as fast
+C<bigend> (C<bigend>) is the char following the last char).
+It returns C<NULL> if the string can't be found. The C<sv>
+does not have to be C<fbm_compiled>, but the search will not be as fast
then.
=cut
+
+If SvTAIL(littlestr) is true, a fake "\n" was appended to to the string
+during FBM compilation due to FBMcf_TAIL in flags. It indicates that
+the littlestr must be anchored to the end of bigstr (or to any \n if
+FBMrf_MULTILINE).
+
+E.g. The regex compiler would compile /abc/ to a littlestr of "abc",
+while /abc$/ compiles to "abc\n" with SvTAIL() true.
+
+A littlestr of "abc", !SvTAIL matches as /abc/;
+a littlestr of "ab\n", SvTAIL matches as:
+ without FBMrf_MULTILINE: /ab\n?\z/
+ with FBMrf_MULTILINE: /ab\n/ || /ab\z/;
+
+(According to Ilya from 1999; I don't know if this is still true, DAPM 2015):
+ "If SvTAIL is actually due to \Z or \z, this gives false positives
+ if multiline".
*/
+
char *
Perl_fbm_instr(pTHX_ unsigned char *big, unsigned char *bigend, SV *littlestr, U32 flags)
{
switch (littlelen) { /* Special cases for 0, 1 and 2 */
case 0:
return (char*)big; /* Cannot be SvTAIL! */
+
case 1:
- if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
- /* Know that bigend != big. */
- if (bigend[-1] == '\n')
- return (char *)(bigend - 1);
- return (char *) bigend;
- }
- s = big;
- while (s < bigend) {
- if (*s == *little)
- return (char *)s;
- s++;
- }
+ if (SvTAIL(littlestr) && !multiline) /* Anchor only! */
+ /* [-1] is safe because we know that bigend != big. */
+ return (char *) (bigend - (bigend[-1] == '\n'));
+
+ s = (unsigned char *)memchr((void*)big, *little, bigend-big);
+ if (s)
+ return (char *)s;
if (SvTAIL(littlestr))
return (char *) bigend;
return NULL;
+
case 2:
if (SvTAIL(littlestr) && !multiline) {
- if (bigend[-1] == '\n' && bigend[-2] == *little)
+ /* a littlestr with SvTAIL must be of the form "X\n" (where X
+ * is a single char). It is anchored, and can only match
+ * "....X\n" or "....X" */
+ if (bigend[-2] == *little && bigend[-1] == '\n')
return (char*)bigend - 2;
if (bigend[-1] == *little)
return (char*)bigend - 1;
return NULL;
}
+
{
- /* This should be better than FBM if c1 == c2, and almost
- as good otherwise: maybe better since we do less indirection.
- And we save a lot of memory by caching no table. */
- const unsigned char c1 = little[0];
- const unsigned char c2 = little[1];
-
- s = big + 1;
- bigend--;
- if (c1 != c2) {
- while (s <= bigend) {
- if (s[0] == c2) {
- if (s[-1] == c1)
- return (char*)s - 1;
- s += 2;
- continue;
- }
- next_chars:
- if (s[0] == c1) {
- if (s == bigend)
- goto check_1char_anchor;
- if (s[1] == c2)
- return (char*)s;
- else {
- s++;
- goto next_chars;
- }
- }
- else
- s += 2;
- }
- goto check_1char_anchor;
- }
- /* Now c1 == c2 */
- while (s <= bigend) {
- if (s[0] == c1) {
- if (s[-1] == c1)
- return (char*)s - 1;
- if (s == bigend)
- goto check_1char_anchor;
- if (s[1] == c1)
- return (char*)s;
- s += 3;
- }
- else
- s += 2;
- }
- }
- check_1char_anchor: /* One char and anchor! */
- if (SvTAIL(littlestr) && (*bigend == *little))
- return (char *)bigend; /* bigend is already decremented. */
- return NULL;
+ /* memchr() is likely to be very fast, possibly using whatever
+ * hardware support is available, such as checking a whole
+ * cache line in one instruction.
+ * So for a 2 char pattern, calling memchr() is likely to be
+ * faster than running FBM, or rolling our own. The previous
+ * version of this code was roll-your-own which typically
+ * only needed to read every 2nd char, which was good back in
+ * the day, but no longer.
+ */
+ unsigned char c1 = little[0];
+ unsigned char c2 = little[1];
+
+ /* *** for all this case, bigend points to the last char,
+ * not the trailing \0: this makes the conditions slightly
+ * simpler */
+ bigend--;
+ s = big;
+ if (c1 != c2) {
+ while (s < bigend) {
+ /* do a quick test for c1 before calling memchr();
+ * this avoids the expensive fn call overhead when
+ * there are lots of c1's */
+ if (LIKELY(*s != c1)) {
+ s++;
+ s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+ if (!s)
+ break;
+ }
+ if (s[1] == c2)
+ return (char*)s;
+
+ /* failed; try searching for c2 this time; that way
+ * we don't go pathologically slow when the string
+ * consists mostly of c1's or vice versa.
+ */
+ s += 2;
+ if (s > bigend)
+ break;
+ s = (unsigned char *)memchr((void*)s, c2, bigend - s + 1);
+ if (!s)
+ break;
+ if (s[-1] == c1)
+ return (char*)s - 1;
+ }
+ }
+ else {
+ /* c1, c2 the same */
+ while (s < bigend) {
+ if (s[0] == c1) {
+ got_1char:
+ if (s[1] == c1)
+ return (char*)s;
+ s += 2;
+ }
+ else {
+ s++;
+ s = (unsigned char *)memchr((void*)s, c1, bigend - s);
+ if (!s || s >= bigend)
+ break;
+ goto got_1char;
+ }
+ }
+ }
+
+ /* failed to find 2 chars; try anchored match at end without
+ * the \n */
+ if (SvTAIL(littlestr) && bigend[0] == little[0])
+ return (char *)bigend;
+ return NULL;
+ }
+
default:
break; /* Only lengths 0 1 and 2 have special-case code. */
}
}
return NULL;
}
+
if (!SvVALID(littlestr)) {
+ /* not compiled; use Perl_ninstr() instead */
char * const b = ninstr((char*)big,(char*)bigend,
(char*)little, (char*)little + littlelen);
oldlittle = little;
if (s < bigend) {
const unsigned char * const table = (const unsigned char *) mg->mg_ptr;
+ const unsigned char lastc = *little;
I32 tmp;
top2:
if ((tmp = table[*s])) {
- if ((s += tmp) < bigend)
- goto top2;
- goto check_end;
+ /* *s != lastc; earliest position it could match now is
+ * tmp slots further on */
+ if ((s += tmp) >= bigend)
+ goto check_end;
+ if (LIKELY(*s != lastc)) {
+ s++;
+ s = (unsigned char *)memchr((void*)s, lastc, bigend - s);
+ if (!s) {
+ s = bigend;
+ goto check_end;
+ }
+ goto top2;
+ }
}
- else { /* less expensive than calling strncmp() */
+
+
+ /* hand-rolled strncmp(): less expensive than calling the
+ * real function (maybe???) */
+ {
unsigned char * const olds = s;
tmp = littlelen;
}
}
+
/*
=for apidoc foldEQ
-Returns true if the leading len bytes of the strings s1 and s2 are the same
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same
case-insensitively; false otherwise. Uppercase and lowercase ASCII range bytes
match themselves and their opposite case counterparts. Non-cased and non-ASCII
range bytes match only themselves.
/*
=for apidoc foldEQ_locale
-Returns true if the leading len bytes of the strings s1 and s2 are the same
-case-insensitively in the current locale; false otherwise.
+Returns true if the leading C<len> bytes of the strings C<s1> and C<s2> are the
+same case-insensitively in the current locale; false otherwise.
=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 C<NULL>
pointer is not acceptable)
=cut
=for apidoc Am|SV *|vmess|const char *pat|va_list *args
C<pat> and C<args> are a sprintf-style format pattern and encapsulated
-argument list. These are used to generate a string message. If the
+argument list, respectively. These are used to generate a string message. If
+the
message does not end with a newline, then it will be extended with
some indication of the current location in the code, as described for
L</mess_sv>.
Perl_my_setenv(pTHX_ const char *nam, const char *val)
{
dVAR;
+#ifdef __amigaos4__
+ amigaos4_obtain_environ(__FUNCTION__);
+#endif
#ifdef USE_ITHREADS
/* only parent thread can modify process environment */
if (PL_curinterp == aTHX)
environ[i] = environ[i+1];
i++;
}
+#ifdef __amigaos4__
+ goto my_setenv_out;
+#else
return;
+#endif
}
if (!environ[i]) { /* does not exist yet */
environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
Configure doesn't test for that yet. For Solaris, setenv() and unsetenv()
were introduced in Solaris 9, so testing for HAS UNSETENV is sufficient.
*/
-# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV))
+# if defined(__CYGWIN__)|| defined(__SYMBIAN32__) || defined(__riscos__) || (defined(__sun) && defined(HAS_UNSETENV)) || defined(PERL_DARWIN)
# if defined(HAS_UNSETENV)
if (val == NULL) {
(void)unsetenv(nam);
}
#endif
}
+#ifdef __amigaos4__
+my_setenv_out:
+ amigaos4_release_environ(__FUNCTION__);
+#endif
}
#else /* WIN32 || NETWARE */
PerlIO *
Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args)
{
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(OS2) && !defined(VMS) && !defined(NETWARE) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
int p[2];
I32 This, that;
Pid_t pid;
/* Close parent's end of error status pipe (if any) */
if (did_pipes) {
PerlLIO_close(pp[0]);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#if defined(HAS_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
/* Close error pipe automatically if exec works */
if (fcntl(pp[1], F_SETFD, FD_CLOEXEC) < 0)
return NULL;
#endif
}
- /* VMS' my_popen() is in VMS.c, same with OS/2. */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+ /* VMS' my_popen() is in VMS.c, same with OS/2 and AmigaOS 4. */
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
PerlIO *
Perl_my_popen(pTHX_ const char *cmd, const char *mode)
{
/* this is called in parent before the fork() */
void
Perl_atfork_lock(void)
+#if defined(USE_ITHREADS)
+# ifdef USE_PERLIO
+ PERL_TSA_ACQUIRE(PL_perlio_mutex)
+# endif
+# ifdef MYMALLOC
+ PERL_TSA_ACQUIRE(PL_malloc_mutex)
+# endif
+ PERL_TSA_ACQUIRE(PL_op_mutex)
+#endif
{
#if defined(USE_ITHREADS)
dVAR;
/* this is called in both parent and child after the fork() */
void
Perl_atfork_unlock(void)
+#if defined(USE_ITHREADS)
+# ifdef USE_PERLIO
+ PERL_TSA_RELEASE(PL_perlio_mutex)
+# endif
+# ifdef MYMALLOC
+ PERL_TSA_RELEASE(PL_malloc_mutex)
+# endif
+ PERL_TSA_RELEASE(PL_op_mutex)
+#endif
{
#if defined(USE_ITHREADS)
dVAR;
pid = fork();
#endif
return pid;
+#elif defined(__amigaos4__)
+ return amigaos_fork();
#else
/* this "canna happen" since nothing should be calling here if !HAS_FORK */
Perl_croak_nocontext("fork() not available");
#endif /* !PERL_MICRO */
/* VMS' my_pclose() is in VMS.c; same with OS/2 */
-#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__LIBCATAMOUNT__)
+#if (!defined(DOSISH) || defined(HAS_FORK)) && !defined(VMS) && !defined(__LIBCATAMOUNT__) && !defined(__amigaos4__)
I32
Perl_my_pclose(pTHX_ PerlIO *ptr)
{
}
#endif
-#if defined(OS2)
+#if defined(OS2) || defined(__amigaos4__)
+# if defined(__amigaos4__) && defined(pclose)
+# undef pclose
+# endif
int pclose();
#ifdef HAS_FORK
int /* Cannot prototype with I32
while (deftypes ||
(!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
{
+ Stat_t statbuf;
if (deftypes) {
deftypes = 0;
*tmpbuf = '\0';
#endif
DEBUG_p(PerlIO_printf(Perl_debug_log,
"Looking for %s\n",cur));
- if (PerlLIO_stat(cur,&PL_statbuf) >= 0
- && !S_ISDIR(PL_statbuf.st_mode)) {
- dosearch = 0;
- scriptname = cur;
+ {
+ Stat_t statbuf;
+ if (PerlLIO_stat(cur,&statbuf) >= 0
+ && !S_ISDIR(statbuf.st_mode)) {
+ dosearch = 0;
+ scriptname = cur;
#ifdef SEARCH_EXTS
- break;
+ break;
#endif
+ }
}
#ifdef SEARCH_EXTS
if (cur == scriptname) {
bufend = s + strlen(s);
while (s < bufend) {
+ Stat_t statbuf;
# ifdef DOSISH
for (len = 0; *s
&& *s != ';'; len++, s++) {
do {
#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 = PerlLIO_stat(tmpbuf,&statbuf);
+ if (S_ISDIR(statbuf.st_mode)) {
retval = -1;
}
#ifdef SEARCH_EXTS
#endif
if (retval < 0)
continue;
- if (S_ISREG(PL_statbuf.st_mode)
- && cando(S_IRUSR,TRUE,&PL_statbuf)
+ if (S_ISREG(statbuf.st_mode)
+ && cando(S_IRUSR,TRUE,&statbuf)
#if !defined(DOSISH)
- && cando(S_IXUSR,TRUE,&PL_statbuf)
+ && cando(S_IXUSR,TRUE,&statbuf)
#endif
)
{
xfailed = savepv(tmpbuf);
}
#ifndef DOSISH
- if (!xfound && !seen_dot && !xfailed &&
- (PerlLIO_stat(scriptname,&PL_statbuf) < 0
- || S_ISDIR(PL_statbuf.st_mode)))
+ {
+ Stat_t statbuf;
+ if (!xfound && !seen_dot && !xfailed &&
+ (PerlLIO_stat(scriptname,&statbuf) < 0
+ || S_ISDIR(statbuf.st_mode)))
+#endif
+ seen_dot = 1; /* Disable message. */
+#ifndef DOSISH
+ }
#endif
- seen_dot = 1; /* Disable message. */
if (!xfound) {
if (flags & 1) { /* do or die? */
/* diag_listed_as: Can't execute %s */
=for apidoc getcwd_sv
-Fill the sv with current working directory
+Fill C<sv> with current working directory
=cut
*/
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.
-Exists to avoid test for a NULL function pointer and because it could
+Exists to avoid test for a C<NULL> function pointer and because it could
potentially warn under some level of strict-ness.
=cut
Dummy routine which reports that object can be destroyed when there is no
sharing module present. It ignores its single SV argument, and returns
-'true'. Exists to avoid test for a NULL function pointer and because it
+'true'. Exists to avoid test for a C<NULL> function pointer and because it
could potentially warn under some level of strict-ness.
=cut
Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
}
}
+ else {
+ Perl_croak(aTHX_ "Invalid number '%s' for -C option.\n", p);
+ }
}
else {
for (; *p; p++) {
* if there isn't enough entropy available. You can compile with
* PERL_RANDOM_DEVICE to it if you'd prefer Perl to block until there
* is enough real entropy to fill the seed. */
-# define PERL_RANDOM_DEVICE "/dev/urandom"
+# ifdef __amigaos4__
+# define PERL_RANDOM_DEVICE "RANDOM:SIZE=4"
+# else
+# define PERL_RANDOM_DEVICE "/dev/urandom"
+# endif
#endif
fd = PerlLIO_open(PERL_RANDOM_DEVICE, 0);
if (fd != -1) {
/*
=for apidoc quadmath_format_single
-quadmath_snprintf() is very strict about its format string and will
-fail, returning -1, if the format is invalid. It acccepts exactly
+C<quadmath_snprintf()> is very strict about its C<format> string and will
+fail, returning -1, if the format is invalid. It accepts exactly
one format spec.
-quadmath_format_single() checks that the intended single spec looks
+C<quadmath_format_single()> checks that the intended single spec looks
sane: begins with C<%>, has only one C<%>, ends with C<[efgaEFGA]>,
and has C<Q> before it. This is not a full "printf syntax check",
just the basics.
Returns the format if it is valid, NULL if not.
-quadmath_format_single() can and will actually patch in the missing
+C<quadmath_format_single()> can and will actually patch in the missing
C<Q>, if necessary. In this case it will return the modified copy of
the format, B<which the caller will need to free.>
/*
=for apidoc quadmath_format_needed
-quadmath_format_needed() returns true if the format string seems to
-contain at least one non-Q-prefixed %[efgaEFGA] format specifier,
+C<quadmath_format_needed()> returns true if the C<format> string seems to
+contain at least one non-Q-prefixed C<%[efgaEFGA]> format specifier,
or returns false otherwise.
The format specifier detection is not complete printf-syntax detection,
but it should catch most common cases.
If true is returned, those arguments B<should> in theory be processed
-with quadmath_snprintf(), but in case there is more than one such
+with C<quadmath_snprintf()>, but in case there is more than one such
format specifier (see L</quadmath_format_single>), and if there is
anything else beyond that one (even just a single byte), they
-B<cannot> be processed because quadmath_snprintf() is very strict,
+B<cannot> be processed because C<quadmath_snprintf()> is very strict,
accepting only one format spec, and nothing else.
In this case, the code should probably fail.
va_list apc;
PERL_ARGS_ASSERT_MY_VSNPRINTF;
-#ifndef HAS_VSNPRINTF
- PERL_UNUSED_VAR(len);
-#endif
Perl_va_copy(ap, apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, apc);
# else
+ PERL_UNUSED_ARG(len);
retval = vsprintf(buffer, format, apc);
# endif
va_end(apc);
# ifdef HAS_VSNPRINTF
retval = vsnprintf(buffer, len, format, ap);
# else
+ PERL_UNUSED_ARG(len);
retval = vsprintf(buffer, format, ap);
# endif
#endif /* #ifdef NEED_VA_COPY */
SAVEPPTR(PL_xsubfilename);/* which was require'd from a XSUB BEGIN */
PL_xsubfilename = file; /* so the old name must be restored for
additional XSUBs to register themselves */
- (void)gv_fetchfile(file);
+ /* XSUBs can't be perl lang/perl5db.pl debugged
+ if (PERLDB_LINE_OR_SAVESRC)
+ (void)gv_fetchfile(file); */
}
if(key & HSf_POPMARK) {
PERL_ARGS_ASSERT_DRAND48_INIT_R;
#ifdef PERL_DRAND48_QUAD
- *random_state = FREEBSD_DRAND48_SEED_0 + ((U64TYPE)seed << 16);
+ *random_state = FREEBSD_DRAND48_SEED_0 + ((U64)seed << 16);
#else
random_state->seed[0] = FREEBSD_DRAND48_SEED_0;
random_state->seed[1] = (U16) seed;
=for apidoc get_c_backtrace
Collects the backtrace (aka "stacktrace") into a single linear
-malloced buffer, which the caller B<must> Perl_free_c_backtrace().
+malloced buffer, which the caller B<must> C<Perl_free_c_backtrace()>.
-Scans the frames back by depth + skip, then drops the skip innermost,
-returning at most depth frames.
+Scans the frames back by S<C<depth + skip>>, then drops the C<skip> innermost,
+returning at most C<depth> frames.
=cut
*/
/*
=for apidoc get_c_backtrace_dump
-Returns a SV a dump of |depth| frames of the call stack, skipping
-the |skip| innermost ones. depth of 20 is usually enough.
+Returns a SV containing a dump of C<depth> frames of the call stack, skipping
+the C<skip> innermost ones. C<depth> of 20 is usually enough.
The appended output looks like:
The fields are tab-separated. The first column is the depth (zero
being the innermost non-skipped frame). In the hex:offset, the hex is
-where the program counter was in S_parse_body, and the :offset (might
-be missing) tells how much inside the S_parse_body the program counter was.
+where the program counter was in C<S_parse_body>, and the :offset (might
+be missing) tells how much inside the C<S_parse_body> the program counter was.
-The util.c:1716 is the source code file and line number.
+The C<util.c:1716> is the source code file and line number.
-The /usr/bin/perl is obvious (hopefully).
+The F</usr/bin/perl> is obvious (hopefully).
Unknowns are C<"-">. Unknowns can happen unfortunately quite easily:
if the platform doesn't support retrieving the information;
/*
=for apidoc dump_c_backtrace
-Dumps the C backtrace to the given fp.
+Dumps the C backtrace to the given C<fp>.
Returns true if a backtrace could be retrieved, false if not.
#endif /* #ifdef USE_C_BACKTRACE */
+#ifdef PERL_TSA_ACTIVE
+
+/* pthread_mutex_t and perl_mutex are typedef equivalent
+ * so casting the pointers is fine. */
+
+int perl_tsa_mutex_lock(perl_mutex* mutex)
+{
+ return pthread_mutex_lock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_unlock(perl_mutex* mutex)
+{
+ return pthread_mutex_unlock((pthread_mutex_t *) mutex);
+}
+
+int perl_tsa_mutex_destroy(perl_mutex* mutex)
+{
+ return pthread_mutex_destroy((pthread_mutex_t *) mutex);
+}
+
+#endif
+
/*
* ex: set ts=8 sts=4 sw=4 et:
*/
https://perl5.git.perl.org / perl5.git / blobdiff