void
Perl_pack_cat(pTHX_ SV *cat, const char *pat, const char *patend, SV **beglist, SV **endlist, SV ***next_in_list, U32 flags)
{
PERL_ARGS_ASSERT_PACK_CAT;
PERL_UNUSED_ARG(next_in_list);
PERL_UNUSED_ARG(flags);
packlist(cat, pat, patend, beglist, endlist);
}
IV
PerlIOUtil_useless_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
PerlIO_funcs* tab){
PERL_UNUSED_ARG(fp);
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(arg);
PerlIOUtil_warnif(aTHX_ packWARN(WARN_LAYER), "Too late for %s layer", tab->name);
return -1;
}
static IV
PerlIOFlock_pushed(pTHX_ PerlIO* fp, const char* mode, SV* arg,
PerlIO_funcs* tab){
int lock_mode;
int fd;
int ret;
PERL_UNUSED_ARG(mode);
PERL_UNUSED_ARG(tab);
if(!PerlIOValid(fp)){
SETERRNO(EBADF, SS_IVCHAN);
return -1;
}
lock_mode = IOLflag(fp, PERLIO_F_CANWRITE) ? LOCK_EX : LOCK_SH;
if(arg && SvOK(arg)){
const char* const blocking = SvPV_nolen_const(arg);
if(strEQ(blocking, "blocking")){
/* noop */
}
else if(strEQ(blocking, "non-blocking")
|| strEQ(blocking, "LOCK_NB")){
lock_mode |= LOCK_NB;
}
else{
Perl_croak(aTHX_ "Unrecognized :flock handler '%s' "
"(it must be 'blocking' or 'non-blocking')",
blocking);
}
}
fd = PerlIO_fileno(fp);
if(fd == -1){ /* :scalar, :dir, etc. */
return 0; /* success */
}
PerlIO_flush(fp);
ret = PerlLIO_flock(fd, lock_mode);
PerlIO_debug(STRINGIFY(FLOCK) "(%d, %s) -> %d\n", fd,
( lock_mode == (LOCK_SH) ? "LOCK_SH"
: lock_mode == (LOCK_SH|LOCK_NB) ? "LOCK_SH|LOCK_NB"
: lock_mode == (LOCK_EX) ? "LOCK_EX"
: lock_mode == (LOCK_EX|LOCK_NB) ? "LOCK_EX|LOCK_NB"
: "(UNKNOWN)" ),
ret);
return ret;
}
I32
Perl_unpack_str(pTHX_ const char *pat, const char *patend, const char *s,
const char *strbeg, const char *strend, char **new_s, I32 ocnt,
U32 flags)
{
PERL_ARGS_ASSERT_UNPACK_STR;
PERL_UNUSED_ARG(strbeg);
PERL_UNUSED_ARG(new_s);
PERL_UNUSED_ARG(ocnt);
return unpackstring(pat, patend, s, strend, flags);
}
STATIC void
S_deb_stack_n(pTHX_ SV** stack_base, I32 stack_min, I32 stack_max,
I32 mark_min, I32 mark_max)
{
#ifdef DEBUGGING
dVAR;
I32 i = stack_max - 30;
const I32 *markscan = PL_markstack + mark_min;
PERL_ARGS_ASSERT_DEB_STACK_N;
if (i < stack_min)
i = stack_min;
while (++markscan <= PL_markstack + mark_max)
if (*markscan >= i)
break;
if (i > stack_min)
PerlIO_printf(Perl_debug_log, "... ");
if (stack_base[0] != &PL_sv_undef || stack_max < 0)
PerlIO_printf(Perl_debug_log, " [STACK UNDERFLOW!!!]\n");
do {
++i;
if (markscan <= PL_markstack + mark_max && *markscan < i) {
do {
++markscan;
PerlIO_putc(Perl_debug_log, '*');
}
while (markscan <= PL_markstack + mark_max && *markscan < i);
PerlIO_printf(Perl_debug_log, " ");
}
if (i > stack_max)
break;
PerlIO_printf(Perl_debug_log, "%-4s ", SvPEEK(stack_base[i]));
}
while (1);
PerlIO_printf(Perl_debug_log, "\n");
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(stack_base);
PERL_UNUSED_ARG(stack_min);
PERL_UNUSED_ARG(stack_max);
PERL_UNUSED_ARG(mark_min);
PERL_UNUSED_ARG(mark_max);
#endif /* DEBUGGING */
}
UV
mop_check_package_cache_flag (pTHX_ HV *stash)
{
PERL_UNUSED_ARG(stash);
assert(SvTYPE(stash) == SVt_PVHV);
return PL_sub_generation;
}
bool
Perl_do_open9(pTHX_ GV *gv, const char *name, I32 len, int
as_raw,
int rawmode, int rawperm, PerlIO *supplied_fp, SV *svs,
I32 num_svs)
{
PERL_ARGS_ASSERT_DO_OPEN9;
PERL_UNUSED_ARG(num_svs);
return do_openn(gv, name, len, as_raw, rawmode, rawperm,
supplied_fp, &svs, 1);
}
void
Perl_vdeb(pTHX_ const char *pat, va_list *args)
{
#ifdef DEBUGGING
const char* const file = PL_curcop ? OutCopFILE(PL_curcop) : "<null>";
const char* const display_file = file ? file : "<free>";
const long line = PL_curcop ? (long)CopLINE(PL_curcop) : 0;
PERL_ARGS_ASSERT_VDEB;
if (DEBUG_v_TEST)
PerlIO_printf(Perl_debug_log, "(%ld:%s:%ld)\t",
(long)PerlProc_getpid(), display_file, line);
else
PerlIO_printf(Perl_debug_log, "(%s:%ld)\t", display_file, line);
(void) PerlIO_vprintf(Perl_debug_log, pat, *args);
#else
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(pat);
PERL_UNUSED_ARG(args);
#endif /* DEBUGGING */
}
void
Perl_deb_nocontext(const char *pat, ...)
{
#ifdef DEBUGGING
dTHX;
va_list args;
PERL_ARGS_ASSERT_DEB_NOCONTEXT;
va_start(args, pat);
vdeb(pat, &args);
va_end(args);
#else
PERL_UNUSED_ARG(pat);
#endif /* DEBUGGING */
}
static PerlIO*
PerlIOUtil_open_with_flags(pTHX_ PerlIO_funcs* self, PerlIO_list_t* layers, IV n,
const char* mode, int fd, int imode, int perm,
PerlIO* f, int narg, SV** args, int flags){
char numeric_mode[PERLIOUTIL_MODE_MAX]; /* [I#]? [wra]\+? [tb] \0 */
PERL_UNUSED_ARG(self);
assert( mode != NULL );
if(mode[0] != IoTYPE_NUMERIC){
numeric_mode[0] = IoTYPE_NUMERIC; /* as sysopen() */
Copy(mode, &numeric_mode[1], strlen(mode) + 1 /* '\0' */, char);
mode = &numeric_mode[0];
}
/*
* Set up for a new ctype locale.
*/
void
Perl_new_ctype(pTHX_ char *newctype)
{
#ifdef USE_LOCALE_CTYPE
int i;
for (i = 0; i < 256; i++) {
if (isUPPER_LC(i))
PL_fold_locale[i] = toLOWER_LC(i);
else if (isLOWER_LC(i))
PL_fold_locale[i] = toUPPER_LC(i);
else
PL_fold_locale[i] = i;
}
#endif /* USE_LOCALE_CTYPE */
PERL_UNUSED_ARG(newctype);
}
/*
* Set up for a new ctype locale.
*/
void
Perl_new_ctype(pTHX_ const char *newctype)
{
#ifdef USE_LOCALE_CTYPE
dVAR;
int i;
PERL_ARGS_ASSERT_NEW_CTYPE;
for (i = 0; i < 256; i++) {
if (isUPPER_LC(i))
PL_fold_locale[i] = toLOWER_LC(i);
else if (isLOWER_LC(i))
PL_fold_locale[i] = toUPPER_LC(i);
else
PL_fold_locale[i] = i;
}
#endif /* USE_LOCALE_CTYPE */
PERL_ARGS_ASSERT_NEW_CTYPE;
PERL_UNUSED_ARG(newctype);
PERL_UNUSED_CONTEXT;
}
PERL_STATIC_INLINE bool
S_grok_bslash_x(pTHX_ char **s, UV *uv, const char** error_msg,
const bool output_warning, const bool strict,
const bool silence_non_portable,
const bool UTF)
{
/* Documentation to be supplied when interface nailed down finally
* This returns FALSE if there is an error which the caller need not recover
* from; , otherwise TRUE. In either case the caller should look at *len
* On input:
* s is the address of a pointer to a NULL terminated string that begins
* with 'x', and the previous character was a backslash. At exit, *s
* will be advanced to the byte just after those absorbed by this
* function. Hence the caller can continue parsing from there. In
* the case of an error, this routine has generally positioned *s to
* point just to the right of the first bad spot, so that a message
* that has a "<--" to mark the spot will be correctly positioned.
* uv points to a UV that will hold the output value, valid only if the
* return from the function is TRUE
* error_msg is a pointer that will be set to an internal buffer giving an
* error message upon failure (the return is FALSE). Untouched if
* function succeeds
* output_warning says whether to output any warning messages, or suppress
* them
* strict is true if anything out of the ordinary should cause this to
* fail instead of warn or be silent. For example, it requires
* exactly 2 digits following the \x (when there are no braces).
* 3 digits could be a mistake, so is forbidden in this mode.
* silence_non_portable is true if to suppress warnings about the code
* point returned being too large to fit on all platforms.
* UTF is true iff the string *s is encoded in UTF-8.
*/
char* e;
STRLEN numbers_len;
I32 flags = PERL_SCAN_DISALLOW_PREFIX;
PERL_ARGS_ASSERT_GROK_BSLASH_X;
PERL_UNUSED_ARG(output_warning);
assert(**s == 'x');
(*s)++;
if (strict) {
flags |= PERL_SCAN_SILENT_ILLDIGIT;
}
if (**s != '{') {
STRLEN len = (strict) ? 3 : 2;
*uv = grok_hex(*s, &len, &flags, NULL);
*s += len;
if (strict && len != 2) {
if (len < 2) {
*s += (UTF) ? UTF8SKIP(*s) : 1;
*error_msg = "Non-hex character";
}
else {
*error_msg = "Use \\x{...} for more than two hex characters";
}
return FALSE;
}
return TRUE;
}
e = strchr(*s, '}');
if (!e) {
(*s)++; /* Move past the '{' */
while (isXDIGIT(**s)) { /* Position beyond the legal digits */
(*s)++;
}
/* XXX The corresponding message above for \o is just '\\o{'; other
* messages for other constructs include the '}', so are inconsistent.
*/
*error_msg = "Missing right brace on \\x{}";
return FALSE;
}
(*s)++; /* Point to expected first digit (could be first byte of utf8
sequence if not a digit) */
numbers_len = e - *s;
if (numbers_len == 0) {
if (strict) {
(*s)++; /* Move past the } */
*error_msg = "Number with no digits";
return FALSE;
}
return TRUE;
}
flags |= PERL_SCAN_ALLOW_UNDERSCORES;
if (silence_non_portable) {
flags |= PERL_SCAN_SILENT_NON_PORTABLE;
}
*uv = grok_hex(*s, &numbers_len, &flags, NULL);
/* Note that if has non-hex, will ignore everything starting with that up
* to the '}' */
if (strict && numbers_len != (STRLEN) (e - *s)) {
*s += numbers_len;
*s += (UTF) ? UTF8SKIP(*s) : 1;
*error_msg = "Non-hex character";
return FALSE;
}
/* Return past the '}' */
*s = e + 1;
return TRUE;
}
UV /* Made into a function, so can be deprecated */
ASCII_TO_NEED(const UV enc, const UV ch)
{
PERL_UNUSED_ARG(enc);
return ch;
}
void
Perl_sv_nounlocking(pTHX_ SV *sv)
{
PERL_UNUSED_CONTEXT;
PERL_UNUSED_ARG(sv);
}
IV
PerlIONginxInput_fileno(pTHX_ PerlIO * f)
{
PERL_UNUSED_ARG(f);
return -1; // I'm kinda socket.
}
int
main(int argc, char **argv, char **env)
#endif
{
dVAR;
int exitstatus, i;
#ifdef PERL_GLOBAL_STRUCT
struct perl_vars *plvarsp = init_global_struct();
# ifdef PERL_GLOBAL_STRUCT_PRIVATE
my_vars = my_plvarsp = plvarsp;
# endif
#endif /* PERL_GLOBAL_STRUCT */
#ifndef NO_ENV_ARRAY_IN_MAIN
PERL_UNUSED_ARG(env);
#endif
#ifndef PERL_USE_SAFE_PUTENV
PL_use_safe_putenv = FALSE;
#endif /* PERL_USE_SAFE_PUTENV */
/* if user wants control of gprof profiling off by default */
/* noop unless Configure is given -Accflags=-DPERL_GPROF_CONTROL */
PERL_GPROF_MONCONTROL(0);
#ifdef NO_ENV_ARRAY_IN_MAIN
PERL_SYS_INIT3(&argc,&argv,&environ);
#else
PERL_SYS_INIT3(&argc,&argv,&env);
#endif
#if defined(USE_ITHREADS)
/* XXX Ideally, this should really be happening in perl_alloc() or
* perl_construct() to keep libperl.a transparently fork()-safe.
* It is currently done here only because Apache/mod_perl have
* problems due to lack of a call to cancel pthread_atfork()
* handlers when shared objects that contain the handlers may
* be dlclose()d. This forces applications that embed perl to
* call PTHREAD_ATFORK() explicitly, but if and only if it hasn't
* been called at least once before in the current process.
* --GSAR 2001-07-20 */
PTHREAD_ATFORK(Perl_atfork_lock,
Perl_atfork_unlock,
Perl_atfork_unlock);
#endif
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct(my_perl);
PL_perl_destruct_level = 0;
}
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
exitstatus = perl_parse(my_perl, xs_init, argc, argv, (char **)NULL);
if (!exitstatus)
perl_run(my_perl);
#ifndef PERL_MICRO
/* Unregister our signal handler before destroying my_perl */
for (i = 0; PL_sig_name[i]; i++) {
if (rsignal_state(PL_sig_num[i]) == (Sighandler_t) PL_csighandlerp) {
rsignal(PL_sig_num[i], (Sighandler_t) SIG_DFL);
}
}
#endif
exitstatus = perl_destruct(my_perl);
perl_free(my_perl);
#if defined(USE_ENVIRON_ARRAY) && defined(PERL_TRACK_MEMPOOL) && !defined(NO_ENV_ARRAY_IN_MAIN)
/*
* The old environment may have been freed by perl_free()
* when PERL_TRACK_MEMPOOL is defined, but without having
* been restored by perl_destruct() before (this is only
* done if destruct_level > 0).
*
* It is important to have a valid environment for atexit()
* routines that are eventually called.
*/
environ = env;
#endif
#ifdef PERL_GLOBAL_STRUCT
free_global_struct(plvarsp);
#endif /* PERL_GLOBAL_STRUCT */
PERL_SYS_TERM();
exit(exitstatus);
return exitstatus;
}
